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

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

db4
Doug Coleman 2008-02-26 02:06:56 -06:00
parent b7bb604d1b 18a96f87ee
commit 9cf3ecf04d
37 changed files with 234 additions and 150 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/compiler/tests/curry.factor
View File

@ -1,5 +1,5 @@
USING: tools.test compiler quotations math kernel sequences
assocs namespaces ;
USING: tools.test quotations math kernel sequences
assocs namespaces compiler.units ;
IN: temporary
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test

2
core/compiler/tests/float.factor
View File

@ -1,5 +1,5 @@
IN: temporary
USING: compiler kernel kernel.private memory math
USING: compiler.units kernel kernel.private memory math
math.private tools.test math.floats.private ;
[ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test

13
core/compiler/tests/intrinsics.factor
View File

@ -1,10 +1,11 @@
IN: temporary
USING: arrays compiler kernel kernel.private math math.constants
math.private sequences strings tools.test words continuations
sequences.private hashtables.private byte-arrays strings.private
system random layouts vectors.private sbufs.private
strings.private slots.private alien alien.accessors
alien.c-types alien.syntax namespaces libc sequences.private ;
USING: arrays compiler.units kernel kernel.private math
math.constants math.private sequences strings tools.test words
continuations sequences.private hashtables.private byte-arrays
strings.private system random layouts vectors.private
sbufs.private strings.private slots.private alien
alien.accessors alien.c-types alien.syntax namespaces libc
sequences.private ;
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test

2
core/compiler/tests/simple.factor
View File

@ -1,4 +1,4 @@
USING: compiler tools.test kernel kernel.private
USING: compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings
alien arrays memory ;
IN: temporary

2
core/compiler/tests/tuples.factor
View File

@ -1,5 +1,5 @@
IN: temporary
USING: kernel tools.test compiler ;
USING: kernel tools.test compiler.units ;
TUPLE: color red green blue ;

9
core/compiler/units/units.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations assocs namespaces sequences words
vocabs definitions hashtables ;
vocabs definitions hashtables init ;
IN: compiler.units
SYMBOL: old-definitions
@ -37,12 +37,13 @@ SYMBOL: recompile-hook
SYMBOL: definition-observers
definition-observers global [ V{ } like ] change-at
GENERIC: definitions-changed ( assoc obj -- )
[ V{ } clone definition-observers set-global ]
"compiler.units" add-init-hook
: add-definition-observer ( obj -- )
definition-observers get push-new ;
definition-observers get push ;
: remove-definition-observer ( obj -- )
definition-observers get delete ;

2
core/inference/state/state-tests.factor
View File

@ -1,5 +1,5 @@
IN: temporary
USING: tools.test inference.state ;
USING: tools.test inference.state words ;
SYMBOL: a
SYMBOL: b

2
core/optimizer/optimizer-tests.factor
View File

@ -1,4 +1,4 @@
USING: arrays compiler generic hashtables inference kernel
USING: arrays compiler.units generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private

2
core/parser/parser.factor
View File

@ -468,7 +468,7 @@ SYMBOL: interactive-vocabs
#! If a class word had a compound definition which was
#! removed, it must go back to being a symbol.
new-definitions get first2 diff
[ nip define-symbol ] assoc-each ;
[ nip dup reset-generic define-symbol ] assoc-each ;
: forget-smudged ( -- )
smudged-usage forget-all

37
core/threads/threads.factor
View File

@ -86,6 +86,13 @@ PRIVATE>
f over set-thread-state
check-registered 2array run-queue push-front ;
: sleep-time ( -- ms/f )
{
{ [ run-queue dlist-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] }
{ [ t ] [ sleep-queue heap-peek nip millis [-] ] }
} cond ;
<PRIVATE
: schedule-sleep ( thread ms -- )
@ -106,23 +113,27 @@ PRIVATE>
[ ] while
drop ;
: next ( -- )
: next ( -- * )
expire-sleep-loop
run-queue pop-back
dup array? [ first2 ] [ f swap ] if dup set-self
f over set-thread-state
thread-continuation box>
continue-with ;
run-queue dup dlist-empty? [
! We should never be in a state where the only threads
! are sleeping; the I/O wait thread is always runnable.
! However, if it dies, we handle this case
! semi-gracefully.
!
! And if sleep-time outputs f, there are no sleeping
! threads either... so WTF.
drop sleep-time [ die 0 ] unless* (sleep) next
] [
pop-back
dup array? [ first2 ] [ f swap ] if dup set-self
f over set-thread-state
thread-continuation box>
continue-with
] if ;
PRIVATE>
: sleep-time ( -- ms/f )
{
{ [ run-queue dlist-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] }
{ [ t ] [ sleep-queue heap-peek nip millis [-] ] }
} cond ;
: stop ( -- )
self dup thread-exit-handler call
unregister-thread next ;

41
core/vocabs/loader/loader.factor
View File

@ -153,16 +153,18 @@ SYMBOL: load-help?
[ load-error. nl ] each ;
SYMBOL: blacklist
SYMBOL: failures
: require-all ( vocabs -- failures )
[
V{ } clone blacklist set
V{ } clone failures set
[
[ require ]
[ >r vocab-name r> 2array blacklist get push ]
[ swap vocab-name failures get set-at ]
recover
] each
blacklist get
failures get
] with-compiler-errors ;
: do-refresh ( modified-sources modified-docs -- )
@ -176,12 +178,17 @@ SYMBOL: blacklist
: refresh-all ( -- ) "" refresh ;
GENERIC: (load-vocab) ( name -- vocab )
!
: add-to-blacklist ( error vocab -- )
vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
M: vocab (load-vocab)
dup vocab-root [
dup vocab-source-loaded? [ dup load-source ] unless
dup vocab-docs-loaded? [ dup load-docs ] unless
] when ;
[
dup vocab-root [
dup vocab-source-loaded? [ dup load-source ] unless
dup vocab-docs-loaded? [ dup load-docs ] unless
] when
] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
M: string (load-vocab)
[ ".private" ?tail drop reload ] keep vocab ;
@ -189,24 +196,14 @@ M: string (load-vocab)
M: vocab-link (load-vocab)
vocab-name (load-vocab) ;
TUPLE: blacklisted-vocab name ;
: blacklisted-vocab ( name -- * )
\ blacklisted-vocab construct-boa throw ;
M: blacklisted-vocab error.
"This vocabulary depends on the " write
blacklisted-vocab-name write
" vocabulary which failed to load" print ;
[
dup vocab-name blacklist get key? [
vocab-name blacklisted-vocab
dup vocab-name blacklist get at* [
rethrow
] [
[
dup vocab [ ] [ ] ?if (load-vocab)
] with-compiler-errors
drop
[ dup vocab swap or (load-vocab) ] with-compiler-errors
] if
] load-vocab-hook set-global
: vocab-where ( vocab -- loc )

8
core/words/words-tests.factor
View File

@ -1,6 +1,6 @@
USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations
vocabs continuations tuples compiler.units ;
vocabs continuations tuples compiler.units io.streams.string ;
IN: temporary
[ 4 ] [
@ -156,11 +156,13 @@ SYMBOL: quot-uses-b
[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test
[ ] [
"IN: temporary GENERIC: symbol-generic" eval
"IN: temporary GENERIC: symbol-generic" <string-reader>
"symbol-generic-test" parse-stream drop
] unit-test
[ ] [
"IN: temporary TUPLE: symbol-generic ;" eval
"IN: temporary TUPLE: symbol-generic ;" <string-reader>
"symbol-generic-test" parse-stream drop
] unit-test
[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test

25
extra/builder/builder.factor
View File

@ -65,12 +65,6 @@ IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : factor-binary ( -- name )
! os "macosx" =
! [ "./Factor.app/Contents/MacOS/factor" ]
! [ "./factor" ]
! if ;
: bootstrap-cmd ( -- cmd )
{ "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
@ -146,7 +140,11 @@ SYMBOL: build-status
show-benchmark-deltas
"../benchmarks" "../../benchmarks" copy-file
"../benchmarks" "../../benchmarks" copy-file
".." cd
maybe-release
] with-file-writer
@ -167,7 +165,7 @@ SYMBOL: builder-recipients
builder-from get >>from
builder-recipients get >>to
subject >>subject
"../report" file>string >>body
"./report" file>string >>body
send ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -176,11 +174,11 @@ SYMBOL: builder-recipients
{ "bzip2" my-boot-image-name } to-strings run-process drop ;
: build ( -- )
[ (build) ] [ drop ] recover
build-status get [ maybe-release ] when
[ (build) ] failsafe
builds cd stamp> cd
[ send-builder-email ] [ drop "not sending mail" . ] recover
".." cd { "rm" "-rf" "factor" } run-process drop
[ compress-image ] [ drop ] recover ;
{ "rm" "-rf" "factor" } run-process drop
[ compress-image ] failsafe ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -215,8 +213,7 @@ USE: bootstrap.image.download
[ build ]
when
]
[ drop ]
recover
failsafe
5 minutes sleep
build-loop ;

10
extra/builder/release/release.factor
View File

@ -64,6 +64,8 @@ USING: system sequences splitting ;
: linux-release ( -- )
"factor" cd
{ "rm" "-rf" "Factor.app" } run-process drop
{ "rm" "-rf" common-files } to-strings run-process drop
@ -78,6 +80,8 @@ USING: system sequences splitting ;
: windows-release ( -- )
"factor" cd
{ "rm" "-rf" "Factor.app" } run-process drop
{ "rm" "-rf" common-files } to-strings run-process drop
@ -92,6 +96,8 @@ USING: system sequences splitting ;
: macosx-release ( -- )
"factor" cd
{ "rm" "-rf" common-files } to-strings run-process drop
".." cd
@ -120,8 +126,8 @@ USING: system sequences splitting ;
: release? ( -- ? )
{
"../load-everything-vocabs"
"../test-all-vocabs"
"./load-everything-vocabs"
"./test-all-vocabs"
}
[ eval-file empty? ]
all? ;

6
extra/builder/util/util.factor
View File

@ -104,4 +104,8 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ;
USE: prettyprint
: to-file ( object file -- ) [ . ] with-file-writer ;
: to-file ( object file -- ) [ . ] with-file-writer ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: failsafe ( quot -- ) [ drop ] recover ;

3
extra/cocoa/cocoa-tests.factor
View File

@ -1,6 +1,7 @@
IN: temporary
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
compiler kernel namespaces cocoa.classes tools.test memory ;
compiler kernel namespaces cocoa.classes tools.test memory
compiler.units ;
CLASS: {
{ +superclass+ "NSObject" }

2
extra/concurrency/conditions/conditions.factor
View File

@ -8,7 +8,7 @@ IN: concurrency.conditions
dup dlist-empty? [ drop ] [ pop-back resume-now ] if ;
: notify-all ( dlist -- )
[ resume-now ] dlist-slurp yield ;
[ resume-now ] dlist-slurp ;
: queue-timeout ( queue timeout -- alarm )
#! Add an alarm which removes the current thread from the

33
extra/concurrency/flags/flags-docs.factor Normal file
View File

@ -0,0 +1,33 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax ;
IN: concurrency.flags
HELP: flag
{ $class-description "A flag allows one thread to notify another when a condition is satisfied." } ;
HELP: <flag>
{ $values { "flag" flag } }
{ $description "Creates a new flag." } ;
HELP: raise-flag
{ $values { "flag" flag } }
{ $description "Raises a flag, notifying any threads waiting on it. Does nothing if the flag has already been raised." } ;
HELP: lower-flag
{ $values { "flag" flag } }
{ $description "Attempts to lower a flag. If the flag has been raised previously, returns immediately, otherwise waits for it to be raised first." } ;
ARTICLE: "concurrency.flags" "Flags"
"A " { $emphasis "flag" } " is a condition notification device which can be in one of two states: " { $emphasis "lowered" } " (the initial state) or " { $emphasis "raised" } "."
$nl
"The flag can be raised at any time; raising a raised flag does nothing. Lowering a flag if the flag has not been raised, it first waits for it to be raised."
$nl
"Essentially, a flag can be thought of as a counting semaphore where the count never goes above one."
{ $subsection flag }
{ $subsection flag? }
"Raising and lowering flags:"
{ $subsection raise-flag }
{ $subsection lower-flag } ;
ABOUT: "concurrency.flags"

21
extra/concurrency/flags/flags.factor Normal file
View File

@ -0,0 +1,21 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: boxes kernel threads ;
IN: concurrency.flags
TUPLE: flag value? thread ;
: <flag> ( -- flag ) f <box> flag construct-boa ;
: raise-flag ( flag -- )
dup flag-value? [
dup flag-thread ?box
[ resume ] [ drop t over set-flag-value? ] if
] unless drop ;
: lower-flag ( flag -- )
dup flag-value? [
f swap set-flag-value?
] [
[ flag-thread >box ] curry "flag" suspend drop
] if ;

2
extra/concurrency/mailboxes/mailboxes.factor
View File

@ -15,7 +15,7 @@ TUPLE: mailbox threads data ;
: mailbox-put ( obj mailbox -- )
[ mailbox-data push-front ] keep
mailbox-threads notify-all ;
mailbox-threads notify-all yield ;
: block-unless-pred ( pred mailbox timeout -- )
2over mailbox-data dlist-contains? [

4
extra/help/handbook/handbook.factor
View File

@ -86,7 +86,8 @@ concurrency.futures
concurrency.locks
concurrency.semaphores
concurrency.count-downs
concurrency.exchangers ;
concurrency.exchangers
concurrency.flags ;
ARTICLE: "concurrency" "Concurrency"
"Factor supports a variety of concurrency abstractions, however they are mostly used to multiplex input/output operations since the thread scheduling is co-operative and only one CPU is used at a time."
@ -106,6 +107,7 @@ $nl
{ $subsection "concurrency.semaphores" }
{ $subsection "concurrency.count-downs" }
{ $subsection "concurrency.exchangers" }
{ $subsection "concurrency.flags" }
"Other concurrency abstractions include " { $vocab-link "concurrency.distributed" } " and " { $vocab-link "channels" } "." ;
ARTICLE: "objects" "Objects"

4
extra/html/elements/elements.factor
View File

@ -87,14 +87,14 @@ SYMBOL: html
#! word.
foo> [ ">" write-html ] empty-effect html-word ;
: </foo> [ "</" % % ">" % ] "" make ;
: </foo> "</" swap ">" 3append ;
: def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned
#! word.
</foo> dup [ write-html ] curry empty-effect html-word ;
: <foo/> [ "<" % % "/>" % ] "" make ;
: <foo/> "<" swap "/>" 3append ;
: def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned

2
extra/io/sockets/impl/impl.factor
View File

@ -53,7 +53,7 @@ M: inet4 make-sockaddr ( inet -- sockaddr )
SYMBOL: port-override
: (port) port-override get [ ] [ ] ?if ;
: (port) port-override get swap or ;
M: inet4 parse-sockaddr
>r dup sockaddr-in-addr <uint> r> inet-ntop

60
extra/io/unix/unix-tests.factor
View File

@ -4,12 +4,12 @@ sequences prettyprint system ;
IN: temporary
! Unix domain stream sockets
[
[
"unix-domain-socket-test" resource-path delete-file
] ignore-errors
: socket-server "unix-domain-socket-test" temp-file ;
"unix-domain-socket-test" resource-path <local>
[
[ socket-server delete-file ] ignore-errors
socket-server <local>
<server> [
stdio get accept [
"Hello world" print flush
@ -17,14 +17,14 @@ IN: temporary
] with-stream
] with-stream
"unix-domain-socket-test" resource-path delete-file
socket-server delete-file
] "Test" spawn drop
yield
[ { "Hello world" "FOO" } ] [
[
"unix-domain-socket-test" resource-path <local> <client>
socket-server <local> <client>
[
readln ,
"XYZ" print flush
@ -33,17 +33,16 @@ yield
] { } make
] unit-test
! Unix domain datagram sockets
[
"unix-domain-datagram-test" resource-path delete-file
] ignore-errors
: datagram-server "unix-domain-datagram-test" temp-file ;
: datagram-client "unix-domain-datagram-test-2" temp-file ;
: server-addr "unix-domain-datagram-test" temp-file <local> ;
: client-addr "unix-domain-datagram-test-2" temp-file <local> ;
! Unix domain datagram sockets
[ datagram-server delete-file ] ignore-errors
[ datagram-client delete-file ] ignore-errors
[
[
server-addr <datagram> "d" set
datagram-server <local> <datagram> "d" set
"Receive 1" print
@ -67,58 +66,53 @@ yield
"Done" print
"unix-domain-datagram-test" resource-path delete-file
datagram-server delete-file
] with-scope
] "Test" spawn drop
yield
[
"unix-domain-datagram-test-2" resource-path delete-file
] ignore-errors
[ datagram-client delete-file ] ignore-errors
client-addr <datagram>
datagram-client <local> <datagram>
"d" set
[ ] [
"hello" >byte-array
server-addr
datagram-server <local>
"d" get send
] unit-test
[ "olleh" t ] [
"d" get receive
server-addr =
datagram-server <local> =
>r >string r>
] unit-test
[ ] [
"hello" >byte-array
server-addr
datagram-server <local>
"d" get send
] unit-test
[ "hello world" t ] [
"d" get receive
server-addr =
datagram-server <local> =
>r >string r>
] unit-test
[ ] [ "d" get dispose ] unit-test
! Test error behavior
: another-datagram "unix-domain-datagram-test-3" temp-file ;
[
"unix-domain-datagram-test-3" resource-path delete-file
] ignore-errors
[ another-datagram delete-file ] ignore-errors
"unix-domain-datagram-test-2" temp-file delete-file
datagram-client delete-file
[ ] [ client-addr <datagram> "d" set ] unit-test
[ ] [ datagram-client <local> <datagram> "d" set ] unit-test
[
B{ 1 2 3 } "unix-domain-datagram-test-3" <local> "d" get send
] must-fail
[ B{ 1 2 3 } another-datagram <local> "d" get send ] must-fail
[ ] [ "d" get dispose ] unit-test
@ -126,7 +120,7 @@ client-addr <datagram>
[ "d" get receive ] must-fail
[ B{ 1 2 } server-addr "d" get send ] must-fail
[ B{ 1 2 } datagram-server <local> "d" get send ] must-fail
! Invalid parameter tests
@ -140,7 +134,7 @@ client-addr <datagram>
[
image [
B{ 1 2 } server-addr
B{ 1 2 } datagram-server <local>
stdio get send
] with-file-reader
] must-fail

2
extra/ogg/player/player.factor
View File

@ -149,7 +149,7 @@ HINTS: yuv>rgb byte-array byte-array ;
dup player-gadget [
dup { player-td player-yuv } get-slots theora_decode_YUVout drop
dup player-rgb over player-yuv yuv>rgb
dup player-gadget relayout yield
dup player-gadget relayout-1 yield
] when ;
: num-audio-buffers-processed ( player -- player n )

2
extra/smtp/smtp.factor
View File

@ -114,7 +114,7 @@ LOG: smtp-response DEBUG
: extract-email ( recepient -- email )
#! This could be much smarter.
" " last-split1 [ ] [ ] ?if "<" ?head drop ">" ?tail drop ;
" " last-split1 swap or "<" ?head drop ">" ?tail drop ;
: message-id ( -- string )
[

2
extra/ui/cocoa/cocoa.factor
View File

@ -19,7 +19,7 @@ SYMBOL: stop-after-last-window?
: event-loop ( -- )
event-loop? [
[
[ NSApp do-events ui-step ui-wait ] ui-try
[ NSApp do-events ui-wait ] ui-try
] with-autorelease-pool event-loop
] when ;

1
extra/ui/cocoa/views/views.factor Normal file → Executable file
View File

@ -298,7 +298,6 @@ CLASS: {
[
[
2drop dup view-dim swap window set-gadget-dim
ui-step
] ui-try
]
}

10
extra/ui/gadgets/gadgets.factor
View File

@ -2,9 +2,13 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables kernel models math namespaces sequences
quotations math.vectors combinators sorting vectors dlists
models threads ;
models threads concurrency.flags ;
IN: ui.gadgets
SYMBOL: ui-notify-flag
: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
TUPLE: rect loc dim ;
C: <rect> rect
@ -178,10 +182,6 @@ M: array gadget-text*
: forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
SYMBOL: ui-thread
: notify-ui-thread ( -- ) ui-thread get interrupt ;
: layout-queue ( -- queue ) \ layout-queue get ;
: layout-later ( gadget -- )

2
extra/ui/tools/listener/listener.factor
View File

@ -133,7 +133,7 @@ M: stack-display tool-scroller
: restart-listener ( listener -- )
dup com-end dup clear-output
[ init-namespaces listener-thread ] curry
[ listener-thread ] curry
"Listener" spawn drop ;
: init-listener ( listener -- )

5
extra/ui/tools/search/search.factor
View File

@ -7,7 +7,7 @@ source-files definitions strings tools.completion tools.crossref
tuples ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
ui.gestures ui.operations vocabs words vocabs.loader
tools.browser unicode.case calendar ;
tools.browser unicode.case calendar ui ;
IN: ui.tools.search
TUPLE: live-search field list ;
@ -45,7 +45,8 @@ search-field H{
} set-gestures
: <search-model> ( producer -- model )
>r g live-search-field gadget-model 1/5 seconds <delay>
>r g live-search-field gadget-model
ui-running? [ 1/5 seconds <delay> ] when
[ "\n" join ] r> append <filter> ;
: <search-list> ( seq limited? presenter -- gadget )

2
extra/ui/ui-docs.factor
View File

@ -167,7 +167,7 @@ ARTICLE: "ui-backend-init" "UI initialization and the event loop"
{ $subsection start-ui }
"The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down."
$nl
"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-step } ", which performs pending layout and sleeps for 10 milliseconds." ;
"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-wait } "." ;
ARTICLE: "ui-backend-windows" "UI backend window management"
"The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:"

46
extra/ui/ui.factor
View File

@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces
prettyprint dlists sequences threads sequences words
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init combinators
hashtables ;
hashtables concurrency.flags ;
IN: ui
! Assoc mapping aliens to gadgets
@ -130,14 +130,36 @@ SYMBOL: ui-hook
: notify-queued ( -- )
graft-queue [ notify ] dlist-slurp ;
: ui-step ( -- )
: update-ui ( -- )
[ notify-queued layout-queued redraw-worlds ] assert-depth ;
: ui-wait ( -- )
10 sleep ;
: ui-try ( quot -- ) [ ui-error ] recover ;
SYMBOL: ui-thread
: ui-running ( quot -- )
t \ ui-running set-global
[ f \ ui-running set-global ] [ ] cleanup ; inline
: ui-running? ( -- ? )
\ ui-running get-global ;
: update-ui-loop ( -- )
ui-running? ui-thread get-global self eq? [
ui-notify-flag get lower-flag
[ update-ui ] ui-try
update-ui-loop
] when ;
: start-ui-thread ( -- )
[ self ui-thread set-global update-ui-loop ]
"UI update" spawn drop ;
: open-world-window ( world -- )
dup pref-dim over set-gadget-dim dup relayout graft ui-step ;
dup pref-dim over set-gadget-dim dup relayout graft ;
: open-window ( gadget title -- )
>r [ 1 track, ] { 0 1 } make-track r>
@ -158,21 +180,17 @@ M: object close-window
find-world [ ungraft ] when* ;
: start-ui ( -- )
self ui-thread set-global
restore-windows? [
restore-windows
] [
init-ui ui-hook get call
] if ui-step ;
] if
notify-ui-thread start-ui-thread ;
: ui-running ( quot -- )
t \ ui-running set-global
[ f \ ui-running set-global ] [ ] cleanup ; inline
: ui-running? ( -- ? )
\ ui-running get-global ;
[ f \ ui-running set-global ] "ui" add-init-hook
[
f \ ui-running set-global
<flag> ui-notify-flag set-global
] "ui" add-init-hook
HOOK: ui ui-backend ( -- )
@ -185,5 +203,3 @@ MAIN: ui
f windows set-global
ui-hook [ ui ] with-variable
] if ;
: ui-try ( quot -- ) [ ui-error ] recover ;

10
extra/ui/windows/windows.factor
View File

@ -85,12 +85,12 @@ SYMBOL: mouse-captured
: handle-wm-paint ( hWnd uMsg wParam lParam -- )
#! wParam and lParam are unused
#! only paint if width/height both > 0
3drop window draw-world ;
3drop window relayout-1 ;
: handle-wm-size ( hWnd uMsg wParam lParam -- )
2nip
[ lo-word ] keep hi-word 2array
dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ui-step ] if ;
dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ] if ;
: handle-wm-move ( hWnd uMsg wParam lParam -- )
2nip
@ -353,14 +353,12 @@ M: windows-ui-backend (close-window)
: event-loop ( msg -- )
{
{ [ windows get empty? ] [ drop ] }
{ [ dup peek-message? ] [
>r [ ui-step ui-wait ] ui-try
r> event-loop
] }
{ [ dup peek-message? ] [ ui-wait event-loop ] }
{ [ dup MSG-message WM_QUIT = ] [ drop ] }
{ [ t ] [
dup TranslateMessage drop
dup DispatchMessage drop
yield
event-loop
] }
} cond ;

2
extra/ui/x11/x11.factor
View File

@ -178,7 +178,7 @@ M: world client-event
next-event dup
None XFilterEvent zero? [ drop wait-event ] unless
] [
ui-step ui-wait wait-event
ui-wait wait-event
] if ;
: do-events ( -- )

2
vm/code_heap.c
View File

@ -229,7 +229,7 @@ CELL allot_code_block(CELL size)
/* Insufficient room even after code GC, give up */
if(start == 0)
critical_error("Out of memory in add-compiled-block",0);
fatal_error("Out of memory in add-compiled-block",0);
}
return start;

2
vm/factor.c
View File

@ -19,7 +19,7 @@ void default_parameters(F_PARAMETERS *p)
p->rs_size = 32 * CELLS;
p->gen_count = 3;
p->code_size = 4 * CELLS;
p->code_size = 8 * CELLS;
p->young_size = 2 * CELLS;
p->aging_size = 4 * CELLS;
#endif