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

db4
Doug Coleman 2008-07-01 10:24:42 -05:00
commit f864d51255
43 changed files with 302 additions and 124 deletions

View File

@ -5,7 +5,7 @@ cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
cpu.architecture kernel kernel.private math namespaces sequences cpu.architecture kernel kernel.private math namespaces sequences
generator.registers generator.fixup generator system layouts generator.registers generator.fixup generator system layouts
alien.compiler combinators command-line alien.compiler combinators command-line
compiler compiler.units io vocabs.loader accessors ; compiler compiler.units io vocabs.loader accessors init ;
IN: cpu.x86.32 IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once. ! We implement the FFI for Linux, OS X and Windows all at once.
@ -262,9 +262,11 @@ os windows? [
4 "double" c-type set-c-type-align 4 "double" c-type set-c-type-align
] unless ] unless
: sse2? ( -- ? ) "Intrinsic" throw ; : (sse2?) ( -- ? ) "Intrinsic" throw ;
\ sse2? [ <<
\ (sse2?) [
{ EAX EBX ECX EDX } [ PUSH ] each { EAX EBX ECX EDX } [ PUSH ] each
EAX 1 MOV EAX 1 MOV
CPUID CPUID
@ -274,6 +276,10 @@ os windows? [
JE JE
] { } define-if-intrinsic ] { } define-if-intrinsic
>>
: sse2? ( -- ? ) (sse2?) ;
"-no-sse2" cli-args member? [ "-no-sse2" cli-args member? [
"Checking if your CPU supports SSE2..." print flush "Checking if your CPU supports SSE2..." print flush
[ optimized-recompile-hook ] recompile-hook [ [ optimized-recompile-hook ] recompile-hook [
@ -282,6 +288,14 @@ os windows? [
[ [
" - yes" print " - yes" print
"cpu.x86.sse2" require "cpu.x86.sse2" require
[
sse2? [
"This image was built to use SSE2, which your CPU does not support." print
"You will need to bootstrap Factor again." print
flush
1 exit
] unless
] "cpu.x86" add-init-hook
] [ ] [
" - no" print " - no" print
] if ] if

View File

@ -1,7 +1,8 @@
IN: io.files.tests IN: io.files.tests
USING: tools.test io.files io.files.private io threads kernel USING: tools.test io.files io.files.private io threads kernel
continuations io.encodings.ascii io.files.unique sequences continuations io.encodings.ascii io.files.unique sequences
strings accessors io.encodings.utf8 math destructors ; strings accessors io.encodings.utf8 math destructors
namespaces ;
\ exists? must-infer \ exists? must-infer
\ (exists?) must-infer \ (exists?) must-infer
@ -276,3 +277,12 @@ strings accessors io.encodings.utf8 math destructors ;
[ "touch-twice-test" temp-file delete-file ] ignore-errors [ "touch-twice-test" temp-file delete-file ] ignore-errors
[ ] [ 2 [ "touch-twice-test" temp-file touch-file ] times ] unit-test [ ] [ 2 [ "touch-twice-test" temp-file touch-file ] times ] unit-test
! aum's bug
[
"." current-directory set
".." "resource-path" set
[ "../core/bootstrap/stage2.factor" ]
[ "resource:core/bootstrap/stage2.factor" (normalize-path) ]
unit-test
] with-scope

View File

@ -121,6 +121,7 @@ PRIVATE>
{ {
{ [ over empty? ] [ append-path-empty ] } { [ over empty? ] [ append-path-empty ] }
{ [ dup empty? ] [ drop ] } { [ dup empty? ] [ drop ] }
{ [ over right-trim-separators "." = ] [ nip ] }
{ [ dup absolute-path? ] [ nip ] } { [ dup absolute-path? ] [ nip ] }
{ [ dup head.? ] [ rest left-trim-separators append-path ] } { [ dup head.? ] [ rest left-trim-separators append-path ] }
{ [ dup head..? ] [ { [ dup head..? ] [

View File

@ -1,61 +1,59 @@
USING: kernel parser namespaces quotations arrays vectors strings USING: kernel parser combinators sequences splitting quotations arrays macros
sequences assocs classes.tuple math combinators ; arrays.lib combinators.cleave combinators.conditional newfx ;
IN: bake IN: bake
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: insert-quot expr ; SYMBOL: ,
SYMBOL: @
C: <insert-quot> insert-quot : comma? ( obj -- ? ) , = ;
: atsym? ( obj -- ? ) @ = ;
: ,[ \ ] [ >quotation <insert-quot> ] parse-literal ; parsing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: splice-quot expr ; DEFER: [bake-array]
C: <splice-quot> splice-quot : broil-element ( obj -- quot )
{
: %[ \ ] [ >quotation <splice-quot> ] parse-literal ; parsing { [ comma? ] [ drop [ >r ] ] }
{ [ array? ] [ [bake-array] [ >r ] append ] }
{ [ drop t ] [ [ >r ] prefix-on ] }
}
1cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ,u ( seq -- seq ) unclip building get push ; : [broil] ( array -- quot )
[ reverse [ broil-element ] map concat ]
[ length [ drop [ r> ] ] map concat ]
[ length [ narray ] prefix-on ]
tri append append
>quotation ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: exemplar : [simmer] ( array -- quot )
: reset-building ( -- ) 1024 <vector> building set ; { @ } split reverse
[ [ [bake-array] [ append ] append [ >r ] append ] map concat ]
[ length [ drop [ r> append ] ] map concat ]
bi
: save-exemplar ( seq -- seq ) dup exemplar set ; >r 2 head* [ >r ] append r> ! remove the last append
: finish-baking ( -- seq ) building get exemplar get like ; [ { } ] swap append
DEFER: bake append ;
: bake-item ( item -- )
{ { [ dup \ , = ] [ drop , ] }
{ [ dup \ % = ] [ drop % ] }
{ [ dup \ ,u = ] [ drop ,u ] }
{ [ dup insert-quot? ] [ insert-quot-expr call , ] }
{ [ dup splice-quot? ] [ splice-quot-expr call % ] }
{ [ dup integer? ] [ , ] }
{ [ dup string? ] [ , ] }
{ [ dup tuple? ] [ tuple>array bake >tuple , ] }
{ [ dup assoc? ] [ [ >alist bake ] keep assoc-like , ] }
{ [ dup sequence? ] [ bake , ] }
{ [ t ] [ , ] } }
cond ;
: bake-items ( seq -- ) [ bake-item ] each ;
: bake ( seq -- seq )
[ reset-building save-exemplar bake-items finish-baking ] with-scope ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing : [bake-array] ( array -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ;
MACRO: bake-array ( array -- quot ) [bake-array] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: `{ \ } [ >array ] parse-literal \ bake-array parsed ; parsing

View File

@ -1,13 +1,13 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: bootstrap.image.download
USING: http.client checksums checksums.openssl splitting assocs USING: http.client checksums checksums.openssl splitting assocs
kernel io.files bootstrap.image sequences io ; kernel io.files bootstrap.image sequences io urls ;
IN: bootstrap.image.download
: url "http://factorcode.org/images/latest/" ; : url URL" http://factorcode.org/images/latest/" ;
: download-checksums ( -- alist ) : download-checksums ( -- alist )
url "checksums.txt" append http-get nip url "checksums.txt" >url derive-url http-get nip
string-lines [ " " split1 ] { } map>assoc ; string-lines [ " " split1 ] { } map>assoc ;
: need-new-image? ( image -- ? ) : need-new-image? ( image -- ? )
@ -21,7 +21,10 @@ kernel io.files bootstrap.image sequences io ;
: download-image ( arch -- ) : download-image ( arch -- )
boot-image-name dup need-new-image? [ boot-image-name dup need-new-image? [
"Downloading " write dup write "..." print "Downloading " write dup write "..." print
url prepend download url over >url derive-url download
need-new-image? [
"Boot image corrupt, or checksums.txt on server out of date" throw
] when
] [ ] [
"Boot image up to date" print "Boot image up to date" print
drop drop

View File

@ -1,7 +1,7 @@
USING: kernel debugger system namespaces sequences splitting combinators USING: kernel debugger system namespaces sequences splitting combinators
io io.files io.launcher prettyprint bootstrap.image io io.files io.launcher prettyprint bootstrap.image
bake combinators.cleave combinators.cleave
builder.util builder.util
builder.common builder.common
builder.release.branch builder.release.branch

View File

@ -6,7 +6,7 @@ USING: kernel words namespaces classes parser continuations
combinators sequences splitting quotations arrays strings tools.time combinators sequences splitting quotations arrays strings tools.time
sequences.deep accessors assocs.lib sequences.deep accessors assocs.lib
io.encodings.utf8 io.encodings.utf8
combinators.cleave bake calendar calendar.format ; combinators.cleave calendar calendar.format ;
IN: builder.util IN: builder.util

View File

@ -0,0 +1,17 @@
USING: kernel combinators sequences macros fry newfx combinators.cleave ;
IN: combinators.conditional
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: 1if ( test then else -- ) '[ dup @ , , if ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: 1cond ( tbl -- )
[ [ 1st [ dup ] prepend ] [ 2nd ] bi {2} ] map
[ cond ] prefix-on ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -88,6 +88,7 @@ $nl
$nl $nl
"The basic building blocks:" "The basic building blocks:"
{ $subsection "threads" } { $subsection "threads" }
{ $subsection "alarms" }
"High-level abstractions:" "High-level abstractions:"
{ $subsection "concurrency.combinators" } { $subsection "concurrency.combinators" }
{ $subsection "concurrency.promises" } { $subsection "concurrency.promises" }
@ -274,6 +275,7 @@ ARTICLE: "handbook" "Factor documentation"
{ $heading "Library reference" } { $heading "Library reference" }
{ $subsection "numbers" } { $subsection "numbers" }
{ $subsection "collections" } { $subsection "collections" }
{ $subsection "models" }
{ $subsection "io" } { $subsection "io" }
{ $subsection "concurrency" } { $subsection "concurrency" }
{ $subsection "system" } { $subsection "system" }
@ -288,8 +290,8 @@ ARTICLE: "handbook" "Factor documentation"
{ $subsection "compiler" } { $subsection "compiler" }
{ $subsection "layouts" } { $subsection "layouts" }
{ $heading "User interface" } { $heading "User interface" }
{ $about "ui" } { $subsection "ui" }
{ $about "ui.tools" } { $subsection "ui-tools" }
{ $heading "Index" } { $heading "Index" }
{ $subsection "primitive-index" } { $subsection "primitive-index" }
{ $subsection "error-index" } { $subsection "error-index" }

View File

@ -55,23 +55,31 @@ ARTICLE: "io.monitors.descriptors" "File system change descriptors"
{ $subsection +rename-file+ } ; { $subsection +rename-file+ } ;
ARTICLE: "io.monitors.platforms" "Monitors on different platforms" ARTICLE: "io.monitors.platforms" "Monitors on different platforms"
"Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is platform-specific. User code should not assume either case." "Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is unspecified, and may even vary on the same platform. User code should not assume either case."
$nl
"If the immediate path being monitored was changed, then " { $snippet "path" } " will equal " { $snippet "\"\"" } "; however this condition is not reported on all platforms. See below."
{ $heading "Mac OS X" } { $heading "Mac OS X" }
"Factor uses " { $snippet "FSEventStream" } "s to implement monitors on Mac OS X. This requires Mac OS X 10.5 or later." "Factor uses " { $snippet "FSEventStream" } "s to implement monitors on Mac OS X. This requires Mac OS X 10.5 or later."
$nl $nl
{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link <monitor> } " has no effect." { $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link <monitor> } " has no effect."
$nl $nl
"The " { $snippet "changed" } " output value of the " { $link next-change } " word always outputs " { $link +modify-file+ } " and the " { $snippet "path" } " output value is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available." "The " { $snippet "changed" } " output value of the " { $link next-change } " word always outputs " { $link +modify-file+ } " and the " { $snippet "path" } " output value is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available."
$nl
"Only directories may be monitored, not individual files. Changes to the directory itself (permissions, modification time, and so on) are not reported; only changes to children are reported."
{ $heading "Windows" } { $heading "Windows" }
"Factor uses " { $snippet "ReadDirectoryChanges" } " to implement monitors on Windows." "Factor uses " { $snippet "ReadDirectoryChanges" } " to implement monitors on Windows."
$nl $nl
"Both recursive and non-recursive monitors are directly supported by the operating system." "Both recursive and non-recursive monitors are directly supported by the operating system."
$nl
"Only directories may be monitored, not individual files. Changes to the directory itself (permissions, modification time, and so on) are not reported; only changes to children are reported."
{ $heading "Linux" } { $heading "Linux" }
"Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later." "Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later."
$nl $nl
"Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory, since " { $snippet "inotify" } " can only monitor a single directory. This is transparent to user code." "Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory, since " { $snippet "inotify" } " can only monitor a single directory. This is transparent to user code."
$nl $nl
"Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory." "Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory."
$nl
"Both directories and files may be monitored. Unlike Mac OS X and Windows, changes to the immediate directory being monitored (permissions, modification time, and so on) are reported."
{ $heading "BSD" } { $heading "BSD" }
"Factor uses " { $snippet "kqueue" } " to implement monitors on BSD." "Factor uses " { $snippet "kqueue" } " to implement monitors on BSD."
$nl $nl

View File

@ -0,0 +1,34 @@
IN: io.unix.linux.monitors.tests
USING: io.monitors tools.test io.files system sequences
continuations namespaces concurrency.count-downs kernel io
threads calendar prettyprint destructors io.timeouts ;
! On Linux, a notification on the directory itself would report an invalid
! path name
[
[ ] [ "monitor-test-self" temp-file make-directories ] unit-test
! Non-recursive
[ ] [ "monitor-test-self" temp-file f <monitor> "m" set ] unit-test
[ ] [ "monitor-test-self" temp-file touch-file ] unit-test
[ t ] [
"m" get next-change drop
[ "" = ] [ "monitor-test-self" temp-file = ] bi or
] unit-test
[ ] [ "m" get dispose ] unit-test
! Recursive
[ ] [ "monitor-test-self" temp-file t <monitor> "m" set ] unit-test
[ ] [ "monitor-test-self" temp-file touch-file ] unit-test
[ t ] [
"m" get next-change drop
[ "" = ] [ "monitor-test-self" temp-file = ] bi or
] unit-test
[ ] [ "m" get dispose ] unit-test
] with-monitors

View File

@ -83,12 +83,15 @@ M: linux-monitor dispose* ( monitor -- )
drop drop
] { } make prune ; ] { } make prune ;
: parse-event-name ( event -- name )
dup inotify-event-len zero?
[ drop "" ] [ inotify-event-name utf8 alien>string ] if ;
: parse-file-notify ( buffer -- path changed ) : parse-file-notify ( buffer -- path changed )
dup inotify-event-mask ignore-flags? [ dup inotify-event-mask ignore-flags? [
drop f f drop f f
] [ ] [
[ inotify-event-name utf8 alien>string ] [ parse-event-name ] [ inotify-event-mask parse-action ] bi
[ inotify-event-mask parse-action ] bi
] if ; ] if ;
: events-exhausted? ( i buffer -- ? ) : events-exhausted? ( i buffer -- ? )

View File

@ -2,7 +2,7 @@ USING: tools.test io.pipes io.unix.pipes io.encodings.utf8
io.encodings io namespaces sequences ; io.encodings io namespaces sequences ;
IN: io.unix.pipes.tests IN: io.unix.pipes.tests
[ { 0 0 } ] [ { "ls" "grep x" } run-pipeline ] unit-test [ { 0 0 } ] [ { "ls" "grep ." } run-pipeline ] unit-test
[ { 0 f 0 } ] [ [ { 0 f 0 } ] [
{ {
@ -12,6 +12,6 @@ IN: io.unix.pipes.tests
output-stream [ utf8 <encoder> ] change output-stream [ utf8 <encoder> ] change
input-stream get lines reverse [ print ] each f input-stream get lines reverse [ print ] each f
] ]
"grep x" "grep ."
} run-pipeline } run-pipeline
] unit-test ] unit-test

View File

@ -52,7 +52,3 @@ HOOK: add-completion io-backend ( port -- )
"SECURITY_ATTRIBUTES" <c-object> "SECURITY_ATTRIBUTES" <c-object>
"SECURITY_ATTRIBUTES" heap-size "SECURITY_ATTRIBUTES" heap-size
over set-SECURITY_ATTRIBUTES-nLength ; over set-SECURITY_ATTRIBUTES-nLength ;
: security-attributes-inherit ( -- obj )
default-security-attributes
TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ; foldable

View File

@ -1,2 +1,3 @@
Bruno Deferrari
Doug Coleman Doug Coleman
Slava Pestov Slava Pestov

View File

@ -1,7 +1,8 @@
USING: kernel tools.test accessors arrays sequences qualified USING: kernel tools.test accessors arrays sequences qualified
io.streams.string io.streams.duplex namespaces threads io.streams.string io.streams.duplex namespaces threads
calendar irc.client.private ; calendar irc.client.private concurrency.mailboxes classes ;
EXCLUDE: irc.client => join ; EXCLUDE: irc.client => join ;
RENAME: join irc.client => join_
IN: irc.client.tests IN: irc.client.tests
! Utilities ! Utilities
@ -64,13 +65,16 @@ privmsg new
[ connect-irc ] keep 1 seconds sleep [ connect-irc ] keep 1 seconds sleep
nick>> name>> ] unit-test nick>> name>> ] unit-test
! TODO: Channel join messages { join_ "#factortest" } [
! { ":factorbot!n=factorbo@some.where JOIN :#factortest" { ":factorbot!n=factorbo@some.where JOIN :#factortest"
! ":ircserver.net MODE #factortest +ns" ":ircserver.net MODE #factortest +ns"
! ":ircserver.net 353 factorbot @ #factortest :@factorbot " ":ircserver.net 353 factorbot @ #factortest :@factorbot "
! ":ircserver.net 366 factorbot #factortest :End of /NAMES list." ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
! ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
! } make-client dup "factorbot" set-nick } make-client dup "factorbot" set-nick
[ connect-irc ] keep 1 seconds sleep
join-messages>> 5 seconds mailbox-get-timeout
[ class ] [ trailing>> ] bi ] unit-test
! TODO: user join ! TODO: user join
! ":somedude!n=user@isp.net JOIN :#factortest" ! ":somedude!n=user@isp.net JOIN :#factortest"
! TODO: channel message ! TODO: channel message

View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Doug Coleman, Slava Pestov. ! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators concurrency.mailboxes fry io strings USING: combinators concurrency.mailboxes fry io strings
io.encodings.8-bit io.sockets kernel namespaces sequences io.encodings.8-bit io.sockets kernel namespaces sequences
sequences.lib splitting threads calendar classes.tuple splitting threads calendar classes.tuple
classes ascii assocs accessors destructors continuations ; classes ascii assocs accessors destructors continuations ;
IN: irc.client IN: irc.client
@ -33,7 +33,6 @@ TUPLE: irc-listener in-messages out-messages ;
TUPLE: irc-server-listener < irc-listener ; TUPLE: irc-server-listener < irc-listener ;
TUPLE: irc-channel-listener < irc-listener name password timeout ; TUPLE: irc-channel-listener < irc-listener name password timeout ;
TUPLE: irc-nick-listener < irc-listener name ; TUPLE: irc-nick-listener < irc-listener name ;
UNION: irc-named-listener irc-nick-listener irc-channel-listener ;
: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ; : <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
@ -78,13 +77,19 @@ TUPLE: unhandled < irc-message ;
<PRIVATE <PRIVATE
! ====================================== ! ======================================
! Shortcuts ! Utils
! ====================================== ! ======================================
: irc> ( -- irc-client ) current-irc-client get ; : irc> ( -- irc-client ) current-irc-client get ;
: irc-stream> ( -- stream ) irc> stream>> ; : irc-stream> ( -- stream ) irc> stream>> ;
: irc-write ( s -- ) irc-stream> stream-write ; : irc-write ( s -- ) irc-stream> stream-write ;
: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ; : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
: listener> ( name -- listener/f ) irc> listeners>> at ;
: unregister-listener ( name -- ) irc> listeners>> delete-at ;
: to-listener ( message name -- )
listener> [ f listener> ] unless*
[ in-messages>> mailbox-put ] [ drop ] if* ;
! ====================================== ! ======================================
! IRC client messages ! IRC client messages
@ -188,8 +193,7 @@ TUPLE: unhandled < irc-message ;
GENERIC: handle-incoming-irc ( irc-message -- ) GENERIC: handle-incoming-irc ( irc-message -- )
M: irc-message handle-incoming-irc ( irc-message -- ) M: irc-message handle-incoming-irc ( irc-message -- )
f irc> listeners>> at f listener> [ in-messages>> mailbox-put ] [ drop ] if* ;
[ in-messages>> mailbox-put ] [ drop ] if* ;
M: logged-in handle-incoming-irc ( logged-in -- ) M: logged-in handle-incoming-irc ( logged-in -- )
name>> irc> nick>> (>>name) ; name>> irc> nick>> (>>name) ;
@ -201,11 +205,15 @@ M: nick-in-use handle-incoming-irc ( nick-in-use -- )
name>> "_" append /NICK ; name>> "_" append /NICK ;
M: privmsg handle-incoming-irc ( privmsg -- ) M: privmsg handle-incoming-irc ( privmsg -- )
dup irc-message-origin irc> listeners>> [ at ] keep dup irc-message-origin to-listener ;
'[ f , at ] unless* [ in-messages>> mailbox-put ] [ drop ] if* ;
M: join handle-incoming-irc ( join -- ) M: join handle-incoming-irc ( join -- )
irc> join-messages>> mailbox-put ; dup trailing>> listener>
[ irc> join-messages>> ] unless* mailbox-put ;
M: kick handle-incoming-irc ( kick -- )
[ ] [ channel>> ] [ who>> ] tri me? [ dup unregister-listener ] when
to-listener ;
M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
broadcast-message-to-listeners ; broadcast-message-to-listeners ;
@ -326,6 +334,5 @@ PRIVATE>
spawn-irc spawn-irc
] with-variable ; ] with-variable ;
GENERIC: add-listener ( irc-client irc-listener -- ) : add-listener ( irc-listener irc-client -- )
M: irc-listener add-listener ( irc-client irc-listener -- ) current-irc-client rot '[ , (add-listener) ] with-variable ;
current-irc-client swap '[ , (add-listener) ] with-variable ;

View File

@ -22,7 +22,7 @@ VAR: command-table
: exec-command* ( string -- ) : exec-command* ( string -- )
[ parameter ] [ command ] bi [ parameter ] [ command ] bi
command-table> at dup command-table> at dup
[ 1 tail* call ] [ 3drop ] if ; [ 1 tail* call ] [ 2drop ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

1
extra/micros/authors.txt Normal file
View File

@ -0,0 +1 @@
Phil Dawes

View File

@ -0,0 +1,4 @@
IN: micros.backend
USING: io.backend ;
HOOK: (micros) io-backend ( -- n )

View File

@ -0,0 +1,14 @@
IN: micros
USING: help.syntax help.markup kernel prettyprint sequences ;
HELP: micros
{ $values { "n" "an integer" } }
{ $description "Outputs the number of microseconds ellapsed since midnight January 1, 1970"
} ;
HELP: micro-time
{ $values { "quot" "a quot" }
{ "n" "an integer" } }
{ $description "executes the quotation and pushes the number of microseconds taken onto the stack"
} ;

View File

@ -0,0 +1,7 @@
IN: micros.tests
USING: micros tools.test math math.functions system kernel ;
! a bit racy but I can't think of a better way to check this right now
[ t ]
[ millis 1000 / micros 1000000 / [ truncate ] bi@ = ] unit-test

View File

@ -0,0 +1,13 @@
IN: micros
USING: micros.backend system kernel combinators vocabs.loader math ;
: micros ( -- n ) (micros) ; inline
: micro-time ( quot -- n )
micros slip micros swap - ; inline
{
{ [ os unix? ] [ "micros.unix" ] }
{ [ os windows? ] [ "micros.windows" ] }
} cond require

1
extra/micros/summary.txt Normal file
View File

@ -0,0 +1 @@
Microsecond precision clock

View File

@ -0,0 +1,6 @@
IN: micros.unix
USING: micros.backend io.backend system alien.c-types kernel unix.time math ;
M: unix (micros)
"timespec" <c-object> dup f gettimeofday drop
[ timespec-sec 1000000 * ] [ timespec-nsec ] bi + ;

View File

@ -0,0 +1,7 @@
IN: micros.windows
USING: system kernel windows.time math math.functions micros.backend ;
! 116444736000000000 is the windowstime epoch offset
! since windowstime starts at 1600 and unix epoch is 1970
M: windows (micros)
windows-time 116444736000000000 - 10 / truncate ;

View File

@ -232,8 +232,10 @@ HELP: move-by-page
{ $side-effects "range" } ; { $side-effects "range" } ;
ARTICLE: "models" "Models" ARTICLE: "models" "Models"
"The Factor UI provides basic support for dataflow programming via " { $emphasis "models" } " and " { $emphasis "controls" } ". A model is an observable value. Changing a model's value notifies other objects which depend on the model automatically, and models may depend on each other's values." "The " { $vocab-link "models" } " vocabulary provides basic support for dataflow programming. A model is an observable value. Changing a model's value notifies other objects which depend on the model automatically, and models may depend on each other's values."
$nl $nl
"The class of models:"
{ $subsection model }
"Creating models:" "Creating models:"
{ $subsection <model> } { $subsection <model> }
"Adding and removing connections:" "Adding and removing connections:"

View File

@ -195,4 +195,8 @@ METHOD: as-mutate { object object assoc } set-at ;
: adjoin ( seq elt -- seq ) over sets:adjoin ; : adjoin ( seq elt -- seq ) over sets:adjoin ;
: adjoin-on ( elt seq -- seq ) tuck sets:adjoin ; : adjoin-on ( elt seq -- seq ) tuck sets:adjoin ;
: adjoined ( set elt -- ) swap sets:adjoin ; : adjoined ( set elt -- ) swap sets:adjoin ;
: adjoined-on ( elt set -- ) sets:adjoin ; : adjoined-on ( elt set -- ) sets:adjoin ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: start ( seq subseq -- i ) swap sequences:start ;

View File

@ -0,0 +1,9 @@
IN: ori.tests
USING: ori tools.test ;
\ pitch-up must-infer
\ pitch-down must-infer
\ turn-left must-infer
\ turn-right must-infer
\ roll-left must-infer
\ roll-right must-infer

View File

@ -17,7 +17,7 @@ C: <ori> ori
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-matrix ( quot width -- matrix ) >r { } make r> group ; : make-matrix ( quot width -- matrix ) >r { } make r> group ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -1,6 +1,6 @@
USING: kernel namespaces arrays quotations sequences assocs combinators USING: kernel namespaces arrays quotations sequences assocs combinators
mirrors math math.vectors random macros bake ; mirrors math math.vectors random macros fry ;
IN: random-weighted IN: random-weighted
@ -16,5 +16,5 @@ probabilities layers [ 1000 * ] map 1000 random [ > ] curry find drop ;
dup [ second ] map swap [ first ] map random-weighted swap nth ; dup [ second ] map swap [ first ] map random-weighted swap nth ;
MACRO: call-random-weighted ( exp -- ) MACRO: call-random-weighted ( exp -- )
[ keys ] [ values <enum> >alist ] bi swap [ keys ] [ values <enum> >alist ] bi
[ , random-weighted , case ] bake ; '[ , random-weighted , case ] ;

View File

@ -1,5 +1,6 @@
USING: kernel parser namespaces threads arrays sequences unix unix.process bake ; USING: kernel parser namespaces threads arrays sequences unix unix.process
bake ;
IN: raptor IN: raptor

View File

@ -1,30 +1,26 @@
USING: kernel parser math quotations namespaces sequences namespaces.lib USING: kernel parser math quotations namespaces sequences macros fry ;
inference.transforms ;
IN: rewrite-closures IN: rewrite-closures
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : set-parameters ( seq -- ) reverse [ set ] each ; : [set-parameters] ( seq -- quot ) reverse [ [ set ] curry ] map concat ;
: [set-parameters] ( seq -- quot ) [ [ set ] curry ] map concat ; MACRO: set-parameters ( seq -- quot ) [set-parameters] ;
: set-parameters ( seq -- ) [set-parameters] call ;
\ set-parameters [ [set-parameters] ] 1 define-transform
: parametric-quot ( parameters quot -- quot )
[ [ swap ] set-parameters [ ] call ] make* ;
: scoped-quot ( quot -- quot ) [ with-scope ] curry ;
: closed-quot ( quot -- quot )
[ namestack >r [ namestack ] set-namestack [ ] call r> set-namestack ] make* ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: lambda ( parameters quot -- ) parametric-quot scoped-quot closed-quot ; : parametric-quot ( parameters quot -- quot ) '[ , set-parameters , call ] ;
: scoped-quot ( quot -- quot ) '[ , with-scope ] ;
: closed-quot ( quot -- quot )
namestack swap '[ namestack [ , set-namestack @ ] dip set-namestack ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: lambda ( parameters quot -- quot ) parametric-quot scoped-quot closed-quot ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -12,15 +12,15 @@ IN: size-of
VAR: headers VAR: headers
: include-headers ( -- seq ) : include-headers ( -- seq )
headers> [ { "#include <" , ">" } bake to-string ] map ; headers> [ `{ "#include <" , ">" } to-string ] map ;
: size-of-c-program ( type -- lines ) : size-of-c-program ( type -- lines )
{ `{
"#include <stdio.h>" "#include <stdio.h>"
include-headers include-headers
{ "main() { printf( \"%i\" , sizeof( " , " ) ) ; }" } { "main() { printf( \"%i\" , sizeof( " , " ) ) ; }" }
} }
bake to-strings ; to-strings ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -1,6 +1,6 @@
USING: kernel namespaces arrays sequences threads math math.vectors USING: kernel namespaces arrays sequences threads math math.vectors
ui random bake springies springies.ui ; ui random springies springies.ui ;
IN: springies.models.2x2snake IN: springies.models.2x2snake

View File

@ -1,5 +1,5 @@
USING: kernel namespaces arrays sequences threads math ui random bake USING: kernel namespaces arrays sequences threads math ui random fry
springies springies.ui ; springies springies.ui ;
IN: springies.models.3snake IN: springies.models.3snake
@ -158,8 +158,10 @@ times
; ;
: go* ( quot -- ) ! : go* ( quot -- )
[ [ [ springies-window* 1000 sleep % ] with-scope ] with-ui ] bake call ; ! [ [ [ springies-window* 1000 sleep % ] with-scope ] with-ui ] bake call ;
: go* ( quot -- ) '[ [ springies-window* 1000 sleep @ ] with-scope ] with-ui ;
! : go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ; ! : go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ;

View File

@ -1,5 +1,5 @@
USING: kernel namespaces arrays sequences threads math ui random bake USING: kernel namespaces arrays sequences threads math ui random
springies springies.ui ; springies springies.ui ;
IN: springies.models.belt-tire IN: springies.models.belt-tire

View File

@ -1,6 +1,6 @@
USING: kernel namespaces arrays sequences threads math math.vectors USING: kernel namespaces arrays sequences threads math math.vectors
ui random bake springies springies.ui ; ui random springies springies.ui ;
IN: springies.models.nifty IN: springies.models.nifty

View File

@ -1,6 +1,6 @@
USING: kernel namespaces arrays sequences threads math math.vectors USING: kernel namespaces arrays sequences threads math math.vectors
ui random bake ui random
springies springies.ui ; springies springies.ui ;
IN: springies.models.urchin IN: springies.models.urchin

View File

@ -1,7 +1,7 @@
USING: kernel namespaces threads sequences math math.vectors USING: kernel namespaces threads sequences math math.vectors
opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate
bake rewrite-closures vars springies ; fry rewrite-closures vars springies ;
IN: springies.ui IN: springies.ui
@ -62,5 +62,4 @@ DEFER: maybe-loop
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: go* ( quot -- ) : go* ( quot -- ) '[ [ springies-window* 1000 sleep @ ] with-scope ] with-ui ;
[ [ [ springies-window* 1000 sleep % ] with-scope ] with-ui ] bake call ;

View File

@ -89,8 +89,8 @@ ARTICLE: "building-ui" "Building user interfaces"
{ $subsection "ui-geometry" } { $subsection "ui-geometry" }
{ $subsection "ui-layouts" } { $subsection "ui-layouts" }
{ $subsection "gadgets" } { $subsection "gadgets" }
{ $subsection "models" } { $subsection "ui-windows" }
{ $subsection "ui-windows" } ; { $see-also "models" } ;
ARTICLE: "gadgets" "Pre-made UI gadgets" ARTICLE: "gadgets" "Pre-made UI gadgets"
{ $subsection "ui.gadgets.labels" } { $subsection "ui.gadgets.labels" }

View File

@ -29,4 +29,5 @@ C-STRUCT: timespec
[ set-timespec-sec ] keep ; [ set-timespec-sec ] keep ;
FUNCTION: time_t time ( time_t* t ) ; FUNCTION: time_t time ( time_t* t ) ;
FUNCTION: tm* localtime ( time_t* clock ) ; FUNCTION: tm* localtime ( time_t* clock ) ;
FUNCTION: int gettimeofday ( timespec* TP, void* TZP ) ;

View File

@ -28,8 +28,14 @@ INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
F_ZONE *tenured = &data_heap->generations[TENURED]; F_ZONE *tenured = &data_heap->generations[TENURED];
if(fread((void*)tenured->start,h->data_size,1,file) != 1) long int bytes_read = fread((void*)tenured->start,1,h->data_size,file);
if(bytes_read != h->data_size)
{
fprintf(stderr,"truncated image: %ld bytes read, %ld bytes expected\n",
bytes_read,h->data_size);
fatal_error("load_data_heap failed",0); fatal_error("load_data_heap failed",0);
}
tenured->here = tenured->start + h->data_size; tenured->here = tenured->start + h->data_size;
data_relocation_base = h->data_relocation_base; data_relocation_base = h->data_relocation_base;
@ -44,9 +50,16 @@ INLINE void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
init_code_heap(p->code_size); init_code_heap(p->code_size);
if(h->code_size != 0 if(h->code_size != 0)
&& fread(first_block(&code_heap),h->code_size,1,file) != 1) {
fatal_error("load_code_heap failed",0); long int bytes_read = fread(first_block(&code_heap),1,h->code_size,file);
if(bytes_read != h->code_size)
{
fprintf(stderr,"truncated image: %ld bytes read, %ld bytes expected\n",
bytes_read,h->code_size);
fatal_error("load_code_heap failed",0);
}
}
code_relocation_base = h->code_relocation_base; code_relocation_base = h->code_relocation_base;
build_free_list(&code_heap,h->code_size); build_free_list(&code_heap,h->code_size);