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

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

release
Eduardo Cavazos 2007-11-04 13:42:26 -06:00
parent 1364674546 d366ced0a8
commit 049ceb7044
57 changed files with 487 additions and 492 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/bootstrap/ui/tools/tools.factor
View File

@ -1,4 +1,4 @@
USING: kernel vocabs vocabs.loader sequences ;
USING: kernel vocabs vocabs.loader sequences system ;
{ "ui" "help" "tools" }
[ "bootstrap." swap append vocab ] all? [
@ -8,3 +8,5 @@ USING: kernel vocabs vocabs.loader sequences ;
"ui.cocoa.tools" require
] when
] when
macosx? [ "ui.tools.deploy" require ] when

2
core/bootstrap/ui/ui.factor
View File

@ -12,5 +12,3 @@ vocabs vocabs.loader ;
"ui.freetype" require
] when
macosx? [ "ui.tools.deploy" require ] when

2
core/cpu/arm/architecture/architecture.factor
View File

@ -278,7 +278,7 @@ M: arm-backend %alien-indirect ( -- )
M: arm-backend %alien-callback ( quot -- )
R0 load-indirect
"run_callback" f %alien-invoke ;
"c_to_factor" f %alien-invoke ;
M: arm-backend %callback-value ( ctype -- )
! Save top of data stack

4
core/cpu/arm/arm.factor
View File

@ -3,7 +3,7 @@
USING: alien alien.c-types kernel math namespaces
cpu.architecture cpu.arm.architecture cpu.arm.assembler
cpu.arm.intrinsics generator generator.registers continuations
compiler io vocabs.loader sequences ;
compiler io vocabs.loader sequences system ;
! EABI passes floats in integer registers.
[ alien-float ]
@ -53,4 +53,4 @@ T{ arm-backend } compiler-backend set-global
t have-BLX? set-global
] when
7 cells set-profiler-prologue
7 cells set-profiler-prologues

32
core/heaps/heaps-tests.factor Normal file
View File

@ -0,0 +1,32 @@
! Copyright 2007 Ryan Murphy
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math tools.test heaps heaps.private ;
IN: temporary
[ <min-heap> pop-heap ] unit-test-fails
[ <max-heap> pop-heap ] unit-test-fails
[ t ] [ <min-heap> heap-empty? ] unit-test
[ f ] [ <min-heap> 1 over push-heap heap-empty? ] unit-test
[ t ] [ <max-heap> heap-empty? ] unit-test
[ f ] [ <max-heap> 1 over push-heap heap-empty? ] unit-test
! 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 3 T{ min-heap } heap-compare ] unit-test
{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test
[ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ]
[ <min-heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over push-heap* ] unit-test
[ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [
<min-heap> { 3 5 4 6 5 7 6 8 } over push-heap*
3 [ dup pop-heap* ] times
] unit-test
[ 2 ] [ <min-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap pop-heap ] unit-test
[ 1 ] [ <min-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test
[ 400 ] [ <max-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test

112
core/heaps/heaps.factor Normal file
View File

@ -0,0 +1,112 @@
! Copyright (C) 2007 Ryan Murphy, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences ;
IN: heaps
<PRIVATE
TUPLE: heap data ;
: <heap> ( -- obj )
V{ } clone heap construct-boa ;
PRIVATE>
TUPLE: min-heap ;
: <min-heap> ( -- obj )
<heap> min-heap construct-delegate ;
TUPLE: max-heap ;
: <max-heap> ( -- obj )
<heap> max-heap construct-delegate ;
<PRIVATE
: left ( n -- m ) 2 * 1+ ;
: right ( n -- m ) 2 * 2 + ;
: up ( n -- m ) 1- 2 /i ;
: left-value ( n heap -- obj ) >r left r> nth ;
: right-value ( n heap -- obj ) >r right r> nth ;
: up-value ( n vec -- obj ) >r up r> nth ;
: swap-up ( n vec -- ) >r dup up r> exchange ;
: last-index ( vec -- n ) length 1- ;
GENERIC: heap-compare ( obj1 obj2 heap -- ? )
M: min-heap heap-compare drop <=> 0 > ;
M: max-heap heap-compare drop <=> 0 < ;
: left-bounds-check? ( m heap -- ? )
>r left r> heap-data length >= ;
: right-bounds-check? ( m heap -- ? )
>r right r> heap-data length >= ;
: (up-heap) ( vec heap -- )
[
>r [ last-index ] keep [ up-value ] keep peek r> heap-compare
] 2keep rot [
>r dup last-index
[ over swap-up ] keep
up 1+ head-slice
r> (up-heap)
] [
2drop
] if ;
: up-heap ( heap -- )
[ heap-data ] keep (up-heap) ;
: child ( m heap -- n )
2dup right-bounds-check? [
drop left
] [
dupd
[ heap-data left-value ] 2keep
[ heap-data right-value ] keep heap-compare [
right
] [
left
] if
] if ;
: swap-down ( m heap -- )
[ child ] 2keep heap-data exchange ;
DEFER: down-heap
: (down-heap) ( m heap -- )
2dup [ heap-data nth ] 2keep child pick
dupd [ heap-data nth swapd ] keep
heap-compare [
-rot [ swap-down ] keep down-heap
] [
3drop
] if ;
: down-heap ( m heap -- )
2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ;
PRIVATE>
: push-heap ( obj heap -- )
tuck heap-data push up-heap ;
: push-heap* ( seq heap -- )
swap [ swap push-heap ] curry* each ;
: peek-heap ( heap -- obj )
heap-data first ;
: pop-heap* ( heap -- )
dup heap-data length 1 > [
[ heap-data pop 0 ] keep
[ heap-data set-nth ] keep
>r 0 r> down-heap
] [
heap-data pop*
] if ;
: pop-heap ( heap -- fist ) [ heap-data first ] keep pop-heap* ;
: heap-empty? ( heap -- ? )
heap-data empty? ;

26
core/memory/memory.factor
View File

@ -16,29 +16,3 @@ math strings combinators ;
pusher >r each-object r> >array ; inline
: save ( -- ) image save-image ;
<PRIVATE
: intern-objects ( predicate -- )
instances
dup H{ } clone [ [ ] cache ] curry map
become ; inline
: prepare-compress-image ( -- seq )
[ sbuf? ] instances [ underlying ] map ;
PRIVATE>
: compress-image ( -- )
prepare-compress-image "bad-strings" [
[
{
{ [ dup quotation? ] [ t ] }
{ [ dup wrapper? ] [ t ] }
{ [ dup fixnum? ] [ f ] }
{ [ dup number? ] [ t ] }
{ [ dup string? ] [ dup "bad-strings" get memq? not ] }
{ [ t ] [ f ] }
} cond nip
] intern-objects
] with-variable ;

4
core/optimizer/known-words/known-words.factor
View File

@ -5,7 +5,7 @@ USING: alien arrays generic hashtables inference.dataflow
inference.class kernel assocs math math.private kernel.private
sequences words parser vectors strings sbufs io namespaces
assocs quotations sequences.private io.binary io.crc32
io.buffers io.streams.string layouts splitting math.intervals
io.streams.string layouts splitting math.intervals
math.floats.private tuples tuples.private classes
optimizer.def-use optimizer.backend optimizer.pattern-match
float-arrays combinators.private ;
@ -148,5 +148,3 @@ float-arrays combinators.private ;
\ >le { { fixnum bignum } fixnum } "specializer" set-word-prop
\ >be { { fixnum bignum } fixnum } "specializer" set-word-prop
\ search-buffer-until { fixnum fixnum simple-alien string } "specializer" set-word-prop

20
core/threads/threads.factor
View File

@ -2,7 +2,7 @@
! Copyright (C) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license.
IN: threads
USING: arrays init hashtables io.backend kernel kernel.private
USING: arrays init hashtables heaps io.backend kernel kernel.private
math namespaces queues sequences vectors io system sorting
continuations debugger ;
@ -10,21 +10,22 @@ continuations debugger ;
SYMBOL: sleep-queue
TUPLE: sleeping ms continuation ;
M: sleeping <=> ( obj1 obj2 -- n )
[ sleeping-ms ] 2apply - ;
: sleep-time ( -- ms )
sleep-queue get-global
dup empty? [ drop 1000 ] [ first first millis [-] ] if ;
dup heap-empty? [ drop 1000 ] [ peek-heap sleeping-ms millis [-] ] if ;
: run-queue ( -- queue ) \ run-queue get-global ;
: schedule-sleep ( ms continuation -- )
2array global [
sleep-queue [ swap add sort-keys ] change
] bind ;
sleeping construct-boa sleep-queue get-global push-heap ;
: wake-up ( -- continuation )
global [
sleep-queue [ unclip second swap ] change
] bind ;
sleep-queue get-global pop-heap sleeping-continuation ;
PRIVATE>
@ -67,9 +68,8 @@ PRIVATE>
: init-threads ( -- )
<queue> \ run-queue set-global
f sleep-queue set-global
<min-heap> sleep-queue set-global
[ idle-thread ] in-thread ;
[ init-threads ] "threads" add-init-hook
PRIVATE>

8
extra/calendar/calendar-tests.factor
View File

@ -126,16 +126,16 @@ continuations system ;
2004 1 1 13 30 0 0 make-timestamp = ] unit-test
[ 0 ] [ 2004 1 1 13 30 0 0 make-timestamp
2004 1 1 12 30 0 -1 make-timestamp compare-timestamps ] unit-test
2004 1 1 12 30 0 -1 make-timestamp <=> ] unit-test
[ 1 ] [ 2004 1 1 13 30 0 0 make-timestamp
2004 1 1 12 30 0 0 make-timestamp compare-timestamps ] unit-test
2004 1 1 12 30 0 0 make-timestamp <=> ] unit-test
[ -1 ] [ 2004 1 1 12 30 0 0 make-timestamp
2004 1 1 13 30 0 0 make-timestamp compare-timestamps ] unit-test
2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test
[ 1 ] [ 2005 1 1 12 30 0 0 make-timestamp
2004 1 1 13 30 0 0 make-timestamp compare-timestamps ] unit-test
2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test
[ t ] [ now timestamp>unix-time millis 1000 /f - 10 < ] unit-test
[ t ] [ 0 unix-time>timestamp unix-1970 = ] unit-test

2
extra/calendar/calendar.factor
View File

@ -205,7 +205,7 @@ M: number +second ( timestamp n -- timestamp )
: >gmt ( timestamp -- timestamp )
0 convert-timezone ;
: compare-timestamps ( tuple tuple -- n )
M: timestamp <=> ( ts1 ts2 -- n )
[ >gmt tuple-slots ] compare ;
: timestamp- ( timestamp timestamp -- seconds )

83
extra/concurrency/concurrency.factor
View File

@ -5,11 +5,20 @@
! concurrency.
USING: vectors dlists threads sequences continuations
namespaces random math quotations words kernel match
arrays io assocs init ;
arrays io assocs init shuffle system ;
IN: concurrency
TUPLE: mailbox threads data ;
TUPLE: thread timeout continuation continued? ;
: <thread> ( timeout continuation -- obj )
>r dup [ millis + ] when r>
{
set-thread-timeout
set-thread-continuation
} thread construct ;
: make-mailbox ( -- mailbox )
V{ } clone <dlist> mailbox construct-boa ;
@ -18,34 +27,44 @@ TUPLE: mailbox threads data ;
: mailbox-put ( obj mailbox -- )
[ mailbox-data dlist-push-end ] keep
[ mailbox-threads ] keep 0 <vector> swap set-mailbox-threads
[ schedule-thread ] each yield ;
[ mailbox-threads ] keep
V{ } clone swap set-mailbox-threads
[ thread-continuation schedule-thread ] each yield ;
<PRIVATE
: (mailbox-block-unless-pred) ( pred mailbox -- )
2dup mailbox-data dlist-contains? [
2drop
: (mailbox-block-unless-pred) ( pred mailbox timeout -- )
2over mailbox-data dlist-contains? [
3drop
] [
[ swap mailbox-threads push stop ] callcc0
[ <thread> swap mailbox-threads push stop ] callcc0
(mailbox-block-unless-pred)
] if ; inline
: (mailbox-block-if-empty) ( mailbox -- mailbox2 )
dup mailbox-empty? [
[ swap mailbox-threads push stop ] callcc0
: (mailbox-block-if-empty) ( mailbox timeout -- mailbox2 )
over mailbox-empty? [
[ <thread> swap mailbox-threads push stop ] callcc0
"(mailbox-block-if-empty)" print flush
(mailbox-block-if-empty)
] when ;
] [
drop
] if ;
PRIVATE>
: mailbox-get ( mailbox -- obj )
: mailbox-get* ( mailbox timeout -- obj )
(mailbox-block-if-empty)
mailbox-data dlist-pop-front ;
: mailbox-get-all ( mailbox -- array )
: mailbox-get ( mailbox -- obj )
f mailbox-get* ;
: mailbox-get-all* ( mailbox timeout -- array )
(mailbox-block-if-empty)
[ dup mailbox-empty? ]
[ dup mailbox-data dlist-pop-front ]
{ } unfold ;
: mailbox-get-all ( mailbox -- array )
f mailbox-get-all* ;
: while-mailbox-empty ( mailbox quot -- )
over mailbox-empty? [
dup >r swap slip r> while-mailbox-empty
@ -53,10 +72,12 @@ PRIVATE>
2drop
] if ; inline
: mailbox-get?* ( pred mailbox timeout -- obj )
2over >r >r (mailbox-block-unless-pred) r> r>
mailbox-data dlist-remove ; inline
: mailbox-get? ( pred mailbox -- obj )
2dup (mailbox-block-unless-pred)
mailbox-data dlist-remove ;
inline
f mailbox-get?* ;
TUPLE: process links pid mailbox ;
@ -64,9 +85,7 @@ C: <process> process
GENERIC: send ( message process -- )
: random-64 ( -- id )
#! Generate a random id to use for pids
"ID" 64 [ drop 10 random CHAR: 0 + ] map append ;
: random-pid ( -- id ) 8 big-random ;
<PRIVATE
: make-process ( -- process )
@ -74,13 +93,13 @@ GENERIC: send ( message process -- )
#! similar to a thread but can send and receive messages to and
#! from other processes. It may also be linked to other processes so
#! that it receives a message if that process terminates.
[ ] random-64 make-mailbox <process> ;
[ ] random-pid make-mailbox <process> ;
: make-linked-process ( process -- process )
#! Return a process set to run on the local node. That process is
#! linked to the process on the stack. It will receive a message if
#! that process terminates.
1quotation random-64 make-mailbox <process> ;
1quotation random-pid make-mailbox <process> ;
PRIVATE>
: self ( -- process )
@ -187,7 +206,7 @@ MATCH-VARS: ?from ?tag ;
<PRIVATE
: tag-message ( message -- tagged-message )
#! Given a message, wrap it with the sending process and a unique tag.
>r self random-64 r> 3array ;
>r self random-pid r> 3array ;
PRIVATE>
: send-synchronous ( message process -- reply )
@ -286,23 +305,29 @@ TUPLE: promise fulfilled? value processes ;
[ set-promise-value ] keep
[ t swap set-promise-fulfilled? ] keep
[ promise-processes ] keep
0 <vector> swap set-promise-processes
[ schedule-thread ] each yield
V{ } clone swap set-promise-processes
[ thread-continuation schedule-thread ] each yield
] if ;
<PRIVATE
: (maybe-block-promise) ( promise -- promise )
: (maybe-block-promise) ( promise timeout -- promise )
#! Block the process if the promise is unfulfilled. This is different from
#! (mailbox-block-if-empty) in that when a promise is fulfilled, all threads
#! need to be resumed, rather than just one.
dup promise-fulfilled? [
[ swap promise-processes push stop ] callcc0
] unless ;
over promise-fulfilled? [
drop
] [
[ <thread> swap promise-processes push stop ] callcc0
drop
] if ;
PRIVATE>
: ?promise ( promise -- result )
: ?promise* ( promise timeout -- result )
(maybe-block-promise) promise-value ;
: ?promise ( promise -- result )
f ?promise* ;
! ******************************
! Experimental code below
! ******************************

32
extra/heaps/heaps-tests.factor Normal file
View File

@ -0,0 +1,32 @@
! Copyright 2007 Ryan Murphy
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math tools.test heaps heaps.private ;
IN: temporary
[ <min-heap> pop-heap ] unit-test-fails
[ <max-heap> pop-heap ] unit-test-fails
[ t ] [ <min-heap> heap-empty? ] unit-test
[ f ] [ <min-heap> 1 over push-heap heap-empty? ] unit-test
[ t ] [ <max-heap> heap-empty? ] unit-test
[ f ] [ <max-heap> 1 over push-heap heap-empty? ] unit-test
! 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 3 T{ min-heap } heap-compare ] unit-test
{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test
[ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ]
[ <min-heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over push-heap* ] unit-test
[ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [
<min-heap> { 3 5 4 6 5 7 6 8 } over push-heap*
3 [ dup pop-heap* ] times
] unit-test
[ 2 ] [ <min-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap pop-heap ] unit-test
[ 1 ] [ <min-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test
[ 400 ] [ <max-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test

112
extra/heaps/heaps.factor Normal file
View File

@ -0,0 +1,112 @@
! Copyright (C) 2007 Ryan Murphy, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences ;
IN: heaps
<PRIVATE
TUPLE: heap data ;
: <heap> ( -- obj )
V{ } clone heap construct-boa ;
PRIVATE>
TUPLE: min-heap ;
: <min-heap> ( -- obj )
<heap> min-heap construct-delegate ;
TUPLE: max-heap ;
: <max-heap> ( -- obj )
<heap> max-heap construct-delegate ;
<PRIVATE
: left ( n -- m ) 2 * 1+ ;
: right ( n -- m ) 2 * 2 + ;
: up ( n -- m ) 1- 2 /i ;
: left-value ( n heap -- obj ) >r left r> nth ;
: right-value ( n heap -- obj ) >r right r> nth ;
: up-value ( n vec -- obj ) >r up r> nth ;
: swap-up ( n vec -- ) >r dup up r> exchange ;
: last-index ( vec -- n ) length 1- ;
GENERIC: heap-compare ( obj1 obj2 heap -- ? )
M: min-heap heap-compare drop <=> 0 > ;
M: max-heap heap-compare drop <=> 0 < ;
: left-bounds-check? ( m heap -- ? )
>r left r> heap-data length >= ;
: right-bounds-check? ( m heap -- ? )
>r right r> heap-data length >= ;
: (up-heap) ( vec heap -- )
[
>r [ last-index ] keep [ up-value ] keep peek r> heap-compare
] 2keep rot [
>r dup last-index
[ over swap-up ] keep
up 1+ head-slice
r> (up-heap)
] [
2drop
] if ;
: up-heap ( heap -- )
[ heap-data ] keep (up-heap) ;
: child ( m heap -- n )
2dup right-bounds-check? [
drop left
] [
dupd
[ heap-data left-value ] 2keep
[ heap-data right-value ] keep heap-compare [
right
] [
left
] if
] if ;
: swap-down ( m heap -- )
[ child ] 2keep heap-data exchange ;
DEFER: down-heap
: (down-heap) ( m heap -- )
2dup [ heap-data nth ] 2keep child pick
dupd [ heap-data nth swapd ] keep
heap-compare [
-rot [ swap-down ] keep down-heap
] [
3drop
] if ;
: down-heap ( m heap -- )
2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ;
PRIVATE>
: push-heap ( obj heap -- )
tuck heap-data push up-heap ;
: push-heap* ( seq heap -- )
swap [ swap push-heap ] curry* each ;
: peek-heap ( heap -- obj )
heap-data first ;
: pop-heap* ( heap -- )
dup heap-data length 1 > [
[ heap-data pop 0 ] keep
[ heap-data set-nth ] keep
>r 0 r> down-heap
] [
heap-data pop*
] if ;
: pop-heap ( heap -- fist ) [ heap-data first ] keep pop-heap* ;
: heap-empty? ( heap -- ? )
heap-data empty? ;

5
extra/http/server/responders/callback/callback.factor
View File

@ -2,8 +2,7 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: html http http.server.responders io kernel math namespaces
continuations random system sequences assocs ;
prettyprint continuations random system sequences assocs ;
IN: http.server.responders.callback
#! Name of the variable holding the continuation used to exit
@ -58,7 +57,7 @@ TUPLE: request stream exitcc method url raw-query query header response ;
: get-random-id ( -- id )
#! Generate a random id to use for continuation URL's
"ID" 32 [ drop 9 random CHAR: 0 + ] map append ;
4 big-random unparse ;
: callback-table ( -- <hashtable> )
#! Return the global table of continuations

0
core/io/buffers/authors.txt → extra/io/buffers/authors.txt
View File

0
core/io/buffers/buffers-docs.factor → extra/io/buffers/buffers-docs.factor
View File

0
core/io/buffers/buffers-tests.factor → extra/io/buffers/buffers-tests.factor
View File

4
core/io/buffers/buffers.factor → extra/io/buffers/buffers.factor
View File

@ -3,7 +3,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: io.buffers
USING: alien alien.syntax kernel kernel.private libc math
sequences strings ;
sequences strings hints ;
TUPLE: buffer size ptr fill pos ;
@ -54,6 +54,8 @@ TUPLE: buffer size ptr fill pos ;
: search-buffer-until ( start end alien separators -- n )
[ >r swap alien-unsigned-1 r> memq? ] 2curry find* drop ;
HINTS: search-buffer-until { fixnum fixnum simple-alien string } ;
: finish-buffer-until ( buffer n -- string separator )
[
over buffer-pos -

0
core/io/buffers/summary.txt → extra/io/buffers/summary.txt
View File

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

@ -1,9 +1,5 @@
USING: arrays kernel math roman roman.private sequences tools.test ;
[ { { 1 } { -1 5 } { 2 4 } } ]
[ { 1 -1 5 2 4 } [ < ] monotonic-split [ >array ] map ] unit-test
[ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ]
[ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test
[ "i" ] [ 1 >roman ] unit-test
[ "ii" ] [ 2 >roman ] unit-test
[ "iii" ] [ 3 >roman ] unit-test

12
extra/roman/roman.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math math.vectors namespaces
quotations sequences sequences.private strings ;
quotations sequences sequences.lib sequences.private strings ;
IN: roman
<PRIVATE
@ -22,16 +22,6 @@ TUPLE: roman-range-error n ;
roman-range-error construct-boa throw
] if ;
: ,, building get peek push ;
: v, V{ } clone , ;
: ,v building get dup peek empty? [ dup pop* ] when drop ;
: monotonic-split ( seq quot -- newseq )
[
>r dup unclip add r>
v, [ pick ,, call [ v, ] unless ] curry 2each ,v
] { } make ;
: roman<= ( ch1 ch2 -- ? )
[ 1string roman-digits index ] 2apply >= ;

7
extra/sequences/lib/lib-tests.factor
View File

@ -1,4 +1,5 @@
USING: kernel sequences.lib math math.functions tools.test ;
USING: arrays kernel sequences sequences.lib math
math.functions tools.test ;
[ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test
[ 36 ] [ { 2 3 } [ sq ] [ * ] map-reduce ] unit-test
@ -28,3 +29,7 @@ USING: kernel sequences.lib math math.functions tools.test ;
[ -11 -9 ] [ { -11 -10 -9 } minmax ] unit-test
[ -1/0. 1/0. ] [ { -1/0. 1/0. -11 -10 -9 } minmax ] unit-test
[ { { 1 } { -1 5 } { 2 4 } } ]
[ { 1 -1 5 2 4 } [ < ] monotonic-split [ >array ] map ] unit-test
[ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ]
[ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test

17
extra/sequences/lib/lib.factor
View File

@ -1,4 +1,4 @@
USING: combinators.lib kernel sequences math
USING: combinators.lib kernel sequences math namespaces
sequences.private shuffle ;
IN: sequences.lib
@ -46,3 +46,18 @@ IN: sequences.lib
#! find the min and max of a seq in one pass
1/0. -1/0. rot [ tuck max >r min r> ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ,, building get peek push ;
: v, V{ } clone , ;
: ,v building get dup peek empty? [ dup pop* ] when drop ;
: monotonic-split ( seq quot -- newseq )
[
>r dup unclip add r>
v, [ pick ,, call [ v, ] unless ] curry 2each ,v
] { } make ;
: singleton? ( seq -- ? )
length 1 = ;

41
extra/store/store-tests.factor Normal file
View File

@ -0,0 +1,41 @@
USING: assocs continuations debugger io.files kernel
namespaces store tools.test ;
IN: temporary
SYMBOL: store
SYMBOL: foo
SYMBOL: bar
: the-store ( -- path )
"store-test.store" resource-path ;
: delete-the-store ( -- )
[ the-store delete-file ] catch drop ;
: load-the-store ( -- )
the-store load-store store set ;
: save-the-store ( -- )
store get save-store ;
delete-the-store
the-store load-store store set
[ f ] [ foo store get store-data at ] unit-test
[ ] [ 100 foo store get store-variable ] unit-test
[ ] [ save-the-store ] unit-test
[ 100 ] [ foo store get store-data at ] unit-test
1000 foo set
[ ] [ save-the-store ] unit-test
[ ] [ load-the-store ] unit-test
[ 1000 ] [ foo store get store-data at ] unit-test
delete-the-store

5
extra/store/store.factor
View File

@ -11,12 +11,12 @@ C: <store> store
[ store-data ] keep store-path <file-writer> [
[
dup
[ drop [ get ] keep rot set-at ] curry* assoc-each
[ >r drop [ get ] keep r> set-at ] curry assoc-each
] keep serialize
] with-stream ;
: load-store ( path -- store )
resource-path dup exists? [
dup exists? [
dup <file-reader> [
deserialize
] with-stream
@ -30,4 +30,3 @@ C: <store> store
] [
drop >r 2dup set-global r> set-at
] if ;

2
extra/tools/deploy/config/config.factor
View File

@ -17,7 +17,7 @@ SYMBOL: deploy-io
{ 3 "Level 3 - Non-blocking streams and networking" }
} ;
: strip-io? deploy-io get zero? ;
: strip-io? deploy-io get 1 = ;
: native-io? deploy-io get 3 = ;

4
extra/tools/deploy/deploy.factor
View File

@ -37,8 +37,8 @@ IN: tools.deploy
""
deploy-math? get " math" ?append
deploy-compiler? get " compiler" ?append
native-io? " io" ?append
deploy-ui? get " ui" ?append
native-io? " io" ?append
] bind ;
: deploy-command-line ( vm image vocab config -- vm flags )
@ -49,7 +49,7 @@ IN: tools.deploy
"\"-output-image=" swap "\"" 3append ,
"-no-stack-traces" ,
! "-no-stack-traces" ,
"-no-user-init" ,
] { } make ;

19
extra/tools/deploy/shaker/shaker.factor
View File

@ -5,7 +5,7 @@ assocs kernel vocabs words sequences memory io system arrays
continuations math definitions mirrors splitting parser classes
inspector layouts vocabs.loader prettyprint.config prettyprint
debugger io.streams.c io.streams.duplex io.files io.backend
quotations words.private tools.deploy.config ;
quotations words.private tools.deploy.config compiler ;
IN: tools.deploy.shaker
: show ( msg -- )
@ -23,6 +23,15 @@ IN: tools.deploy.shaker
"Stripping debugger" show
"resource:extra/tools/deploy/shaker/strip-debugger.factor"
run-file
recompile
] when ;
: strip-libc ( -- )
"libc" vocab [
"Stripping manual memory management debug code" show
"resource:extra/tools/deploy/shaker/strip-libc.factor"
run-file
recompile
] when ;
: strip-cocoa ( -- )
@ -30,6 +39,7 @@ IN: tools.deploy.shaker
"Stripping unused Cocoa methods" show
"resource:extra/tools/deploy/shaker/strip-cocoa.factor"
run-file
recompile
] when ;
: strip-assoc ( retained-keys assoc -- newassoc )
@ -70,8 +80,8 @@ IN: tools.deploy.shaker
strip-word-defs ;
: strip-environment ( retain-globals -- )
"Stripping environment" show
strip-globals? [
"Stripping environment" show
global strip-assoc 21 setenv
] [ drop ] if ;
@ -126,7 +136,7 @@ SYMBOL: deploy-vocab
} %
] unless
deploy-c-types? get deploy-ui? get or [
deploy-c-types? get [
"c-types" "alien.c-types" lookup ,
] when
@ -141,6 +151,7 @@ SYMBOL: deploy-vocab
] { } make dup . ;
: strip ( -- )
strip-libc
strip-cocoa
strip-debugger
strip-init-hooks
@ -160,8 +171,6 @@ SYMBOL: deploy-vocab
deploy-vocab get require
r> [ call ] when*
strip
"Compressing image" show
compress-image
finish-deploy
] [
print-error flush 1 exit

8
extra/tools/deploy/shaker/strip-libc.factor Normal file
View File

@ -0,0 +1,8 @@
USING: libc.private ;
IN: libc
: malloc (malloc) ;
: free (free) ;
: realloc (realloc) ;

27
extra/ui/gadgets/buttons/buttons.factor
View File

@ -4,7 +4,8 @@ USING: arrays ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.controls ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render kernel math models namespaces sequences strings
quotations assocs combinators classes colors tuples ;
quotations assocs combinators classes colors tuples opengl
math.vectors ;
IN: ui.gadgets.buttons
TUPLE: button pressed? selected? quot ;
@ -95,6 +96,18 @@ repeat-button H{
repeat-button construct-empty
[ >r <bevel-button> r> set-gadget-delegate ] keep ;
TUPLE: checkmark-paint color ;
C: <checkmark-paint> checkmark-paint
M: checkmark-paint draw-interior
checkmark-paint-color gl-color
origin get [
rect-dim
{ 0 0 } over gl-line
dup { 0 1 } v* swap { 1 0 } v* gl-line
] with-translation ;
: checkmark-theme ( gadget -- )
f
f
@ -125,6 +138,18 @@ repeat-button H{
[ set-button-selected? ] <control>
dup checkbox-theme ;
TUPLE: radio-paint color ;
C: <radio-paint> radio-paint
M: radio-paint draw-interior
radio-paint-color gl-color
origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
M: radio-paint draw-boundary
radio-paint-color gl-color
origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
: radio-knob-theme ( gadget -- )
f
f

26
extra/ui/render/render.factor
View File

@ -140,32 +140,6 @@ M: polygon draw-interior
>r <polygon> <gadget> r> over set-rect-dim
[ set-gadget-interior ] keep ;
! Checkbox and radio button pens
TUPLE: checkmark-paint color ;
C: <checkmark-paint> checkmark-paint
M: checkmark-paint draw-interior
checkmark-paint-color gl-color
origin get [
rect-dim
{ 0 0 } over gl-line
dup { 0 1 } v* swap { 1 0 } v* gl-line
] with-translation ;
TUPLE: radio-paint color ;
C: <radio-paint> radio-paint
M: radio-paint draw-interior
radio-paint-color gl-color
origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
M: radio-paint draw-boundary
radio-paint-color gl-color
origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
! Font rendering
SYMBOL: font-renderer

0
extra/channels/authors.txt → unmaintained/channels/authors.txt
View File

0
extra/channels/channels-docs.factor → unmaintained/channels/channels-docs.factor
View File

0
extra/channels/channels-tests.factor → unmaintained/channels/channels-tests.factor
View File

0
extra/channels/channels.factor → unmaintained/channels/channels.factor
View File

0
extra/channels/examples/authors.txt → unmaintained/channels/examples/authors.txt
View File

0
extra/channels/examples/examples.factor → unmaintained/channels/examples/examples.factor
View File

0
extra/channels/examples/summary.txt → unmaintained/channels/examples/summary.txt
View File

0
extra/channels/examples/tags.txt → unmaintained/channels/examples/tags.txt
View File

0
extra/channels/remote/authors.txt → unmaintained/channels/remote/authors.txt
View File

0
extra/channels/remote/remote-docs.factor → unmaintained/channels/remote/remote-docs.factor
View File

0
extra/channels/remote/remote-tests.factor → unmaintained/channels/remote/remote-tests.factor
View File

0
extra/channels/remote/remote.factor → unmaintained/channels/remote/remote.factor
View File

0
extra/channels/remote/summary.txt → unmaintained/channels/remote/summary.txt
View File

0
extra/channels/remote/tags.txt → unmaintained/channels/remote/tags.txt
View File

0
extra/channels/sniffer/bsd/bsd.factor → unmaintained/channels/sniffer/bsd/bsd.factor
View File

0
extra/channels/sniffer/sniffer.factor → unmaintained/channels/sniffer/sniffer.factor
View File

0
extra/channels/summary.txt → unmaintained/channels/summary.txt
View File

0
extra/channels/tags.txt → unmaintained/channels/tags.txt
View File

74
unmaintained/heap/heap.factor
View File

@ -1,74 +0,0 @@
! Binary Min Heap
! Copyright 2007 Ryan Murphy
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences ;
IN: heap
: [comp] ( elt elt -- ? ) <=> 0 > ;
: <heap> ( -- heap ) V{ } clone ;
: left ( index -- index ) ! left child
2 * 1 + ;
: leftv ( heap index -- value )
left swap nth ;
: right ( index -- index ) ! right child
2 * 2 + ;
: rightv ( heap index -- value )
right swap nth ;
: l-oob ( i heap -- ? ) swap left swap length >= ;
: r-oob ( i heap -- ? ) swap right swap length >= ;
: up ( index -- index ) ! parent node
1 - 2 /i ;
: upv ( heap index -- value ) ! parent's value
up swap nth ;
: lasti ( seq -- index ) length 1 - ;
: swapup ( heap index -- ) dup up rot exchange ;
: (farchild) ( heap index -- index ) tuck 2dup leftv -rot rightv [comp] [ right ] [ left ] if ;
: farchild ( heap index -- index ) dup right pick length >= [ nip left ] [ (farchild) ] if ;
: farchildv ( heap index -- value ) dupd farchild swap nth ;
: swapdown ( heap index -- ) 2dup farchild rot exchange ;
: upheap ( heap -- )
dup dup lasti upv over peek [comp]
[ dup lasti 2dup swapup up 1 + head-slice upheap ] [ drop ] if ;
: add ( elt heap -- )
tuck push upheap ;
: add-many ( seq heap -- )
swap [ swap add ] each-with ;
DEFER: (downheap)
: (downheap2) ( i heap -- )
2dup nth -rot
2dup swap farchild dup pick nth 2swap
>r >r
swapd [comp]
[ r> r> tuck swap swapdown (downheap) ] [ drop r> r> 2drop ] if ;
: (downheap) ( i heap -- )
over left over length >= [ 2drop ] [ (downheap2) ] if ;
: downheap ( heap -- )
0 swap (downheap) ;
: bump ( heap -- )
dup peek 0 pick set-nth dup pop* downheap ;
: gbump ( heap -- first )
dup first swap bump ;

76
unmaintained/heap/heap.facts
View File

@ -1,76 +0,0 @@
! Binary Min Heap
! Copyright 2007 Ryan Murphy
! See http://factorcode.org/license.txt for BSD license.
USING: help heap sequences ;
ARTICLE: { "heap" "heap" } "Binary Min Heap"
"A vector-based implementation of a binary min heap. Elements are simply stored in a vector, so use " { $link first } " to access the root of the heap."
{ $subsection <heap> }
{ $subsection add }
{ $subsection add-many }
{ $subsection bump }
{ $subsection gbump }
{ $subsection print-heap }
;
HELP: <heap>
"Creates a new heap with nothing on it." ;
HELP: add
"Adds 1 element to the heap."
{ $examples
{ $code
"USE: heap"
"<heap> 3 over add 4 over add 5 over add"
"print-heap"
}
}
;
HELP: add-many
"For each element in the sequence, add it to the heap."
{ $examples
{ $code
"USE: heap"
"<heap> { 7 6 5 4 3 2 1 } over add-many"
"print-heap"
}
}
;
HELP: bump
"\"Bumps\" the root element off of the heap, rearranging the remaining elements so that the heap remains valid."
{ $examples
{ $code
"USE: heap"
"<heap> { 7 6 5 4 3 2 1 } over add-many"
"dup print-heap"
"dup bump \"(bump)\" print dup print-heap"
"dup bump \"(bump)\" print dup print-heap"
"dup bump \"(bump)\" print dup print-heap"
}
}
;
HELP: gbump
"(\"Get-bump\") Does a " { $link bump } ", but leaves the bumped element on the stack instead of discarding it."
{ $examples
{ $code
"USE: heap"
"<heap> { 7 6 5 4 3 2 1 } over add-many"
"dup gbump"
}
}
;
HELP: print-heap
"Prints the heap in tree form."
{ $examples
{ $code
"USE: heap"
"<heap> { 7 6 5 4 3 2 1 } over add-many"
"print-heap"
}
}
;

100
unmaintained/heap/human tests.factor
View File

@ -1,100 +0,0 @@
: test-agg2 ( -- )
{
} >vector
{
"bbbbbbb"
"bbbbbbb"
} >vector
aggregate2 [ print ] each "" print
{
"aa"
"aa"
} >vector
{
} >vector
aggregate2 [ print ] each "" print
{
} >vector
{
} >vector
aggregate2 [ print ] each "" print
{
"aaaaaaa"
"aaaaaaa"
"aaaaaaa"
"aaaaaaa"
"aaaaaaa"
"aaaaaaa"
} >vector
{
"bbbb"
"bbbb"
"bbbb"
} >vector
aggregate2 [ print ] each "" print
{
"aaaa"
"aaaa"
"aaaa"
} >vector
{
"bbbbbbb"
"bbbbbbb"
"bbbbbbb"
"bbbbbbb"
"bbbbbbb"
"bbbbbbb"
"bbbbbbb"
"bbbbbbb"
} >vector
aggregate2 [ print ] each "" print
;
: test-agg ( -- )
{
"....5.."
"...|.|."
"..7...9"
".|....."
"8......"
} >vector
{
"..3.."
".|.|."
"4...4"
} >vector
{
".2."
"|.|"
} >vector
aggregate3 [ print ] each "" print
{
"....5.."
"...|.|."
"..7...9"
".|....."
"8......"
} >vector
{
"......3...."
".....|.|..."
"....4...4.."
"...|.|....."
"..5...6...."
".|........."
"6.........."
} >vector
{
".2."
"|.|"
} >vector
aggregate3 [ print ] each "" print
;

16
unmaintained/heap/load.factor
View File

@ -1,16 +0,0 @@
! Binary Min Heap
! Copyright 2007 Ryan Murphy
! See http://factorcode.org/license.txt for BSD license.
PROVIDE: libs/heap
{ +files+ {
"heap.factor"
"print.factor"
"heap.facts"
} }
{ +tests+ {
"tests.factor"
} } ;

51
unmaintained/heap/print.factor
View File

@ -1,51 +0,0 @@
! Binary Min Heap
! Copyright 2007 Ryan Murphy
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel math sequences prettyprint io ;
IN: heap
: spaces ( n -- str )
[ [ " " % ] times ] "" make ;
: prepend-s ( v1 n -- v1' )
spaces swap [ append ] map-with ;
: append-s ( v1 v2 -- v1' )
spaces swap [ swap append ] map-with ;
: pad-r ( lv rv -- rv' )
dup first length spaces pick length pick length -
[ [ dup , ] times ] V{ } make
nip append nip ;
: pad-l ( lv rv -- lv' )
swap pad-r ;
: (aggregate2) ( lv rv -- v )
over length over length >= [ dupd pad-r ] [ tuck pad-l swap ] if
[ append ] 2map ;
: aggregate2 ( lv rv -- v )
dup empty? [ drop ] [ over empty? [ nip ] [ (aggregate2) ] if ] if ;
: (agg3len) ( v -- len )
dup empty? [ drop 0 ] [ first length ] if ;
: aggregate3 ( lv rv pv -- v )
dup (agg3len) -roll
pick (agg3len) prepend-s
over (agg3len) append-s
-roll -rot swap append-s
swap aggregate2 append ;
: output-node ( elt -- str ) [ [ pprint ] string-out , ] V{ } make ;
: (print-heap) ( i heap -- vector )
2dup l-oob [ V{ } clone ] [ over left over (print-heap) ] if -rot
2dup r-oob [ V{ } clone ] [ over right over (print-heap) ] if -rot
V{ } clone pick pick nth output-node append
-rot 2drop aggregate3 ;
: print-heap ( heap -- )
dup empty? [ drop ] [ 0 swap (print-heap) [ print ] each ] if ;

35
unmaintained/heap/tests.factor
View File

@ -1,35 +0,0 @@
! Binary Min Heap
! Copyright 2007 Ryan Murphy
! See http://factorcode.org/license.txt for BSD license.
USING: heap test kernel ;
{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
{ t } [ 5 3 [comp] ] unit-test
{ V{ } } [ <heap> ] unit-test
{ V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } [ <heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over add-many ] unit-test
{ V{ "hire" "hose" } } [ V{ "hi" "ho" } V{ "re" "se" } aggregate2 ] unit-test
{ V{ "hire" "hose" " it" } } [ V{ "hi" "ho" } V{ "re" "se" "it" } aggregate2 ] unit-test
{ V{ "tracks" "snacks" "crack " } } [ V{ "track" "snack" "crack" } V{ "s" "s" } aggregate2 ] unit-test
{ V{ " top " "left right" } } [ V{ "left" } V{ "right" } V{ "top" } aggregate3 ] unit-test
{ V{ " top "
" dog "
"left right"
"over on "
" man " } } [ V{ "left" "over" } V{ "right" "on " "man " } V{ "top" "dog" } aggregate3 ] unit-test
{ V{ " -6 "
" -4 2 "
" 1 5 3 2 "
" 4 3 7 6 8 3 4 4"
"6 5 5 " } } [ 0 <heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over add-many (print-heap) ] unit-test
{ V{ 5 6 6 7 8 } } [ <heap> { 3 5 4 6 5 7 6 8 } over add-many dup bump dup bump dup bump ] unit-test

3
vm/os-windows.c
View File

@ -51,8 +51,7 @@ void ffi_dlopen (F_DLL *dll, bool error)
{
dll->dll = NULL;
if(error)
general_error(ERROR_FFI,F,F,
(void*)tag_object(get_error_message()));
general_error(ERROR_FFI,F,tag_object(get_error_message()),NULL);
else
return;
}