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

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

db4
Joe Groff 2009-06-10 13:06:44 -05:00
parent 50f4db1ce2 bcfc0c5759
commit 12d99ed6f8
56 changed files with 1390 additions and 441 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/bitstreams/bitstreams.factor
View File

@ -158,3 +158,9 @@ M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ;
writer bytes>> swap push writer bytes>> swap push
] unless ] unless
writer bytes>> ; writer bytes>> ;
:: byte-array-n>seq ( byte-array n -- seq )
byte-array length 8 * n / iota
byte-array <msb0-bit-reader> '[
drop n _ read
] { } map-as ;

1
basis/circular/circular-tests.factor
View File

@ -13,6 +13,7 @@ circular strings ;
[ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test [ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ ] like ] unit-test [ [ 2 3 1 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ ] like ] unit-test
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ rotate-circular ] keep [ ] like ] unit-test
[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start [ ] like ] unit-test [ [ 2 3 1 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start [ ] like ] unit-test
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test [ [ 3 1 2 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test [ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test

4
basis/circular/circular.factor
View File

@ -28,10 +28,10 @@ M: circular virtual-seq seq>> ;
circular-wrap (>>start) ; circular-wrap (>>start) ;
: rotate-circular ( circular -- ) : rotate-circular ( circular -- )
[ start>> 1 + ] keep circular-wrap (>>start) ; [ 1 ] dip change-circular-start ;
: push-circular ( elt circular -- ) : push-circular ( elt circular -- )
[ set-first ] [ 1 swap change-circular-start ] bi ; [ set-first ] [ rotate-circular ] bi ;
: <circular-string> ( n -- circular ) : <circular-string> ( n -- circular )
0 <string> <circular> ; 0 <string> <circular> ;

4
basis/compiler/cfg/cfg.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays vectors accessors USING: kernel arrays vectors accessors
namespaces make fry sequences ; namespaces math make fry sequences ;
IN: compiler.cfg IN: compiler.cfg
TUPLE: basic-block < identity-tuple TUPLE: basic-block < identity-tuple
id { id integer }
number number
{ instructions vector } { instructions vector }
{ successors vector } { successors vector }

3
basis/compiler/cfg/checker/checker.factor
View File

@ -16,6 +16,9 @@ ERROR: last-insn-not-a-jump insn ;
[ ##return? ] [ ##return? ]
[ ##callback-return? ] [ ##callback-return? ]
[ ##jump? ] [ ##jump? ]
[ ##fixnum-add-tail? ]
[ ##fixnum-sub-tail? ]
[ ##fixnum-mul-tail? ]
[ ##call? ] [ ##call? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ; } 1|| [ drop ] [ last-insn-not-a-jump ] if ;

237
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences math math.order kernel assocs USING: namespaces sequences math math.order kernel assocs
accessors vectors fry heaps cpu.architecture combinators accessors vectors fry heaps cpu.architecture sorting locals
compiler.cfg.registers combinators compiler.cfg.registers
compiler.cfg.linear-scan.live-intervals ; compiler.cfg.linear-scan.live-intervals hints ;
IN: compiler.cfg.linear-scan.allocation IN: compiler.cfg.linear-scan.allocation
! Mapping from register classes to sequences of machine registers ! Mapping from register classes to sequences of machine registers
@ -27,13 +27,61 @@ SYMBOL: active-intervals
: delete-active ( live-interval -- ) : delete-active ( live-interval -- )
dup vreg>> active-intervals-for delq ; dup vreg>> active-intervals-for delq ;
: expire-old-intervals ( n -- ) ! Vector of inactive live intervals
active-intervals swap '[ SYMBOL: inactive-intervals
[
[ end>> _ < ] partition : inactive-intervals-for ( vreg -- seq )
[ [ deallocate-register ] each ] dip reg-class>> inactive-intervals get at ;
] assoc-map
] change ; : add-inactive ( live-interval -- )
dup vreg>> inactive-intervals-for push ;
! Vector of handled live intervals
SYMBOL: handled-intervals
: add-handled ( live-interval -- )
handled-intervals get push ;
: finished? ( n live-interval -- ? ) end>> swap < ;
: finish ( n live-interval -- keep? )
nip [ deallocate-register ] [ add-handled ] bi f ;
: activate ( n live-interval -- keep? )
nip add-active f ;
: deactivate ( n live-interval -- keep? )
nip add-inactive f ;
: don't-change ( n live-interval -- keep? ) 2drop t ;
! Moving intervals between active and inactive sets
: process-intervals ( n symbol quots -- )
! symbol stores an alist mapping register classes to vectors
[ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline
: covers? ( insn# live-interval -- ? )
ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ;
: deactivate-intervals ( n -- )
! Any active intervals which have ended are moved to handled
! Any active intervals which cover the current position
! are moved to inactive
active-intervals {
{ [ 2dup finished? ] [ finish ] }
{ [ 2dup covers? not ] [ deactivate ] }
[ don't-change ]
} process-intervals ;
: activate-intervals ( n -- )
! Any inactive intervals which have ended are moved to handled
! Any inactive intervals which do not cover the current position
! are moved to active
inactive-intervals {
{ [ 2dup finished? ] [ finish ] }
{ [ 2dup covers? ] [ activate ] }
[ don't-change ]
} process-intervals ;
! Minheap of live intervals which still need a register allocation ! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals SYMBOL: unhandled-intervals
@ -66,29 +114,64 @@ SYMBOL: progress
: coalesce ( live-interval -- ) : coalesce ( live-interval -- )
dup copy-from>> active-interval dup copy-from>> active-interval
[ [ add-active ] [ delete-active ] bi* ] [ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
[ reg>> >>reg drop ] [ reg>> >>reg drop ]
2bi ; 2bi ;
! Splitting ! Splitting
: find-use ( live-interval n quot -- i elt ) : split-range ( live-range n -- before after )
[ uses>> ] 2dip curry find ; inline [ [ from>> ] dip <live-range> ]
[ 1 + swap to>> <live-range> ]
2bi ;
: split-before ( live-interval i -- before ) : split-last-range? ( last n -- ? )
[ clone dup uses>> ] dip swap to>> <= ;
[ head >>uses ] [ 1- swap nth >>end ] 2bi ;
: split-after ( live-interval i -- after ) : split-last-range ( before after last n -- before' after' )
[ clone dup uses>> ] dip split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ;
[ tail >>uses ] [ swap nth >>start ] 2bi
f >>reg f >>copy-from ;
: split-interval ( live-interval n -- before after ) : split-ranges ( live-ranges n -- before after )
[ drop ] [ [ > ] find-use drop ] 2bi [ '[ from>> _ <= ] partition ]
[ split-before ] [ split-after ] 2bi ; [
pick empty? [ drop ] [
[ over last ] dip 2dup split-last-range?
[ split-last-range ] [ 2drop ] if
] if
] bi ;
: split-uses ( uses n -- before after )
'[ _ <= ] partition ;
: record-split ( live-interval before after -- ) : record-split ( live-interval before after -- )
[ >>split-before ] [ >>split-after ] bi* drop ; [ >>split-before ] [ >>split-after ] bi* drop ; inline
: check-split ( live-interval -- )
[ end>> ] [ start>> ] bi - 0 =
[ "BUG: splitting atomic interval" throw ] when ; inline
: split-before ( before -- before' )
[ [ ranges>> last ] [ uses>> last ] bi >>to drop ]
[ compute-start/end ]
[ ]
tri ; inline
: split-after ( after -- after' )
[ [ ranges>> first ] [ uses>> first ] bi >>from drop ]
[ compute-start/end ]
[ ]
tri ; inline
:: split-interval ( live-interval n -- before after )
live-interval check-split
live-interval clone :> before
live-interval clone f >>copy-from f >>reg :> after
live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi*
live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi*
live-interval before after record-split
before split-before
after split-after ;
HINTS: split-interval live-interval object ;
! Spilling ! Spilling
SYMBOL: spill-counts SYMBOL: spill-counts
@ -96,6 +179,9 @@ SYMBOL: spill-counts
: next-spill-location ( reg-class -- n ) : next-spill-location ( reg-class -- n )
spill-counts get [ dup 1+ ] change-at ; spill-counts get [ dup 1+ ] change-at ;
: find-use ( live-interval n quot -- i elt )
[ uses>> ] 2dip curry find ; inline
: interval-to-spill ( active-intervals current -- live-interval ) : interval-to-spill ( active-intervals current -- live-interval )
#! We spill the interval with the most distant use location. #! We spill the interval with the most distant use location.
start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
@ -108,8 +194,7 @@ SYMBOL: spill-counts
[ >>spill-to ] [ >>reload-from ] bi-curry bi* ; [ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
: split-and-spill ( new existing -- before after ) : split-and-spill ( new existing -- before after )
dup rot start>> split-interval swap start>> split-interval assign-spill ;
[ record-split ] [ assign-spill ] 2bi ;
: reuse-register ( new existing -- ) : reuse-register ( new existing -- )
reg>> >>reg add-active ; reg>> >>reg add-active ;
@ -121,7 +206,7 @@ SYMBOL: spill-counts
#! of the existing interval again. #! of the existing interval again.
[ reuse-register ] [ reuse-register ]
[ nip delete-active ] [ nip delete-active ]
[ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ; [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
: spill-new ( new existing -- ) : spill-new ( new existing -- )
#! Our new interval will be used after the active interval #! Our new interval will be used after the active interval
@ -141,37 +226,101 @@ SYMBOL: spill-counts
: assign-free-register ( new registers -- ) : assign-free-register ( new registers -- )
pop >>reg add-active ; pop >>reg add-active ;
: assign-register ( new -- ) : relevant-ranges ( new inactive -- new' inactive' )
dup coalesce? [ ! Slice off all ranges of 'inactive' that precede the start of 'new'
coalesce [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
: intersect-live-range ( range1 range2 -- n/f )
2dup [ from>> ] bi@ > [ swap ] when
2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
: intersect-live-ranges ( ranges1 ranges2 -- n )
{
{ [ over empty? ] [ 2drop 1/0. ] }
{ [ dup empty? ] [ 2drop 1/0. ] }
[
2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
drop
2dup [ first from>> ] bi@ <
[ [ rest-slice ] dip ] [ rest-slice ] if
intersect-live-ranges
] if
]
} cond ;
: intersect-inactive ( new inactive -- n )
relevant-ranges intersect-live-ranges ;
: intersecting-inactive ( new -- live-intervals )
dup vreg>> inactive-intervals-for
[ tuck intersect-inactive ] with { } map>assoc ;
: fits-in-hole ( new pair -- )
first reuse-register ;
: split-before-use ( new pair -- before after )
! Find optimal split position
! Insert move instruction
second split-interval ;
: assign-inactive-register ( new live-intervals -- )
! If there is an interval which is inactive for the entire lifetime
! if the new interval, reuse its vreg. Otherwise, split new so that
! the first half fits.
sort-values last
2dup [ end>> ] [ second ] bi* < [
fits-in-hole
] [ ] [
dup vreg>> free-registers-for [ split-before-use ] keep
[ assign-blocked-register ] '[ _ fits-in-hole ] [ add-unhandled ] bi*
[ assign-free-register ] ] if ;
: assign-register ( new -- )
dup coalesce? [ coalesce ] [
dup vreg>> free-registers-for [
dup intersecting-inactive
[ assign-blocked-register ]
[ assign-inactive-register ]
if-empty
] [ assign-free-register ]
if-empty if-empty
] if ; ] if ;
! Main loop ! Main loop
: reg-classes ( -- seq ) { int-regs double-float-regs } ; inline CONSTANT: reg-classes { int-regs double-float-regs }
: reg-class-assoc ( quot -- assoc )
[ reg-classes ] dip { } map>assoc ; inline
: init-allocator ( registers -- ) : init-allocator ( registers -- )
<min-heap> unhandled-intervals set
[ reverse >vector ] assoc-map free-registers set [ reverse >vector ] assoc-map free-registers set
reg-classes [ 0 ] { } map>assoc spill-counts set [ 0 ] reg-class-assoc spill-counts set
reg-classes [ V{ } clone ] { } map>assoc active-intervals set <min-heap> unhandled-intervals set
[ V{ } clone ] reg-class-assoc active-intervals set
[ V{ } clone ] reg-class-assoc inactive-intervals set
V{ } clone handled-intervals set
-1 progress set ; -1 progress set ;
: handle-interval ( live-interval -- ) : handle-interval ( live-interval -- )
[ start>> progress set ] [
[ start>> expire-old-intervals ] start>>
[ assign-register ] [ progress set ]
tri ; [ deactivate-intervals ]
[ activate-intervals ] tri
] [ assign-register ] bi ;
: (allocate-registers) ( -- ) : (allocate-registers) ( -- )
unhandled-intervals get [ handle-interval ] slurp-heap ; unhandled-intervals get [ handle-interval ] slurp-heap ;
: finish-allocation ( -- )
! Sanity check: all live intervals should've been processed
active-intervals inactive-intervals
[ get values [ handled-intervals get push-all ] each ] bi@ ;
: allocate-registers ( live-intervals machine-registers -- live-intervals ) : allocate-registers ( live-intervals machine-registers -- live-intervals )
#! This modifies the input live-intervals. #! This modifies the input live-intervals.
init-allocator init-allocator
dup init-unhandled init-unhandled
(allocate-registers) ; (allocate-registers)
finish-allocation
handled-intervals get ;

47
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -1,11 +1,12 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math assocs namespaces sequences heaps USING: accessors kernel math assocs namespaces sequences heaps
fry make combinators fry make combinators sets
cpu.architecture cpu.architecture
compiler.cfg.def-use compiler.cfg.def-use
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.live-intervals ; compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.assignment IN: compiler.cfg.linear-scan.assignment
@ -25,35 +26,49 @@ TUPLE: active-intervals seq ;
SYMBOL: unhandled-intervals SYMBOL: unhandled-intervals
: add-unhandled ( live-interval -- ) : add-unhandled ( live-interval -- )
dup split-before>> [ dup start>> unhandled-intervals get heap-push ;
[ split-before>> ] [ split-after>> ] bi
[ add-unhandled ] bi@
] [
dup start>> unhandled-intervals get heap-push
] if ;
: init-unhandled ( live-intervals -- ) : init-unhandled ( live-intervals -- )
[ add-unhandled ] each ; [ add-unhandled ] each ;
! Mapping spill slots to vregs
SYMBOL: spill-slots
: spill-slots-for ( vreg -- assoc )
reg-class>> spill-slots get at ;
: record-spill ( live-interval -- )
[ dup spill-to>> ] [ vreg>> spill-slots-for ] bi
2dup key? [ "BUG: Already spilled" throw ] [ set-at ] if ;
: insert-spill ( live-interval -- ) : insert-spill ( live-interval -- )
[ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
dup [ _spill ] [ 3drop ] if ;
: handle-spill ( live-interval -- )
dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
: expire-old-intervals ( n -- ) : expire-old-intervals ( n -- )
active-intervals get active-intervals get
[ swap '[ end>> _ = ] partition ] change-seq drop [ swap '[ end>> _ = ] partition ] change-seq drop
[ insert-spill ] each ; [ handle-spill ] each ;
: record-reload ( live-interval -- )
[ reload-from>> ] [ vreg>> spill-slots-for ] bi
2dup key? [ delete-at ] [ "BUG: Already reloaded" throw ] if ;
: insert-reload ( live-interval -- ) : insert-reload ( live-interval -- )
[ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
dup [ _reload ] [ 3drop ] if ;
: handle-reload ( live-interval -- )
dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] if ;
: activate-new-intervals ( n -- ) : activate-new-intervals ( n -- )
#! Any live intervals which start on the current instruction #! Any live intervals which start on the current instruction
#! are added to the active set. #! are added to the active set.
unhandled-intervals get dup heap-empty? [ 2drop ] [ unhandled-intervals get dup heap-empty? [ 2drop ] [
2dup heap-peek drop start>> = [ 2dup heap-peek drop start>> = [
heap-pop drop [ add-active ] [ insert-reload ] bi heap-pop drop
[ add-active ] [ handle-reload ] bi
activate-new-intervals activate-new-intervals
] [ 2drop ] if ] [ 2drop ] if
] if ; ] if ;
@ -76,8 +91,7 @@ M: insn assign-before drop ;
active-intervals get seq>> [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ; active-intervals get seq>> [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
: compute-live-spill-slots ( -- spill-slots ) : compute-live-spill-slots ( -- spill-slots )
unhandled-intervals get spill-slots get values [ values ] map concat
heap-values [ reload-from>> ] filter
[ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ; [ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
M: ##gc assign-after M: ##gc assign-after
@ -93,6 +107,7 @@ M: insn assign-after drop ;
: init-assignment ( live-intervals -- ) : init-assignment ( live-intervals -- )
<active-intervals> active-intervals set <active-intervals> active-intervals set
<min-heap> unhandled-intervals set <min-heap> unhandled-intervals set
[ H{ } clone ] reg-class-assoc spill-slots set
init-unhandled ; init-unhandled ;
: assign-registers-in-block ( bb -- ) : assign-registers-in-block ( bb -- )

276
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -12,6 +12,60 @@ compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.debugger ; compiler.cfg.linear-scan.debugger ;
[
{ T{ live-range f 1 10 } T{ live-range f 15 15 } }
{ T{ live-range f 16 20 } }
] [
{
T{ live-range f 1 10 }
T{ live-range f 15 20 }
} 15 split-ranges
] unit-test
[
{ T{ live-range f 1 10 } T{ live-range f 15 16 } }
{ T{ live-range f 17 20 } }
] [
{
T{ live-range f 1 10 }
T{ live-range f 15 20 }
} 16 split-ranges
] unit-test
[
{ T{ live-range f 1 10 } }
{ T{ live-range f 15 20 } }
] [
{
T{ live-range f 1 10 }
T{ live-range f 15 20 }
} 12 split-ranges
] unit-test
[
{ T{ live-range f 1 10 } T{ live-range f 15 17 } }
{ T{ live-range f 18 20 } }
] [
{
T{ live-range f 1 10 }
T{ live-range f 15 20 }
} 17 split-ranges
] unit-test
[
{ }
{ T{ live-range f 1 10 } }
] [
{ T{ live-range f 1 10 } } 0 split-ranges
] unit-test
[
{ T{ live-range f 0 0 } }
{ T{ live-range f 1 5 } }
] [
{ T{ live-range f 0 5 } } 0 split-ranges
] unit-test
[ 7 ] [ [ 7 ] [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } } { vreg T{ vreg { reg-class int-regs } { n 2 } } }
@ -44,23 +98,26 @@ compiler.cfg.linear-scan.debugger ;
[ [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 } { start 0 }
{ end 1 } { end 1 }
{ uses V{ 0 1 } } { uses V{ 0 1 } }
{ ranges V{ T{ live-range f 0 1 } } }
} }
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 } { start 5 }
{ end 5 } { end 5 }
{ uses V{ 5 } } { uses V{ 5 } }
{ ranges V{ T{ live-range f 5 5 } } }
} }
] [ ] [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 } { start 0 }
{ end 5 } { end 5 }
{ uses V{ 0 1 5 } } { uses V{ 0 1 5 } }
{ ranges V{ T{ live-range f 0 5 } } }
} 2 split-interval } 2 split-interval
] unit-test ] unit-test
@ -70,12 +127,14 @@ compiler.cfg.linear-scan.debugger ;
{ start 0 } { start 0 }
{ end 0 } { end 0 }
{ uses V{ 0 } } { uses V{ 0 } }
{ ranges V{ T{ live-range f 0 0 } } }
} }
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 } { start 1 }
{ end 5 } { end 5 }
{ uses V{ 1 5 } } { uses V{ 1 5 } }
{ ranges V{ T{ live-range f 1 5 } } }
} }
] [ ] [
T{ live-interval T{ live-interval
@ -83,6 +142,7 @@ compiler.cfg.linear-scan.debugger ;
{ start 0 } { start 0 }
{ end 5 } { end 5 }
{ uses V{ 0 1 5 } } { uses V{ 0 1 5 } }
{ ranges V{ T{ live-range f 0 5 } } }
} 0 split-interval } 0 split-interval
] unit-test ] unit-test
@ -173,7 +233,13 @@ compiler.cfg.linear-scan.debugger ;
[ ] [ [ ] [
{ {
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } T{ live-interval
{ vreg T{ vreg { n 1 } { reg-class int-regs } } }
{ start 0 }
{ end 100 }
{ uses V{ 0 100 } }
{ ranges V{ T{ live-range f 0 100 } } }
}
} }
H{ { int-regs { "A" } } } H{ { int-regs { "A" } } }
check-linear-scan check-linear-scan
@ -181,8 +247,20 @@ compiler.cfg.linear-scan.debugger ;
[ ] [ [ ] [
{ {
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 10 } { uses V{ 0 10 } } } T{ live-interval
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 11 } { end 20 } { uses V{ 11 20 } } } { vreg T{ vreg { n 1 } { reg-class int-regs } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 10 } }
{ ranges V{ T{ live-range f 0 10 } } }
}
T{ live-interval
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
{ start 11 }
{ end 20 }
{ uses V{ 11 20 } }
{ ranges V{ T{ live-range f 11 20 } } }
}
} }
H{ { int-regs { "A" } } } H{ { int-regs { "A" } } }
check-linear-scan check-linear-scan
@ -190,8 +268,20 @@ compiler.cfg.linear-scan.debugger ;
[ ] [ [ ] [
{ {
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } T{ live-interval
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 60 } { uses V{ 30 60 } } } { vreg T{ vreg { n 1 } { reg-class int-regs } } }
{ start 0 }
{ end 100 }
{ uses V{ 0 100 } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
{ start 30 }
{ end 60 }
{ uses V{ 30 60 } }
{ ranges V{ T{ live-range f 30 60 } } }
}
} }
H{ { int-regs { "A" } } } H{ { int-regs { "A" } } }
check-linear-scan check-linear-scan
@ -199,8 +289,20 @@ compiler.cfg.linear-scan.debugger ;
[ ] [ [ ] [
{ {
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } T{ live-interval
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 200 } { uses V{ 30 200 } } } { vreg T{ vreg { n 1 } { reg-class int-regs } } }
{ start 0 }
{ end 100 }
{ uses V{ 0 100 } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
{ start 30 }
{ end 200 }
{ uses V{ 30 200 } }
{ ranges V{ T{ live-range f 30 200 } } }
}
} }
H{ { int-regs { "A" } } } H{ { int-regs { "A" } } }
check-linear-scan check-linear-scan
@ -208,8 +310,20 @@ compiler.cfg.linear-scan.debugger ;
[ [
{ {
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } } T{ live-interval
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 100 } { uses V{ 30 100 } } } { vreg T{ vreg { n 1 } { reg-class int-regs } } }
{ start 0 }
{ end 100 }
{ uses V{ 0 100 } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
{ start 30 }
{ end 100 }
{ uses V{ 30 100 } }
{ ranges V{ T{ live-range f 30 100 } } }
}
} }
H{ { int-regs { "A" } } } H{ { int-regs { "A" } } }
check-linear-scan check-linear-scan
@ -272,31 +386,10 @@ USING: math.private compiler.cfg.debugger ;
test-cfg first optimize-cfg linear-scan drop test-cfg first optimize-cfg linear-scan drop
] unit-test ] unit-test
[ 0 1 ] [ : fake-live-ranges ( seq -- seq' )
{ [
T{ live-interval clone dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } ] map ;
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 3 }
{ end 4 }
{ uses V{ 3 4 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ start 2 }
{ end 6 }
{ uses V{ 2 4 6 } }
}
} [ clone ] map
H{ { int-regs { "A" "B" } } }
allocate-registers
first split-before>> [ start>> ] [ end>> ] bi
] unit-test
! Coalescing interacted badly with splitting ! Coalescing interacted badly with splitting
[ ] [ [ ] [
@ -345,7 +438,7 @@ USING: math.private compiler.cfg.debugger ;
{ end 10 } { end 10 }
{ uses V{ 9 10 } } { uses V{ 9 10 } }
} }
} } fake-live-ranges
{ { int-regs { 0 1 2 3 } } } { { int-regs { 0 1 2 3 } } }
allocate-registers drop allocate-registers drop
] unit-test ] unit-test
@ -1100,7 +1193,7 @@ USING: math.private compiler.cfg.debugger ;
{ end 109 } { end 109 }
{ uses V{ 103 109 } } { uses V{ 103 109 } }
} }
} } fake-live-ranges
{ { int-regs { 0 1 2 3 4 } } } { { int-regs { 0 1 2 3 4 } } }
allocate-registers drop allocate-registers drop
] unit-test ] unit-test
@ -1193,7 +1286,92 @@ USING: math.private compiler.cfg.debugger ;
{ end 92 } { end 92 }
{ uses V{ 42 45 78 80 92 } } { uses V{ 42 45 78 80 92 } }
} }
} } fake-live-ranges
{ { int-regs { 0 1 2 3 } } } { { int-regs { 0 1 2 3 } } }
allocate-registers drop allocate-registers drop
] unit-test ] unit-test
! Spill slot liveness was computed incorrectly, leading to a FEP
! early in bootstrap on x86-32
[ t ] [
T{ basic-block
{ instructions
V{
T{ ##gc f V int-regs 6 V int-regs 7 }
T{ ##peek f V int-regs 0 D 0 }
T{ ##peek f V int-regs 1 D 1 }
T{ ##peek f V int-regs 2 D 2 }
T{ ##peek f V int-regs 3 D 3 }
T{ ##peek f V int-regs 4 D 4 }
T{ ##peek f V int-regs 5 D 5 }
T{ ##replace f V int-regs 0 D 1 }
T{ ##replace f V int-regs 1 D 2 }
T{ ##replace f V int-regs 2 D 3 }
T{ ##replace f V int-regs 3 D 4 }
T{ ##replace f V int-regs 4 D 5 }
T{ ##replace f V int-regs 5 D 0 }
}
}
} dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
instructions>> first live-spill-slots>> empty?
] unit-test
[ f ] [
T{ live-range f 0 10 }
T{ live-range f 20 30 }
intersect-live-range
] unit-test
[ 10 ] [
T{ live-range f 0 10 }
T{ live-range f 10 30 }
intersect-live-range
] unit-test
[ 5 ] [
T{ live-range f 0 10 }
T{ live-range f 5 30 }
intersect-live-range
] unit-test
[ 5 ] [
T{ live-range f 5 30 }
T{ live-range f 0 10 }
intersect-live-range
] unit-test
[ 5 ] [
T{ live-range f 5 10 }
T{ live-range f 0 15 }
intersect-live-range
] unit-test
[ 50 ] [
{
T{ live-range f 0 10 }
T{ live-range f 20 30 }
T{ live-range f 40 50 }
}
{
T{ live-range f 11 15 }
T{ live-range f 31 35 }
T{ live-range f 50 55 }
}
intersect-live-ranges
] unit-test
[ 5 ] [
T{ live-interval
{ start 0 }
{ end 10 }
{ uses { 0 10 } }
{ ranges V{ T{ live-range f 0 10 } } }
}
T{ live-interval
{ start 5 }
{ end 10 }
{ uses { 5 10 } }
{ ranges V{ T{ live-range f 5 10 } } }
}
intersect-inactive
] unit-test

12
basis/compiler/cfg/linear-scan/linear-scan.factor
View File

@ -25,13 +25,15 @@ IN: compiler.cfg.linear-scan
! by Omri Traub, Glenn Holloway, Michael D. Smith ! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
: (linear-scan) ( rpo -- ) : (linear-scan) ( rpo machine-registers -- )
dup number-instructions [
dup compute-live-intervals dup number-instructions
machine-registers allocate-registers assign-registers ; dup compute-live-intervals
] dip
allocate-registers assign-registers ;
: linear-scan ( cfg -- cfg' ) : linear-scan ( cfg -- cfg' )
[ [
dup reverse-post-order (linear-scan) dup reverse-post-order machine-registers (linear-scan)
spill-counts get >>spill-counts spill-counts get >>spill-counts
] with-scope ; ] with-scope ;

3
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math math.order fry USING: namespaces kernel assocs accessors sequences math math.order fry
compiler.cfg.instructions compiler.cfg.registers binary-search compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ; compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
IN: compiler.cfg.linear-scan.live-intervals IN: compiler.cfg.linear-scan.live-intervals
@ -109,6 +109,7 @@ M: ##copy-float compute-live-intervals*
: compute-start/end ( live-interval -- ) : compute-start/end ( live-interval -- )
dup ranges>> [ first from>> ] [ last to>> ] bi dup ranges>> [ first from>> ] [ last to>> ] bi
2dup > [ "BUG: start > end" throw ] when
[ >>start ] [ >>end ] bi* drop ; [ >>start ] [ >>end ] bi* drop ;
: finish-live-intervals ( live-intervals -- ) : finish-live-intervals ( live-intervals -- )

11
basis/compiler/cfg/optimizer/optimizer.factor
View File

@ -11,9 +11,17 @@ compiler.cfg.dce
compiler.cfg.write-barrier compiler.cfg.write-barrier
compiler.cfg.liveness compiler.cfg.liveness
compiler.cfg.rpo compiler.cfg.rpo
compiler.cfg.phi-elimination ; compiler.cfg.phi-elimination
compiler.cfg.checker ;
IN: compiler.cfg.optimizer IN: compiler.cfg.optimizer
SYMBOL: check-optimizer?
: ?check ( cfg -- cfg' )
check-optimizer? get [
dup check-cfg
] when ;
: optimize-cfg ( cfg -- cfg' ) : optimize-cfg ( cfg -- cfg' )
[ [
compute-predecessors compute-predecessors
@ -27,4 +35,5 @@ IN: compiler.cfg.optimizer
eliminate-dead-code eliminate-dead-code
eliminate-write-barriers eliminate-write-barriers
eliminate-phis eliminate-phis
?check
] with-scope ; ] with-scope ;

19
basis/compiler/cfg/two-operand/two-operand.factor
View File

@ -1,15 +1,15 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel sequences make compiler.cfg.instructions USING: accessors kernel sequences make compiler.cfg.instructions
compiler.cfg.rpo cpu.architecture ; compiler.cfg.local cpu.architecture ;
IN: compiler.cfg.two-operand IN: compiler.cfg.two-operand
! On x86, instructions take the form x = x op y ! On x86, instructions take the form x = x op y
! Our SSA IR is x = y op z ! Our SSA IR is x = y op z
! We don't bother with ##add, ##add-imm or ##sub-imm since x86 ! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm
! has a LEA instruction which is effectively a three-operand ! since x86 has LEA and IMUL instructions which are effectively
! addition ! three-operand addition and multiplication, respectively.
: make-copy ( dst src -- insn ) \ ##copy new-insn ; inline : make-copy ( dst src -- insn ) \ ##copy new-insn ; inline
@ -34,7 +34,6 @@ M: ##not convert-two-operand*
M: ##sub convert-two-operand* convert-two-operand/integer ; M: ##sub convert-two-operand* convert-two-operand/integer ;
M: ##mul convert-two-operand* convert-two-operand/integer ; M: ##mul convert-two-operand* convert-two-operand/integer ;
M: ##mul-imm convert-two-operand* convert-two-operand/integer ;
M: ##and convert-two-operand* convert-two-operand/integer ; M: ##and convert-two-operand* convert-two-operand/integer ;
M: ##and-imm convert-two-operand* convert-two-operand/integer ; M: ##and-imm convert-two-operand* convert-two-operand/integer ;
M: ##or convert-two-operand* convert-two-operand/integer ; M: ##or convert-two-operand* convert-two-operand/integer ;
@ -54,9 +53,7 @@ M: insn convert-two-operand* , ;
: convert-two-operand ( cfg -- cfg' ) : convert-two-operand ( cfg -- cfg' )
two-operand? [ two-operand? [
dup [ [ drop ]
[ [ [ [ convert-two-operand* ] each ] V{ } make ]
[ [ convert-two-operand* ] each ] V{ } make local-optimization
] change-instructions drop
] each-basic-block
] when ; ] when ;

5
basis/compiler/codegen/codegen.factor
View File

@ -8,6 +8,7 @@ continuations.private fry cpu.architecture
source-files.errors source-files.errors
compiler.errors compiler.errors
compiler.alien compiler.alien
compiler.constants
compiler.cfg compiler.cfg
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.stack-frame compiler.cfg.stack-frame
@ -94,7 +95,9 @@ M: _dispatch generate-insn
[ src>> register ] [ temp>> register ] bi %dispatch ; [ src>> register ] [ temp>> register ] bi %dispatch ;
M: _dispatch-label generate-insn M: _dispatch-label generate-insn
label>> lookup-label %dispatch-label ; label>> lookup-label
cell 0 <repetition> %
rc-absolute-cell label-fixup ;
: >slot< ( insn -- dst obj slot tag ) : >slot< ( insn -- dst obj slot tag )
{ {

3
basis/compiler/compiler.factor
View File

@ -193,7 +193,8 @@ M: optimizing-compiler recompile ( words -- alist )
] each ] each
compile-queue get compile-loop compile-queue get compile-loop
compiled get >alist compiled get >alist
] with-scope ; ] with-scope
"trace-compilation" get [ "--- compile done" print flush ] when ;
: with-optimizer ( quot -- ) : with-optimizer ( quot -- )
[ optimizing-compiler compiler-impl ] dip with-variable ; inline [ optimizing-compiler compiler-impl ] dip with-variable ; inline

2
basis/compression/run-length/run-length.factor
View File

@ -3,5 +3,5 @@
USING: arrays grouping sequences ; USING: arrays grouping sequences ;
IN: compression.run-length IN: compression.run-length
: run-length-uncompress8 ( byte-array -- byte-array' ) : run-length-uncompress ( byte-array -- byte-array' )
2 group [ first2 <array> ] map concat ; 2 group [ first2 <array> ] map concat ;

40
basis/constructors/constructors-tests.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: tools.test constructors calendar kernel accessors USING: tools.test constructors calendar kernel accessors
combinators.short-circuit ; combinators.short-circuit initializers math ;
IN: constructors.tests IN: constructors.tests
TUPLE: stock-spread stock spread timestamp ; TUPLE: stock-spread stock spread timestamp ;
@ -19,3 +19,41 @@ SYMBOL: AAPL
[ timestamp>> timestamp? ] [ timestamp>> timestamp? ]
} 1&& } 1&&
] unit-test ] unit-test
TUPLE: ct1 a ;
TUPLE: ct2 < ct1 b ;
TUPLE: ct3 < ct2 c ;
TUPLE: ct4 < ct3 d ;
CONSTRUCTOR: ct1 ( a -- obj )
[ 1 + ] change-a ;
CONSTRUCTOR: ct2 ( a b -- obj )
initialize-ct1
[ 1 + ] change-a ;
CONSTRUCTOR: ct3 ( a b c -- obj )
initialize-ct1
[ 1 + ] change-a ;
CONSTRUCTOR: ct4 ( a b c d -- obj )
initialize-ct3
[ 1 + ] change-a ;
[ 1001 ] [ 1000 <ct1> a>> ] unit-test
[ 2 ] [ 0 0 <ct2> a>> ] unit-test
[ 2 ] [ 0 0 0 <ct3> a>> ] unit-test
[ 3 ] [ 0 0 0 0 <ct4> a>> ] unit-test
TUPLE: rofl a b c ;
CONSTRUCTOR: rofl ( b c a -- obj ) ;
[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 <rofl> ] unit-test
TUPLE: default { a integer initial: 0 } ;
CONSTRUCTOR: default ( -- obj ) ;
[ 0 ] [ <default> a>> ] unit-test

53
basis/constructors/constructors.factor
View File

@ -1,23 +1,54 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: slots kernel sequences fry accessors parser lexer words USING: accessors assocs classes.tuple effects.parser fry
effects.parser macros ; generalizations generic.standard kernel lexer locals macros
parser sequences slots vocabs words ;
IN: constructors IN: constructors
! An experiment ! An experiment
MACRO: set-slots ( slots -- quot ) : initializer-name ( class -- word )
<reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ; name>> "initialize-" prepend ;
: construct ( ... class slots -- instance ) : lookup-initializer ( class -- word/f )
[ new ] dip set-slots ; inline initializer-name "initializers" lookup ;
: define-constructor ( name class effect body -- ) : initializer-word ( class -- word )
[ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi initializer-name
define-declared ; "initializers" create-vocab create
[ t "initializer" set-word-prop ] [ ] bi ;
: define-initializer-generic ( name -- )
initializer-word (( object -- object )) define-simple-generic ;
: define-initializer ( class def -- )
[ drop define-initializer-generic ]
[ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
MACRO:: slots>constructor ( class slots -- quot )
class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params
slots length
params length
'[
_ narray slots swap zip
params swap assoc-union
values _ firstn class boa
] ;
:: define-constructor ( constructor-word class effect def -- )
constructor-word
class def define-initializer
class effect in>> '[ _ _ slots>constructor ]
class lookup-initializer
'[ @ _ execute( obj -- obj ) ] effect define-declared ;
: scan-constructor ( -- class word )
scan-word [ name>> "<" ">" surround create-in ] keep ;
SYNTAX: CONSTRUCTOR: SYNTAX: CONSTRUCTOR:
scan-word [ name>> "<" ">" surround create-in ] keep scan-constructor
complete-effect complete-effect
parse-definition parse-definition
define-constructor ; define-constructor ;
"initializers" create-vocab drop

1
basis/cpu/architecture/architecture.factor
View File

@ -55,7 +55,6 @@ HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- ) HOOK: %return cpu ( -- )
HOOK: %dispatch cpu ( src temp -- ) HOOK: %dispatch cpu ( src temp -- )
HOOK: %dispatch-label cpu ( label -- )
HOOK: %slot cpu ( dst obj slot tag temp -- ) HOOK: %slot cpu ( dst obj slot tag temp -- )
HOOK: %slot-imm cpu ( dst obj slot tag -- ) HOOK: %slot-imm cpu ( dst obj slot tag -- )

21
basis/cpu/ppc/ppc.factor
View File

@ -3,10 +3,11 @@
USING: accessors assocs sequences kernel combinators make math USING: accessors assocs sequences kernel combinators make math
math.order math.ranges system namespaces locals layouts words math.order math.ranges system namespaces locals layouts words
alien alien.accessors alien.c-types literals cpu.architecture alien alien.accessors alien.c-types literals cpu.architecture
cpu.ppc.assembler cpu.ppc.assembler.backend literals compiler.cfg.registers cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers
compiler.cfg.instructions compiler.constants compiler.codegen compiler.cfg.instructions compiler.constants compiler.codegen
compiler.codegen.fixup compiler.cfg.intrinsics compiler.codegen.fixup compiler.cfg.intrinsics
compiler.cfg.stack-frame compiler.units ; compiler.cfg.stack-frame compiler.cfg.build-stack-frame
compiler.units ;
FROM: cpu.ppc.assembler => B ; FROM: cpu.ppc.assembler => B ;
IN: cpu.ppc IN: cpu.ppc
@ -461,16 +462,18 @@ M:: ppc %write-barrier ( src card# table -- )
src card# deck-bits SRWI src card# deck-bits SRWI
table scratch-reg card# STBX ; table scratch-reg card# STBX ;
M: ppc %gc M:: ppc %gc ( temp1 temp2 gc-roots gc-root-count -- )
"end" define-label "end" define-label
12 load-zone-ptr temp2 load-zone-ptr
11 12 cell LWZ ! nursery.here -> r11 temp1 temp2 cell LWZ
12 12 3 cells LWZ ! nursery.end -> r12 temp2 temp2 3 cells LWZ
11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here temp1 temp1 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
11 0 12 CMP ! is here >= end? temp1 0 temp2 CMP ! is here >= end?
"end" get BLE "end" get BLE
%prepare-alien-invoke %prepare-alien-invoke
"minor_gc" f %alien-invoke 0 3 LI
0 4 LI
"inline_gc" f %alien-invoke
"end" resolve-label ; "end" resolve-label ;
M: ppc %prologue ( n -- ) M: ppc %prologue ( n -- )

8
basis/cpu/x86/assembler/assembler-tests.factor
View File

@ -64,3 +64,11 @@ IN: cpu.x86.assembler.tests
[ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test [ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test
[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test [ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test
[ { HEX: 4d HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 R8 3 IMUL3 ] { } make ] unit-test
[ { HEX: 49 HEX: 6b HEX: c0 HEX: 03 } ] [ [ RAX R8 3 IMUL3 ] { } make ] unit-test
[ { HEX: 4c HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 RAX 3 IMUL3 ] { } make ] unit-test
[ { HEX: 48 HEX: 6b HEX: c1 HEX: 03 } ] [ [ RAX RCX 3 IMUL3 ] { } make ] unit-test
[ { HEX: 48 HEX: 69 HEX: c1 HEX: 44 HEX: 03 HEX: 00 HEX: 00 } ] [ [ RAX RCX HEX: 344 IMUL3 ] { } make ] unit-test
[ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test

28
basis/cpu/x86/assembler/assembler.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays io.binary kernel combinators USING: arrays io.binary kernel combinators kernel.private math
kernel.private math namespaces make sequences words system layouts namespaces make sequences words system layouts math.order accessors
math.order accessors cpu.x86.assembler.syntax ; cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler IN: cpu.x86.assembler
! A postfix assembler for x86-32 and x86-64. ! A postfix assembler for x86-32 and x86-64.
@ -402,20 +402,26 @@ M: operand TEST OCT: 204 2-operand ;
: SHR ( dst n -- ) BIN: 101 (SHIFT) ; : SHR ( dst n -- ) BIN: 101 (SHIFT) ;
: SAR ( dst n -- ) BIN: 111 (SHIFT) ; : SAR ( dst n -- ) BIN: 111 (SHIFT) ;
GENERIC: IMUL2 ( dst src -- ) : IMUL2 ( dst src -- )
M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ; OCT: 257 extended-opcode (2-operand) ;
M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
: IMUL3 ( dst src imm -- )
dup fits-in-byte? [
[ swap HEX: 6a 2-operand ] dip 1,
] [
[ swap HEX: 68 2-operand ] dip 4,
] if ;
: MOVSX ( dst src -- ) : MOVSX ( dst src -- )
dup register-32? OCT: 143 OCT: 276 extended-opcode ? swap
over register-16? [ BIN: 1 opcode-or ] when over register-32? OCT: 143 OCT: 276 extended-opcode ?
swapd pick register-16? [ BIN: 1 opcode-or ] when
(2-operand) ; (2-operand) ;
: MOVZX ( dst src -- ) : MOVZX ( dst src -- )
swap
OCT: 266 extended-opcode OCT: 266 extended-opcode
over register-16? [ BIN: 1 opcode-or ] when pick register-16? [ BIN: 1 opcode-or ] when
swapd
(2-operand) ; (2-operand) ;
! Conditional move ! Conditional move

5
basis/cpu/x86/x86.factor
View File

@ -91,9 +91,6 @@ M: x86 %return ( -- ) 0 RET ;
: align-code ( n -- ) : align-code ( n -- )
0 <repetition> % ; 0 <repetition> % ;
M: x86 %dispatch-label ( label -- )
0 cell, rc-absolute-cell label-fixup ;
:: (%slot) ( obj slot tag temp -- op ) :: (%slot) ( obj slot tag temp -- op )
temp slot obj [+] LEA temp slot obj [+] LEA
temp tag neg [+] ; inline temp tag neg [+] ; inline
@ -111,7 +108,7 @@ M: x86 %add-imm [+] LEA ;
M: x86 %sub nip SUB ; M: x86 %sub nip SUB ;
M: x86 %sub-imm neg [+] LEA ; M: x86 %sub-imm neg [+] LEA ;
M: x86 %mul nip swap IMUL2 ; M: x86 %mul nip swap IMUL2 ;
M: x86 %mul-imm nip IMUL2 ; M: x86 %mul-imm IMUL3 ;
M: x86 %and nip AND ; M: x86 %and nip AND ;
M: x86 %and-imm nip AND ; M: x86 %and-imm nip AND ;
M: x86 %or nip OR ; M: x86 %or nip OR ;

4
basis/formatting/formatting-tests.factor
View File

@ -77,6 +77,9 @@ IN: formatting.tests
[ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test [ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test
[ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test [ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test
[ t ] [ "{ 1, 2, 3 }" { 1 2 3 } "%[%s, %]" sprintf = ] unit-test
[ t ] [ "{ 1:2, 3:4 }" H{ { 1 2 } { 3 4 } } "%[%s: %s %]" sprintf = ] unit-test
[ "%H:%M:%S" strftime ] must-infer [ "%H:%M:%S" strftime ] must-infer
@ -95,3 +98,4 @@ IN: formatting.tests
[ t ] [ "Thu Oct 09 12:03:15 2008" testtime "%c" strftime = ] unit-test [ t ] [ "Thu Oct 09 12:03:15 2008" testtime "%c" strftime = ] unit-test
[ t ] [ "PM" testtime "%p" strftime = ] unit-test [ t ] [ "PM" testtime "%p" strftime = ] unit-test

2
basis/help/lint/lint.factor
View File

@ -3,7 +3,7 @@
USING: assocs continuations fry help help.lint.checks USING: assocs continuations fry help help.lint.checks
help.topics io kernel namespaces parser sequences help.topics io kernel namespaces parser sequences
source-files.errors vocabs.hierarchy vocabs words classes source-files.errors vocabs.hierarchy vocabs words classes
locals tools.errors ; locals tools.errors listener ;
FROM: help.lint.checks => all-vocabs ; FROM: help.lint.checks => all-vocabs ;
IN: help.lint IN: help.lint

236
basis/images/bitmap/bitmap.factor
View File

@ -2,77 +2,146 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays byte-arrays columns USING: accessors alien alien.c-types arrays byte-arrays columns
combinators compression.run-length endian fry grouping images combinators compression.run-length endian fry grouping images
images.loader io io.binary io.encodings.binary io.files kernel images.loader io io.binary io.encodings.binary io.files
locals macros math math.bitwise math.functions namespaces io.streams.limited kernel locals macros math math.bitwise
sequences strings summary ; math.functions namespaces sequences specialized-arrays.uint
specialized-arrays.ushort strings summary io.encodings.8-bit
io.encodings.string ;
QUALIFIED-WITH: bitstreams b
IN: images.bitmap IN: images.bitmap
: assert-sequence= ( a b -- )
2dup sequence= [ 2drop ] [ assert ] if ;
: read2 ( -- n ) 2 read le> ; : read2 ( -- n ) 2 read le> ;
: read4 ( -- n ) 4 read le> ; : read4 ( -- n ) 4 read le> ;
: write2 ( n -- ) 2 >le write ; : write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ; : write4 ( n -- ) 4 >le write ;
TUPLE: bitmap-image < image ; SINGLETON: bitmap-image
"bmp" bitmap-image register-image-class
! Used to construct the final bitmap-image
TUPLE: loading-bitmap TUPLE: loading-bitmap
size reserved offset header-length width magic size reserved1 reserved2 offset header-length width
height planes bit-count compression size-image height planes bit-count compression size-image
x-pels y-pels color-used color-important color-palette color-index x-pels y-pels color-used color-important
uncompressed-bytes ; red-mask green-mask blue-mask alpha-mask
cs-type end-points
gamma-red gamma-green gamma-blue
intent profile-data profile-size reserved3
color-palette color-index bitfields ;
ERROR: bitmap-magic magic ; ! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint
M: bitmap-magic summary
drop "First two bytes of bitmap stream must be 'BM'" ;
<PRIVATE <PRIVATE
: 8bit>buffer ( bitmap -- array ) : os2-color-lookup ( loading-bitmap -- seq )
[ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] [ color-index>> >array ]
[ color-index>> >array ] bi [ swap nth ] with map concat ; [ color-palette>> 3 <sliced-groups> ] bi
'[ _ nth ] map concat ;
: os2v2-color-lookup ( loading-bitmap -- seq )
[ color-index>> >array ]
[ color-palette>> 3 <sliced-groups> ] bi
'[ _ nth ] map concat ;
: v3-color-lookup ( loading-bitmap -- seq )
[ color-index>> >array ]
[ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] bi
'[ _ nth ] map concat ;
: color-lookup ( loading-bitmap -- seq )
dup header-length>> {
{ 12 [ os2-color-lookup ] }
{ 64 [ os2v2-color-lookup ] }
{ 40 [ v3-color-lookup ] }
! { 108 [ v4-color-lookup ] }
! { 124 [ v5-color-lookup ] }
} case ;
ERROR: bmp-not-supported n ; ERROR: bmp-not-supported n ;
: reverse-lines ( byte-array width -- byte-array ) : uncompress-bitfield ( seq masks -- bytes' )
<sliced-groups> <reversed> concat ; inline '[
_ [
[ bitand ] [ bit-count ] [ log2 ] tri - shift
] with map
] { } map-as B{ } concat-as ;
: bitmap>bytes ( loading-bitmap -- array ) : bitmap>bytes ( loading-bitmap -- byte-array )
dup bit-count>> dup bit-count>>
{ {
{ 32 [ color-index>> ] } { 32 [ color-index>> ] }
{ 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] } { 24 [ color-index>> ] }
{ 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] } { 16 [
[
! byte-array>ushort-array
2 group [ le> ] map
! 5 6 5
! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield
! 5 5 5
{ HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield
] change-color-index
color-index>>
] }
{ 8 [ color-lookup ] }
{ 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
{ 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] }
[ bmp-not-supported ] [ bmp-not-supported ]
} case >byte-array ; } case >byte-array ;
: set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
dup bit-count>> {
{ 16 [ dup color-palette>> 4 group [ le> ] map ] }
{ 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
} case reverse >>bitfields ;
ERROR: unsupported-bitfield-widths n ;
M: unsupported-bitfield-widths summary
drop "Bitmaps only support bitfield compression in 16/32bit images" ;
: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
set-bitfield-widths
dup bit-count>> {
{ 16 [
dup bitfields>> '[
byte-array>ushort-array _ uncompress-bitfield
] change-color-index
] }
{ 32 [
dup bitfields>> '[
byte-array>uint-array _ uncompress-bitfield
] change-color-index
] }
[ unsupported-bitfield-widths ]
} case ;
ERROR: unsupported-bitmap-compression compression ; ERROR: unsupported-bitmap-compression compression ;
: uncompress-bitmap ( loading-bitmap -- loading-bitmap' ) : uncompress-bitmap ( loading-bitmap -- loading-bitmap' )
dup compression>> { dup compression>> {
{ f [ ] }
{ 0 [ ] } { 0 [ ] }
{ 1 [ [ run-length-uncompress8 ] change-color-index ] } { 1 [ [ run-length-uncompress ] change-color-index ] }
{ 2 [ "run-length encoding 4" unsupported-bitmap-compression ] } { 2 [ [ 4 b:byte-array-n>seq run-length-uncompress >byte-array ] change-color-index ] }
{ 3 [ "bitfields" unsupported-bitmap-compression ] } { 3 [ uncompress-bitfield-widths ] }
{ 4 [ "jpeg" unsupported-bitmap-compression ] } { 4 [ "jpeg" unsupported-bitmap-compression ] }
{ 5 [ "png" unsupported-bitmap-compression ] } { 5 [ "png" unsupported-bitmap-compression ] }
} case ; } case ;
: bitmap-padding ( width -- n )
3 * 4 mod 4 swap - 4 mod ; inline
: loading-bitmap>bytes ( loading-bitmap -- byte-array ) : loading-bitmap>bytes ( loading-bitmap -- byte-array )
uncompress-bitmap bitmap>bytes ; uncompress-bitmap
bitmap>bytes ;
: parse-file-header ( loading-bitmap -- loading-bitmap ) : parse-file-header ( loading-bitmap -- loading-bitmap )
2 read "BM" assert-sequence= 2 read latin1 decode >>magic
read4 >>size read4 >>size
read4 >>reserved read2 >>reserved1
read2 >>reserved2
read4 >>offset ; read4 >>offset ;
: parse-bitmap-header ( loading-bitmap -- loading-bitmap ) : read-v3-header ( loading-bitmap -- loading-bitmap )
read4 >>header-length
read4 >>width read4 >>width
read4 32 >signed >>height read4 32 >signed >>height
read2 >>planes read2 >>planes
@ -84,6 +153,50 @@ ERROR: unsupported-bitmap-compression compression ;
read4 >>color-used read4 >>color-used
read4 >>color-important ; read4 >>color-important ;
: read-v4-header ( loading-bitmap -- loading-bitmap )
read-v3-header
read4 >>red-mask
read4 >>green-mask
read4 >>blue-mask
read4 >>alpha-mask
read4 >>cs-type
read4 read4 read4 3array >>end-points
read4 >>gamma-red
read4 >>gamma-green
read4 >>gamma-blue ;
: read-v5-header ( loading-bitmap -- loading-bitmap )
read-v4-header
read4 >>intent
read4 >>profile-data
read4 >>profile-size
read4 >>reserved3 ;
: read-os2-header ( loading-bitmap -- loading-bitmap )
read2 >>width
read2 16 >signed >>height
read2 >>planes
read2 >>bit-count ;
: read-os2v2-header ( loading-bitmap -- loading-bitmap )
read4 >>width
read4 32 >signed >>height
read2 >>planes
read2 >>bit-count ;
ERROR: unknown-bitmap-header n ;
: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
read4 [ >>header-length ] keep
{
{ 12 [ read-os2-header ] }
{ 64 [ read-os2v2-header ] }
{ 40 [ read-v3-header ] }
{ 108 [ read-v4-header ] }
{ 124 [ read-v5-header ] }
[ unknown-bitmap-header ]
} case ;
: color-palette-length ( loading-bitmap -- n ) : color-palette-length ( loading-bitmap -- n )
[ offset>> 14 - ] [ header-length>> ] bi - ; [ offset>> 14 - ] [ header-length>> ] bi - ;
@ -98,56 +211,54 @@ ERROR: unsupported-bitmap-compression compression ;
: image-size ( loading-bitmap -- n ) : image-size ( loading-bitmap -- n )
[ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ; [ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
: bitmap-padding ( width -- n )
3 * 4 mod 4 swap - 4 mod ; inline
:: fixup-color-index ( loading-bitmap -- loading-bitmap )
loading-bitmap width>> :> width
width 3 * :> width*3
loading-bitmap width>> bitmap-padding :> padding
loading-bitmap [ color-index>> length ] [ height>> abs ] bi /i :> stride
loading-bitmap
padding 0 > [
[
stride <sliced-groups>
[ width*3 head-slice ] map concat
] change-color-index
] when ;
: parse-bitmap ( loading-bitmap -- loading-bitmap ) : parse-bitmap ( loading-bitmap -- loading-bitmap )
dup color-palette-length read >>color-palette dup color-palette-length read >>color-palette
dup color-index-length read >>color-index dup size-image>> dup 0 > [
fixup-color-index ; read >>color-index
] [
drop dup color-index-length read >>color-index
] if ;
ERROR: unsupported-bitmap-file magic ;
: load-bitmap ( path -- loading-bitmap ) : load-bitmap ( path -- loading-bitmap )
binary [ binary stream-throws <limited-file-reader> [
loading-bitmap new loading-bitmap new
parse-file-header parse-bitmap-header parse-bitmap parse-file-header dup magic>> {
] with-file-reader ; { "BM" [ parse-bitmap-header parse-bitmap ] }
! { "BA" [ parse-os2-bitmap-array ] }
! { "CI" [ parse-os2-color-icon ] }
! { "CP" [ parse-os2-color-pointer ] }
! { "IC" [ parse-os2-icon ] }
! { "PT" [ parse-os2-pointer ] }
[ unsupported-bitmap-file ]
} case
] with-input-stream ;
ERROR: unknown-component-order bitmap ; ERROR: unknown-component-order bitmap ;
: bitmap>component-order ( loading-bitmap -- object ) : bitmap>component-order ( loading-bitmap -- object )
bit-count>> { bit-count>> {
{ 32 [ BGRA ] } { 32 [ BGR ] }
{ 24 [ BGR ] } { 24 [ BGR ] }
{ 16 [ BGR ] }
{ 8 [ BGR ] } { 8 [ BGR ] }
{ 4 [ BGR ] }
{ 1 [ BGR ] }
[ unknown-component-order ] [ unknown-component-order ]
} case ; } case ;
: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image ) M: bitmap-image load-image* ( path bitmap-image -- bitmap )
drop load-bitmap
[ image new ] dip
{ {
[ loading-bitmap>bytes >>bitmap ] [ loading-bitmap>bytes >>bitmap ]
[ [ width>> ] [ height>> abs ] bi 2array >>dim ] [ [ width>> ] [ height>> abs ] bi 2array >>dim ]
[ height>> 0 < [ t >>upside-down? ] when ] [ height>> 0 < not >>upside-down? ]
[ compression>> 3 = [ t >>upside-down? ] when ]
[ bitmap>component-order >>component-order ] [ bitmap>component-order >>component-order ]
} cleave ; } cleave ;
M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
swap load-bitmap loading-bitmap>bitmap-image ;
"bmp" bitmap-image register-image-class
PRIVATE> PRIVATE>
: bitmap>color-index ( bitmap -- byte-array ) : bitmap>color-index ( bitmap -- byte-array )
@ -165,6 +276,9 @@ PRIVATE>
] if ] if
] bi ; ] bi ;
: reverse-lines ( byte-array width -- byte-array )
<sliced-groups> <reversed> concat ; inline
: save-bitmap ( image path -- ) : save-bitmap ( image path -- )
binary [ binary [
B{ CHAR: B CHAR: M } write B{ CHAR: B CHAR: M } write

9
basis/images/images.factor
View File

@ -34,14 +34,7 @@ TUPLE: image dim component-order upside-down? bitmap ;
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ; : has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
GENERIC: load-image* ( path tuple -- image ) GENERIC: load-image* ( path class -- image )
: make-image ( bitmap -- image )
! bitmap is a sequence of sequences of pixels which are RGBA
<image>
over [ first length ] [ length ] bi 2array >>dim
RGBA >>component-order
swap concat concat B{ } like >>bitmap ;
<PRIVATE <PRIVATE

16
basis/images/jpeg/jpeg.factor
View File

@ -7,11 +7,13 @@ io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order math.constants math.functions math.matrices math.order
math.ranges math.vectors memoize multiline namespaces math.ranges math.vectors memoize multiline namespaces
sequences sequences.deep images.loader ; sequences sequences.deep images.loader ;
QUALIFIED-WITH: bitstreams bs
IN: images.jpeg IN: images.jpeg
QUALIFIED-WITH: bitstreams bs SINGLETON: jpeg-image
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each
TUPLE: jpeg-image < image TUPLE: loading-jpeg < image
{ headers } { headers }
{ bitstream } { bitstream }
{ color-info initial: { f f f f } } { color-info initial: { f f f f } }
@ -21,7 +23,7 @@ TUPLE: jpeg-image < image
<PRIVATE <PRIVATE
CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ; CONSTRUCTOR: loading-jpeg ( headers bitstream -- image ) ;
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
APP JPG COM TEM RES ; APP JPG COM TEM RES ;
@ -63,7 +65,7 @@ TUPLE: jpeg-color-info
CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ; CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
: jpeg> ( -- jpeg-image ) jpeg-image get ; : jpeg> ( -- jpeg-image ) loading-jpeg get ;
: apply-diff ( dc color -- dc' ) : apply-diff ( dc color -- dc' )
[ diff>> + dup ] [ (>>diff) ] bi ; [ diff>> + dup ] [ (>>diff) ] bi ;
@ -291,9 +293,9 @@ PRIVATE>
binary [ binary [
parse-marker { SOI } assert= parse-marker { SOI } assert=
parse-headers parse-headers
contents <jpeg-image> contents <loading-jpeg>
] with-file-reader ] with-file-reader
dup jpeg-image [ dup loading-jpeg [
baseline-parse baseline-parse
baseline-decompress baseline-decompress
jpeg> bitmap>> 3 <groups> [ color-transform ] change-each jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
@ -302,5 +304,3 @@ PRIVATE>
M: jpeg-image load-image* ( path jpeg-image -- bitmap ) M: jpeg-image load-image* ( path jpeg-image -- bitmap )
drop load-jpeg ; drop load-jpeg ;
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each

4
basis/images/loader/loader.factor
View File

@ -7,16 +7,18 @@ IN: images.loader
ERROR: unknown-image-extension extension ; ERROR: unknown-image-extension extension ;
<PRIVATE <PRIVATE
SYMBOL: types SYMBOL: types
types [ H{ } clone ] initialize types [ H{ } clone ] initialize
: image-class ( path -- class ) : image-class ( path -- class )
file-extension >lower types get ?at file-extension >lower types get ?at
[ unknown-image-extension ] unless ; [ unknown-image-extension ] unless ;
PRIVATE> PRIVATE>
: register-image-class ( extension class -- ) : register-image-class ( extension class -- )
swap types get set-at ; swap types get set-at ;
: load-image ( path -- image ) : load-image ( path -- image )
dup image-class new load-image* ; dup image-class load-image* ;

16
basis/images/png/png.factor
View File

@ -7,12 +7,15 @@ checksums checksums.crc32 compression.inflate grouping byte-arrays
images.loader ; images.loader ;
IN: images.png IN: images.png
TUPLE: png-image < image chunks SINGLETON: png-image
"png" png-image register-image-class
TUPLE: loading-png < image chunks
width height bit-depth color-type compression-method width height bit-depth color-type compression-method
filter-method interlace-method uncompressed ; filter-method interlace-method uncompressed ;
CONSTRUCTOR: png-image ( -- image ) CONSTRUCTOR: loading-png ( -- image )
V{ } clone >>chunks ; V{ } clone >>chunks ;
TUPLE: png-chunk length type data ; TUPLE: png-chunk length type data ;
@ -104,9 +107,8 @@ ERROR: unimplemented-color-type image ;
} case ; } case ;
: load-png ( path -- image ) : load-png ( path -- image )
[ binary <file-reader> ] [ file-info size>> ] bi binary stream-throws <limited-file-reader> [
stream-throws <limited-stream> [ <loading-png>
<png-image>
read-png-header read-png-header
read-png-chunks read-png-chunks
parse-ihdr-chunk parse-ihdr-chunk
@ -116,5 +118,3 @@ ERROR: unimplemented-color-type image ;
M: png-image load-image* M: png-image load-image*
drop load-png ; drop load-png ;
"png" png-image register-image-class

32
basis/images/tiff/tiff.factor
View File

@ -9,10 +9,10 @@ strings math.vectors specialized-arrays.float locals
images.loader ; images.loader ;
IN: images.tiff IN: images.tiff
TUPLE: tiff-image < image ; SINGLETON: tiff-image
TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ; TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ; CONSTRUCTOR: loading-tiff ( -- tiff ) V{ } clone >>ifds ;
TUPLE: ifd count ifd-entries next TUPLE: ifd count ifd-entries next
processed-tags strips bitmap ; processed-tags strips bitmap ;
@ -410,7 +410,7 @@ ERROR: bad-small-ifd-type n ;
[ nip unhandled-ifd-entry swap ] [ nip unhandled-ifd-entry swap ]
} case ; } case ;
: process-ifds ( parsed-tiff -- parsed-tiff ) : process-ifds ( loading-tiff -- loading-tiff )
[ [
[ [
dup ifd-entries>> dup ifd-entries>>
@ -483,18 +483,6 @@ ERROR: unknown-component-order ifd ;
[ unknown-component-order ] [ unknown-component-order ]
} case ; } case ;
: normalize-alpha-data ( seq -- byte-array )
B{ } like dup
byte-array>float-array
4 <sliced-groups>
[
dup fourth dup 0 = [
2drop
] [
[ 3 head-slice ] dip '[ _ / ] change-each
] if
] each ;
: handle-alpha-data ( ifd -- ifd ) : handle-alpha-data ( ifd -- ifd )
dup extra-samples find-tag { dup extra-samples find-tag {
{ extra-samples-associated-alpha-data [ ] } { extra-samples-associated-alpha-data [ ] }
@ -508,17 +496,17 @@ ERROR: unknown-component-order ifd ;
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
[ ifd-component-order f ] [ ifd-component-order f ]
[ bitmap>> ] [ bitmap>> ]
} cleave tiff-image boa ; } cleave image boa ;
: tiff>image ( image -- image ) : tiff>image ( image -- image )
ifds>> [ ifd>image ] map first ; ifds>> [ ifd>image ] map first ;
: with-tiff-endianness ( parsed-tiff quot -- ) : with-tiff-endianness ( loading-tiff quot -- )
[ dup endianness>> ] dip with-endianness ; inline [ dup endianness>> ] dip with-endianness ; inline
: load-tiff-ifds ( path -- parsed-tiff ) : load-tiff-ifds ( path -- loading-tiff )
binary [ binary [
<parsed-tiff> <loading-tiff>
read-header [ read-header [
dup ifd-offset>> read-ifds dup ifd-offset>> read-ifds
process-ifds process-ifds
@ -550,10 +538,10 @@ ERROR: unknown-component-order ifd ;
drop "no planar configuration" throw drop "no planar configuration" throw
] if ; ] if ;
: process-tif-ifds ( parsed-tiff -- ) : process-tif-ifds ( loading-tiff -- )
ifds>> [ process-ifd ] each ; ifds>> [ process-ifd ] each ;
: load-tiff ( path -- parsed-tiff ) : load-tiff ( path -- loading-tiff )
[ load-tiff-ifds dup ] keep [ load-tiff-ifds dup ] keep
binary [ binary [
[ process-tif-ifds ] with-tiff-endianness [ process-tif-ifds ] with-tiff-endianness

11
basis/io/streams/limited/limited.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math io io.encodings destructors accessors USING: accessors byte-vectors combinators destructors fry io
sequences namespaces byte-vectors fry combinators ; io.encodings io.files io.files.info kernel math namespaces
sequences ;
IN: io.streams.limited IN: io.streams.limited
TUPLE: limited-stream stream count limit mode stack ; TUPLE: limited-stream stream count limit mode stack ;
@ -16,6 +17,12 @@ SINGLETONS: stream-throws stream-eofs ;
swap >>stream swap >>stream
0 >>count ; 0 >>count ;
: <limited-file-reader> ( path encoding mode -- stream' )
[
[ <file-reader> ]
[ drop file-info size>> ] 2bi
] dip <limited-stream> ;
GENERIC# limit 2 ( stream limit mode -- stream' ) GENERIC# limit 2 ( stream limit mode -- stream' )
M: decoder limit ( stream limit mode -- stream' ) M: decoder limit ( stream limit mode -- stream' )

2
basis/json/reader/authors.txt
View File

@ -1 +1,3 @@
Chris Double Chris Double
Peter Burns
Philipp Winkler

3
basis/json/reader/reader-tests.factor
View File

@ -19,6 +19,8 @@ IN: json.reader.tests
{ 10.25 } [ "1025e-2" json> ] unit-test { 10.25 } [ "1025e-2" json> ] unit-test
{ 0.125 } [ "0.125" json> ] unit-test { 0.125 } [ "0.125" json> ] unit-test
{ -0.125 } [ "-0.125" json> ] unit-test { -0.125 } [ "-0.125" json> ] unit-test
{ -0.00125 } [ "-0.125e-2" json> ] unit-test
{ -012.5 } [ "-0.125e+2" json> ] unit-test
! not widely supported by javascript, but allowed in the grammar, and a nice ! not widely supported by javascript, but allowed in the grammar, and a nice
! feature to get ! feature to get
@ -31,6 +33,7 @@ IN: json.reader.tests
{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test { 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test
{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test { HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test
{ H{ { "a" { } } { "b" 123 } } } [ "{\"a\":[],\"b\":123}" json> ] unit-test
{ { } } [ "[]" json> ] unit-test { { } } [ "[]" json> ] unit-test
{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test { { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test
{ H{ } } [ "{}" json> ] unit-test { H{ } } [ "{}" json> ] unit-test

128
basis/json/reader/reader.factor
View File

@ -1,61 +1,103 @@
! Copyright (C) 2008 Peter Burns. ! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg peg.ebnf math.parser math.parser.private strings math USING: arrays assocs combinators io io.streams.string json
math.functions sequences arrays vectors hashtables assocs kernel math math.parser math.parser.private prettyprint
prettyprint json ; sequences strings vectors ;
IN: json.reader IN: json.reader
<PRIVATE <PRIVATE
: value ( char -- num char )
1string " \t\r\n,:}]" read-until
[
append
[ string>float ]
[ [ "eE." index ] any? [ >integer ] unless ] bi
] dip ;
: grammar-list>vector ( seq -- vec ) first2 values swap prefix ; DEFER: j-string
! Grammar for JSON from RFC 4627 : convert-string ( str -- str )
EBNF: (json>) read1
{
{ CHAR: b [ 8 ] }
{ CHAR: f [ 12 ] }
{ CHAR: n [ CHAR: \n ] }
{ CHAR: r [ CHAR: \r ] }
{ CHAR: t [ CHAR: \t ] }
{ CHAR: u [ 4 read hex> ] }
[ ]
} case
dup
[ 1string append j-string append ]
[ drop ] if ;
ws = (" " | "\r" | "\t" | "\n")* : j-string ( -- str )
"\\\"" read-until CHAR: \" =
[ convert-string ] unless ;
true = "true" => [[ t ]] : second-last ( seq -- second-last )
false = "false" => [[ f ]] [ length 2 - ] keep nth ; inline
null = "null" => [[ json-null ]]
hex = [0-9a-fA-F] : third-last ( seq -- third-last )
char = '\\"' [[ CHAR: " ]] [ length 3 - ] keep nth ; inline
| "\\\\" [[ CHAR: \ ]]
| "\\/" [[ CHAR: / ]]
| "\\b" [[ 8 ]]
| "\\f" [[ 12 ]]
| "\\n" [[ CHAR: \n ]]
| "\\r" [[ CHAR: \r ]]
| "\\t" [[ CHAR: \t ]]
| "\\u" (hex hex hex hex) [[ hex> ]] => [[ second ]]
| [^"\]
string = '"' char*:cs '"' => [[ cs >string ]]
sign = ("-" | "+")? => [[ "-" = "-" "" ? ]] : last2 ( seq -- second-last last )
digits = [0-9]+ => [[ >string ]] [ second-last ] [ last ] bi ; inline
decimal = "." digits => [[ concat ]]
exp = ("e" | "E") sign digits => [[ concat ]]
number = sign digits decimal? exp? => [[ dup concat swap fourth [ string>float ] [ string>number ] if ]]
elements = value ("," value)* => [[ grammar-list>vector ]] : last3 ( seq -- third-last second-last last )
array = "[" elements?:arr "]" => [[ arr >array ]] [ third-last ] [ last2 ] bi ; inline
pair = ws string:key ws ":" value:val => [[ { key val } ]] : v-over-push ( vec -- vec' )
members = pair ("," pair)* => [[ grammar-list>vector ]] dup length 2 >=
object = "{" members?:hash "}" => [[ hash >hashtable ]] [
dup
[ pop ]
[ last ] bi push
] when ;
val = true : v-pick-push ( vec -- vec' )
| false dup length 3 >=
| null [
| string dup
| number [ pop ]
| array [ second-last ] bi push
| object ] when ;
value = ws val:v ws => [[ v ]] : (close-array) ( accum -- accum' )
dup last vector? [ v-over-push ] unless
dup pop >array over push ;
;EBNF : (close-hash) ( accum -- accum' )
dup length 3 >= [ v-over-push ] when
dup dup [ pop ] dip pop swap
zip H{ } assoc-clone-like over push ;
: scan ( accum char -- accum )
! 2dup . . ! Great for debug...
[
{
{ CHAR: \" [ j-string over push ] }
{ CHAR: [ [ V{ } clone over push ] }
{ CHAR: , [ v-over-push ] }
{ CHAR: ] [ (close-array) ] }
{ CHAR: { [ 2 [ V{ } clone over push ] times ] }
{ CHAR: : [ v-pick-push ] }
{ CHAR: } [ (close-hash) ] }
{ CHAR: \u000020 [ ] }
{ CHAR: \t [ ] }
{ CHAR: \r [ ] }
{ CHAR: \n [ ] }
{ CHAR: t [ 3 read drop t over push ] }
{ CHAR: f [ 4 read drop f over push ] }
{ CHAR: n [ 3 read drop json-null over push ] }
[ value [ over push ] dip [ scan ] when* ]
} case
] when* ;
: (json-parser>) ( string -- object )
[ V{ } clone [ read1 dup ] [ scan ] while drop first ] with-string-reader ;
PRIVATE> PRIVATE>
: json> ( string -- object ) (json>) ; : json> ( string -- object )
(json-parser>) ;

4
basis/listener/listener-docs.factor
View File

@ -13,6 +13,10 @@ ARTICLE: "listener-watch" "Watching variables in the listener"
"Hiding all visible variables:" "Hiding all visible variables:"
{ $subsection hide-all-vars } ; { $subsection hide-all-vars } ;
HELP: only-use-vocabs
{ $values { "vocabs" "a sequence of vocabulary specifiers" } }
{ $description "Replaces the current manifest's vocabulary search path with the given set of vocabularies." } ;
HELP: show-var HELP: show-var
{ $values { "var" "a variable name" } } { $values { "var" "a variable name" } }
{ $description "Adds a variable to the watch list; its value will be printed by the listener after every expression." } ; { $description "Adds a variable to the watch list; its value will be printed by the listener after every expression." } ;

74
basis/listener/listener.factor
View File

@ -4,7 +4,7 @@ USING: arrays hashtables io kernel math math.parser memory
namespaces parser lexer sequences strings io.styles namespaces parser lexer sequences strings io.styles
vectors words generic system combinators continuations debugger vectors words generic system combinators continuations debugger
definitions compiler.units accessors colors prettyprint fry definitions compiler.units accessors colors prettyprint fry
sets vocabs.parser source-files.errors locals ; sets vocabs.parser source-files.errors locals vocabs vocabs.loader ;
IN: listener IN: listener
GENERIC: stream-read-quot ( stream -- quot/f ) GENERIC: stream-read-quot ( stream -- quot/f )
@ -124,6 +124,78 @@ t error-summary? set-global
PRIVATE> PRIVATE>
SYMBOL: interactive-vocabs
{
"accessors"
"arrays"
"assocs"
"combinators"
"compiler"
"compiler.errors"
"compiler.units"
"continuations"
"debugger"
"definitions"
"editors"
"help"
"help.apropos"
"help.lint"
"help.vocabs"
"inspector"
"io"
"io.files"
"io.pathnames"
"kernel"
"listener"
"math"
"math.order"
"memory"
"namespaces"
"parser"
"prettyprint"
"see"
"sequences"
"slicing"
"sorting"
"stack-checker"
"strings"
"syntax"
"tools.annotations"
"tools.crossref"
"tools.disassembler"
"tools.errors"
"tools.memory"
"tools.profiler"
"tools.test"
"tools.threads"
"tools.time"
"vocabs"
"vocabs.loader"
"vocabs.refresh"
"vocabs.hierarchy"
"words"
"scratchpad"
} interactive-vocabs set-global
: only-use-vocabs ( vocabs -- )
clear-manifest
[ vocab ] filter
[
vocab
[ find-vocab-root not ]
[ source-loaded?>> +done+ eq? ] bi or
] filter
[ use-vocab ] each ;
: with-interactive-vocabs ( quot -- )
[
<manifest> manifest set
"scratchpad" set-current-vocab
interactive-vocabs get only-use-vocabs
call
] with-scope ; inline
: listener ( -- ) : listener ( -- )
[ [ { } (listener) ] with-interactive-vocabs ] with-return ; [ [ { } (listener) ] with-interactive-vocabs ] with-return ;

3
basis/prettyprint/prettyprint-tests.factor
View File

@ -3,7 +3,8 @@ kernel math namespaces parser prettyprint prettyprint.config
prettyprint.sections sequences tools.test vectors words prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard prettyprint.private effects splitting generic.standard prettyprint.private
continuations generic compiler.units tools.continuations continuations generic compiler.units tools.continuations
tools.continuations.private eval accessors make vocabs.parser see ; tools.continuations.private eval accessors make vocabs.parser see
listener ;
IN: prettyprint.tests IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test [ "4" ] [ 4 unparse ] unit-test

2
basis/tools/deploy/shaker/shaker.factor
View File

@ -277,8 +277,6 @@ IN: tools.deploy.shaker
compiled-generic-crossref compiled-generic-crossref
compiler-impl compiler-impl
compiler.errors:compiler-errors compiler.errors:compiler-errors
! definition-observers
interactive-vocabs
lexer-factory lexer-factory
print-use-hook print-use-hook
root-cache root-cache

62
core/parser/parser.factor
View File

@ -112,68 +112,6 @@ SYMBOL: bootstrap-syntax
call call
] with-scope ; inline ] with-scope ; inline
SYMBOL: interactive-vocabs
{
"accessors"
"arrays"
"assocs"
"combinators"
"compiler"
"compiler.errors"
"compiler.units"
"continuations"
"debugger"
"definitions"
"editors"
"help"
"help.apropos"
"help.lint"
"help.vocabs"
"inspector"
"io"
"io.files"
"io.pathnames"
"kernel"
"listener"
"math"
"math.order"
"memory"
"namespaces"
"parser"
"prettyprint"
"see"
"sequences"
"slicing"
"sorting"
"stack-checker"
"strings"
"syntax"
"tools.annotations"
"tools.crossref"
"tools.disassembler"
"tools.errors"
"tools.memory"
"tools.profiler"
"tools.test"
"tools.threads"
"tools.time"
"vocabs"
"vocabs.loader"
"vocabs.refresh"
"vocabs.hierarchy"
"words"
"scratchpad"
} interactive-vocabs set-global
: with-interactive-vocabs ( quot -- )
[
<manifest> manifest set
"scratchpad" set-current-vocab
interactive-vocabs get only-use-vocabs
call
] with-scope ; inline
SYMBOL: print-use-hook SYMBOL: print-use-hook
print-use-hook [ [ ] ] initialize print-use-hook [ [ ] ] initialize

5
core/vocabs/parser/parser-docs.factor
View File

@ -65,7 +65,6 @@ $nl
"Words for working with the current manifest:" "Words for working with the current manifest:"
{ $subsection use-vocab } { $subsection use-vocab }
{ $subsection unuse-vocab } { $subsection unuse-vocab }
{ $subsection only-use-vocabs }
{ $subsection add-qualified } { $subsection add-qualified }
{ $subsection add-words-from } { $subsection add-words-from }
{ $subsection add-words-excluding } { $subsection add-words-excluding }
@ -117,10 +116,6 @@ HELP: unuse-vocab
{ $description "Removes a vocabulary from the current manifest." } { $description "Removes a vocabulary from the current manifest." }
{ $notes "This word is used to implement " { $link POSTPONE: UNUSE: } "." } ; { $notes "This word is used to implement " { $link POSTPONE: UNUSE: } "." } ;
HELP: only-use-vocabs
{ $values { "vocabs" "a sequence of vocabulary specifiers" } }
{ $description "Replaces the current manifest's vocabulary search path with the given set of vocabularies." } ;
HELP: add-qualified HELP: add-qualified
{ $values { "vocab" "a vocabulary specifier" } { "prefix" string } } { $values { "vocab" "a vocabulary specifier" } { "prefix" string } }
{ $description "Adds the vocabulary's words, prefixed with the given string, to the current manifest." } { $description "Adds the vocabulary's words, prefixed with the given string, to the current manifest." }

7
core/vocabs/parser/parser.factor
View File

@ -52,8 +52,6 @@ M: extra-words equal?
C: <extra-words> extra-words C: <extra-words> extra-words
<PRIVATE
: clear-manifest ( -- ) : clear-manifest ( -- )
manifest get manifest get
[ search-vocab-names>> clear-assoc ] [ search-vocab-names>> clear-assoc ]
@ -61,6 +59,8 @@ C: <extra-words> extra-words
[ qualified-vocabs>> delete-all ] [ qualified-vocabs>> delete-all ]
tri ; tri ;
<PRIVATE
: (add-qualified) ( qualified -- ) : (add-qualified) ( qualified -- )
manifest get qualified-vocabs>> push ; manifest get qualified-vocabs>> push ;
@ -126,9 +126,6 @@ TUPLE: no-current-vocab ;
2bi 2bi
] [ drop ] if ; ] [ drop ] if ;
: only-use-vocabs ( vocabs -- )
clear-manifest [ vocab ] filter [ use-vocab ] each ;
TUPLE: qualified vocab prefix words ; TUPLE: qualified vocab prefix words ;
: <qualified> ( vocab prefix -- qualified ) : <qualified> ( vocab prefix -- qualified )

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

@ -0,0 +1 @@
John Benediktsson

49
extra/brainfuck/brainfuck-docs.factor Normal file
View File

@ -0,0 +1,49 @@
! Copyright (C) 2009 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: help.syntax help.markup brainfuck strings ;
IN: brainfuck
HELP: run-brainfuck
{ $values { "code" string } }
{ $description
"A brainfuck program is a sequence of eight commands that are "
"executed sequentially. An instruction pointer begins at the first "
"command, and each command is executed until the program terminates "
"when the instruction pointer moves beyond the last command.\n"
"\n"
"The eight language commands, each consisting of a single character, "
"are the following:\n"
{ $table
{ "Character" "Meaning" }
{ ">" "increment the data pointer (to point to the next cell to the right)." }
{ "<" "decrement the data pointer (to point to the next cell to the left)." }
{ "+" "increment (increase by one) the byte at the data pointer." }
{ "-" "decrement (decrease by one) the byte at the data pointer." }
{ "." "output the value of the byte at the data pointer." }
{ "," "accept one byte of input, storing its value in the byte at the data pointer." }
{ "[" "if the byte at the data pointer is zero, then instead of moving the instruction pointer forward to the next command, jump it forward to the command after the matching ] command*." }
{ "]" "if the byte at the data pointer is nonzero, then instead of moving the instruction pointer forward to the next command, jump it back to the command after the matching [ command*." }
}
"\n"
"Brainfuck programs can be translated into C using the following "
"substitutions, assuming ptr is of type unsigned char* and has been "
"initialized to point to an array of zeroed bytes:\n"
{ $table
{ "Character" "C equivalent" }
{ ">" "++ptr;" }
{ "<" "--ptr;" }
{ "+" "++*ptr;" }
{ "-" "--*ptr;" }
{ "." "putchar(*ptr);" }
{ "," "*ptr=getchar();" }
{ "[" "while (*ptr) {" }
{ "]" "}" }
}
} ;
HELP: get-brainfuck
{ $values { "code" string } { "result" string } }
{ $description "Returns the output from a brainfuck program as a result string." }
{ $see-also run-brainfuck } ;

62
extra/brainfuck/brainfuck-tests.factor Normal file
View File

@ -0,0 +1,62 @@
! Copyright (C) 2009 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: brainfuck kernel io.streams.string math math.parser math.ranges
multiline quotations sequences tools.test ;
[ "+" run-brainfuck ] must-infer
[ "+" get-brainfuck ] must-infer
! Hello World!
[ "Hello World!\n" ] [ <" ++++++++++[>+++++++>++++++++++>+++>+<<<<-]
>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.
------.--------.>+.>. "> get-brainfuck ] unit-test
! Addition (single-digit)
[ "8" ] [ "35" [ ",>++++++[<-------->-],[<+>-]<."
get-brainfuck ] with-string-reader ] unit-test
! Multiplication (single-digit)
[ "8\0" ] [ "24" [ <" ,>,>++++++++[<------<------>>-]
<<[>[>+>+<<-]>>[<<+>>-]<<<-]
>>>++++++[<++++++++>-],<.>. ">
get-brainfuck ] with-string-reader ] unit-test
! Division (single-digit, integer)
[ "3" ] [ "62" [ <" ,>,>++++++[-<--------<-------->>]
<<[
>[->+>+<<]
>[-<<-
[>]>>>[<[>>>-<<<[-]]>>]<<]
>>>+
<<[-<<+>>]
<<<]
>[-]>>>>[-<<<<<+>>>>>]
<<<<++++++[-<++++++++>]<. ">
get-brainfuck ] with-string-reader ] unit-test
! Uppercase
[ "A" ] [ "a\n" [ ",----------[----------------------.,----------]"
get-brainfuck ] with-string-reader ] unit-test
! cat
[ "ABC" ] [ "ABC\0" [ ",[.,]" get-brainfuck ] with-string-reader ] unit-test
! Squares of numbers from 0 to 100
100 [0,b] [ dup * number>string ] map "\n" join "\n" append 1quotation
[ <" ++++[>+++++<-]>[<+++++>-]+<+[
>[>+>+<<-]++>>[<<+>>-]>>>[-]++>[-]+
>>>+[[-]++++++>>>]<<<[[<++++++++<++>>-]+<.<[>----<-]<]
<<[>>>>>[>>>[-]+++++++++<[>-<-]+++++++++>
[-[<->-]+[<<<]]<[>+<-]>]<<-]<<-] ">
get-brainfuck ] unit-test

77
extra/brainfuck/brainfuck.factor Normal file
View File

@ -0,0 +1,77 @@
! Copyright (C) 2009 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: accessors assocs fry io io.streams.string kernel macros math
peg.ebnf prettyprint quotations sequences strings ;
IN: brainfuck
<PRIVATE
TUPLE: brainfuck pointer memory ;
: <brainfuck> ( -- brainfuck )
0 H{ } clone brainfuck boa ;
: get-memory ( brainfuck -- brainfuck value )
dup [ pointer>> ] [ memory>> ] bi at 0 or ;
: set-memory ( brainfuck value -- brainfuck )
over [ pointer>> ] [ memory>> ] bi set-at ;
: (+) ( brainfuck n -- brainfuck )
[ get-memory ] dip + 255 bitand set-memory ;
: (-) ( brainfuck n -- brainfuck )
[ get-memory ] dip - 255 bitand set-memory ;
: (?) ( brainfuck -- brainfuck t/f )
get-memory 0 = not ;
: (.) ( brainfuck -- brainfuck )
get-memory 1string write ;
: (,) ( brainfuck -- brainfuck )
read1 set-memory ;
: (>) ( brainfuck n -- brainfuck )
[ dup pointer>> ] dip + >>pointer ;
: (<) ( brainfuck n -- brainfuck )
[ dup pointer>> ] dip - >>pointer ;
: (#) ( brainfuck -- brainfuck )
dup
[ "ptr=" write pointer>> pprint ]
[ ",mem=" write memory>> pprint nl ] bi ;
: compose-all ( seq -- quot )
[ ] [ compose ] reduce ;
EBNF: parse-brainfuck
inc-ptr = (">")+ => [[ length 1quotation [ (>) ] append ]]
dec-ptr = ("<")+ => [[ length 1quotation [ (<) ] append ]]
inc-mem = ("+")+ => [[ length 1quotation [ (+) ] append ]]
dec-mem = ("-")+ => [[ length 1quotation [ (-) ] append ]]
output = "." => [[ [ (.) ] ]]
input = "," => [[ [ (,) ] ]]
debug = "#" => [[ [ (#) ] ]]
space = (" "|"\t"|"\r\n"|"\n")+ => [[ [ ] ]]
unknown = (.) => [[ "Invalid input" throw ]]
ops = inc-ptr|dec-ptr|inc-mem|dec-mem|output|input|debug|space
loop = "[" {loop|ops}+ "]" => [[ second compose-all 1quotation [ [ (?) ] ] prepend [ while ] append ]]
code = (loop|ops|unknown)* => [[ compose-all ]]
;EBNF
PRIVATE>
MACRO: run-brainfuck ( code -- )
[ <brainfuck> ] swap parse-brainfuck [ drop flush ] 3append ;
: get-brainfuck ( code -- result )
[ run-brainfuck ] with-string-writer ; inline

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

@ -0,0 +1 @@
Brainfuck programming language.

3
extra/fuel/help/help.factor
View File

@ -4,7 +4,8 @@
USING: accessors arrays assocs combinators help help.crossref USING: accessors arrays assocs combinators help help.crossref
help.markup help.topics io io.streams.string kernel make namespaces help.markup help.topics io io.streams.string kernel make namespaces
parser prettyprint sequences summary help.vocabs parser prettyprint sequences summary help.vocabs
vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see ; vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see
listener ;
IN: fuel.help IN: fuel.help

8
extra/images/processing/rotation/rotation-tests.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Kobi Lurie, Doug Coleman. ! Copyright (C) 2009 Kobi Lurie, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors fry images.loader images.normalization USING: accessors fry images.loader
images.processing.rotation kernel literals math sequences images.processing.rotation kernel literals math sequences
tools.test images.processing.rotation.private ; tools.test images.processing.rotation.private ;
IN: images.processing.rotation.tests IN: images.processing.rotation.tests
@ -24,13 +24,13 @@ IN: images.processing.rotation.tests
CONSTANT: pasted-image CONSTANT: pasted-image
$[ $[
"vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp" "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"
load-image normalize-image clone-image load-image clone-image
] ]
CONSTANT: pasted-image90 CONSTANT: pasted-image90
$[ $[
"vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp" "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"
load-image normalize-image clone-image load-image clone-image
] ]
CONSTANT: lake-image CONSTANT: lake-image
@ -55,7 +55,7 @@ CONSTANT: lake-image
"vocab:images/processing/rotation/test-bitmaps/small.bmp" "vocab:images/processing/rotation/test-bitmaps/small.bmp"
load-image 90 rotate load-image 90 rotate
"vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp" "vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp"
load-image normalize-image = load-image =
] unit-test ] unit-test
[ t ] [ [ t ] [

3
extra/managed-server/chat/chat.factor
View File

@ -126,7 +126,8 @@ M: chat-server handle-client-disconnect
] "" append-outputs-as send-everyone ; ] "" append-outputs-as send-everyone ;
M: chat-server handle-already-logged-in M: chat-server handle-already-logged-in
username username-taken-string send-line ; username username-taken-string send-line
t client (>>quit?) ;
M: chat-server handle-managed-client* M: chat-server handle-managed-client*
readln dup f = [ t client (>>quit?) ] when readln dup f = [ t client (>>quit?) ] when

31
extra/managed-server/managed-server.factor
View File

@ -11,7 +11,7 @@ TUPLE: managed-server < threaded-server clients ;
TUPLE: managed-client TUPLE: managed-client
input-stream output-stream local-address remote-address input-stream output-stream local-address remote-address
username object quit? ; username object quit? logged-in? ;
HOOK: handle-login threaded-server ( -- username ) HOOK: handle-login threaded-server ( -- username )
HOOK: handle-managed-client* managed-server ( -- ) HOOK: handle-managed-client* managed-server ( -- )
@ -62,26 +62,39 @@ PRIVATE>
local-address get >>local-address local-address get >>local-address
remote-address get >>remote-address ; remote-address get >>remote-address ;
: check-logged-in ( username -- username ) : maybe-login-client ( -- )
dup clients key? [ handle-already-logged-in ] when ; username clients key? [
handle-already-logged-in
] [
t client (>>logged-in?)
client username clients set-at
] if ;
: add-managed-client ( -- ) : when-logged-in ( quot -- )
client username check-logged-in clients set-at ; client logged-in?>> [ call ] [ drop ] if ; inline
: delete-managed-client ( -- ) : delete-managed-client ( -- )
username server clients>> delete-at ; [ username server clients>> delete-at ] when-logged-in ;
: handle-managed-client ( -- ) : handle-managed-client ( -- )
handle-login <managed-client> managed-client set handle-login <managed-client> managed-client set
add-managed-client handle-client-join maybe-login-client [
[ handle-managed-client* client quit?>> not ] loop ; handle-client-join
[ handle-managed-client* client quit?>> not ] loop
] when-logged-in ;
: cleanup-client ( -- )
[
delete-managed-client
handle-client-disconnect
] when-logged-in ;
PRIVATE> PRIVATE>
M: managed-server handle-client* M: managed-server handle-client*
managed-server set managed-server set
[ handle-managed-client ] [ handle-managed-client ]
[ delete-managed-client handle-client-disconnect ] [ cleanup-client ]
[ ] cleanup ; [ ] cleanup ;
: new-managed-server ( port name encoding class -- server ) : new-managed-server ( port name encoding class -- server )

18
misc/bash/cdfactor.sh Executable file
View File

@ -0,0 +1,18 @@
#!/bin/bash
# change directories to a factor module
function cdfactor {
code=$(printf "USING: io io.pathnames vocabs vocabs.loader ; "
printf "\"%s\" <vocab> vocab-source-path (normalize-path) print" $1)
echo $code > $HOME/.cdfactor
fn=$(factor $HOME/.cdfactor)
dn=$(dirname $fn)
echo $dn
if [ -z "$dn" ]; then
echo "Warning: directory '$1' not found" 1>&2
else
cd $dn
fi
}

16
misc/fuel/factor-mode.el
View File

@ -125,7 +125,8 @@ code in the buffer."
(defun factor-mode--indent-setter-line () (defun factor-mode--indent-setter-line ()
(when (fuel-syntax--at-setter-line) (when (fuel-syntax--at-setter-line)
(save-excursion (save-excursion
(let ((indent (and (fuel-syntax--at-constructor-line) (current-indentation)))) (let ((indent (and (fuel-syntax--at-constructor-line)
(current-indentation))))
(while (not (or indent (while (not (or indent
(bobp) (bobp)
(fuel-syntax--at-begin-of-def) (fuel-syntax--at-begin-of-def)
@ -225,6 +226,19 @@ code in the buffer."
(defsubst factor-mode--cycling-setup () (defsubst factor-mode--cycling-setup ()
(setq factor-mode--cycling-no-ask nil)) (setq factor-mode--cycling-no-ask nil))
(defun factor-mode--code-file (kind &optional file)
(let* ((file (or file (buffer-file-name)))
(bn (file-name-nondirectory file)))
(and (string-match (format "\\(.+\\)-%s\\.factor$" kind) bn)
(expand-file-name (concat (match-string 1 bn) ".factor")
(file-name-directory file)))))
(defsubst factor-mode--in-docs (&optional file)
(factor-mode--code-file "docs"))
(defsubst factor-mode--in-tests (&optional file)
(factor-mode--code-file "tests"))
(defun factor-mode-visit-other-file (&optional skip) (defun factor-mode-visit-other-file (&optional skip)
"Cycle between code, tests and docs factor files. "Cycle between code, tests and docs factor files.
With prefix, non-existing files will be skipped." With prefix, non-existing files will be skipped."

2
misc/fuel/fuel-markup.el
View File

@ -382,7 +382,7 @@
(when (looking-at "Word *\\(Stack effect\\|Syntax\\)$") (when (looking-at "Word *\\(Stack effect\\|Syntax\\)$")
(push (list "Word" (match-string-no-properties 1)) rows) (push (list "Word" (match-string-no-properties 1)) rows)
(forward-line)) (forward-line))
(while (looking-at "\\(.+?\\)\\( +\\(.+\\)\\)?$") (while (looking-at " ?\\(.+?\\)\\( +\\(.+\\)\\)?$")
(let ((word `($link ,(match-string-no-properties 1) (let ((word `($link ,(match-string-no-properties 1)
,(match-string-no-properties 1) ,(match-string-no-properties 1)
word)) word))

5
misc/fuel/fuel-mode.el
View File

@ -172,7 +172,10 @@ interacting with a factor listener is at your disposal.
(when fuel-mode-autodoc-p (fuel-autodoc-mode fuel-mode)) (when fuel-mode-autodoc-p (fuel-autodoc-mode fuel-mode))
(setq fuel-stack-mode-string "/S") (setq fuel-stack-mode-string "/S")
(when fuel-mode-stack-p (fuel-stack-mode fuel-mode))) (when fuel-mode-stack-p (fuel-stack-mode fuel-mode))
(when (and fuel-mode (not (file-exists-p (buffer-file-name))))
(fuel-scaffold--maybe-insert)))
;;; Keys: ;;; Keys:

62
misc/fuel/fuel-scaffold.el
View File

@ -39,6 +39,64 @@
(let ((cmd '(:fuel* (vocab-roots get :get) "fuel"))) (let ((cmd '(:fuel* (vocab-roots get :get) "fuel")))
(fuel-eval--retort-result (fuel-eval--send/wait cmd)))) (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
(defun fuel-scaffold--dev-name ()
(or fuel-scaffold-developer-name
(let ((cmd '(:fuel* (developer-name get :get) "fuel")))
(fuel-eval--retort-result (fuel-eval--send/wait cmd)))
"Your name"))
(defun fuel-scaffold--first-vocab ()
(goto-char (point-min))
(re-search-forward fuel-syntax--current-vocab-regex nil t))
(defsubst fuel-scaffold--vocab (file)
(save-excursion
(set-buffer (find-file-noselect file))
(fuel-scaffold--first-vocab)
(fuel-syntax--current-vocab)))
(defconst fuel-scaffold--tests-header-format
"! Copyright (C) %s %s
! See http://factorcode.org/license.txt for BSD license.
USING: %s tools.test ;
IN: %s
")
(defsubst fuel-scaffold--check-auto (var)
(and var (or (eq var 'always) (y-or-n-p "Insert template? "))))
(defun fuel-scaffold--tests (parent)
(when (and parent (fuel-scaffold--check-auto fuel-scaffold-test-autoinsert-p))
(let ((year (format-time-string "%Y"))
(name (fuel-scaffold--dev-name))
(vocab (fuel-scaffold--vocab parent)))
(insert (format fuel-scaffold--tests-header-format
year name vocab vocab))
t)))
(defsubst fuel-scaffold--create-docs (vocab)
(let ((cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help)
"fuel")))
(fuel-eval--send/wait cmd)))
(defun fuel-scaffold--help (parent)
(when (and parent (fuel-scaffold--check-auto fuel-scaffold-help-autoinsert-p))
(let* ((ret (fuel-scaffold--create-docs (fuel-scaffold--vocab parent)))
(file (fuel-eval--retort-result ret)))
(when file
(revert-buffer t t t)
(when (and fuel-scaffold-help-header-only-p
(fuel-scaffold--first-vocab))
(delete-region (1+ (point)) (point-max))
(save-buffer))
(message "Inserting template ... done."))
(goto-char (point-min)))))
(defun fuel-scaffold--maybe-insert ()
(ignore-errors
(or (fuel-scaffold--tests (factor-mode--in-tests))
(fuel-scaffold--help (factor-mode--in-docs)))))
;;; User interface: ;;; User interface:
@ -73,9 +131,7 @@ You can configure `fuel-scaffold-developer-name' (set by default to
(interactive "P") (interactive "P")
(let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab)) (let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
(fuel-completion--read-vocab nil))) (fuel-completion--read-vocab nil)))
(cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help) (ret (fuel-scaffold--create-docs vocab))
"fuel"))
(ret (fuel-eval--send/wait cmd))
(file (fuel-eval--retort-result ret))) (file (fuel-eval--retort-result ret)))
(unless file (unless file
(error "Error creating help file" (car (fuel-eval--retort-error ret)))) (error "Error creating help file" (car (fuel-eval--retort-error ret))))

70
misc/fuel/fuel-table.el
View File

@ -72,21 +72,67 @@
(push (fuel-table--pad-row (reverse frow)) frows))) (push (fuel-table--pad-row (reverse frow)) frows)))
(reverse frows))) (reverse frows)))
(defvar fuel-table-corner-lt "┌")
(defvar fuel-table-corner-lb "└")
(defvar fuel-table-corner-rt "┐")
(defvar fuel-table-corner-rb "┘")
(defvar fuel-table-line "─")
(defvar fuel-table-tee-t "┬")
(defvar fuel-table-tee-b "┴")
(defvar fuel-table-tee-l "├")
(defvar fuel-table-tee-r "┤")
(defvar fuel-table-crux "┼")
(defvar fuel-table-sep "│")
(defun fuel-table--insert-line (widths first last sep)
(insert first fuel-table-line)
(dolist (w widths)
(while (> w 0)
(insert fuel-table-line)
(setq w (1- w)))
(insert fuel-table-line sep fuel-table-line))
(delete-char -2)
(insert fuel-table-line last)
(newline))
(defun fuel-table--insert-first-line (widths)
(fuel-table--insert-line widths
fuel-table-corner-lt
fuel-table-corner-rt
fuel-table-tee-t))
(defun fuel-table--insert-middle-line (widths)
(fuel-table--insert-line widths
fuel-table-tee-l
fuel-table-tee-r
fuel-table-crux))
(defun fuel-table--insert-last-line (widths)
(fuel-table--insert-line widths
fuel-table-corner-lb
fuel-table-corner-rb
fuel-table-tee-b))
(defun fuel-table--insert-row (r)
(let ((ln (length (car r)))
(l 0))
(while (< l ln)
(insert (concat fuel-table-sep " "
(mapconcat 'identity
(mapcar `(lambda (x) (nth ,l x)) r)
(concat " " fuel-table-sep " "))
" " fuel-table-sep "\n"))
(setq l (1+ l)))))
(defun fuel-table--insert (rows) (defun fuel-table--insert (rows)
(let* ((widths (fuel-table--col-widths rows)) (let* ((widths (fuel-table--col-widths rows))
(rows (fuel-table--format-rows rows widths)) (rows (fuel-table--format-rows rows widths)))
(ls (concat "+" (mapconcat (lambda (n) (make-string n ?-)) widths "-+") "-+"))) (fuel-table--insert-first-line widths)
(insert ls "\n")
(dolist (r rows) (dolist (r rows)
(let ((ln (length (car r))) (fuel-table--insert-row r)
(l 0)) (fuel-table--insert-middle-line widths))
(while (< l ln) (kill-line -1)
(insert (concat "|" (mapconcat 'identity (fuel-table--insert-last-line widths)))
(mapcar `(lambda (x) (nth ,l x)) r)
" |")
" |\n"))
(setq l (1+ l))))
(insert ls "\n"))))
(provide 'fuel-table) (provide 'fuel-table)