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

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

Conflicts:

	extra/io/unix/unix-tests.factor
	extra/ogg/player/player.factor
db4
Daniel Ehrenberg 2008-02-26 00:31:34 -06:00
parent 4cfdc3de62 18a96f87ee
commit f7a2bc066c
56 changed files with 386 additions and 268 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile
View File

@ -145,7 +145,8 @@ wince-arm:
macosx.app: factor macosx.app: factor
mkdir -p $(BUNDLE)/Contents/MacOS mkdir -p $(BUNDLE)/Contents/MacOS
cp $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
ln -s Factor.app/Contents/MacOS/factor ./factor
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks cp $(ENGINE) $(BUNDLE)/Contents/Frameworks
install_name_tool \ install_name_tool \

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

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

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

@ -1,5 +1,5 @@
IN: temporary IN: temporary
USING: compiler kernel kernel.private memory math USING: compiler.units kernel kernel.private memory math
math.private tools.test math.floats.private ; math.private tools.test math.floats.private ;
[ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test [ 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 IN: temporary
USING: arrays compiler kernel kernel.private math math.constants USING: arrays compiler.units kernel kernel.private math
math.private sequences strings tools.test words continuations math.constants math.private sequences strings tools.test words
sequences.private hashtables.private byte-arrays strings.private continuations sequences.private hashtables.private byte-arrays
system random layouts vectors.private sbufs.private strings.private system random layouts vectors.private
strings.private slots.private alien alien.accessors sbufs.private strings.private slots.private alien
alien.c-types alien.syntax namespaces libc sequences.private ; alien.accessors alien.c-types alien.syntax namespaces libc
sequences.private ;
! Make sure that intrinsic ops compile to correct code. ! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test [ ] [ 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 sequences.private math.private math combinators strings
alien arrays memory ; alien arrays memory ;
IN: temporary IN: temporary

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

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

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

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

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

@ -1,5 +1,5 @@
IN: temporary IN: temporary
USING: tools.test inference.state ; USING: tools.test inference.state words ;
SYMBOL: a SYMBOL: a
SYMBOL: b 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 kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private 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 #! If a class word had a compound definition which was
#! removed, it must go back to being a symbol. #! removed, it must go back to being a symbol.
new-definitions get first2 diff new-definitions get first2 diff
[ nip define-symbol ] assoc-each ; [ nip dup reset-generic define-symbol ] assoc-each ;
: forget-smudged ( -- ) : forget-smudged ( -- )
smudged-usage forget-all smudged-usage forget-all

18
core/threads/threads-docs.factor
View File

@ -19,8 +19,7 @@ ARTICLE: "threads-yield" "Yielding and suspending threads"
{ $subsection yield } { $subsection yield }
"Sleeping for a period of time:" "Sleeping for a period of time:"
{ $subsection sleep } { $subsection sleep }
"Interruptible sleep:" "Interrupting sleep:"
{ $subsection nap }
{ $subsection interrupt } { $subsection interrupt }
"Threads can be suspended and woken up at some point in the future when a condition is satisfied:" "Threads can be suspended and woken up at some point in the future when a condition is satisfied:"
{ $subsection suspend } { $subsection suspend }
@ -106,14 +105,17 @@ HELP: stop
HELP: yield HELP: yield
{ $description "Adds the current thread to the end of the run queue, and switches to the next runnable thread." } ; { $description "Adds the current thread to the end of the run queue, and switches to the next runnable thread." } ;
HELP: sleep-until
{ $values { "time/f" "a non-negative integer or " { $link f } } }
{ $description "Suspends the current thread until the given time, or indefinitely if a value of " { $link f } " is passed in."
$nl
"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;
HELP: sleep HELP: sleep
{ $values { "ms" "a non-negative integer" } } { $values { "ms" "a non-negative integer" } }
{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds." } { $description "Suspends the current thread for " { $snippet "ms" } " milliseconds."
{ $errors "Throws an error if another thread interrupted the sleep with " { $link interrupt } "." } ; $nl
"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;
HELP: nap
{ $values { "ms/f" "a non-negative integer or " { $link f } } { "?" "a boolean indicating whether the thread was interrupted" } }
{ $description "Suspends the current thread until another thread interrupts it with " { $link interrupt } ". If the input parameter is not " { $link f } ", then the thread will also wake up if the timeout expires before an interrupt is received." } ;
HELP: interrupt HELP: interrupt
{ $values { "thread" thread } } { $values { "thread" thread } }

72
core/threads/threads.factor
View File

@ -75,14 +75,24 @@ PRIVATE>
: sleep-queue 43 getenv ; : sleep-queue 43 getenv ;
: resume ( thread -- ) : resume ( thread -- )
f over set-thread-state
check-registered run-queue push-front ; check-registered run-queue push-front ;
: resume-now ( thread -- ) : resume-now ( thread -- )
f over set-thread-state
check-registered run-queue push-back ; check-registered run-queue push-back ;
: resume-with ( obj thread -- ) : resume-with ( obj thread -- )
f over set-thread-state
check-registered 2array run-queue push-front ; 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 <PRIVATE
: schedule-sleep ( thread ms -- ) : schedule-sleep ( thread ms -- )
@ -103,23 +113,27 @@ PRIVATE>
[ ] while [ ] while
drop ; drop ;
: next ( -- ) : next ( -- * )
expire-sleep-loop expire-sleep-loop
run-queue pop-back run-queue dup dlist-empty? [
dup array? [ first2 ] [ f swap ] if dup set-self ! We should never be in a state where the only threads
f over set-thread-state ! are sleeping; the I/O wait thread is always runnable.
thread-continuation box> ! However, if it dies, we handle this case
continue-with ; ! 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> 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 ( -- ) : stop ( -- )
self dup thread-exit-handler call self dup thread-exit-handler call
unregister-thread next ; unregister-thread next ;
@ -131,34 +145,27 @@ PRIVATE>
self swap call next self swap call next
] callcc1 2nip ; inline ] callcc1 2nip ; inline
: yield ( -- ) [ resume ] "yield" suspend drop ; : yield ( -- ) [ resume ] f suspend drop ;
GENERIC: nap-until ( time -- ? ) GENERIC: sleep-until ( time/f -- )
M: integer nap-until [ schedule-sleep ] curry "sleep" suspend ; M: integer sleep-until
[ schedule-sleep ] curry "sleep" suspend drop ;
M: f nap-until drop [ drop ] "interrupt" suspend ; M: f sleep-until
drop [ drop ] "interrupt" suspend drop ;
GENERIC: nap ( time -- ? ) GENERIC: sleep ( ms -- )
M: real nap millis + >integer nap-until ; M: real sleep
millis + >integer sleep-until ;
M: f nap nap-until ;
: sleep-until ( time -- )
nap-until [ "Sleep interrupted" throw ] when ;
: sleep ( time -- )
nap [ "Sleep interrupted" throw ] when ;
: interrupt ( thread -- ) : interrupt ( thread -- )
dup self eq? [ dup thread-state [
drop
] [
dup thread-sleep-entry [ sleep-queue heap-delete ] when* dup thread-sleep-entry [ sleep-queue heap-delete ] when*
f over set-thread-sleep-entry f over set-thread-sleep-entry
t swap resume-with dup resume
] if ; ] when drop ;
: (spawn) ( thread -- ) : (spawn) ( thread -- )
[ [
@ -204,6 +211,7 @@ M: f nap nap-until ;
initial-thread global initial-thread global
[ drop f "Initial" [ die ] <thread> ] cache [ drop f "Initial" [ die ] <thread> ] cache
<box> over set-thread-continuation <box> over set-thread-continuation
f over set-thread-state
dup register-thread dup register-thread
set-self ; set-self ;

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

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

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

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

2
extra/alarms/alarms.factor
View File

@ -62,7 +62,7 @@ SYMBOL: alarm-thread
: alarm-thread-loop ( -- ) : alarm-thread-loop ( -- )
alarms get-global alarms get-global
dup next-alarm nap-until drop dup next-alarm sleep-until
dup trigger-alarms dup trigger-alarms
alarm-thread-loop ; alarm-thread-loop ;

30
extra/builder/builder.factor
View File

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

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

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

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

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

4
extra/calendar/calendar.factor
View File

@ -473,9 +473,9 @@ M: timestamp year. ( timestamp -- )
: seconds-since-midnight ( timestamp -- x ) : seconds-since-midnight ( timestamp -- x )
dup beginning-of-day timestamp- ; dup beginning-of-day timestamp- ;
M: timestamp nap-until timestamp>millis nap-until ; M: timestamp sleep-until timestamp>millis sleep-until ;
M: dt nap from-now nap-until ; M: dt sleep from-now sleep-until ;
{ {
{ [ unix? ] [ "calendar.unix" ] } { [ unix? ] [ "calendar.unix" ] }

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

@ -1,6 +1,7 @@
IN: temporary IN: temporary
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types 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: { CLASS: {
{ +superclass+ "NSObject" } { +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 ; dup dlist-empty? [ drop ] [ pop-back resume-now ] if ;
: notify-all ( dlist -- ) : notify-all ( dlist -- )
[ resume-now ] dlist-slurp yield ; [ resume-now ] dlist-slurp ;
: queue-timeout ( queue timeout -- alarm ) : queue-timeout ( queue timeout -- alarm )
#! Add an alarm which removes the current thread from the #! 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-put ( obj mailbox -- )
[ mailbox-data push-front ] keep [ mailbox-data push-front ] keep
mailbox-threads notify-all ; mailbox-threads notify-all yield ;
: block-unless-pred ( pred mailbox timeout -- ) : block-unless-pred ( pred mailbox timeout -- )
2over mailbox-data dlist-contains? [ 2over mailbox-data dlist-contains? [

6
extra/db/postgresql/postgresql.factor
View File

@ -161,7 +161,7 @@ M: postgresql-db create-sql-statement ( class -- seq )
[ [
[ create-table-sql , ] keep [ create-table-sql , ] keep
dup db-columns find-primary-key native-id? dup db-columns find-primary-key native-id?
[ create-function-sql , ] [ 2drop ] if [ create-function-sql , ] [ drop ] if
] { } make ; ] { } make ;
: drop-function-sql ( class -- statement ) : drop-function-sql ( class -- statement )
@ -176,13 +176,13 @@ M: postgresql-db create-sql-statement ( class -- seq )
: drop-table-sql ( table -- statement ) : drop-table-sql ( table -- statement )
[ [
"drop table " 0% 0% ";" 0% drop "drop table " 0% 0% ";" 0% drop
] postgresql-make dup . ; ] postgresql-make ;
M: postgresql-db drop-sql-statement ( class -- seq ) M: postgresql-db drop-sql-statement ( class -- seq )
[ [
[ drop-table-sql , ] keep [ drop-table-sql , ] keep
dup db-columns find-primary-key native-id? dup db-columns find-primary-key native-id?
[ drop-function-sql , ] [ 2drop ] if [ drop-function-sql , ] [ drop ] if
] { } make ; ] { } make ;
M: postgresql-db <insert-native-statement> ( class -- statement ) M: postgresql-db <insert-native-statement> ( class -- statement )

64
extra/db/tuples/tuples-tests.factor
View File

@ -16,29 +16,37 @@ TUPLE: person the-id the-name the-number the-real ;
: <assigned-person> ( id name number the-real -- obj ) : <assigned-person> ( id name number the-real -- obj )
<person> [ set-person-the-id ] keep ; <person> [ set-person-the-id ] keep ;
SYMBOL: the-person SYMBOL: the-person1
SYMBOL: the-person2
: test-tuples ( -- ) : test-tuples ( -- )
[ person drop-table ] [ drop ] recover [ person drop-table ] [ drop ] recover
[ ] [ person create-table ] unit-test [ ] [ person create-table ] unit-test
[ ] [ the-person get insert-tuple ] unit-test [ ] [ the-person1 get insert-tuple ] unit-test
[ 1 ] [ the-person get person-the-id ] unit-test [ 1 ] [ the-person1 get person-the-id ] unit-test
200 the-person get set-person-the-number 200 the-person1 get set-person-the-number
[ ] [ the-person get update-tuple ] unit-test [ ] [ the-person1 get update-tuple ] unit-test
[ T{ person f 1 "billy" 200 3.14 } ] [ T{ person f 1 "billy" 200 3.14 } ]
[ T{ person f 1 } select-tuple ] unit-test [ T{ person f 1 } select-tuple ] unit-test
[ ] [ the-person2 get insert-tuple ] unit-test
[
{
T{ person f 1 "billy" 200 3.14 }
T{ person f 2 "johnny" 10 3.14 }
}
] [ T{ person f f f f 3.14 } select-tuples ] unit-test
! [ ] [ the-person get delete-tuple ] unit-test [ ] [ the-person1 get delete-tuple ] unit-test
! [ ] [ person drop-table ] unit-test [ f ] [ T{ person f 1 } select-tuple ] unit-test
; [ ] [ person drop-table ] unit-test ;
: test-sqlite ( -- ) : test-sqlite ( -- )
"tuples-test.db" resource-path <sqlite-db> [ "tuples-test.db" resource-path sqlite-db [
test-tuples test-tuples
] with-db ; ] with-db ;
@ -55,23 +63,25 @@ person "PERSON"
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } } { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
} define-persistent } define-persistent
"billy" 10 3.14 <person> the-person set "billy" 10 3.14 <person> the-person1 set
"johnny" 10 3.14 <person> the-person2 set
! test-sqlite ! test-sqlite
test-postgresql test-postgresql
! person "PERSON" person "PERSON"
! { {
! { "the-id" "ID" INTEGER +assigned-id+ } { "the-id" "ID" INTEGER +assigned-id+ }
! { "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
! { "the-number" "AGE" INTEGER { +default+ 0 } } { "the-number" "AGE" INTEGER { +default+ 0 } }
! { "the-real" "REAL" DOUBLE { +default+ 0.3 } } { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
! } define-persistent } define-persistent
! 1 "billy" 20 6.28 <assigned-person> the-person set 1 "billy" 10 3.14 <assigned-person> the-person1 set
2 "johnny" 10 3.14 <assigned-person> the-person2 set
! test-sqlite ! test-sqlite
! test-postgresql test-postgresql
TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: paste n summary author channel mode contents timestamp annotations ;
TUPLE: annotation n paste-id summary author mode contents ; TUPLE: annotation n paste-id summary author mode contents ;
@ -98,11 +108,11 @@ annotation "ANNOTATION"
{ "contents" "CONTENTS" TEXT } { "contents" "CONTENTS" TEXT }
} define-persistent } define-persistent
! "localhost" "postgres" "" "factor-test" <postgresql-db> [ { "localhost" "postgres" "" "factor-test" } postgresql-db [
! [ paste drop-table ] [ drop ] recover [ paste drop-table ] [ drop ] recover
! [ annotation drop-table ] [ drop ] recover [ annotation drop-table ] [ drop ] recover
! [ paste drop-table ] [ drop ] recover [ paste drop-table ] [ drop ] recover
! [ annotation drop-table ] [ drop ] recover [ annotation drop-table ] [ drop ] recover
! [ ] [ paste create-table ] unit-test [ ] [ paste create-table ] unit-test
! [ ] [ annotation create-table ] unit-test [ ] [ annotation create-table ] unit-test
! ] with-db ] with-db

13
extra/db/tuples/tuples.factor
View File

@ -50,10 +50,7 @@ HOOK: insert-tuple* db ( tuple statement -- )
: query-tuples ( statement -- seq ) : query-tuples ( statement -- seq )
[ statement-out-params ] keep query-results [ [ statement-out-params ] keep query-results [
! out-parms result-set [ sql-row swap resulting-tuple ] with query-map
[
sql-row swap resulting-tuple
] with query-map
] with-disposal ; ] with-disposal ;
: query-modify-tuple ( tuple statement -- ) : query-modify-tuple ( tuple statement -- )
@ -91,13 +88,13 @@ HOOK: insert-tuple* db ( tuple statement -- )
: update-tuples ( seq -- ) : update-tuples ( seq -- )
<update-tuples-statement> execute-statement ; <update-tuples-statement> execute-statement ;
: persist ( tuple -- ) : delete-tuple ( tuple -- )
dup class db-columns find-primary-key ; dup class <delete-tuple-statement>
[ bind-tuple ] keep execute-statement ;
: setup-select ( tuple -- statement ) : setup-select ( tuple -- statement )
dup dup class <select-by-slots-statement> dup dup class <select-by-slots-statement>
[ bind-tuple ] keep ; [ bind-tuple ] keep ;
: select-tuples ( tuple -- tuple ) setup-select query-tuples ; : select-tuples ( tuple -- tuple ) setup-select query-tuples ;
: select-tuple ( tuple -- tuple ) select-tuples first ; : select-tuple ( tuple -- tuple/f ) select-tuples ?first ;

1
extra/furnace/furnace.factor
View File

@ -204,4 +204,3 @@ SYMBOL: model
] [ ] [
drop drop
] if ; ] if ;

7
extra/furnace/sessions/sessions.factor
View File

@ -1,5 +1,5 @@
USING: assocs calendar init kernel math.parser USING: assocs calendar init kernel math.parser
namespaces random boxes alarms ; namespaces random boxes alarms combinators.lib ;
IN: furnace.sessions IN: furnace.sessions
SYMBOL: sessions SYMBOL: sessions
@ -11,9 +11,8 @@ SYMBOL: sessions
] "furnace.sessions" add-init-hook ] "furnace.sessions" add-init-hook
: new-session-id ( -- str ) : new-session-id ( -- str )
4 big-random >hex [ 4 big-random >hex ]
dup sessions get-global key? [ sessions get-global key? not ] generate ;
[ drop new-session-id ] when ;
TUPLE: session id namespace alarm user-agent ; TUPLE: session id namespace alarm user-agent ;

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

@ -86,7 +86,8 @@ concurrency.futures
concurrency.locks concurrency.locks
concurrency.semaphores concurrency.semaphores
concurrency.count-downs concurrency.count-downs
concurrency.exchangers ; concurrency.exchangers
concurrency.flags ;
ARTICLE: "concurrency" "Concurrency" 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." "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.semaphores" }
{ $subsection "concurrency.count-downs" } { $subsection "concurrency.count-downs" }
{ $subsection "concurrency.exchangers" } { $subsection "concurrency.exchangers" }
{ $subsection "concurrency.flags" }
"Other concurrency abstractions include " { $vocab-link "concurrency.distributed" } " and " { $vocab-link "channels" } "." ; "Other concurrency abstractions include " { $vocab-link "concurrency.distributed" } " and " { $vocab-link "channels" } "." ;
ARTICLE: "objects" "Objects" ARTICLE: "objects" "Objects"

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

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

2
extra/http/basic-authentication/basic-authentication.factor
View File

@ -61,5 +61,5 @@ SYMBOL: realms
#! Check if the user is authenticated in the given realm #! Check if the user is authenticated in the given realm
#! to run the specified quotation. If not, use Basic #! to run the specified quotation. If not, use Basic
#! Authentication to ask for authorization details. #! Authentication to ask for authorization details.
over "Authorization" header-param authorization-ok? over "authorization" header-param authorization-ok?
[ nip call ] [ drop authentication-error ] if ; [ nip call ] [ drop authentication-error ] if ;

2
extra/http/server/responders/responders.factor
View File

@ -77,7 +77,7 @@ SYMBOL: max-post-request
1024 256 * max-post-request set-global 1024 256 * max-post-request set-global
: content-length ( header -- n ) : content-length ( header -- n )
"content-length" peek at string>number dup [ "content-length" swap peek-at string>number dup [
dup max-post-request get > [ dup max-post-request get > [
"Content-Length > max-post-request" throw "Content-Length > max-post-request" throw
] when ] when

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

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

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

@ -4,12 +4,12 @@ sequences prettyprint system io.encodings.binary io.encodings.ascii ;
IN: temporary IN: temporary
! Unix domain stream sockets ! Unix domain stream sockets
[ : socket-server "unix-domain-socket-test" temp-file ;
[
"unix-domain-socket-test" temp-file delete-file
] ignore-errors
"unix-domain-socket-test" temp-file <local> [
[ socket-server delete-file ] ignore-errors
socket-server <local>
ascii <server> [ ascii <server> [
accept [ accept [
"Hello world" print flush "Hello world" print flush
@ -17,15 +17,15 @@ IN: temporary
] with-stream ] with-stream
] with-disposal ] with-disposal
"unix-domain-socket-test" temp-file delete-file socket-server delete-file
] "Test" spawn drop ] "Test" spawn drop
yield yield
[ { "Hello world" "FOO" } ] [ [ { "Hello world" "FOO" } ] [
[ [
"unix-domain-socket-test" temp-file <local> socket-server <local> ascii <client>
ascii <client> [ [
readln , readln ,
"XYZ" print flush "XYZ" print flush
readln , readln ,
@ -33,17 +33,16 @@ yield
] { } make ] { } make
] unit-test ] unit-test
! Unix domain datagram sockets : datagram-server "unix-domain-datagram-test" temp-file ;
[ : datagram-client "unix-domain-datagram-test-2" temp-file ;
"unix-domain-datagram-test" temp-file delete-file
] ignore-errors
: server-addr "unix-domain-datagram-test" temp-file <local> ; ! Unix domain datagram sockets
: client-addr "unix-domain-datagram-test-2" temp-file <local> ; [ 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 "Receive 1" print
@ -67,59 +66,53 @@ yield
"Done" print "Done" print
"unix-domain-datagram-test" temp-file delete-file datagram-server delete-file
] with-scope ] with-scope
] "Test" spawn drop ] "Test" spawn drop
yield yield
[ [ datagram-client delete-file ] ignore-errors
"unix-domain-datagram-test-2" temp-file delete-file
] ignore-errors
client-addr <datagram> datagram-client <local> <datagram>
"Four" print
"d" set "d" set
[ ] [ [ ] [
"hello" >byte-array "hello" >byte-array
server-addr datagram-server <local>
"d" get send "d" get send
] unit-test ] unit-test
[ "olleh" t ] [ [ "olleh" t ] [
"d" get receive "d" get receive
server-addr = datagram-server <local> =
>r >string r> >r >string r>
] unit-test ] unit-test
[ ] [ [ ] [
"hello" >byte-array "hello" >byte-array
server-addr datagram-server <local>
"d" get send "d" get send
] unit-test ] unit-test
[ "hello world" t ] [ [ "hello world" t ] [
"d" get receive "d" get receive
server-addr = datagram-server <local> =
>r >string r> >r >string r>
] unit-test ] unit-test
[ ] [ "d" get dispose ] unit-test [ ] [ "d" get dispose ] unit-test
! Test error behavior ! Test error behavior
: another-datagram "unix-domain-datagram-test-3" temp-file ;
[ [ another-datagram delete-file ] ignore-errors
"unix-domain-datagram-test-3" temp-file 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 } another-datagram <local> "d" get send ] must-fail
B{ 1 2 3 } "unix-domain-datagram-test-3" <local> "d" get send
] must-fail
[ ] [ "d" get dispose ] unit-test [ ] [ "d" get dispose ] unit-test
@ -127,7 +120,7 @@ client-addr <datagram>
[ "d" get receive ] must-fail [ "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 ! Invalid parameter tests

4
extra/io/windows/launcher/launcher.factor
View File

@ -146,8 +146,8 @@ M: windows-io kill-process* ( handle -- )
: wait-loop ( -- ) : wait-loop ( -- )
processes get dup assoc-empty? processes get dup assoc-empty?
[ drop f nap drop ] [ drop f sleep-until ]
[ wait-for-processes [ 100 nap drop ] when ] if ; [ wait-for-processes [ 100 sleep ] when ] if ;
SYMBOL: wait-thread SYMBOL: wait-thread

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

@ -15,7 +15,7 @@ USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays
namespaces threads shuffle opengl arrays ui.gadgets.worlds namespaces threads shuffle opengl arrays ui.gadgets.worlds
combinators math.parser ui.gadgets ui.render opengl.gl ui combinators math.parser ui.gadgets ui.render opengl.gl ui
continuations io.files hints combinators.lib sequences.lib continuations io.files hints combinators.lib sequences.lib
io.encodings.binary ; io.encodings.binary debugger ;
IN: ogg.player IN: ogg.player
@ -150,7 +150,7 @@ HINTS: yuv>rgb byte-array byte-array ;
dup player-gadget [ dup player-gadget [
dup { player-td player-yuv } get-slots theora_decode_YUVout drop dup { player-td player-yuv } get-slots theora_decode_YUVout drop
dup player-rgb over player-yuv yuv>rgb dup player-rgb over player-yuv yuv>rgb
dup player-gadget find-world draw-world dup player-gadget relayout-1 yield
] when ; ] when ;
: num-audio-buffers-processed ( player -- player n ) : num-audio-buffers-processed ( player -- player n )
@ -178,7 +178,7 @@ HINTS: yuv>rgb byte-array byte-array ;
: append-audio ( player -- player bool ) : append-audio ( player -- player bool )
num-audio-buffers-processed { num-audio-buffers-processed {
{ [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] } { [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }
{ [ over player-buffers length 2 = over zero? and ] [ 0 sleep drop f ] } { [ over player-buffers length 2 = over zero? and ] [ yield drop f ] }
{ [ t ] [ fill-processed-audio-buffer t ] } { [ t ] [ fill-processed-audio-buffer t ] }
} cond ; } cond ;
@ -603,8 +603,7 @@ M: theora-gadget draw-gadget* ( gadget -- )
parse-remaining-headers parse-remaining-headers
initialize-decoder initialize-decoder
dup player-gadget [ initialize-gui ] when* dup player-gadget [ initialize-gui ] when*
[ decode ] [ drop ] recover [ decode ] try
! decode
wait-for-sound wait-for-sound
cleanup cleanup
drop ; drop ;

6
extra/peg/peg.factor
View File

@ -306,9 +306,15 @@ MEMO: range ( min max -- parser )
: seq ( seq -- parser ) : seq ( seq -- parser )
seq-parser construct-boa init-parser ; seq-parser construct-boa init-parser ;
: seq* ( quot -- paser )
{ } make seq ; inline
: choice ( seq -- parser ) : choice ( seq -- parser )
choice-parser construct-boa init-parser ; choice-parser construct-boa init-parser ;
: choice* ( quot -- paser )
{ } make choice ; inline
MEMO: repeat0 ( parser -- parser ) MEMO: repeat0 ( parser -- parser )
repeat0-parser construct-boa init-parser ; repeat0-parser construct-boa init-parser ;

3
extra/random-tester/random-tester.factor
View File

@ -1,5 +1,6 @@
USING: compiler continuations io kernel math namespaces USING: compiler continuations io kernel math namespaces
prettyprint quotations random sequences vectors ; prettyprint quotations random sequences vectors
compiler.units ;
USING: random-tester.databank random-tester.safe-words ; USING: random-tester.databank random-tester.safe-words ;
IN: random-tester IN: random-tester

2
extra/smtp/smtp.factor
View File

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

5
extra/tools/threads/threads.factor
View File

@ -8,7 +8,10 @@ heaps.private system math math.parser ;
: thread. ( thread -- ) : thread. ( thread -- )
dup thread-id pprint-cell dup thread-id pprint-cell
dup thread-name over [ write-object ] with-cell dup thread-name over [ write-object ] with-cell
dup thread-state "running" or [ write ] with-cell dup thread-state [
[ dup self eq? "running" "yield" ? ] unless*
write
] with-cell
[ [
thread-sleep-entry [ thread-sleep-entry [
entry-key millis [-] number>string write entry-key millis [-] number>string write

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

@ -19,7 +19,7 @@ SYMBOL: stop-after-last-window?
: event-loop ( -- ) : event-loop ( -- )
event-loop? [ event-loop? [
[ [
[ NSApp do-events ui-step 10 sleep ] ui-try [ NSApp do-events ui-wait ] ui-try
] with-autorelease-pool event-loop ] with-autorelease-pool event-loop
] when ; ] 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 2drop dup view-dim swap window set-gadget-dim
ui-step
] ui-try ] ui-try
] ]
} }

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

@ -2,9 +2,13 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables kernel models math namespaces sequences USING: arrays hashtables kernel models math namespaces sequences
quotations math.vectors combinators sorting vectors dlists quotations math.vectors combinators sorting vectors dlists
models ; models threads concurrency.flags ;
IN: ui.gadgets IN: ui.gadgets
SYMBOL: ui-notify-flag
: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
TUPLE: rect loc dim ; TUPLE: rect loc dim ;
C: <rect> rect C: <rect> rect
@ -184,7 +188,7 @@ M: array gadget-text*
#! When unit testing gadgets without the UI running, the #! When unit testing gadgets without the UI running, the
#! invalid queue is not initialized and we simply ignore #! invalid queue is not initialized and we simply ignore
#! invalidation requests. #! invalidation requests.
layout-queue [ push-front ] [ drop ] if* ; layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;
DEFER: relayout DEFER: relayout
@ -256,11 +260,11 @@ M: gadget layout* drop ;
: queue-graft ( gadget -- ) : queue-graft ( gadget -- )
{ f t } over set-gadget-graft-state { f t } over set-gadget-graft-state
graft-queue push-front ; graft-queue push-front notify-ui-thread ;
: queue-ungraft ( gadget -- ) : queue-ungraft ( gadget -- )
{ t f } over set-gadget-graft-state { t f } over set-gadget-graft-state
graft-queue push-front ; graft-queue push-front notify-ui-thread ;
: graft-later ( gadget -- ) : graft-later ( gadget -- )
dup gadget-graft-state { dup gadget-graft-state {

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

@ -133,7 +133,7 @@ M: stack-display tool-scroller
: restart-listener ( listener -- ) : restart-listener ( listener -- )
dup com-end dup clear-output dup com-end dup clear-output
[ init-namespaces listener-thread ] curry [ listener-thread ] curry
"Listener" spawn drop ; "Listener" spawn drop ;
: init-listener ( listener -- ) : 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 tuples ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
ui.gestures ui.operations vocabs words vocabs.loader ui.gestures ui.operations vocabs words vocabs.loader
tools.browser unicode.case calendar ; tools.browser unicode.case calendar ui ;
IN: ui.tools.search IN: ui.tools.search
TUPLE: live-search field list ; TUPLE: live-search field list ;
@ -45,7 +45,8 @@ search-field H{
} set-gestures } set-gestures
: <search-model> ( producer -- model ) : <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> ; [ "\n" join ] r> append <filter> ;
: <search-list> ( seq limited? presenter -- gadget ) : <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 } { $subsection start-ui }
"The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down." "The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down."
$nl $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" 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:" "The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:"

48
extra/ui/ui.factor
View File

@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces
prettyprint dlists sequences threads sequences words prettyprint dlists sequences threads sequences words
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init combinators ui.gestures ui.backend ui.render continuations init combinators
hashtables ; hashtables concurrency.flags ;
IN: ui IN: ui
! Assoc mapping aliens to gadgets ! Assoc mapping aliens to gadgets
@ -130,11 +130,36 @@ SYMBOL: ui-hook
: notify-queued ( -- ) : notify-queued ( -- )
graft-queue [ notify ] dlist-slurp ; graft-queue [ notify ] dlist-slurp ;
: ui-step ( -- ) : update-ui ( -- )
[ notify-queued layout-queued redraw-worlds ] assert-depth ; [ 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 -- ) : 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 -- ) : open-window ( gadget title -- )
>r [ 1 track, ] { 0 1 } make-track r> >r [ 1 track, ] { 0 1 } make-track r>
@ -159,16 +184,13 @@ M: object close-window
restore-windows restore-windows
] [ ] [
init-ui ui-hook get call 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
[ f \ ui-running set-global ] [ ] cleanup ; inline <flag> ui-notify-flag set-global
] "ui" add-init-hook
: ui-running? ( -- ? )
\ ui-running get-global ;
[ f \ ui-running set-global ] "ui" add-init-hook
HOOK: ui ui-backend ( -- ) HOOK: ui ui-backend ( -- )
@ -181,5 +203,3 @@ MAIN: ui
f windows set-global f windows set-global
ui-hook [ ui ] with-variable ui-hook [ ui ] with-variable
] if ; ] if ;
: ui-try ( quot -- ) [ ui-error ] recover ;

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

@ -15,8 +15,11 @@ TUPLE: windows-ui-backend ;
: lf>crlf [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ; : lf>crlf [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
: enum-clipboard ( -- seq ) : enum-clipboard ( -- seq )
0 [ EnumClipboardFormats win32-error dup dup 0 > ] [ ] 0
{ } unfold nip ; [ EnumClipboardFormats win32-error dup dup 0 > ]
[ ]
[ drop ]
unfold nip ;
: with-clipboard ( quot -- ) : with-clipboard ( quot -- )
f OpenClipboard win32-error=0/f f OpenClipboard win32-error=0/f
@ -40,13 +43,12 @@ TUPLE: windows-ui-backend ;
: copy ( str -- ) : copy ( str -- )
lf>crlf [ lf>crlf [
string>u16-alien string>u16-alien
f OpenClipboard win32-error=0/f
EmptyClipboard win32-error=0/f EmptyClipboard win32-error=0/f
GMEM_MOVEABLE over length 1+ GlobalAlloc GMEM_MOVEABLE over length 1+ GlobalAlloc
dup win32-error=0/f dup win32-error=0/f
dup GlobalLock dup win32-error=0/f dup GlobalLock dup win32-error=0/f
rot dup length memcpy swapd byte-array>memory
dup GlobalUnlock win32-error=0/f dup GlobalUnlock win32-error=0/f
CF_UNICODETEXT swap SetClipboardData win32-error=0/f CF_UNICODETEXT swap SetClipboardData win32-error=0/f
] with-clipboard ; ] with-clipboard ;
@ -72,30 +74,28 @@ SYMBOL: mouse-captured
: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline : style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline : ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
: adjust-RECT ( RECT -- )
style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
: make-RECT ( width height -- RECT )
"RECT" <c-object> [ set-RECT-bottom ] keep [ set-RECT-right ] keep ;
: make-adjusted-RECT ( width height -- RECT )
make-RECT dup adjust-RECT ;
: get-RECT-dimensions ( RECT -- width height )
[ RECT-right ] keep [ RECT-left - ] keep
[ RECT-bottom ] keep RECT-top - ;
: get-RECT-top-left ( RECT -- x y ) : get-RECT-top-left ( RECT -- x y )
[ RECT-left ] keep RECT-top ; [ RECT-left ] keep RECT-top ;
: get-RECT-dimensions ( RECT -- x y width height )
[ get-RECT-top-left ] keep
[ RECT-right ] keep [ RECT-left - ] keep
[ RECT-bottom ] keep RECT-top - ;
: handle-wm-paint ( hWnd uMsg wParam lParam -- ) : handle-wm-paint ( hWnd uMsg wParam lParam -- )
#! wParam and lParam are unused #! wParam and lParam are unused
#! only paint if width/height both > 0 #! only paint if width/height both > 0
3drop window draw-world ; 3drop window relayout-1 ;
: handle-wm-size ( hWnd uMsg wParam lParam -- ) : handle-wm-size ( hWnd uMsg wParam lParam -- )
[ lo-word ] keep hi-word make-RECT get-RECT-dimensions 2array 2nip 2nip
dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ui-step ] if ; [ lo-word ] keep hi-word 2array
dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ] if ;
: handle-wm-move ( hWnd uMsg wParam lParam -- )
2nip
[ lo-word ] keep hi-word 2array
swap window set-world-loc ;
: wm-keydown-codes ( -- key ) : wm-keydown-codes ( -- key )
H{ H{
@ -240,7 +240,7 @@ M: windows-ui-backend (close-window)
: mouse-absolute>relative ( lparam handle -- array ) : mouse-absolute>relative ( lparam handle -- array )
>r >lo-hi r> >r >lo-hi r>
0 0 make-RECT [ GetWindowRect win32-error=0/f ] keep "RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
get-RECT-top-left 2array v- ; get-RECT-top-left 2array v- ;
: mouse-event>gesture ( uMsg -- button ) : mouse-event>gesture ( uMsg -- button )
@ -317,6 +317,7 @@ M: windows-ui-backend (close-window)
{ [ dup WM_PAINT = ] { [ dup WM_PAINT = ]
[ drop 4dup handle-wm-paint DefWindowProc ] } [ drop 4dup handle-wm-paint DefWindowProc ] }
{ [ dup WM_SIZE = ] [ drop handle-wm-size 0 ] } { [ dup WM_SIZE = ] [ drop handle-wm-size 0 ] }
{ [ dup WM_MOVE = ] [ drop handle-wm-move 0 ] }
! Keyboard events ! Keyboard events
{ [ dup WM_KEYDOWN = over WM_SYSKEYDOWN = or ] { [ dup WM_KEYDOWN = over WM_SYSKEYDOWN = or ]
@ -352,14 +353,12 @@ M: windows-ui-backend (close-window)
: event-loop ( msg -- ) : event-loop ( msg -- )
{ {
{ [ windows get empty? ] [ drop ] } { [ windows get empty? ] [ drop ] }
{ [ dup peek-message? ] [ { [ dup peek-message? ] [ ui-wait event-loop ] }
>r [ ui-step 10 sleep ] ui-try
r> event-loop
] }
{ [ dup MSG-message WM_QUIT = ] [ drop ] } { [ dup MSG-message WM_QUIT = ] [ drop ] }
{ [ t ] [ { [ t ] [
dup TranslateMessage drop dup TranslateMessage drop
dup DispatchMessage drop dup DispatchMessage drop
yield
event-loop event-loop
] } ] }
} cond ; } cond ;
@ -383,13 +382,26 @@ M: windows-ui-backend (close-window)
RegisterClassEx dup win32-error=0/f RegisterClassEx dup win32-error=0/f
] when ; ] when ;
: create-window ( width height -- hwnd ) : adjust-RECT ( RECT -- )
style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
: make-RECT ( world -- RECT )
dup world-loc { 40 40 } vmax dup rot rect-dim v+
"RECT" <c-object>
over first over set-RECT-right
swap second over set-RECT-bottom
over first over set-RECT-left
swap second over set-RECT-top ;
: make-adjusted-RECT ( rect -- RECT )
make-RECT dup adjust-RECT ;
: create-window ( rect -- hwnd )
make-adjusted-RECT make-adjusted-RECT
>r class-name-ptr get-global f r> >r class-name-ptr get-global f r>
>r >r >r ex-style r> r> >r >r >r ex-style r> r>
{ WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
CW_USEDEFAULT dup r> r> get-RECT-dimensions
get-RECT-dimensions
f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ; f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
: show-window ( hWnd -- ) : show-window ( hWnd -- )
@ -424,7 +436,7 @@ M: windows-ui-backend (close-window)
get-dc dup setup-pixel-format dup get-rc ; get-dc dup setup-pixel-format dup get-rc ;
M: windows-ui-backend (open-window) ( world -- ) M: windows-ui-backend (open-window) ( world -- )
[ rect-dim first2 create-window dup setup-gl ] keep [ create-window dup setup-gl ] keep
[ f <win> ] keep [ f <win> ] keep
[ swap win-hWnd register-window ] 2keep [ swap win-hWnd register-window ] 2keep
dupd set-world-handle dupd set-world-handle
@ -445,8 +457,8 @@ M: windows-ui-backend raise-window* ( world -- )
M: windows-ui-backend set-title ( string world -- ) M: windows-ui-backend set-title ( string world -- )
world-handle [ nip win-hWnd WM_SETTEXT 0 ] 2keep world-handle [ nip win-hWnd WM_SETTEXT 0 ] 2keep
dup win-title [ free ] when* dup win-title [ free ] when*
>r malloc-u16-string r> >r malloc-u16-string dup r>
dupd set-win-title alien-address set-win-title alien-address
SendMessage drop ; SendMessage drop ;
M: windows-ui-backend ui M: windows-ui-backend ui

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

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

8
extra/webapps/cgi/cgi.factor
View File

@ -31,13 +31,13 @@ SYMBOL: cgi-root
"method" get >upper "REQUEST_METHOD" set "method" get >upper "REQUEST_METHOD" set
"raw-query" get "QUERY_STRING" set "raw-query" get "QUERY_STRING" set
"Cookie" header-param "HTTP_COOKIE" set "cookie" header-param "HTTP_COOKIE" set
"User-Agent" header-param "HTTP_USER_AGENT" set "user-agent" header-param "HTTP_USER_AGENT" set
"Accept" header-param "HTTP_ACCEPT" set "accept" header-param "HTTP_ACCEPT" set
post? [ post? [
"Content-Type" header-param "CONTENT_TYPE" set "content-type" header-param "CONTENT_TYPE" set
"raw-response" get length number>string "CONTENT_LENGTH" set "raw-response" get length number>string "CONTENT_LENGTH" set
] when ] when
] H{ } make-assoc ; ] H{ } make-assoc ;

2
extra/webapps/file/file.factor
View File

@ -25,7 +25,7 @@ SYMBOL: doc-root
: last-modified-matches? ( filename -- bool ) : last-modified-matches? ( filename -- bool )
file-http-date dup [ file-http-date dup [
"If-Modified-Since" header-param = "if-modified-since" header-param =
] when ; ] when ;
: not-modified-response ( -- ) : not-modified-response ( -- )

2
extra/webapps/fjsc/fjsc.factor
View File

@ -25,7 +25,7 @@ IN: webapps.fjsc
: compile-url ( url -- ) : compile-url ( url -- )
#! Compile the factor code at the given url, return the javascript. #! Compile the factor code at the given url, return the javascript.
dup "http:" head? [ "Unable to access remote sites." throw ] when dup "http:" head? [ "Unable to access remote sites." throw ] when
"http://" "Host" header-param rot 3append http-get compile "();" write flush ; "http://" "host" header-param rot 3append http-get compile "();" write flush ;
\ compile-url { \ compile-url {
{ "url" v-required } { "url" v-required }

4
misc/factor.sh
View File

@ -186,8 +186,8 @@ find_word_size() {
set_factor_binary() { set_factor_binary() {
case $OS in case $OS in
winnt) FACTOR_BINARY=factor-nt;; # winnt) FACTOR_BINARY=factor-nt;;
macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; # macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;;
*) FACTOR_BINARY=factor;; *) FACTOR_BINARY=factor;;
esac esac
} }

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 */ /* Insufficient room even after code GC, give up */
if(start == 0) 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; return start;

2
vm/factor.c
View File

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