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 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
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> ;
! 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 }
[ ##return? ]
[ ##callback-return? ]
[ ##jump? ]
+ [ ##fixnum-add-tail? ]
+ [ ##fixnum-sub-tail? ]
+ [ ##fixnum-mul-tail? ]
[ ##call? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
-! 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
: 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
: 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-last-range? ( last n -- ? )
+ swap to>> <= ;
-: split-before ( live-interval i -- before )
- [ clone dup uses>> ] dip
- [ head >>uses ] [ 1- swap nth >>end ] 2bi ;
+: split-last-range ( before after last n -- before' after' )
+ split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ;
-: split-after ( live-interval i -- after )
- [ clone dup uses>> ] dip
- [ tail >>uses ] [ swap nth >>start ] 2bi
- f >>reg f >>copy-from ;
+: 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-interval ( live-interval n -- before after )
- [ drop ] [ [ > ] find-use drop ] 2bi
- [ split-before ] [ split-after ] 2bi ;
+: 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
: 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
[ >>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 ;
#! 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
: 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 ;
-! 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
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 ;
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
: 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 -- )
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 } } }
[
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
{ 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
{ start 0 }
{ end 5 }
{ uses V{ 0 1 5 } }
+ { ranges V{ T{ live-range f 0 5 } } }
} 0 split-interval
] unit-test
[ ] [
{
- 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
[ ] [
{
- 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
[ ] [
{
- 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
[ ] [
{
- 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
[
{
- 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
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
[ ] [
{ end 10 }
{ uses V{ 9 10 } }
}
- }
+ } fake-live-ranges
{ { int-regs { 0 1 2 3 } } }
allocate-registers drop
] unit-test
{ end 109 }
{ uses V{ 103 109 } }
}
- }
+ } fake-live-ranges
{ { int-regs { 0 1 2 3 4 } } }
allocate-registers drop
] unit-test
{ 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
\ No newline at end of file
! 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 ;
! 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
: 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 -- )
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
eliminate-dead-code
eliminate-write-barriers
eliminate-phis
+ ?check
] with-scope ;
! 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
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 ;
: 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 ;
source-files.errors
compiler.errors
compiler.alien
+compiler.constants
compiler.cfg
compiler.cfg.instructions
compiler.cfg.stack-frame
[ 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 )
{
] 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
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 ;
! 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 ;
[ spread>> 1234 = ]
[ timestamp>> timestamp? ]
} 1&&
-] unit-test
\ No newline at end of file
+] 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
-! 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 ;
\ No newline at end of file
+ define-constructor ;
+
+"initializers" create-vocab drop
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 -- )
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
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 -- )
[ { 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
! 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.
: 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
: 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
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 ;
[ 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
[ t ] [ "Thu Oct 09 12:03:15 2008" testtime "%c" strftime = ] unit-test
[ t ] [ "PM" testtime "%p" strftime = ] unit-test
+
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
! 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
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 - ;
: 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 )
] 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
: 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
math.constants math.functions math.matrices math.order\r
math.ranges math.vectors memoize multiline namespaces\r
sequences sequences.deep images.loader ;\r
+QUALIFIED-WITH: bitstreams bs\r
IN: images.jpeg\r
\r
-QUALIFIED-WITH: bitstreams bs\r
+SINGLETON: jpeg-image\r
+{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each\r
\r
-TUPLE: jpeg-image < image\r
+TUPLE: loading-jpeg < image\r
{ headers }\r
{ bitstream }\r
{ color-info initial: { f f f f } }\r
\r
<PRIVATE\r
\r
-CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;\r
+CONSTRUCTOR: loading-jpeg ( headers bitstream -- image ) ;\r
\r
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP\r
APP JPG COM TEM RES ;\r
\r
CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;\r
\r
-: jpeg> ( -- jpeg-image ) jpeg-image get ;\r
+: jpeg> ( -- jpeg-image ) loading-jpeg get ;\r
\r
: apply-diff ( dc color -- dc' )\r
[ diff>> + dup ] [ (>>diff) ] bi ;\r
binary [\r
parse-marker { SOI } assert=\r
parse-headers\r
- contents <jpeg-image>\r
+ contents <loading-jpeg>\r
] with-file-reader\r
- dup jpeg-image [\r
+ dup loading-jpeg [\r
baseline-parse\r
baseline-decompress\r
jpeg> bitmap>> 3 <groups> [ color-transform ] change-each\r
\r
M: jpeg-image load-image* ( path jpeg-image -- bitmap )\r
drop load-jpeg ;\r
-\r
-{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each\r
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* ;
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 ;
} 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
M: png-image load-image*
drop load-png ;
-
-"png" png-image register-image-class
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 ;
[ nip unhandled-ifd-entry swap ]
} case ;
-: process-ifds ( parsed-tiff -- parsed-tiff )
+: process-ifds ( loading-tiff -- loading-tiff )
[
[
dup ifd-entries>>
[ 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 [ ] }
[ [ 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
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
! 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 ;
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' )
Chris Double
+Peter Burns
+Philipp Winkler
{ 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
{ 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
-! 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>) ;
\ No newline at end of file
+
+: json> ( string -- object )
+ (json-parser>) ;
\ No newline at end of file
"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." } ;
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 )
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 ;
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
compiled-generic-crossref
compiler-impl
compiler.errors:compiler-errors
- ! definition-observers
- interactive-vocabs
lexer-factory
print-use-hook
root-cache
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
"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 }
{ $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." }
C: <extra-words> extra-words
-<PRIVATE
-
: clear-manifest ( -- )
manifest get
[ search-vocab-names>> clear-assoc ]
[ qualified-vocabs>> delete-all ]
tri ;
+<PRIVATE
+
: (add-qualified) ( qualified -- )
manifest get qualified-vocabs>> push ;
2bi
] [ drop ] if ;
-: only-use-vocabs ( vocabs -- )
- clear-manifest [ vocab ] filter [ use-vocab ] each ;
-
TUPLE: qualified vocab prefix words ;
: <qualified> ( vocab prefix -- qualified )
--- /dev/null
+John Benediktsson
--- /dev/null
+! 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 } ;
--- /dev/null
+! 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
+
+
--- /dev/null
+! 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
+
--- /dev/null
+Brainfuck programming language.
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
! Copyright (C) 2009 Kobi Lurie, Doug Coleman.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors fry images.loader images.normalization\r
+USING: accessors fry images.loader\r
images.processing.rotation kernel literals math sequences\r
tools.test images.processing.rotation.private ;\r
IN: images.processing.rotation.tests\r
CONSTANT: pasted-image\r
$[\r
"vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"\r
- load-image normalize-image clone-image\r
+ load-image clone-image\r
]\r
\r
CONSTANT: pasted-image90\r
$[\r
"vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"\r
- load-image normalize-image clone-image\r
+ load-image clone-image\r
]\r
\r
CONSTANT: lake-image\r
"vocab:images/processing/rotation/test-bitmaps/small.bmp"\r
load-image 90 rotate \r
"vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp"\r
- load-image normalize-image =\r
+ load-image =\r
] unit-test\r
\r
[ t ] [\r
] "" 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
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 ( -- )
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 )
--- /dev/null
+#!/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
+}
+
+
(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)
(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."
(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))
(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)))
\f
;;; Keys:
(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)))))
+
\f
;;; User interface:
(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))))
(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)))
\f
(provide 'fuel-table)
projects / factor.git / commitdiff