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

Merge git://factorcode.org/git/factor

db4
Eduardo Cavazos 2008-02-21 19:39:05 -06:00
parent 95185cf9e1 0eda22fb5a
commit fc1116d3f1
37 changed files with 435 additions and 403 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
core/heaps/heaps-docs.factor Normal file → Executable file
View File

@ -11,69 +11,72 @@ $nl
{ $subsection min-heap? }
{ $subsection <min-heap> }
"Max-heaps sort their elements so that the maximum element is first:"
{ $subsection min-heap }
{ $subsection min-heap? }
{ $subsection <min-heap> }
{ $subsection max-heap }
{ $subsection max-heap? }
{ $subsection <max-heap> }
"Both obey a protocol."
$nl
"Queries:"
{ $subsection heap-empty? }
{ $subsection heap-length }
{ $subsection heap-size }
{ $subsection heap-peek }
"Insertion:"
{ $subsection heap-push }
{ $subsection heap-push* }
{ $subsection heap-push-all }
"Removal:"
{ $subsection heap-pop* }
{ $subsection heap-pop } ;
{ $subsection heap-pop }
{ $subsection heap-delete } ;
ABOUT: "heaps"
HELP: <min-heap>
{ $values { "min-heap" min-heap } }
{ $description "Create a new " { $link min-heap } "." }
{ $see-also <max-heap> } ;
{ $description "Create a new " { $link min-heap } "." } ;
HELP: <max-heap>
{ $values { "max-heap" max-heap } }
{ $description "Create a new " { $link max-heap } "." }
{ $see-also <min-heap> } ;
{ $description "Create a new " { $link max-heap } "." } ;
HELP: heap-push
{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } }
{ $description "Push an pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
{ $side-effects "heap" }
{ $see-also heap-push-all heap-pop } ;
{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } }
{ $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
{ $side-effects "heap" } ;
HELP: heap-push*
{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } { "entry" entry } }
{ $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." }
{ $side-effects "heap" } ;
HELP: heap-push-all
{ $values { "assoc" assoc } { "heap" heap } }
{ $values { "assoc" assoc } { "heap" "a heap" } }
{ $description "Push every key/value pair of an assoc onto a heap." }
{ $side-effects "heap" }
{ $see-also heap-push heap-pop } ;
{ $side-effects "heap" } ;
HELP: heap-peek
{ $values { "heap" heap } { "key" object } { "value" object } }
{ $description "Outputs the first element in the heap, leaving it in the heap." }
{ $see-also heap-pop heap-pop* } ;
{ $values { "heap" "a heap" } { "key" object } { "value" object } }
{ $description "Output the first element in the heap, leaving it in the heap." } ;
HELP: heap-pop*
{ $values { "heap" heap } }
{ $description "Removes the first element from the heap." }
{ $side-effects "heap" }
{ $see-also heap-pop heap-push heap-peek } ;
{ $values { "heap" "a heap" } }
{ $description "Remove the first element from the heap." }
{ $side-effects "heap" } ;
HELP: heap-pop
{ $values { "heap" heap } { "key" object } { "value" object } }
{ $description "Outputs the first element in the heap and removes it from the heap." }
{ $side-effects "heap" }
{ $see-also heap-pop* heap-push heap-peek } ;
{ $values { "heap" "a heap" } { "key" object } { "value" object } }
{ $description "Output and remove the first element in the heap." }
{ $side-effects "heap" } ;
HELP: heap-empty?
{ $values { "heap" heap } { "?" "a boolean" } }
{ $description "Tests if a " { $link heap } " has no nodes." }
{ $see-also heap-length heap-peek } ;
{ $values { "heap" "a heap" } { "?" "a boolean" } }
{ $description "Tests if a heap has no nodes." } ;
HELP: heap-length
{ $values { "heap" heap } { "n" integer } }
{ $description "Returns the number of key/value pairs in the heap." }
{ $see-also heap-empty? } ;
HELP: heap-size
{ $values { "heap" "a heap" } { "n" integer } }
{ $description "Returns the number of key/value pairs in the heap." } ;
HELP: heap-delete
{ $values { "heap" "a heap" } { "key" object } { "value" object } }
{ $description "Output and remove the first element in the heap." }
{ $side-effects "heap" } ;

77
core/heaps/heaps-tests.factor Normal file → Executable file
View File

@ -1,8 +1,8 @@
! Copyright 2007 Ryan Murphy
! Copyright 2007, 2008 Ryan Murphy, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces tools.test
heaps heaps.private ;
heaps heaps.private math.parser random assocs sequences sorting ;
IN: temporary
[ <min-heap> heap-pop ] must-fail
@ -15,16 +15,8 @@ IN: temporary
! Binary Min Heap
{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
{ t } [ { 5 t } { 3 t } T{ min-heap } heap-compare ] unit-test
{ f } [ { 5 t } { 3 t } T{ max-heap } heap-compare ] unit-test
[ T{ min-heap T{ heap f V{ { -6 t } { -4 t } { 2 t } { 1 t } { 5 t } { 3 t } { 2 t } { 4 t } { 3 t } { 7 t } { 6 t } { 8 t } { 3 t } { 4 t } { 4 t } { 6 t } { 5 t } { 5 t } } } } ]
[ <min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 7 t } { 8 t } { 2 t } { 4 t } { 3 t } { 5 t } { 6 t } { 1 t } { 3 t } { 2 t } { 4 t } { 5 t } { -6 t } { -4 t } } over heap-push-all ] unit-test
[ T{ min-heap T{ heap f V{ { 5 t } { 6 t } { 6 t } { 7 t } { 8 t } } } } ] [
<min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 5 t } { 7 t } { 6 t } { 8 t } } over heap-push-all
3 [ dup heap-pop* ] times
] unit-test
{ t } [ t 5 <entry> t 3 <entry> T{ min-heap } heap-compare ] unit-test
{ f } [ t 5 <entry> t 3 <entry> T{ max-heap } heap-compare ] unit-test
[ t 2 ] [ <min-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push heap-pop ] unit-test
@ -32,18 +24,51 @@ IN: temporary
[ t 400 ] [ <max-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test
[ 0 ] [ <max-heap> heap-length ] unit-test
[ 1 ] [ <max-heap> t 1 pick heap-push heap-length ] unit-test
[ 0 ] [ <max-heap> heap-size ] unit-test
[ 1 ] [ <max-heap> t 1 pick heap-push heap-size ] unit-test
[ { { 1 2 } { 3 4 } { 5 6 } } ] [
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
[ [ 10 < nip ] [ 2array , ] heap-pop-while ] { } make
] unit-test
[ { { 1 2 } } ] [
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
[ [ 3 < nip ] [ 2array , ] heap-pop-while ] { } make
] unit-test
[ { } ] [
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
[ [ 1 < nip ] [ 2array , ] heap-pop-while ] { } make
] unit-test
: heap-sort ( alist -- keys )
<min-heap> [ heap-push-all ] keep heap-pop-all ;
: random-alist ( n -- alist )
[
[
(random) dup number>string swap set
] times
] H{ } make-assoc ;
: test-heap-sort ( n -- ? )
random-alist dup >alist sort-keys swap heap-sort = ;
14 [
[ t ] swap [ 2^ test-heap-sort ] curry unit-test
] each
: test-entry-indices ( n -- ? )
random-alist
<min-heap> [ heap-push-all ] keep
heap-data dup length swap [ entry-index ] map sequence= ;
14 [
[ t ] swap [ 2^ test-entry-indices ] curry unit-test
] each
: delete-random ( seq -- elt )
dup length random dup pick nth >r swap delete-nth r> ;
: sort-entries ( entries -- entries' )
[ [ entry-key ] compare ] sort ;
: delete-test ( n -- ? )
[
random-alist
<min-heap> [ heap-push-all ] keep
dup heap-data clone swap
] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
heap-data
[ [ entry-key ] map ] 2apply
[ natural-sort ] 2apply ;
11 [
[ t ] swap [ 2^ delete-test sequence= ] curry unit-test
] each

183
core/heaps/heaps.factor Normal file → Executable file
View File

@ -1,26 +1,31 @@
! Copyright (C) 2007 Ryan Murphy, Doug Coleman.
! Copyright (C) 2007, 2008 Ryan Murphy, Doug Coleman,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences arrays assocs ;
USING: kernel math sequences arrays assocs sequences.private
growable ;
IN: heaps
MIXIN: priority-queue
GENERIC: heap-push ( value key heap -- )
GENERIC: heap-push* ( value key heap -- entry )
GENERIC: heap-peek ( heap -- value key )
GENERIC: heap-pop* ( heap -- )
GENERIC: heap-pop ( heap -- value key )
GENERIC: heap-delete ( key heap -- )
GENERIC: heap-delete* ( key heap -- old ? )
GENERIC: heap-delete ( entry heap -- )
GENERIC: heap-empty? ( heap -- ? )
GENERIC: heap-length ( heap -- n )
GENERIC# heap-pop-while 2 ( heap pred quot -- )
GENERIC: heap-size ( heap -- n )
<PRIVATE
TUPLE: heap data ;
: heap-data delegate ; inline
: <heap> ( class -- heap )
>r V{ } clone heap construct-boa r>
construct-delegate ; inline
>r V{ } clone r> construct-delegate ; inline
TUPLE: entry value key index ;
: <entry> ( value key -- entry ) f entry construct-boa ;
PRIVATE>
TUPLE: min-heap ;
@ -34,23 +39,67 @@ TUPLE: max-heap ;
INSTANCE: min-heap priority-queue
INSTANCE: max-heap priority-queue
M: priority-queue heap-empty? ( heap -- ? )
heap-data empty? ;
M: priority-queue heap-size ( heap -- n )
heap-data length ;
<PRIVATE
: left ( n -- m ) 2 * 1+ ; inline
: right ( n -- m ) 2 * 2 + ; inline
: up ( n -- m ) 1- 2 /i ; inline
: left-value ( n heap -- obj ) >r left r> nth ; inline
: right-value ( n heap -- obj ) >r right r> nth ; inline
: up-value ( n vec -- obj ) >r up r> nth ; inline
: swap-up ( n vec -- ) >r dup up r> exchange ; inline
: last-index ( vec -- n ) length 1- ; inline
: left ( n -- m ) 1 shift 1 + ; inline
: right ( n -- m ) 1 shift 2 + ; inline
: up ( n -- m ) 1- 2/ ; inline
: data-nth ( n heap -- entry )
heap-data nth-unsafe ; inline
: up-value ( n heap -- entry )
>r up r> data-nth ; inline
: left-value ( n heap -- entry )
>r left r> data-nth ; inline
: right-value ( n heap -- entry )
>r right r> data-nth ; inline
: data-set-nth ( entry n heap -- )
>r [ swap set-entry-index ] 2keep r>
heap-data set-nth-unsafe ;
: data-push ( entry heap -- n )
dup heap-size [
swap 2dup heap-data ensure 2drop data-set-nth
] keep ; inline
: data-pop ( heap -- entry )
heap-data pop ; inline
: data-pop* ( heap -- )
heap-data pop* ; inline
: data-peek ( heap -- entry )
heap-data peek ; inline
: data-first ( heap -- entry )
heap-data first ; inline
: data-exchange ( m n heap -- )
[ tuck data-nth >r data-nth r> ] 3keep
tuck >r >r data-set-nth r> r> data-set-nth ; inline
GENERIC: heap-compare ( pair1 pair2 heap -- ? )
: (heap-compare) drop [ first ] compare 0 ; inline
: (heap-compare) drop [ entry-key ] compare 0 ; inline
M: min-heap heap-compare (heap-compare) > ;
M: max-heap heap-compare (heap-compare) < ;
: heap-bounds-check? ( m heap -- ? )
heap-data length >= ; inline
heap-size >= ; inline
: left-bounds-check? ( m heap -- ? )
>r left r> heap-bounds-check? ; inline
@ -58,41 +107,44 @@ M: max-heap heap-compare (heap-compare) < ;
: right-bounds-check? ( m heap -- ? )
>r right r> heap-bounds-check? ; inline
: up-heap-continue? ( vec heap -- ? )
>r [ last-index ] keep [ up-value ] keep peek r>
: continue? ( m up[m] heap -- ? )
[ data-nth swap ] keep [ data-nth ] keep
heap-compare ; inline
: up-heap ( vec heap -- )
2dup up-heap-continue? [
>r dup last-index [ over swap-up ] keep
up 1+ head-slice r> up-heap
DEFER: up-heap
: (up-heap) ( n heap -- )
>r dup up r>
3dup continue? [
[ data-exchange ] 2keep up-heap
] [
2drop
3drop
] if ;
: up-heap ( n heap -- )
over 0 > [ (up-heap) ] [ 2drop ] if ;
: (child) ( m heap -- n )
dupd
[ heap-data left-value ] 2keep
[ heap-data right-value ] keep heap-compare
2dup right-value
>r 2dup left-value r>
rot heap-compare
[ right ] [ left ] if ;
: child ( m heap -- n )
2dup right-bounds-check? [ drop left ] [ (child) ] if ;
2dup right-bounds-check?
[ drop left ] [ (child) ] if ;
: swap-down ( m heap -- )
[ child ] 2keep heap-data exchange ;
[ child ] 2keep data-exchange ;
DEFER: down-heap
: down-heap-continue? ( heap m heap -- m heap ? )
[ heap-data nth ] 2keep child pick
dupd [ heap-data nth swapd ] keep heap-compare ;
: (down-heap) ( m heap -- )
2dup down-heap-continue? [
-rot [ swap-down ] keep down-heap
] [
[ child ] 2keep swapd
3dup continue? [
3drop
] [
[ data-exchange ] 2keep down-heap
] if ;
: down-heap ( m heap -- )
@ -100,40 +152,37 @@ DEFER: down-heap
PRIVATE>
M: priority-queue heap-push ( value key heap -- )
>r swap 2array r>
[ heap-data push ] keep
[ heap-data ] keep
up-heap ;
M: priority-queue heap-push* ( value key heap -- entry )
>r <entry> dup r> [ data-push ] keep up-heap ;
: heap-push ( value key heap -- ) heap-push* drop ;
: heap-push-all ( assoc heap -- )
[ swapd heap-push ] curry assoc-each ;
: >entry< ( entry -- key value )
{ entry-value entry-key } get-slots ;
M: priority-queue heap-peek ( heap -- value key )
heap-data first first2 swap ;
data-first >entry< ;
M: priority-queue heap-delete ( entry heap -- )
>r entry-index r>
2dup heap-size 1- = [
nip data-pop*
] [
[ nip data-pop ] 2keep
[ data-set-nth ] 2keep
down-heap
] if ;
M: priority-queue heap-pop* ( heap -- )
dup heap-data length 1 > [
[ heap-data pop ] keep
[ heap-data set-first ] keep
0 swap down-heap
] [
heap-data pop*
] if ;
dup data-first swap heap-delete ;
M: priority-queue heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ;
M: priority-queue heap-pop ( heap -- value key )
dup data-first [ swap heap-delete ] keep >entry< ;
M: priority-queue heap-empty? ( heap -- ? ) heap-data empty? ;
M: priority-queue heap-length ( heap -- n ) heap-data length ;
: (heap-pop-while) ( heap pred quot -- )
pick heap-empty? [
3drop
] [
[ >r >r dup heap-peek r> call r> [ drop f ] if ] 3keep
roll [ (heap-pop-while) ] [ 3drop ] if
] if ;
M: priority-queue heap-pop-while ( heap pred quot -- )
[ heap-pop ] swap [ t ] 3compose (heap-pop-while) ;
: heap-pop-all ( heap -- alist )
[ dup heap-empty? not ]
[ dup heap-pop swap 2array ]
[ ] unfold nip ;

7
core/inference/class/class-tests.factor
View File

@ -288,3 +288,10 @@ cell-bits 32 = [
[ HEX: ff bitand 0 HEX: ff between? ]
\ >= inlined?
] unit-test
[ t ] [
[ HEX: ff swap HEX: ff bitand >= ]
\ >= inlined?
] unit-test

2
core/optimizer/math/math.factor
View File

@ -379,7 +379,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
>r dup dup node-in-d first node-interval
swap dup node-in-d second node-literal r> execute ; inline
: foldable-comparison? ( #call word -- )
: foldable-comparison? ( #call word -- ? )
>r dup known-comparison? [
r> perform-comparison incomparable eq? not
] [

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

@ -17,7 +17,11 @@ ARTICLE: "threads-start/stop" "Starting and stopping threads"
ARTICLE: "threads-yield" "Yielding and suspending threads"
"Yielding to other threads:"
{ $subsection yield }
"Sleeping for a period of time:"
{ $subsection sleep }
"Interruptible sleep:"
{ $subsection nap }
{ $subsection interrupt }
"Threads can be suspended and woken up at some point in the future when a condition is satisfied:"
{ $subsection suspend }
{ $subsection resume }
@ -104,7 +108,16 @@ HELP: yield
HELP: sleep
{ $values { "ms" "a non-negative integer" } }
{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds. It will not get woken up before this time period elapses, but since the multitasker is co-operative, the precise wakeup time is dependent on when other threads yield." } ;
{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds." }
{ $errors "Throws an error if another thread interrupted the sleep with " { $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
{ $values { "thread" thread } }
{ $description "Interrupts a sleeping thread." } ;
HELP: suspend
{ $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "obj" object } }

35
core/threads/threads.factor
View File

@ -13,7 +13,7 @@ TUPLE: thread
name quot error-handler exit-handler
id
continuation state
mailbox variables ;
mailbox variables sleep-entry ;
: self ( -- thread ) 40 getenv ; inline
@ -86,19 +86,25 @@ PRIVATE>
<PRIVATE
: schedule-sleep ( thread ms -- )
>r check-registered r> sleep-queue heap-push ;
>r check-registered dup r> sleep-queue heap-push*
swap set-thread-sleep-entry ;
: wake-up? ( heap -- ? )
: expire-sleep? ( heap -- ? )
dup heap-empty?
[ drop f ] [ heap-peek nip millis <= ] if ;
: wake-up ( -- )
: expire-sleep ( thread -- )
f over set-thread-sleep-entry resume ;
: expire-sleep-loop ( -- )
sleep-queue
[ dup wake-up? ] [ dup heap-pop drop resume ] [ ] while
[ dup expire-sleep? ]
[ dup heap-pop drop expire-sleep ]
[ ] while
drop ;
: next ( -- )
wake-up
expire-sleep-loop
run-queue pop-back
dup array? [ first2 ] [ f swap ] if dup set-self
f over set-thread-state
@ -127,14 +133,23 @@ PRIVATE>
: yield ( -- ) [ resume ] "yield" suspend drop ;
: nap ( ms/f -- ? )
[
>fixnum millis + [ schedule-sleep ] curry "sleep"
] [
[ drop ] "interrupt"
] if* suspend ;
: sleep ( ms -- )
>fixnum millis +
[ schedule-sleep ] curry
"sleep" suspend drop ;
nap [ "Sleep interrupted" throw ] when ;
: interrupt ( thread -- )
dup thread-sleep-entry [ sleep-queue heap-delete ] when*
t swap resume-with ;
: (spawn) ( thread -- )
[
resume [
resume-now [
dup set-self
dup register-thread
init-namespaces

22
extra/alarms/alarms-docs.factor Executable file
View File

@ -0,0 +1,22 @@
IN: alarms
USING: help.markup help.syntax calendar ;
HELP: alarm
{ $class-description "An alarm. Cancel passed to " { $link cancel-alarm } "." } ;
HELP: add-alarm
{ $values { "time" timestamp } { "frequency" "a " { $link dt } " or " { $link f } } { "quot" quotation } { "alarm" alarm } }
{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;
HELP: cancel-alarm
{ $values { "alarm" alarm } }
{ $description "Cancels an alarm." }
{ $errors "Throws an error if the alarm is not active." } ;
ARTICLE: "alarms" "Alarms"
"Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
{ $subsection alarm }
{ $subsection add-alarm }
{ $subsection cancel-alarm } ;
ABOUT: "alarms"

126
extra/alarms/alarms.factor
View File

@ -1,87 +1,83 @@
! Copyright (C) 2007 Doug Coleman.
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays calendar combinators concurrency.messaging
threads generic init kernel math namespaces sequences ;
USING: arrays calendar combinators generic init kernel math
namespaces sequences heaps boxes threads debugger quotations ;
IN: alarms
TUPLE: alarm time quot ;
C: <alarm> alarm
TUPLE: alarm time interval quot entry ;
<PRIVATE
! for now a V{ }, eventually a min-heap to store alarms
: check-alarm
pick timestamp? [ "Not a timestamp" throw ] unless
over dup dt? swap not or [ "Not a dt" throw ] unless
dup callable? [ "Not a quotation" throw ] unless ; inline
: <alarm> ( time delay quot -- alarm )
check-alarm <box> alarm construct-boa ;
SYMBOL: alarms
SYMBOL: alarm-receiver
SYMBOL: alarm-looper
SYMBOL: alarm-thread
: add-alarm ( alarm -- )
alarms get-global push ;
: notify-alarm-thread ( -- )
alarm-thread get-global interrupt ;
: remove-alarm ( alarm -- )
alarms get-global delete ;
: alarm-expired? ( alarm now -- ? )
>r alarm-time r> <=> 0 <= ;
: handle-alarm ( alarm -- )
dup delegate {
{ "register" [ add-alarm ] }
{ "unregister" [ remove-alarm ] }
} case ;
: expired-alarms ( -- seq )
now alarms get-global
[ alarm-time <=> 0 > ] with subset ;
: unexpired-alarms ( -- seq )
now alarms get-global
[ alarm-time <=> 0 <= ] with subset ;
: reschedule-alarm ( alarm -- )
dup alarm-time over alarm-interval +dt
over set-alarm-time
add-alarm drop ;
: call-alarm ( alarm -- )
alarm-quot "Alarm invocation" spawn drop ;
dup alarm-quot try
dup alarm-entry box> drop
dup alarm-interval [ reschedule-alarm ] [ drop ] if ;
: do-alarms ( -- )
expired-alarms [ call-alarm ] each
unexpired-alarms alarms set-global ;
: (trigger-alarms) ( alarms now -- )
over heap-empty? [
2drop
] [
over heap-peek drop over alarm-expired? [
over heap-pop drop call-alarm
(trigger-alarms)
] [
2drop
] if
] if ;
: alarm-receive-loop ( -- )
receive dup alarm? [ handle-alarm ] [ drop ] if
alarm-receive-loop ;
: trigger-alarms ( alarms -- )
now (trigger-alarms) ;
: start-alarm-receiver ( -- )
[
alarm-receive-loop
] "Alarm receiver" spawn alarm-receiver set-global ;
: next-alarm ( alarms -- ms )
dup heap-empty?
[ drop f ] [
heap-peek drop alarm-time now
[ timestamp>unix-time ] 2apply [-] 1000 *
] if ;
: alarm-loop ( -- )
alarms get-global empty? [
do-alarms
] unless 100 sleep alarm-loop ;
: alarm-thread-loop ( -- )
alarms get-global
dup next-alarm nap drop
dup trigger-alarms
alarm-thread-loop ;
: start-alarm-looper ( -- )
[
alarm-loop
] "Alarm looper" spawn alarm-looper set-global ;
: init-alarms ( -- )
<min-heap> alarms set-global
[ alarm-thread-loop ] "Alarms" spawn
alarm-thread set-global ;
: send-alarm ( str alarm -- )
over set-delegate
alarm-receiver get-global send ;
[ init-alarms ] "alarms" add-init-hook
: start-alarm-daemon ( -- )
alarms get-global [ V{ } clone alarms set-global ] unless
start-alarm-looper
start-alarm-receiver ;
[ start-alarm-daemon ] "alarms" add-init-hook
PRIVATE>
: register-alarm ( alarm -- )
"register" send-alarm ;
: add-alarm ( time frequency quot -- alarm )
<alarm> [
dup dup alarm-time alarms get-global heap-push*
swap alarm-entry >box
notify-alarm-thread
] keep ;
: unregister-alarm ( alarm -- )
"unregister" send-alarm ;
: change-alarm ( alarm-old alarm-new -- )
"register" send-alarm
"unregister" send-alarm ;
! Example:
! 5 seconds from-now [ "hi" print flush ] <alarm> register-alarm
: cancel-alarm ( alarm -- )
alarm-entry box> alarms get-global heap-delete ;

2
extra/bunny/bunny.factor
View File

@ -1,6 +1,6 @@
USING: alien alien.c-types arrays sequences math
math.vectors math.matrices math.parser io io.files kernel opengl
opengl.gl opengl.glu shuffle http.client vectors timers
opengl.gl opengl.glu shuffle http.client vectors
namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting
combinators tools.time system combinators.lib combinators.cleave
float-arrays continuations opengl.demo-support multiline

2
extra/calendar/calendar.factor
View File

@ -223,7 +223,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
[ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
: unix-1970 ( -- timestamp )
1970 1 1 0 0 0 0 <timestamp> ;
1970 1 1 0 0 0 0 <timestamp> ; foldable
: unix-time>timestamp ( n -- timestamp )
>r unix-1970 r> seconds +dt ;

2
extra/http/client/client.factor
View File

@ -47,7 +47,7 @@ DEFER: http-get-stream
dispose "location" swap peek-at nip http-get-stream
] when ;
: default-timeout 60 1000 * over set-timeout ;
: default-timeout 1 minutes over set-timeout ;
: http-get-stream ( url -- code headers stream )
#! Opens a stream for reading from an HTTP URL.

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

@ -50,7 +50,7 @@ IN: http.server
: httpd ( port -- )
internet-server "http.server" [
60000 stdio get set-timeout
1 minutes stdio get set-timeout
readln [ parse-request ] when*
] with-server ;

5
extra/io/launcher/launcher-docs.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax quotations kernel io math ;
USING: help.markup help.syntax quotations kernel io math
calendar ;
IN: io.launcher
HELP: +command+
@ -77,7 +78,7 @@ $nl
"This is used in situations where you want a spawn child process with some overridden environment variables." } ;
HELP: +timeout+
{ $description "Launch descriptor key. If set, specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ;
{ $description "Launch descriptor key. If set to a " { $link dt } ", specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ;
HELP: default-descriptor
{ $description "Association storing default values for launch descriptor keys." } ;

8
extra/io/launcher/launcher.factor
View File

@ -10,14 +10,14 @@ SYMBOL: processes
[ H{ } clone processes set-global ] "io.launcher" add-init-hook
TUPLE: process handle status killed? lapse ;
TUPLE: process handle status killed? timeout ;
HOOK: register-process io-backend ( process -- )
M: object register-process drop ;
: <process> ( handle -- process )
f f <lapse> process construct-boa
f f f process construct-boa
V{ } clone over processes get set-at
dup register-process ;
@ -115,7 +115,9 @@ HOOK: kill-process* io-backend ( handle -- )
t over set-process-killed?
process-handle [ kill-process* ] when* ;
M: process get-lapse process-lapse ;
M: process timeout process-timeout ;
M: process set-timeout set-process-timeout ;
M: process timed-out kill-process ;

11
extra/io/nonblocking/nonblocking.factor
View File

@ -13,11 +13,12 @@ SYMBOL: default-buffer-size
TUPLE: port
handle
error
lapse
timeout
type eof? ;
! Ports support the lapse protocol
M: port get-lapse port-lapse ;
M: port timeout port-timeout ;
M: port set-timeout set-port-timeout ;
SYMBOL: closed
@ -28,12 +29,10 @@ GENERIC: init-handle ( handle -- )
GENERIC: close-handle ( handle -- )
: <port> ( handle buffer type -- port )
pick init-handle
<lapse> {
pick init-handle {
set-port-handle
set-delegate
set-port-type
set-port-lapse
} port construct ;
: <buffered-port> ( handle type -- port )

15
extra/io/timeouts/timeouts-docs.factor
View File

@ -1,14 +1,13 @@
IN: io.timeouts
USING: help.markup help.syntax math kernel ;
USING: help.markup help.syntax math kernel calendar ;
HELP: get-lapse
{ $values { "obj" object } { "lapse" lapse } }
{ $contract "Outputs an object's timeout lapse descriptor." } ;
HELP: timeout
{ $values { "obj" object } { "dt/f" "a " { $link dt } " or " { $link f } } }
{ $contract "Outputs an object's timeout." } ;
HELP: set-timeout
{ $values { "ms" integer } { "obj" object } }
{ $contract "Sets an object's timeout, in milliseconds." }
{ $notes "The default implementation delegates the call to the object's timeout lapse descriptor." } ;
{ $values { "dt/f" "a " { $link dt } " or " { $link f } } { "obj" object } }
{ $contract "Sets an object's timeout." } ;
HELP: timed-out
{ $values { "obj" object } }
@ -20,9 +19,9 @@ HELP: with-timeout
ARTICLE: "io.timeouts" "I/O timeout protocol"
"Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."
{ $subsection timeout }
{ $subsection set-timeout }
"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."
{ $subsection get-lapse }
{ $subsection timed-out }
"A combinator to be used in operations which can time out:"
{ $subsection with-timeout }

76
extra/io/timeouts/timeouts.factor
View File

@ -1,79 +1,27 @@
! Copyright (C) 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math system dlists namespaces assocs init
threads io.streams.duplex ;
USING: kernel calendar alarms io.streams.duplex ;
IN: io.timeouts
TUPLE: lapse entry timeout cutoff ;
: <lapse> f 0 0 \ lapse construct-boa ;
! Won't need this with new slot accessors
GENERIC: get-lapse ( obj -- lapse )
GENERIC: timeout ( obj -- dt/f )
GENERIC: set-timeout ( dt/f obj -- )
GENERIC: set-timeout ( ms obj -- )
M: object set-timeout get-lapse set-timeout ;
M: lapse set-timeout set-lapse-timeout ;
: timeout ( obj -- ms ) get-lapse lapse-timeout ;
: entry ( obj -- dlist-node ) get-lapse lapse-entry ;
: set-entry ( obj dlist-node -- ) get-lapse set-lapse-entry ;
: cutoff ( obj -- ms ) get-lapse lapse-cutoff ;
: set-cutoff ( ms obj -- ) get-lapse set-lapse-cutoff ;
! Won't need this with inheritance
TUPLE: duplex-stream-lapse stream ;
M: duplex-stream-lapse set-timeout
duplex-stream-lapse-stream 2dup
M: duplex-stream set-timeout
2dup
duplex-stream-in set-timeout
duplex-stream-out set-timeout ;
M: duplex-stream get-lapse duplex-stream-lapse construct-boa ;
SYMBOL: timeout-queue
: timeout? ( lapse -- ? )
cutoff dup zero? not swap millis < and ;
timeout-queue global [ [ <dlist> ] unless* ] change-at
: unqueue-timeout ( obj -- )
entry [
timeout-queue get-global swap delete-node
] when* ;
: queue-timeout ( obj -- )
dup timeout-queue get-global push-front*
swap set-entry ;
GENERIC: timed-out ( obj -- )
M: object timed-out drop ;
: expire-timeouts ( -- )
timeout-queue get-global dup dlist-empty? [ drop ] [
dup peek-back timeout?
[ pop-back timed-out expire-timeouts ] [ drop ] if
] if ;
: begin-timeout ( obj -- )
dup timeout dup zero? [
2drop
] [
millis + over set-cutoff
dup unqueue-timeout queue-timeout
] if ;
: queue-timeout ( obj timeout -- alarm )
from-now f rot [ timed-out ] curry add-alarm ;
: with-timeout ( obj quot -- )
over begin-timeout keep unqueue-timeout ; inline
: expiry-thread ( -- )
expire-timeouts 5000 sleep expiry-thread ;
: start-expiry-thread ( -- )
[ expiry-thread ] "I/O expiry" spawn drop ;
[ start-expiry-thread ] "io.timeouts" add-init-hook
over dup timeout dup [
queue-timeout slip cancel-alarm
] [
2drop call
] if ; inline

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

@ -146,10 +146,16 @@ M: windows-io kill-process* ( handle -- )
: wait-loop ( -- )
processes get dup assoc-empty?
[ drop t ] [ wait-for-processes ] if
[ 250 sleep ] when ;
[ drop f nap drop ]
[ wait-for-processes [ 100 nap drop ] when ] if ;
SYMBOL: wait-thread
: start-wait-thread ( -- )
[ wait-loop t ] "Process wait" spawn-server drop ;
[ wait-loop t ] "Process wait" spawn-server
wait-thread set-global ;
M: windows-io register-process
drop wait-thread get-global interrupt ;
[ start-wait-thread ] "io.windows.launcher" add-init-hook

4
extra/locals/locals-tests.factor
View File

@ -122,3 +122,7 @@ SYMBOL: a
USE: kernel ;
[ t ] [ a symbol? ] unit-test
:: let-let-test | n | [let | n [ n 3 + ] | n ] ;
[ 13 ] [ 10 let-let-test ] unit-test

18
extra/models/models.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: generic kernel math sequences timers arrays assocs ;
USING: generic kernel math sequences arrays assocs alarms ;
IN: models
TUPLE: model value connections dependencies ref locked? ;
@ -174,7 +174,7 @@ TUPLE: history back forward ;
dup history-forward delete-all
dup history-back (add-history) ;
TUPLE: delay model timeout ;
TUPLE: delay model timeout alarm ;
: update-delay-model ( delay -- )
dup delay-model model-value swap set-model ;
@ -185,12 +185,18 @@ TUPLE: delay model timeout ;
[ set-delay-model ] 2keep
[ add-dependency ] keep ;
M: delay model-changed nip 0 over delay-timeout add-timer ;
: cancel-delay ( delay -- )
delay-model-alarm [ cancel-alarm ] when* ;
: start-delay ( delay -- )
now over delay-model-timeout dt+ f
pick [ f over set-delay-alarm update-delay-model ] curry
add-alarm swap set-delay-model-alarm ;
M: delay model-changed nip start-delay ;
M: delay model-activated update-delay-model ;
M: delay tick dup remove-timer update-delay-model ;
GENERIC: range-value ( model -- value )
GENERIC: range-page-value ( model -- value )
GENERIC: range-min-value ( model -- value )

2
extra/smtp/server/server.factor
View File

@ -66,7 +66,7 @@ SYMBOL: data-mode
"Starting SMTP server on port " write dup . flush
"127.0.0.1" swap <inet4> <server> [
accept [
60000 stdio get set-timeout
1 minutes stdio get set-timeout
"220 hello\r\n" write flush
process
global [ flush ] bind

1
extra/timers/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

1
extra/timers/summary.txt
View File

@ -1 +0,0 @@
Simple low-resolution timers

36
extra/timers/timers-docs.factor
View File

@ -1,36 +0,0 @@
USING: help.syntax help.markup classes kernel ;
IN: timers
HELP: init-timers
{ $description "Initializes the timer code." }
{ $notes "This word is automatically called when the UI is initialized, and it should only be called manually if timers are being used outside of the UI." } ;
HELP: tick
{ $values { "object" object } }
{ $description "Called to notify an object registered with a timer that the timer has fired." } ;
HELP: add-timer
{ $values { "object" object } { "delay" "a positive integer" } { "initial" "a positive integer" } }
{ $description "Registers a timer. Every " { $snippet "delay" } " milliseconds, " { $link tick } " will be called on the object. The initial delay from the time " { $link add-timer } " is called to when " { $link tick } " is first called is " { $snippet "initial" } " milliseconds." } ;
HELP: remove-timer
{ $values { "object" object } }
{ $description "Unregisters a timer." } ;
HELP: do-timers
{ $description "Fires all registered timers which are due to fire." }
{ $notes "This word is automatically called from the UI event loop, and it should only be called manually if timers are being used outside of the UI." } ;
{ init-timers add-timer remove-timer tick do-timers } related-words
ARTICLE: "timers" "Timers"
"Timers can be added and removed:"
{ $subsection add-timer }
{ $subsection remove-timer }
"Classes must implement a generic word so that their instances can handle timer ticks:"
{ $subsection tick }
"Timers can be used outside of the UI, however they must be initialized with an explicit call, and fired manually:"
{ $subsection init-timers }
{ $subsection do-timers } ;
ABOUT: "timers"

30
extra/timers/timers.factor
View File

@ -1,30 +0,0 @@
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math namespaces sequences system ;
IN: timers
TUPLE: timer object delay next ;
: <timer> ( object delay initial -- timer )
millis + timer construct-boa ;
GENERIC: tick ( object -- )
: timers \ timers get-global ;
: init-timers ( -- ) H{ } clone \ timers set-global ;
: add-timer ( object delay initial -- )
pick >r <timer> r> timers set-at ;
: remove-timer ( object -- ) timers delete-at ;
: advance-timer ( ms timer -- )
[ timer-delay + ] keep set-timer-next ;
: do-timer ( ms timer -- )
dup timer-next pick <=
[ [ advance-timer ] keep timer-object tick ] [ 2drop ] if ;
: do-timers ( -- )
millis timers values [ do-timer ] with each ;

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

@ -2,17 +2,24 @@
! See http://factorcode.org/license.txt for BSD license.
IN: tools.threads
USING: threads kernel prettyprint prettyprint.config
io io.styles sequences assocs namespaces sorting boxes ;
io io.styles sequences assocs namespaces sorting boxes
heaps.private system math math.parser ;
: thread. ( thread -- )
dup thread-id pprint-cell
dup thread-name over [ write-object ] with-cell
thread-state "running" or [ write ] with-cell ;
dup thread-state "running" or [ write ] with-cell
[
thread-sleep-entry [
entry-key millis [-] number>string write
" ms" write
] when*
] with-cell ;
: threads. ( -- )
standard-table-style [
[
{ "ID" "Name" "Waiting on" }
{ "ID" "Name" "Waiting on" "Remaining sleep" }
[ [ write ] with-cell ] each
] with-row

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

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables kernel models math namespaces sequences
timers quotations math.vectors combinators sorting vectors
dlists models ;
quotations math.vectors combinators sorting vectors dlists
models ;
IN: ui.gadgets
TUPLE: rect loc dim ;

13
extra/ui/gestures/gestures.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math models namespaces
sequences words strings system hashtables math.parser
math.vectors tuples classes ui.gadgets timers combinators.lib ;
math.vectors tuples classes ui.gadgets combinators.lib ;
IN: ui.gestures
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
@ -107,20 +107,19 @@ SYMBOL: double-click-timeout
: drag-gesture ( -- )
hand-buttons get-global first <drag> button-gesture ;
TUPLE: drag-timer ;
SYMBOL: drag-timer
M: drag-timer tick drop drag-gesture ;
drag-timer construct-empty drag-timer set-global
<box> drag-timer set-global
: start-drag-timer ( -- )
hand-buttons get-global empty? [
drag-timer get-global 100 300 add-timer
now 300 milliseconds dt+ 100 milliseconds
[ drag-gesture ] add-alarm drag-timer get-global >box
] when ;
: stop-drag-timer ( -- )
hand-buttons get-global empty? [
drag-timer get-global remove-timer
drag-timer get-global box> cancel-alarm
] when ;
: fire-motion ( -- )

4
extra/ui/tools/listener/listener-tests.factor
View File

@ -1,12 +1,10 @@
USING: continuations documents ui.tools.interactor
ui.tools.listener hashtables kernel namespaces parser sequences
timers tools.test ui.commands ui.gadgets ui.gadgets.editors
tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private
threads ;
IN: temporary
timers [ init-timers ] unless
[ f ] [ "word" source-editor command-map empty? ] unit-test
[ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test

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

@ -6,7 +6,7 @@ kernel models namespaces parser quotations sequences ui.commands
ui.gadgets ui.gadgets.editors ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.operations vocabs words
prettyprint listener debugger threads ;
prettyprint listener debugger threads boxes ;
IN: ui.tools.listener
TUPLE: listener-gadget input output stack ;
@ -161,6 +161,7 @@ M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? )
M: listener-gadget graft*
dup delegate graft*
dup listener-gadget-input interactor-thread ?box 2drop
restart-listener ;
M: listener-gadget ungraft*

7
extra/ui/tools/search/search-tests.factor
View File

@ -1,11 +1,9 @@
USING: assocs ui.tools.search help.topics io.files io.styles
kernel namespaces sequences source-files threads timers
kernel namespaces sequences source-files threads
tools.test ui.gadgets ui.gestures vocabs
vocabs.loader words tools.test.ui debugger ;
IN: temporary
timers get [ init-timers ] unless
[ f ] [
"no such word with this name exists, certainly"
f f <definition-search>
@ -16,7 +14,7 @@ timers get [ init-timers ] unless
: update-live-search ( search -- seq )
dup [
300 sleep do-timers
300 sleep
live-search-list control-value
] with-grafted-gadget ;
@ -33,7 +31,6 @@ timers get [ init-timers ] unless
dup [
{ "set-word-prop" } over live-search-field set-control-value
300 sleep
do-timers
search-value \ set-word-prop eq?
] with-grafted-gadget
] unit-test

4
extra/ui/tools/tools-tests.factor
View File

@ -1,6 +1,6 @@
USING: ui.tools ui.tools.interactor ui.tools.listener
ui.tools.search ui.tools.workspace kernel models namespaces
sequences timers tools.test ui.gadgets ui.gadgets.buttons
sequences tools.test ui.gadgets ui.gadgets.buttons
ui.gadgets.labelled ui.gadgets.presentations
ui.gadgets.scrollers vocabs tools.test.ui ui ;
IN: temporary
@ -12,8 +12,6 @@ IN: temporary
] unit-test
] with-scope
timers get [ init-timers ] unless
[ ] [ <workspace> "w" set ] unit-test
[ ] [ "w" get com-scroll-up ] unit-test
[ ] [ "w" get com-scroll-down ] unit-test

3
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. Instead, it should poll for pending events, then call " { $link ui-step } ", which performs pending layout, runs timers and sleeps for 10 milliseconds, or until a Factor thread wakes up." ;
"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." ;
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:"
@ -368,7 +368,6 @@ $nl
{ $subsection "ui-paint" }
{ $subsection "ui-control-impl" }
{ $subsection "clipboard-protocol" }
{ $subsection "timers" }
{ $see-also "ui-layout-impl" } ;
ARTICLE: "ui" "UI framework"

6
extra/ui/ui.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs io kernel math models namespaces
prettyprint dlists sequences threads sequences words
timers 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
hashtables ;
IN: ui
@ -131,8 +131,7 @@ SYMBOL: ui-hook
graft-queue [ notify ] dlist-slurp ;
: ui-step ( -- )
[ do-timers notify-queued layout-queued redraw-worlds ]
assert-depth ;
[ notify-queued layout-queued redraw-worlds ] assert-depth ;
: open-world-window ( world -- )
dup pref-dim over set-gadget-dim dup relayout graft ui-step ;
@ -156,7 +155,6 @@ M: object close-window
find-world [ ungraft ] when* ;
: start-ui ( -- )
init-timers
restore-windows? [
restore-windows
] [

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

@ -5,9 +5,8 @@ ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel
math math.vectors namespaces prettyprint sequences strings
vectors words windows.kernel32 windows.gdi32 windows.user32
windows.opengl32 windows.messages windows.types windows.nt
windows threads timers libc combinators
continuations command-line shuffle opengl ui.render unicode.case
ascii math.bitfields ;
windows threads libc combinators continuations command-line
shuffle opengl ui.render unicode.case ascii math.bitfields ;
IN: ui.windows
TUPLE: windows-ui-backend ;

9
vm/debug.c
View File

@ -37,15 +37,24 @@ void print_array(F_ARRAY* array, CELL nesting)
{
CELL length = array_capacity(array);
CELL i;
bool trimmed;
if(length > 10)
{
trimmed = true;
length = 10;
}
else
trimmed = false;
for(i = 0; i < length; i++)
{
printf(" ");
print_nested_obj(array_nth(array,i),nesting);
}
if(trimmed)
printf("...");
}
void print_nested_obj(CELL obj, F_FIXNUM nesting)