diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index cb6a753735..4718f137e4 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -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 '[ + drop n _ read + ] { } map-as ; diff --git a/basis/circular/circular-tests.factor b/basis/circular/circular-tests.factor index 3a94e14640..b4a9d547f2 100644 --- a/basis/circular/circular-tests.factor +++ b/basis/circular/circular-tests.factor @@ -13,6 +13,7 @@ circular strings ; [ [ 1 2 3 ] ] [ { 1 2 3 } [ ] like ] unit-test [ [ 2 3 1 ] ] [ { 1 2 3 } [ rotate-circular ] keep [ ] like ] unit-test +[ [ 3 1 2 ] ] [ { 1 2 3 } [ rotate-circular ] keep [ rotate-circular ] keep [ ] like ] unit-test [ [ 2 3 1 ] ] [ { 1 2 3 } 1 over change-circular-start [ ] like ] unit-test [ [ 3 1 2 ] ] [ { 1 2 3 } 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test [ [ 3 1 2 ] ] [ { 1 2 3 } -100 over change-circular-start [ ] like ] unit-test diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index ae79e70d73..d47b954ecf 100644 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -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 ; : ( n -- circular ) 0 ; diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor index c3ae15f069..dabc7338d2 100644 --- a/basis/compiler/cfg/cfg.factor +++ b/basis/compiler/cfg/cfg.factor @@ -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 } diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 4aa2088143..4f215f1dc8 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -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 ; diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 908bf2475b..7b56bd6150 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -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 ] + [ 1 + swap to>> ] + 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 -- ) - 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 + 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 ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 0de350c215..6fcd6e7570 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -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 set unhandled-intervals set + [ H{ } clone ] reg-class-assoc spill-slots set init-unhandled ; : assign-registers-in-block ( bb -- ) diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index e0cbe3774f..ccfc4a1ff7 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -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 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 \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index 1e6b9d02c8..ffa356bfc2 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -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 ; diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 78ac9428d8..546443b289 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -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 -- ) diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 8ceafd1693..9d481ef1d2 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -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 ; diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index a3a83b9d14..d30a02b0d3 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -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 ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 7bdaace1db..7602295284 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -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 % + rc-absolute-cell label-fixup ; : >slot< ( insn -- dst obj slot tag ) { diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 7527f6b339..6d0f6f3ace 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -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 diff --git a/basis/compression/run-length/run-length.factor b/basis/compression/run-length/run-length.factor index d281b0718a..6553860546 100644 --- a/basis/compression/run-length/run-length.factor +++ b/basis/compression/run-length/run-length.factor @@ -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 ] map concat ; diff --git a/basis/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor index 367f0ad143..271e173718 100644 --- a/basis/constructors/constructors-tests.factor +++ b/basis/constructors/constructors-tests.factor @@ -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 \ 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 a>> ] unit-test +[ 2 ] [ 0 0 a>> ] unit-test +[ 2 ] [ 0 0 0 a>> ] unit-test +[ 3 ] [ 0 0 0 0 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 ] unit-test + + +TUPLE: default { a integer initial: 0 } ; + +CONSTRUCTOR: default ( -- obj ) ; + +[ 0 ] [ a>> ] unit-test diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor index 7a98cd5e0a..e6982e3d98 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -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 ) - [ 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 diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 805ba4fd71..556424f50c 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -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 -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 934b456075..003eccfa18 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -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 -- ) diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index 203edf956e..a8c54fa65e 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/basis/cpu/x86/assembler/assembler-tests.factor @@ -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 diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 2b40aa2053..95b85ac2dd 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -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 diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index ef353281e5..15c54aa7d8 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -91,9 +91,6 @@ M: x86 %return ( -- ) 0 RET ; : align-code ( n -- ) 0 % ; -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 ; diff --git a/basis/formatting/formatting-tests.factor b/basis/formatting/formatting-tests.factor index c7e9fb985e..c56372f023 100644 --- a/basis/formatting/formatting-tests.factor +++ b/basis/formatting/formatting-tests.factor @@ -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 + diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 08cf4b2cd4..4ead01159a 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -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 diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 8bf8d59944..4f2ad720b6 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -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 buffer ( bitmap -- array ) - [ color-palette>> 4 [ 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 ] bi + '[ _ nth ] map concat ; + +: os2v2-color-lookup ( loading-bitmap -- seq ) + [ color-index>> >array ] + [ color-palette>> 3 ] bi + '[ _ nth ] map concat ; + +: v3-color-lookup ( loading-bitmap -- seq ) + [ color-index>> >array ] + [ color-palette>> 4 [ 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 ) - 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 - [ 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 [ 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 ) + concat ; inline + : save-bitmap ( image path -- ) binary [ B{ CHAR: B CHAR: M } write diff --git a/basis/images/images.factor b/basis/images/images.factor index 62c4f7e2ed..4c76b85459 100755 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -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 - - over [ first length ] [ length ] bi 2array >>dim - RGBA >>component-order - swap concat concat B{ } like >>bitmap ; +GENERIC: load-image* ( path class -- image ) ( -- 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 + contents ] with-file-reader - dup jpeg-image [ + dup loading-jpeg [ baseline-parse baseline-decompress jpeg> bitmap>> 3 [ 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 diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 19f2fd12c8..51d4e0fadf 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -7,16 +7,18 @@ IN: images.loader ERROR: unknown-image-extension 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* ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index d4b284142f..fd5e36e212 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -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-info size>> ] bi - stream-throws [ - + binary stream-throws [ + 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 diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index c98f737b11..876076e9fe 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -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 - [ - 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 [ - + 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 diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index b1b07a08c0..fd441e4c4d 100755 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -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 ; +: ( path encoding mode -- stream' ) + [ + [ ] + [ drop file-info size>> ] 2bi + ] dip ; + GENERIC# limit 2 ( stream limit mode -- stream' ) M: decoder limit ( stream limit mode -- stream' ) diff --git a/basis/json/reader/authors.txt b/basis/json/reader/authors.txt index 44b06f94bc..d269b4ffb5 100644 --- a/basis/json/reader/authors.txt +++ b/basis/json/reader/authors.txt @@ -1 +1,3 @@ Chris Double +Peter Burns +Philipp Winkler diff --git a/basis/json/reader/reader-tests.factor b/basis/json/reader/reader-tests.factor index e97d45babe..14a54b89c0 100644 --- a/basis/json/reader/reader-tests.factor +++ b/basis/json/reader/reader-tests.factor @@ -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 diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor index 887a7a50e5..9886e316d7 100644 --- a/basis/json/reader/reader.factor +++ b/basis/json/reader/reader.factor @@ -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 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 diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor index 0f13b6dd86..7470ef9daa 100644 --- a/basis/listener/listener-docs.factor +++ b/basis/listener/listener-docs.factor @@ -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." } ; diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index 4563f61ab7..34d9eac121 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -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 set + "scratchpad" set-current-vocab + interactive-vocabs get only-use-vocabs + call + ] with-scope ; inline + : listener ( -- ) [ [ { } (listener) ] with-interactive-vocabs ] with-return ; diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index cd10278760..a2696b1263 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -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 diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 46572de47b..270b55fda6 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -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 diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 8d52dcaa2c..94eb0a865c 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -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 set - "scratchpad" set-current-vocab - interactive-vocabs get only-use-vocabs - call - ] with-scope ; inline - SYMBOL: print-use-hook print-use-hook [ [ ] ] initialize diff --git a/core/vocabs/parser/parser-docs.factor b/core/vocabs/parser/parser-docs.factor index e54993b6eb..96619a7114 100644 --- a/core/vocabs/parser/parser-docs.factor +++ b/core/vocabs/parser/parser-docs.factor @@ -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." } diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index ca783c13e6..0bfb607a52 100644 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -52,8 +52,6 @@ M: extra-words equal? C: extra-words -> clear-assoc ] @@ -61,6 +59,8 @@ C: extra-words [ qualified-vocabs>> delete-all ] tri ; +> 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 ; : ( vocab prefix -- qualified ) diff --git a/extra/brainfuck/authors.txt b/extra/brainfuck/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/extra/brainfuck/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/extra/brainfuck/brainfuck-docs.factor b/extra/brainfuck/brainfuck-docs.factor new file mode 100644 index 0000000000..c11c05a2e2 --- /dev/null +++ b/extra/brainfuck/brainfuck-docs.factor @@ -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 } ; diff --git a/extra/brainfuck/brainfuck-tests.factor b/extra/brainfuck/brainfuck-tests.factor new file mode 100644 index 0000000000..2fa6b84a19 --- /dev/null +++ b/extra/brainfuck/brainfuck-tests.factor @@ -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 + + diff --git a/extra/brainfuck/brainfuck.factor b/extra/brainfuck/brainfuck.factor new file mode 100644 index 0000000000..f29e7dc8ae --- /dev/null +++ b/extra/brainfuck/brainfuck.factor @@ -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 + + ( -- 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 -- ) + [ ] swap parse-brainfuck [ drop flush ] 3append ; + +: get-brainfuck ( code -- result ) + [ run-brainfuck ] with-string-writer ; inline + diff --git a/extra/brainfuck/summary.txt b/extra/brainfuck/summary.txt new file mode 100644 index 0000000000..792dbbae08 --- /dev/null +++ b/extra/brainfuck/summary.txt @@ -0,0 +1 @@ +Brainfuck programming language. diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor index 6c43e646df..f20e67f9bc 100644 --- a/extra/fuel/help/help.factor +++ b/extra/fuel/help/help.factor @@ -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 diff --git a/extra/images/processing/rotation/rotation-tests.factor b/extra/images/processing/rotation/rotation-tests.factor index 493f09b145..9d9e72a205 100755 --- a/extra/images/processing/rotation/rotation-tests.factor +++ b/extra/images/processing/rotation/rotation-tests.factor @@ -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 ] [ diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor index 4e841ec95e..f60445c48f 100644 --- a/extra/managed-server/chat/chat.factor +++ b/extra/managed-server/chat/chat.factor @@ -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 diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor index 4d4a440525..6f9bdf25f1 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -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 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 ) diff --git a/misc/bash/cdfactor.sh b/misc/bash/cdfactor.sh new file mode 100755 index 0000000000..cee2d3ac77 --- /dev/null +++ b/misc/bash/cdfactor.sh @@ -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-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 +} + + diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el index b302fb6b8f..cc8ebe35fb 100644 --- a/misc/fuel/factor-mode.el +++ b/misc/fuel/factor-mode.el @@ -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." diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 80fe8e830b..cc788fe5dc 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -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)) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 0186392f34..282ef3240f 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -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: diff --git a/misc/fuel/fuel-scaffold.el b/misc/fuel/fuel-scaffold.el index b1c4462503..9b7d9861c7 100644 --- a/misc/fuel/fuel-scaffold.el +++ b/misc/fuel/fuel-scaffold.el @@ -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)))) diff --git a/misc/fuel/fuel-table.el b/misc/fuel/fuel-table.el index a00b21bf2f..1af2e25712 100644 --- a/misc/fuel/fuel-table.el +++ b/misc/fuel/fuel-table.el @@ -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)