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

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
] unless
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
[ [ 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
[ [ 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

4
basis/circular/circular.factor
View File

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

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

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

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

@ -16,6 +16,9 @@ ERROR: last-insn-not-a-jump insn ;
[ ##return? ]
[ ##callback-return? ]
[ ##jump? ]
[ ##fixnum-add-tail? ]
[ ##fixnum-sub-tail? ]
[ ##fixnum-mul-tail? ]
[ ##call? ]
} 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.
USING: namespaces sequences math math.order kernel assocs
accessors vectors fry heaps cpu.architecture combinators
compiler.cfg.registers
compiler.cfg.linear-scan.live-intervals ;
accessors vectors fry heaps cpu.architecture sorting locals
combinators compiler.cfg.registers
compiler.cfg.linear-scan.live-intervals hints ;
IN: compiler.cfg.linear-scan.allocation
! Mapping from register classes to sequences of machine registers
@ -27,13 +27,61 @@ SYMBOL: active-intervals
: delete-active ( live-interval -- )
dup vreg>> active-intervals-for delq ;
: expire-old-intervals ( n -- )
active-intervals swap '[
[
[ end>> _ < ] partition
[ [ deallocate-register ] each ] dip
] assoc-map
] change ;
! Vector of inactive live intervals
SYMBOL: inactive-intervals
: inactive-intervals-for ( vreg -- seq )
reg-class>> inactive-intervals get at ;
: 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
SYMBOL: unhandled-intervals
@ -66,29 +114,64 @@ SYMBOL: progress
: coalesce ( live-interval -- )
dup copy-from>> active-interval
[ [ add-active ] [ delete-active ] bi* ]
[ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
[ reg>> >>reg drop ]
2bi ;
! Splitting
: find-use ( live-interval n quot -- i elt )
[ uses>> ] 2dip curry find ; inline
: split-range ( live-range n -- before after )
[ [ from>> ] dip <live-range> ]
[ 1 + swap to>> <live-range> ]
2bi ;
: split-before ( live-interval i -- before )
[ clone dup uses>> ] dip
[ head >>uses ] [ 1- swap nth >>end ] 2bi ;
: split-last-range? ( last n -- ? )
swap to>> <= ;
: split-after ( live-interval i -- after )
[ clone dup uses>> ] dip
[ tail >>uses ] [ swap nth >>start ] 2bi
f >>reg f >>copy-from ;
: split-last-range ( before after last n -- before' after' )
split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ;
: split-interval ( live-interval n -- before after )
[ drop ] [ [ > ] find-use drop ] 2bi
[ split-before ] [ split-after ] 2bi ;
: split-ranges ( live-ranges n -- before after )
[ '[ from>> _ <= ] partition ]
[
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 -- )
[ >>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
SYMBOL: spill-counts
@ -96,6 +179,9 @@ SYMBOL: spill-counts
: next-spill-location ( reg-class -- n )
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 )
#! We spill the interval with the most distant use location.
start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
@ -108,8 +194,7 @@ SYMBOL: spill-counts
[ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
: split-and-spill ( new existing -- before after )
dup rot start>> split-interval
[ record-split ] [ assign-spill ] 2bi ;
swap start>> split-interval assign-spill ;
: reuse-register ( new existing -- )
reg>> >>reg add-active ;
@ -121,7 +206,7 @@ SYMBOL: spill-counts
#! of the existing interval again.
[ reuse-register ]
[ nip delete-active ]
[ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ;
[ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
: spill-new ( new existing -- )
#! Our new interval will be used after the active interval
@ -141,37 +226,101 @@ SYMBOL: spill-counts
: assign-free-register ( new registers -- )
pop >>reg add-active ;
: assign-register ( new -- )
dup coalesce? [
coalesce
: relevant-ranges ( new inactive -- new' inactive' )
! Slice off all ranges of 'inactive' that precede the start of 'new'
[ [ 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
[ assign-blocked-register ]
[ assign-free-register ]
[ split-before-use ] keep
'[ _ fits-in-hole ] [ add-unhandled ] bi*
] 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 ;
! 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 -- )
<min-heap> unhandled-intervals set
[ reverse >vector ] assoc-map free-registers set
reg-classes [ 0 ] { } map>assoc spill-counts set
reg-classes [ V{ } clone ] { } map>assoc active-intervals set
[ 0 ] reg-class-assoc spill-counts 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 ;
: handle-interval ( live-interval -- )
[ start>> progress set ]
[ start>> expire-old-intervals ]
[ assign-register ]
tri ;
[
start>>
[ progress set ]
[ deactivate-intervals ]
[ activate-intervals ] tri
] [ assign-register ] bi ;
: (allocate-registers) ( -- )
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 )
#! This modifies the input live-intervals.
init-allocator
dup init-unhandled
(allocate-registers) ;
init-unhandled
(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.
USING: accessors kernel math assocs namespaces sequences heaps
fry make combinators
fry make combinators sets
cpu.architecture
compiler.cfg.def-use
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.assignment
@ -25,35 +26,49 @@ TUPLE: active-intervals seq ;
SYMBOL: unhandled-intervals
: add-unhandled ( live-interval -- )
dup split-before>> [
[ split-before>> ] [ split-after>> ] bi
[ add-unhandled ] bi@
] [
dup start>> unhandled-intervals get heap-push
] if ;
dup start>> unhandled-intervals get heap-push ;
: init-unhandled ( live-intervals -- )
[ 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 -- )
[ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri
dup [ _spill ] [ 3drop ] if ;
[ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
: handle-spill ( live-interval -- )
dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
: expire-old-intervals ( n -- )
active-intervals get
[ 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 -- )
[ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri
dup [ _reload ] [ 3drop ] if ;
[ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
: handle-reload ( live-interval -- )
dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] if ;
: activate-new-intervals ( n -- )
#! Any live intervals which start on the current instruction
#! are added to the active set.
unhandled-intervals get dup heap-empty? [ 2drop ] [
2dup heap-peek drop start>> = [
heap-pop drop [ add-active ] [ insert-reload ] bi
heap-pop drop
[ add-active ] [ handle-reload ] bi
activate-new-intervals
] [ 2drop ] if
] if ;
@ -76,8 +91,7 @@ M: insn assign-before drop ;
active-intervals get seq>> [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
: compute-live-spill-slots ( -- spill-slots )
unhandled-intervals get
heap-values [ reload-from>> ] filter
spill-slots get values [ values ] map concat
[ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
M: ##gc assign-after
@ -93,6 +107,7 @@ M: insn assign-after drop ;
: init-assignment ( live-intervals -- )
<active-intervals> active-intervals set
<min-heap> unhandled-intervals set
[ H{ } clone ] reg-class-assoc spill-slots set
init-unhandled ;
: 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.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 ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
@ -44,23 +98,26 @@ compiler.cfg.linear-scan.debugger ;
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 1 }
{ uses V{ 0 1 } }
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 1 }
{ uses V{ 0 1 } }
{ ranges V{ T{ live-range f 0 1 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
{ ranges V{ T{ live-range f 5 5 } } }
}
] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
{ ranges V{ T{ live-range f 0 5 } } }
} 2 split-interval
] unit-test
@ -70,12 +127,14 @@ compiler.cfg.linear-scan.debugger ;
{ start 0 }
{ end 0 }
{ uses V{ 0 } }
{ ranges V{ T{ live-range f 0 0 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 5 }
{ uses V{ 1 5 } }
{ ranges V{ T{ live-range f 1 5 } } }
}
] [
T{ live-interval
@ -83,6 +142,7 @@ compiler.cfg.linear-scan.debugger ;
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
{ ranges V{ T{ live-range f 0 5 } } }
} 0 split-interval
] 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" } } }
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 { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 11 } { end 20 } { uses V{ 11 20 } } }
T{ live-interval
{ 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" } } }
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 { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 60 } { uses V{ 30 60 } } }
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 } } }
}
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" } } }
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 { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 200 } { uses V{ 30 200 } } }
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 } } }
}
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" } } }
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 { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 100 } { uses V{ 30 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 } } }
}
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" } } }
check-linear-scan
@ -272,31 +386,10 @@ USING: math.private compiler.cfg.debugger ;
test-cfg first optimize-cfg linear-scan drop
] unit-test
[ 0 1 ] [
{
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ 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
: fake-live-ranges ( seq -- seq' )
[
clone dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
] map ;
! Coalescing interacted badly with splitting
[ ] [
@ -345,7 +438,7 @@ USING: math.private compiler.cfg.debugger ;
{ end 10 }
{ uses V{ 9 10 } }
}
}
} fake-live-ranges
{ { int-regs { 0 1 2 3 } } }
allocate-registers drop
] unit-test
@ -1100,7 +1193,7 @@ USING: math.private compiler.cfg.debugger ;
{ end 109 }
{ uses V{ 103 109 } }
}
}
} fake-live-ranges
{ { int-regs { 0 1 2 3 4 } } }
allocate-registers drop
] unit-test
@ -1193,7 +1286,92 @@ USING: math.private compiler.cfg.debugger ;
{ end 92 }
{ uses V{ 42 45 78 80 92 } }
}
}
} fake-live-ranges
{ { int-regs { 0 1 2 3 } } }
allocate-registers drop
] 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
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
: (linear-scan) ( rpo -- )
dup number-instructions
dup compute-live-intervals
machine-registers allocate-registers assign-registers ;
: (linear-scan) ( rpo machine-registers -- )
[
dup number-instructions
dup compute-live-intervals
] dip
allocate-registers assign-registers ;
: linear-scan ( cfg -- cfg' )
[
dup reverse-post-order (linear-scan)
dup reverse-post-order machine-registers (linear-scan)
spill-counts get >>spill-counts
] 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.
! See http://factorcode.org/license.txt for BSD license.
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 ;
IN: compiler.cfg.linear-scan.live-intervals
@ -109,6 +109,7 @@ M: ##copy-float compute-live-intervals*
: compute-start/end ( live-interval -- )
dup ranges>> [ first from>> ] [ last to>> ] bi
2dup > [ "BUG: start > end" throw ] when
[ >>start ] [ >>end ] bi* drop ;
: 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.liveness
compiler.cfg.rpo
compiler.cfg.phi-elimination ;
compiler.cfg.phi-elimination
compiler.cfg.checker ;
IN: compiler.cfg.optimizer
SYMBOL: check-optimizer?
: ?check ( cfg -- cfg' )
check-optimizer? get [
dup check-cfg
] when ;
: optimize-cfg ( cfg -- cfg' )
[
compute-predecessors
@ -27,4 +35,5 @@ IN: compiler.cfg.optimizer
eliminate-dead-code
eliminate-write-barriers
eliminate-phis
?check
] with-scope ;

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

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

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

@ -8,6 +8,7 @@ continuations.private fry cpu.architecture
source-files.errors
compiler.errors
compiler.alien
compiler.constants
compiler.cfg
compiler.cfg.instructions
compiler.cfg.stack-frame
@ -94,7 +95,9 @@ M: _dispatch generate-insn
[ src>> register ] [ temp>> register ] bi %dispatch ;
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 )
{

3
basis/compiler/compiler.factor
View File

@ -193,7 +193,8 @@ M: optimizing-compiler recompile ( words -- alist )
] each
compile-queue get compile-loop
compiled get >alist
] with-scope ;
] with-scope
"trace-compilation" get [ "--- compile done" print flush ] when ;
: with-optimizer ( quot -- )
[ 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 ;
IN: compression.run-length
: run-length-uncompress8 ( byte-array -- byte-array' )
: run-length-uncompress ( byte-array -- byte-array' )
2 group [ first2 <array> ] map concat ;

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

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test constructors calendar kernel accessors
combinators.short-circuit ;
combinators.short-circuit initializers math ;
IN: constructors.tests
TUPLE: stock-spread stock spread timestamp ;
@ -18,4 +18,42 @@ SYMBOL: AAPL
[ spread>> 1234 = ]
[ timestamp>> timestamp? ]
} 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

55
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.
USING: slots kernel sequences fry accessors parser lexer words
effects.parser macros ;
USING: accessors assocs classes.tuple effects.parser fry
generalizations generic.standard kernel lexer locals macros
parser sequences slots vocabs words ;
IN: constructors
! An experiment
MACRO: set-slots ( slots -- quot )
<reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;
: initializer-name ( class -- word )
name>> "initialize-" prepend ;
: construct ( ... class slots -- instance )
[ new ] dip set-slots ; inline
: lookup-initializer ( class -- word/f )
initializer-name "initializers" lookup ;
: define-constructor ( name class effect body -- )
[ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
define-declared ;
: initializer-word ( class -- word )
initializer-name
"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:
scan-word [ name>> "<" ">" surround create-in ] keep
scan-constructor
complete-effect
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: %dispatch cpu ( src temp -- )
HOOK: %dispatch-label cpu ( label -- )
HOOK: %slot cpu ( dst obj slot tag temp -- )
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
math.order math.ranges system namespaces locals layouts words
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.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 ;
IN: cpu.ppc
@ -461,16 +462,18 @@ M:: ppc %write-barrier ( src card# table -- )
src card# deck-bits SRWI
table scratch-reg card# STBX ;
M: ppc %gc
M:: ppc %gc ( temp1 temp2 gc-roots gc-root-count -- )
"end" define-label
12 load-zone-ptr
11 12 cell LWZ ! nursery.here -> r11
12 12 3 cells LWZ ! nursery.end -> r12
11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
11 0 12 CMP ! is here >= end?
temp2 load-zone-ptr
temp1 temp2 cell LWZ
temp2 temp2 3 cells LWZ
temp1 temp1 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
temp1 0 temp2 CMP ! is here >= end?
"end" get BLE
%prepare-alien-invoke
"minor_gc" f %alien-invoke
0 3 LI
0 4 LI
"inline_gc" f %alien-invoke
"end" resolve-label ;
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: 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.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io.binary kernel combinators
kernel.private math namespaces make sequences words system layouts
math.order accessors cpu.x86.assembler.syntax ;
USING: arrays io.binary kernel combinators kernel.private math
namespaces make sequences words system layouts math.order accessors
cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler
! 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) ;
: SAR ( dst n -- ) BIN: 111 (SHIFT) ;
GENERIC: IMUL2 ( dst src -- )
M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
: IMUL2 ( dst src -- )
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 -- )
dup register-32? OCT: 143 OCT: 276 extended-opcode ?
over register-16? [ BIN: 1 opcode-or ] when
swapd
swap
over register-32? OCT: 143 OCT: 276 extended-opcode ?
pick register-16? [ BIN: 1 opcode-or ] when
(2-operand) ;
: MOVZX ( dst src -- )
swap
OCT: 266 extended-opcode
over register-16? [ BIN: 1 opcode-or ] when
swapd
pick register-16? [ BIN: 1 opcode-or ] when
(2-operand) ;
! Conditional move

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

@ -91,9 +91,6 @@ M: x86 %return ( -- ) 0 RET ;
: align-code ( n -- )
0 <repetition> % ;
M: x86 %dispatch-label ( label -- )
0 cell, rc-absolute-cell label-fixup ;
:: (%slot) ( obj slot tag temp -- op )
temp slot obj [+] LEA
temp tag neg [+] ; inline
@ -111,7 +108,7 @@ M: x86 %add-imm [+] LEA ;
M: x86 %sub nip SUB ;
M: x86 %sub-imm neg [+] LEA ;
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-imm nip AND ;
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 ] [ "[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
@ -95,3 +98,4 @@ IN: formatting.tests
[ t ] [ "Thu Oct 09 12:03:15 2008" testtime "%c" 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
help.topics io kernel namespaces parser sequences
source-files.errors vocabs.hierarchy vocabs words classes
locals tools.errors ;
locals tools.errors listener ;
FROM: help.lint.checks => all-vocabs ;
IN: help.lint

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

@ -2,77 +2,146 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays byte-arrays columns
combinators compression.run-length endian fry grouping images
images.loader io io.binary io.encodings.binary io.files kernel
locals macros math math.bitwise math.functions namespaces
sequences strings summary ;
images.loader io io.binary io.encodings.binary io.files
io.streams.limited kernel locals macros math math.bitwise
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
: assert-sequence= ( a b -- )
2dup sequence= [ 2drop ] [ assert ] if ;
: read2 ( -- n ) 2 read le> ;
: read4 ( -- n ) 4 read le> ;
: write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ;
TUPLE: bitmap-image < image ;
! Used to construct the final bitmap-image
SINGLETON: bitmap-image
"bmp" bitmap-image register-image-class
TUPLE: loading-bitmap
size reserved offset header-length width
magic size reserved1 reserved2 offset header-length width
height planes bit-count compression size-image
x-pels y-pels color-used color-important color-palette color-index
uncompressed-bytes ;
x-pels y-pels color-used color-important
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 ;
M: bitmap-magic summary
drop "First two bytes of bitmap stream must be 'BM'" ;
! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint
<PRIVATE
: 8bit>buffer ( bitmap -- array )
[ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ]
[ color-index>> >array ] bi [ swap nth ] with map concat ;
: os2-color-lookup ( loading-bitmap -- seq )
[ color-index>> >array ]
[ 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 ;
: reverse-lines ( byte-array width -- byte-array )
<sliced-groups> <reversed> concat ; inline
: uncompress-bitfield ( seq masks -- bytes' )
'[
_ [
[ 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>>
{
{ 32 [ color-index>> ] }
{ 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] }
{ 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] }
{ 24 [ color-index>> ] }
{ 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 ]
} 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 ;
: uncompress-bitmap ( loading-bitmap -- loading-bitmap' )
dup compression>> {
{ f [ ] }
{ 0 [ ] }
{ 1 [ [ run-length-uncompress8 ] change-color-index ] }
{ 2 [ "run-length encoding 4" unsupported-bitmap-compression ] }
{ 3 [ "bitfields" unsupported-bitmap-compression ] }
{ 1 [ [ run-length-uncompress ] change-color-index ] }
{ 2 [ [ 4 b:byte-array-n>seq run-length-uncompress >byte-array ] change-color-index ] }
{ 3 [ uncompress-bitfield-widths ] }
{ 4 [ "jpeg" unsupported-bitmap-compression ] }
{ 5 [ "png" unsupported-bitmap-compression ] }
} case ;
: bitmap-padding ( width -- n )
3 * 4 mod 4 swap - 4 mod ; inline
: loading-bitmap>bytes ( loading-bitmap -- byte-array )
uncompress-bitmap bitmap>bytes ;
uncompress-bitmap
bitmap>bytes ;
: parse-file-header ( loading-bitmap -- loading-bitmap )
2 read "BM" assert-sequence=
2 read latin1 decode >>magic
read4 >>size
read4 >>reserved
read2 >>reserved1
read2 >>reserved2
read4 >>offset ;
: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
read4 >>header-length
: read-v3-header ( loading-bitmap -- loading-bitmap )
read4 >>width
read4 32 >signed >>height
read2 >>planes
@ -84,6 +153,50 @@ ERROR: unsupported-bitmap-compression compression ;
read4 >>color-used
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 )
[ offset>> 14 - ] [ header-length>> ] bi - ;
@ -98,56 +211,54 @@ ERROR: unsupported-bitmap-compression compression ;
: image-size ( loading-bitmap -- n )
[ [ 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 )
dup color-palette-length read >>color-palette
dup color-index-length read >>color-index
fixup-color-index ;
dup size-image>> dup 0 > [
read >>color-index
] [
drop dup color-index-length read >>color-index
] if ;
ERROR: unsupported-bitmap-file magic ;
: load-bitmap ( path -- loading-bitmap )
binary [
binary stream-throws <limited-file-reader> [
loading-bitmap new
parse-file-header parse-bitmap-header parse-bitmap
] with-file-reader ;
parse-file-header dup magic>> {
{ "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 ;
: bitmap>component-order ( loading-bitmap -- object )
bit-count>> {
{ 32 [ BGRA ] }
{ 32 [ BGR ] }
{ 24 [ BGR ] }
{ 16 [ BGR ] }
{ 8 [ BGR ] }
{ 4 [ BGR ] }
{ 1 [ BGR ] }
[ unknown-component-order ]
} 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 ]
[ [ 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 ]
} cleave ;
M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
swap load-bitmap loading-bitmap>bitmap-image ;
"bmp" bitmap-image register-image-class
PRIVATE>
: bitmap>color-index ( bitmap -- byte-array )
@ -165,6 +276,9 @@ PRIVATE>
] if
] bi ;
: reverse-lines ( byte-array width -- byte-array )
<sliced-groups> <reversed> concat ; inline
: save-bitmap ( image path -- )
binary [
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? ;
GENERIC: load-image* ( path tuple -- 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 ;
GENERIC: load-image* ( path class -- image )
<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.ranges math.vectors memoize multiline namespaces
sequences sequences.deep images.loader ;
QUALIFIED-WITH: bitstreams bs
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 }
{ bitstream }
{ color-info initial: { f f f f } }
@ -21,7 +23,7 @@ TUPLE: jpeg-image < image
<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
APP JPG COM TEM RES ;
@ -63,7 +65,7 @@ TUPLE: 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' )
[ diff>> + dup ] [ (>>diff) ] bi ;
@ -291,9 +293,9 @@ PRIVATE>
binary [
parse-marker { SOI } assert=
parse-headers
contents <jpeg-image>
contents <loading-jpeg>
] with-file-reader
dup jpeg-image [
dup loading-jpeg [
baseline-parse
baseline-decompress
jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
@ -302,5 +304,3 @@ PRIVATE>
M: jpeg-image load-image* ( path jpeg-image -- bitmap )
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 ;
<PRIVATE
SYMBOL: types
types [ H{ } clone ] initialize
: image-class ( path -- class )
file-extension >lower types get ?at
[ unknown-image-extension ] unless ;
PRIVATE>
: register-image-class ( extension class -- )
swap types get set-at ;
: 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 ;
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
filter-method interlace-method uncompressed ;
CONSTRUCTOR: png-image ( -- image )
V{ } clone >>chunks ;
CONSTRUCTOR: loading-png ( -- image )
V{ } clone >>chunks ;
TUPLE: png-chunk length type data ;
@ -104,9 +107,8 @@ ERROR: unimplemented-color-type image ;
} case ;
: load-png ( path -- image )
[ binary <file-reader> ] [ file-info size>> ] bi
stream-throws <limited-stream> [
<png-image>
binary stream-throws <limited-file-reader> [
<loading-png>
read-png-header
read-png-chunks
parse-ihdr-chunk
@ -116,5 +118,3 @@ ERROR: unimplemented-color-type image ;
M: png-image load-image*
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 ;
IN: images.tiff
TUPLE: tiff-image < image ;
SINGLETON: tiff-image
TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ;
CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ;
TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
CONSTRUCTOR: loading-tiff ( -- tiff ) V{ } clone >>ifds ;
TUPLE: ifd count ifd-entries next
processed-tags strips bitmap ;
@ -410,7 +410,7 @@ ERROR: bad-small-ifd-type n ;
[ nip unhandled-ifd-entry swap ]
} case ;
: process-ifds ( parsed-tiff -- parsed-tiff )
: process-ifds ( loading-tiff -- loading-tiff )
[
[
dup ifd-entries>>
@ -483,18 +483,6 @@ ERROR: unknown-component-order ifd ;
[ unknown-component-order ]
} 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 )
dup extra-samples find-tag {
{ extra-samples-associated-alpha-data [ ] }
@ -508,17 +496,17 @@ ERROR: unknown-component-order ifd ;
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
[ ifd-component-order f ]
[ bitmap>> ]
} cleave tiff-image boa ;
} cleave image boa ;
: tiff>image ( image -- image )
ifds>> [ ifd>image ] map first ;
: with-tiff-endianness ( parsed-tiff quot -- )
: with-tiff-endianness ( loading-tiff quot -- )
[ dup endianness>> ] dip with-endianness ; inline
: load-tiff-ifds ( path -- parsed-tiff )
: load-tiff-ifds ( path -- loading-tiff )
binary [
<parsed-tiff>
<loading-tiff>
read-header [
dup ifd-offset>> read-ifds
process-ifds
@ -550,10 +538,10 @@ ERROR: unknown-component-order ifd ;
drop "no planar configuration" throw
] if ;
: process-tif-ifds ( parsed-tiff -- )
: process-tif-ifds ( loading-tiff -- )
ifds>> [ process-ifd ] each ;
: load-tiff ( path -- parsed-tiff )
: load-tiff ( path -- loading-tiff )
[ load-tiff-ifds dup ] keep
binary [
[ 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) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math io io.encodings destructors accessors
sequences namespaces byte-vectors fry combinators ;
USING: accessors byte-vectors combinators destructors fry io
io.encodings io.files io.files.info kernel math namespaces
sequences ;
IN: io.streams.limited
TUPLE: limited-stream stream count limit mode stack ;
@ -16,6 +17,12 @@ SINGLETONS: stream-throws stream-eofs ;
swap >>stream
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' )
M: decoder limit ( stream limit mode -- stream' )

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

@ -1 +1,3 @@
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
{ 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
! 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
{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test
{ H{ { "a" { } } { "b" 123 } } } [ "{\"a\":[],\"b\":123}" json> ] unit-test
{ { } } [ "[]" json> ] unit-test
{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test
{ H{ } } [ "{}" json> ] unit-test

138
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.
USING: kernel peg peg.ebnf math.parser math.parser.private strings math
math.functions sequences arrays vectors hashtables assocs
prettyprint json ;
USING: arrays assocs combinators io io.streams.string json
kernel math math.parser math.parser.private prettyprint
sequences strings vectors ;
IN: json.reader
<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
: convert-string ( str -- str )
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 ;
: j-string ( -- str )
"\\\"" read-until CHAR: \" =
[ convert-string ] unless ;
: second-last ( seq -- second-last )
[ length 2 - ] keep nth ; inline
! Grammar for JSON from RFC 4627
EBNF: (json>)
: third-last ( seq -- third-last )
[ length 3 - ] keep nth ; inline
: last2 ( seq -- second-last last )
[ second-last ] [ last ] bi ; inline
ws = (" " | "\r" | "\t" | "\n")*
: last3 ( seq -- third-last second-last last )
[ third-last ] [ last2 ] bi ; inline
true = "true" => [[ t ]]
false = "false" => [[ f ]]
null = "null" => [[ json-null ]]
: v-over-push ( vec -- vec' )
dup length 2 >=
[
dup
[ pop ]
[ last ] bi push
] when ;
hex = [0-9a-fA-F]
char = '\\"' [[ CHAR: " ]]
| "\\\\" [[ 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 ]]
: v-pick-push ( vec -- vec' )
dup length 3 >=
[
dup
[ pop ]
[ second-last ] bi push
] when ;
sign = ("-" | "+")? => [[ "-" = "-" "" ? ]]
digits = [0-9]+ => [[ >string ]]
decimal = "." digits => [[ concat ]]
exp = ("e" | "E") sign digits => [[ concat ]]
number = sign digits decimal? exp? => [[ dup concat swap fourth [ string>float ] [ string>number ] if ]]
: (close-array) ( accum -- accum' )
dup last vector? [ v-over-push ] unless
dup pop >array over push ;
elements = value ("," value)* => [[ grammar-list>vector ]]
array = "[" elements?:arr "]" => [[ arr >array ]]
pair = ws string:key ws ":" value:val => [[ { key val } ]]
members = pair ("," pair)* => [[ grammar-list>vector ]]
object = "{" members?:hash "}" => [[ hash >hashtable ]]
val = true
| false
| null
| string
| number
| array
| object
value = ws val:v ws => [[ v ]]
;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>
: 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:"
{ $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
{ $values { "var" "a variable name" } }
{ $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
vectors words generic system combinators continuations debugger
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
GENERIC: stream-read-quot ( stream -- quot/f )
@ -124,6 +124,78 @@ t error-summary? set-global
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) ] 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
effects splitting generic.standard prettyprint.private
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
[ "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
compiler-impl
compiler.errors:compiler-errors
! definition-observers
interactive-vocabs
lexer-factory
print-use-hook
root-cache

62
core/parser/parser.factor
View File

@ -112,68 +112,6 @@ SYMBOL: bootstrap-syntax
call
] 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
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:"
{ $subsection use-vocab }
{ $subsection unuse-vocab }
{ $subsection only-use-vocabs }
{ $subsection add-qualified }
{ $subsection add-words-from }
{ $subsection add-words-excluding }
@ -117,10 +116,6 @@ HELP: unuse-vocab
{ $description "Removes a vocabulary from the current manifest." }
{ $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
{ $values { "vocab" "a vocabulary specifier" } { "prefix" string } }
{ $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
<PRIVATE
: clear-manifest ( -- )
manifest get
[ search-vocab-names>> clear-assoc ]
@ -61,6 +59,8 @@ C: <extra-words> extra-words
[ qualified-vocabs>> delete-all ]
tri ;
<PRIVATE
: (add-qualified) ( qualified -- )
manifest get qualified-vocabs>> push ;
@ -126,9 +126,6 @@ TUPLE: no-current-vocab ;
2bi
] [ drop ] if ;
: only-use-vocabs ( vocabs -- )
clear-manifest [ vocab ] filter [ use-vocab ] each ;
TUPLE: qualified vocab prefix words ;
: <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
help.markup help.topics io io.streams.string kernel make namespaces
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

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

@ -1,6 +1,6 @@
! Copyright (C) 2009 Kobi Lurie, Doug Coleman.
! 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
tools.test images.processing.rotation.private ;
IN: images.processing.rotation.tests
@ -24,13 +24,13 @@ IN: images.processing.rotation.tests
CONSTANT: pasted-image
$[
"vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"
load-image normalize-image clone-image
load-image clone-image
]
CONSTANT: pasted-image90
$[
"vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"
load-image normalize-image clone-image
load-image clone-image
]
CONSTANT: lake-image
@ -55,7 +55,7 @@ CONSTANT: lake-image
"vocab:images/processing/rotation/test-bitmaps/small.bmp"
load-image 90 rotate
"vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp"
load-image normalize-image =
load-image =
] unit-test
[ 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 ;
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*
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
input-stream output-stream local-address remote-address
username object quit? ;
username object quit? logged-in? ;
HOOK: handle-login threaded-server ( -- username )
HOOK: handle-managed-client* managed-server ( -- )
@ -62,26 +62,39 @@ PRIVATE>
local-address get >>local-address
remote-address get >>remote-address ;
: check-logged-in ( username -- username )
dup clients key? [ handle-already-logged-in ] when ;
: maybe-login-client ( -- )
username clients key? [
handle-already-logged-in
] [
t client (>>logged-in?)
client username clients set-at
] if ;
: add-managed-client ( -- )
client username check-logged-in clients set-at ;
: when-logged-in ( quot -- )
client logged-in?>> [ call ] [ drop ] if ; inline
: delete-managed-client ( -- )
username server clients>> delete-at ;
[ username server clients>> delete-at ] when-logged-in ;
: handle-managed-client ( -- )
handle-login <managed-client> managed-client set
add-managed-client handle-client-join
[ handle-managed-client* client quit?>> not ] loop ;
maybe-login-client [
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>
M: managed-server handle-client*
managed-server set
[ handle-managed-client ]
[ delete-managed-client handle-client-disconnect ]
[ cleanup-client ]
[ ] cleanup ;
: 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 ()
(when (fuel-syntax--at-setter-line)
(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
(bobp)
(fuel-syntax--at-begin-of-def)
@ -225,6 +226,19 @@ code in the buffer."
(defsubst factor-mode--cycling-setup ()
(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)
"Cycle between code, tests and docs factor files.
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\\)$")
(push (list "Word" (match-string-no-properties 1)) rows)
(forward-line))
(while (looking-at "\\(.+?\\)\\( +\\(.+\\)\\)?$")
(while (looking-at " ?\\(.+?\\)\\( +\\(.+\\)\\)?$")
(let ((word `($link ,(match-string-no-properties 1)
,(match-string-no-properties 1)
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))
(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:

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

@ -39,6 +39,64 @@
(let ((cmd '(:fuel* (vocab-roots get :get) "fuel")))
(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:
@ -73,9 +131,7 @@ You can configure `fuel-scaffold-developer-name' (set by default to
(interactive "P")
(let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
(fuel-completion--read-vocab nil)))
(cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help)
"fuel"))
(ret (fuel-eval--send/wait cmd))
(ret (fuel-scaffold--create-docs vocab))
(file (fuel-eval--retort-result ret)))
(unless file
(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)))
(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)
(let* ((widths (fuel-table--col-widths rows))
(rows (fuel-table--format-rows rows widths))
(ls (concat "+" (mapconcat (lambda (n) (make-string n ?-)) widths "-+") "-+")))
(insert ls "\n")
(rows (fuel-table--format-rows rows widths)))
(fuel-table--insert-first-line widths)
(dolist (r rows)
(let ((ln (length (car r)))
(l 0))
(while (< l ln)
(insert (concat "|" (mapconcat 'identity
(mapcar `(lambda (x) (nth ,l x)) r)
" |")
" |\n"))
(setq l (1+ l))))
(insert ls "\n"))))
(fuel-table--insert-row r)
(fuel-table--insert-middle-line widths))
(kill-line -1)
(fuel-table--insert-last-line widths)))
(provide 'fuel-table)