Merge branch 'master' into inlinec
* master: ui.gadgets.tables: clicking in empty area no longer notifies selection model vocabs.hierarchy: fix (load) word vocabs.hierarchy: more refactoring, update existing code for new API help.html: Update for vocabs.hierarchy changes help.html: escape # in word names. Reported by ex_rzrjck vocabs.hierachy: redo with cleaner API compiler.cfg.linear-scan: minor fixes webkit-demo: update for recent <ViewWindow> stack effect change compiler.cfg.linear-scan: Get cycle breaking in resolve pass to work by allocating a spare spill slot for this purposedb4
Jeremy Hughes
commit
a5653f3449
|
|
@ -261,4 +261,3 @@ INSN: _reload dst class n ;
|
|||
INSN: _copy dst src class ;
|
||||
INSN: _spill-counts counts ;
|
||||
|
||||
SYMBOL: spill-temp
|
||||
|
|
|
|||
|
|
@ -62,11 +62,12 @@ HINTS: split-interval live-interval object ;
|
|||
2dup [ compute-start/end ] bi@ ;
|
||||
|
||||
: insert-use-for-copy ( seq n -- seq' )
|
||||
dup 1 + [ nip 1array split1 ] 2keep 2array glue ;
|
||||
[ '[ _ < ] filter ]
|
||||
[ nip dup 1 + 2array ]
|
||||
[ 1 + '[ _ > ] filter ]
|
||||
2tri 3append ;
|
||||
|
||||
: split-before-use ( new n -- before after )
|
||||
! Find optimal split position
|
||||
! Insert move instruction
|
||||
1 -
|
||||
2dup swap covers? [
|
||||
[ '[ _ insert-use-for-copy ] change-uses ] keep
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ ERROR: already-spilled ;
|
|||
|
||||
: record-spill ( live-interval -- )
|
||||
[ dup spill-to>> ] [ vreg>> spill-slots-for ] bi
|
||||
2dup key? [ already-spilled ] [ set-at ] if ;
|
||||
2dup key? drop set-at ; ! [ already-spilled ] [ set-at ] if ;
|
||||
|
||||
: insert-spill ( live-interval -- )
|
||||
{
|
||||
|
|
@ -109,7 +109,7 @@ ERROR: already-reloaded ;
|
|||
#! 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>> = [
|
||||
2dup heap-peek drop start>> >= [
|
||||
heap-pop drop
|
||||
[ add-active ] [ handle-reload ] bi
|
||||
activate-new-intervals
|
||||
|
|
@ -137,13 +137,11 @@ ERROR: overlapping-registers intervals ;
|
|||
|
||||
: active-intervals ( n -- intervals )
|
||||
pending-intervals get [ covers? ] with filter
|
||||
check-assignment? get [
|
||||
dup check-assignment
|
||||
] when ;
|
||||
check-assignment? get [ dup check-assignment ] when ;
|
||||
|
||||
M: vreg-insn assign-registers-in-insn
|
||||
dup [ insn#>> active-intervals ] [ all-vregs ] bi
|
||||
'[ vreg>> _ member? ] filter
|
||||
dup [ all-vregs ] [ insn#>> active-intervals ] bi
|
||||
'[ _ [ vreg>> = ] with find nip ] map
|
||||
register-mapping
|
||||
>>regs drop ;
|
||||
|
||||
|
|
@ -171,7 +169,7 @@ M: ##gc assign-registers-in-insn
|
|||
M: insn assign-registers-in-insn drop ;
|
||||
|
||||
: begin-block ( bb -- )
|
||||
dup block-from 1 - prepare-insn
|
||||
dup block-from prepare-insn
|
||||
[ block-from compute-live-values ] keep register-live-ins get set-at ;
|
||||
|
||||
: end-block ( bb -- )
|
||||
|
|
|
|||
|
|
@ -206,6 +206,56 @@ check-assignment? on
|
|||
} 5 split-before-use [ f >>split-next ] bi@
|
||||
] unit-test
|
||||
|
||||
[
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 4 }
|
||||
{ uses V{ 0 1 4 } }
|
||||
{ ranges V{ T{ live-range f 0 4 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 5 }
|
||||
{ end 10 }
|
||||
{ uses V{ 5 10 } }
|
||||
{ ranges V{ T{ live-range f 5 10 } } }
|
||||
}
|
||||
] [
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 10 }
|
||||
{ uses V{ 0 1 10 } }
|
||||
{ ranges V{ T{ live-range f 0 10 } } }
|
||||
} 5 split-before-use [ f >>split-next ] bi@
|
||||
] unit-test
|
||||
|
||||
[
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 4 }
|
||||
{ uses V{ 0 1 4 } }
|
||||
{ ranges V{ T{ live-range f 0 4 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 5 }
|
||||
{ end 10 }
|
||||
{ uses V{ 5 10 } }
|
||||
{ ranges V{ T{ live-range f 5 10 } } }
|
||||
}
|
||||
] [
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 10 }
|
||||
{ uses V{ 0 1 4 5 10 } }
|
||||
{ ranges V{ T{ live-range f 0 10 } } }
|
||||
} 5 split-before-use [ f >>split-next ] bi@
|
||||
] unit-test
|
||||
|
||||
[
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
|
|
@ -1858,6 +1908,8 @@ test-diamond
|
|||
|
||||
[ _spill ] [ 3 get instructions>> second class ] unit-test
|
||||
|
||||
[ f ] [ 3 get instructions>> [ _reload? ] any? ] unit-test
|
||||
|
||||
[ _reload ] [ 4 get instructions>> first class ] unit-test
|
||||
|
||||
! Resolve pass
|
||||
|
|
@ -1975,4 +2027,77 @@ V{
|
|||
[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test
|
||||
|
||||
! Resolve pass should insert this
|
||||
[ _reload ] [ 5 get instructions>> first class ] unit-test
|
||||
[ _reload ] [ 5 get instructions>> first class ] unit-test
|
||||
|
||||
! Some random bug
|
||||
V{
|
||||
T{ ##peek f V int-regs 1 D 1 }
|
||||
T{ ##peek f V int-regs 2 D 2 }
|
||||
T{ ##replace f V int-regs 1 D 1 }
|
||||
T{ ##replace f V int-regs 2 D 2 }
|
||||
T{ ##peek f V int-regs 3 D 0 }
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{ T{ ##branch } } 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 1 D 1 }
|
||||
T{ ##peek f V int-regs 2 D 2 }
|
||||
T{ ##replace f V int-regs 3 D 3 }
|
||||
T{ ##replace f V int-regs 1 D 1 }
|
||||
T{ ##replace f V int-regs 2 D 2 }
|
||||
T{ ##replace f V int-regs 0 D 3 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{ T{ ##branch } } 3 test-bb
|
||||
|
||||
V{
|
||||
T{ ##return }
|
||||
} 4 test-bb
|
||||
|
||||
test-diamond
|
||||
|
||||
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
|
||||
|
||||
! Spilling an interval immediately after its activated;
|
||||
! and the interval does not have a use at the activation point
|
||||
V{
|
||||
T{ ##peek f V int-regs 1 D 1 }
|
||||
T{ ##peek f V int-regs 2 D 2 }
|
||||
T{ ##replace f V int-regs 1 D 1 }
|
||||
T{ ##replace f V int-regs 2 D 2 }
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##branch }
|
||||
} 0 test-bb
|
||||
|
||||
V{ T{ ##branch } } 1 test-bb
|
||||
|
||||
V{
|
||||
T{ ##peek f V int-regs 1 D 1 }
|
||||
T{ ##branch }
|
||||
} 2 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 1 D 1 }
|
||||
T{ ##peek f V int-regs 2 D 2 }
|
||||
T{ ##replace f V int-regs 2 D 2 }
|
||||
T{ ##branch }
|
||||
} 3 test-bb
|
||||
|
||||
V{ T{ ##branch } } 4 test-bb
|
||||
|
||||
V{
|
||||
T{ ##replace f V int-regs 0 D 0 }
|
||||
T{ ##return }
|
||||
} 5 test-bb
|
||||
|
||||
1 get 1vector 0 get (>>successors)
|
||||
2 get 4 get V{ } 2sequence 1 get (>>successors)
|
||||
5 get 1vector 4 get (>>successors)
|
||||
3 get 1vector 2 get (>>successors)
|
||||
5 get 1vector 3 get (>>successors)
|
||||
|
||||
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ ERROR: dead-value-error vreg ;
|
|||
V{ } clone >>ranges
|
||||
swap >>vreg ;
|
||||
|
||||
: block-from ( bb -- n ) instructions>> first insn#>> ;
|
||||
: block-from ( bb -- n ) instructions>> first insn#>> 1 - ;
|
||||
|
||||
: block-to ( bb -- n ) instructions>> last insn#>> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@ compiler.cfg.debugger compiler.cfg.instructions
|
|||
compiler.cfg.linear-scan.debugger
|
||||
compiler.cfg.linear-scan.live-intervals
|
||||
compiler.cfg.linear-scan.numbering
|
||||
compiler.cfg.linear-scan.allocation.state
|
||||
compiler.cfg.linear-scan.resolve compiler.cfg.predecessors
|
||||
compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel
|
||||
namespaces tools.test vectors ;
|
||||
|
|
@ -12,15 +13,18 @@ IN: compiler.cfg.linear-scan.resolve.tests
|
|||
{ 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array
|
||||
] unit-test
|
||||
|
||||
H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
|
||||
H{ } clone spill-temps set
|
||||
|
||||
[
|
||||
{
|
||||
T{ _copy { dst 5 } { src 4 } { class int-regs } }
|
||||
T{ _spill { src 1 } { class int-regs } { n spill-temp } }
|
||||
T{ _spill { src 1 } { class int-regs } { n 10 } }
|
||||
T{ _copy { dst 1 } { src 0 } { class int-regs } }
|
||||
T{ _reload { dst 0 } { class int-regs } { n spill-temp } }
|
||||
T{ _spill { src 1 } { class float-regs } { n spill-temp } }
|
||||
T{ _reload { dst 0 } { class int-regs } { n 10 } }
|
||||
T{ _spill { src 1 } { class float-regs } { n 20 } }
|
||||
T{ _copy { dst 1 } { src 0 } { class float-regs } }
|
||||
T{ _reload { dst 0 } { class float-regs } { n spill-temp } }
|
||||
T{ _reload { dst 0 } { class float-regs } { n 20 } }
|
||||
}
|
||||
] [
|
||||
{
|
||||
|
|
@ -34,10 +38,10 @@ IN: compiler.cfg.linear-scan.resolve.tests
|
|||
|
||||
[
|
||||
{
|
||||
T{ _spill { src 2 } { class int-regs } { n spill-temp } }
|
||||
T{ _spill { src 2 } { class int-regs } { n 10 } }
|
||||
T{ _copy { dst 2 } { src 1 } { class int-regs } }
|
||||
T{ _copy { dst 1 } { src 0 } { class int-regs } }
|
||||
T{ _reload { dst 0 } { class int-regs } { n spill-temp } }
|
||||
T{ _reload { dst 0 } { class int-regs } { n 10 } }
|
||||
}
|
||||
] [
|
||||
{
|
||||
|
|
@ -49,10 +53,10 @@ IN: compiler.cfg.linear-scan.resolve.tests
|
|||
|
||||
[
|
||||
{
|
||||
T{ _spill { src 0 } { class int-regs } { n spill-temp } }
|
||||
T{ _spill { src 0 } { class int-regs } { n 10 } }
|
||||
T{ _copy { dst 0 } { src 2 } { class int-regs } }
|
||||
T{ _copy { dst 2 } { src 1 } { class int-regs } }
|
||||
T{ _reload { dst 1 } { class int-regs } { n spill-temp } }
|
||||
T{ _reload { dst 1 } { class int-regs } { n 10 } }
|
||||
}
|
||||
] [
|
||||
{
|
||||
|
|
@ -113,10 +117,10 @@ IN: compiler.cfg.linear-scan.resolve.tests
|
|||
{
|
||||
T{ _copy { dst 1 } { src 0 } { class int-regs } }
|
||||
T{ _copy { dst 2 } { src 0 } { class int-regs } }
|
||||
T{ _spill { src 4 } { class int-regs } { n spill-temp } }
|
||||
T{ _spill { src 4 } { class int-regs } { n 10 } }
|
||||
T{ _copy { dst 4 } { src 0 } { class int-regs } }
|
||||
T{ _copy { dst 0 } { src 3 } { class int-regs } }
|
||||
T{ _reload { dst 3 } { class int-regs } { n spill-temp } }
|
||||
T{ _reload { dst 3 } { class int-regs } { n 10 } }
|
||||
}
|
||||
] [
|
||||
{
|
||||
|
|
@ -133,10 +137,10 @@ IN: compiler.cfg.linear-scan.resolve.tests
|
|||
T{ _copy { dst 2 } { src 0 } { class int-regs } }
|
||||
T{ _copy { dst 9 } { src 1 } { class int-regs } }
|
||||
T{ _copy { dst 1 } { src 0 } { class int-regs } }
|
||||
T{ _spill { src 4 } { class int-regs } { n spill-temp } }
|
||||
T{ _spill { src 4 } { class int-regs } { n 10 } }
|
||||
T{ _copy { dst 4 } { src 0 } { class int-regs } }
|
||||
T{ _copy { dst 0 } { src 3 } { class int-regs } }
|
||||
T{ _reload { dst 3 } { class int-regs } { n spill-temp } }
|
||||
T{ _reload { dst 3 } { class int-regs } { n 10 } }
|
||||
}
|
||||
] [
|
||||
{
|
||||
|
|
|
|||
|
|
@ -3,10 +3,15 @@
|
|||
USING: accessors arrays assocs classes.parser classes.tuple
|
||||
combinators combinators.short-circuit fry hashtables kernel locals
|
||||
make math math.order namespaces sequences sets words parser
|
||||
compiler.cfg.instructions compiler.cfg.linear-scan.assignment
|
||||
compiler.cfg.liveness ;
|
||||
compiler.cfg.instructions compiler.cfg.linear-scan.allocation.state
|
||||
compiler.cfg.linear-scan.assignment compiler.cfg.liveness ;
|
||||
IN: compiler.cfg.linear-scan.resolve
|
||||
|
||||
SYMBOL: spill-temps
|
||||
|
||||
: spill-temp ( reg-class -- n )
|
||||
spill-temps get [ next-spill-slot ] cache ;
|
||||
|
||||
<<
|
||||
|
||||
TUPLE: operation from to reg-class ;
|
||||
|
|
@ -116,11 +121,15 @@ ERROR: resolve-error ;
|
|||
|
||||
: break-cycle-n ( operations -- operations' )
|
||||
split-cycle [
|
||||
[ from>> spill-temp <spill-slot> ]
|
||||
[ reg-class>> ] bi \ register->memory boa
|
||||
[ from>> ]
|
||||
[ reg-class>> spill-temp <spill-slot> ]
|
||||
[ reg-class>> ]
|
||||
tri \ register->memory boa
|
||||
] [
|
||||
[ to>> spill-temp <spill-slot> swap ]
|
||||
[ reg-class>> ] bi \ memory->register boa
|
||||
[ reg-class>> spill-temp <spill-slot> ]
|
||||
[ to>> ]
|
||||
[ reg-class>> ]
|
||||
tri \ memory->register boa
|
||||
] bi [ 1array ] bi@ surround ;
|
||||
|
||||
: break-cycle ( operations -- operations' )
|
||||
|
|
@ -197,4 +206,5 @@ ERROR: resolve-error ;
|
|||
dup successors>> [ resolve-edge-data-flow ] with each ;
|
||||
|
||||
: resolve-data-flow ( rpo -- )
|
||||
H{ } clone spill-temps set
|
||||
[ resolve-block-data-flow ] each ;
|
||||
|
|
|
|||
|
|
@ -3,8 +3,9 @@
|
|||
USING: parser lexer kernel namespaces sequences definitions
|
||||
io.files io.backend io.pathnames io summary continuations
|
||||
tools.crossref vocabs.hierarchy prettyprint source-files
|
||||
source-files.errors assocs vocabs vocabs.loader splitting
|
||||
source-files.errors assocs vocabs.loader splitting
|
||||
accessors debugger help.topics ;
|
||||
FROM: vocabs => vocab-name >vocab-link ;
|
||||
IN: editors
|
||||
|
||||
TUPLE: no-edit-hook ;
|
||||
|
|
@ -15,7 +16,7 @@ M: no-edit-hook summary
|
|||
SYMBOL: edit-hook
|
||||
|
||||
: available-editors ( -- seq )
|
||||
"editors" all-child-vocabs-seq [ vocab-name ] map ;
|
||||
"editors" child-vocabs no-roots no-prefixes [ vocab-name ] map ;
|
||||
|
||||
: editor-restarts ( -- alist )
|
||||
available-editors
|
||||
|
|
|
|||
|
|
@ -42,7 +42,8 @@ M: more-completions article-content
|
|||
[ dup name>> >lower ] { } map>assoc ;
|
||||
|
||||
: vocab-candidates ( -- candidates )
|
||||
all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
|
||||
all-vocabs-recursive no-roots no-prefixes
|
||||
[ dup vocab-name >lower ] { } map>assoc ;
|
||||
|
||||
: help-candidates ( seq -- candidates )
|
||||
[ [ >link ] [ article-title >lower ] bi ] { } map>assoc
|
||||
|
|
|
|||
|
|
@ -5,7 +5,8 @@ io.files io.files.temp io.directories html.streams help kernel
|
|||
assocs sequences make words accessors arrays help.topics vocabs
|
||||
vocabs.hierarchy help.vocabs namespaces prettyprint io
|
||||
vocabs.loader serialize fry memoize unicode.case math.order
|
||||
sorting debugger html xml.syntax xml.writer math.parser ;
|
||||
sorting debugger html xml.syntax xml.writer math.parser
|
||||
sets hashtables ;
|
||||
FROM: io.encodings.ascii => ascii ;
|
||||
FROM: ascii => ascii? ;
|
||||
IN: help.html
|
||||
|
|
@ -24,6 +25,7 @@ IN: help.html
|
|||
{ CHAR: / "__slash__" }
|
||||
{ CHAR: , "__comma__" }
|
||||
{ CHAR: @ "__at__" }
|
||||
{ CHAR: # "__hash__" }
|
||||
} at [ % ] [ , ] ?if
|
||||
] [ number>string "__" "__" surround % ] if ;
|
||||
|
||||
|
|
@ -71,9 +73,7 @@ M: topic url-of topic>filename ;
|
|||
dup topic>filename utf8 [ help>html write-xml ] with-file-writer ;
|
||||
|
||||
: all-vocabs-really ( -- seq )
|
||||
#! Hack.
|
||||
all-vocabs values concat
|
||||
vocabs [ find-vocab-root not ] filter [ vocab ] map append ;
|
||||
all-vocabs >hashtable f over delete-at no-roots remove-redundant-prefixes ;
|
||||
|
||||
: all-topics ( -- topics )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@ help.topics io kernel namespaces parser sequences
|
|||
source-files.errors vocabs.hierarchy vocabs words classes
|
||||
locals tools.errors listener ;
|
||||
FROM: help.lint.checks => all-vocabs ;
|
||||
FROM: vocabs => child-vocabs ;
|
||||
IN: help.lint
|
||||
|
||||
SYMBOL: lint-failures
|
||||
|
|
@ -79,7 +80,7 @@ PRIVATE>
|
|||
: help-lint ( prefix -- )
|
||||
[
|
||||
auto-use? off
|
||||
all-vocabs-seq [ vocab-name ] map all-vocabs set
|
||||
all-vocab-names all-vocabs set
|
||||
group-articles vocab-articles set
|
||||
child-vocabs
|
||||
[ check-vocab ] each
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@ help.topics io io.files io.pathnames io.styles kernel macros
|
|||
make namespaces prettyprint sequences sets sorting summary
|
||||
vocabs vocabs.files vocabs.hierarchy vocabs.loader
|
||||
vocabs.metadata words words.symbol definitions.icons ;
|
||||
FROM: vocabs.hierarchy => child-vocabs ;
|
||||
IN: help.vocabs
|
||||
|
||||
: about ( vocab -- )
|
||||
|
|
@ -35,7 +36,7 @@ IN: help.vocabs
|
|||
$heading ;
|
||||
|
||||
: $vocabs ( seq -- )
|
||||
[ vocab-row ] map vocab-headings prefix $table ;
|
||||
convert-prefixes [ vocab-row ] map vocab-headings prefix $table ;
|
||||
|
||||
: $vocab-roots ( assoc -- )
|
||||
[
|
||||
|
|
@ -67,7 +68,8 @@ C: <vocab-author> vocab-author
|
|||
] unless-empty ;
|
||||
|
||||
: describe-children ( vocab -- )
|
||||
vocab-name all-child-vocabs $vocab-roots ;
|
||||
vocab-name child-vocabs
|
||||
$vocab-roots ;
|
||||
|
||||
: files. ( seq -- )
|
||||
snippet-style get [
|
||||
|
|
|
|||
|
|
@ -5,4 +5,4 @@ USING: tools.test vocabs.hierarchy present math vocabs sequences kernel ;
|
|||
[ "Hi" ] [ "Hi" present ] unit-test
|
||||
[ "+" ] [ \ + present ] unit-test
|
||||
[ "kernel" ] [ "kernel" vocab present ] unit-test
|
||||
[ ] [ all-vocabs-seq [ present ] map drop ] unit-test
|
||||
[ ] [ all-vocabs-recursive no-roots no-prefixes [ present ] map drop ] unit-test
|
||||
|
|
@ -75,7 +75,7 @@ IN: tools.completion
|
|||
all-words name-completions ;
|
||||
|
||||
: vocabs-matching ( str -- seq )
|
||||
all-vocabs-seq name-completions ;
|
||||
all-vocabs-recursive no-roots no-prefixes name-completions ;
|
||||
|
||||
: chars-matching ( str -- seq )
|
||||
name-map keys dup zip completions ;
|
||||
|
|
|
|||
|
|
@ -313,13 +313,14 @@ PRIVATE>
|
|||
if ;
|
||||
|
||||
: row-action? ( table -- ? )
|
||||
[ [ mouse-row ] keep valid-line? ]
|
||||
[ single-click?>> hand-click# get 2 = or ] bi and ;
|
||||
single-click?>> hand-click# get 2 = or ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: table-button-up ( table -- )
|
||||
dup row-action? [ row-action ] [ update-selected-value ] if ;
|
||||
dup [ mouse-row ] keep valid-line? [
|
||||
dup row-action? [ row-action ] [ update-selected-value ] if
|
||||
] [ drop ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: vocabs.cache
|
|||
: reset-cache ( -- )
|
||||
root-cache get-global clear-assoc
|
||||
\ vocab-file-contents reset-memoized
|
||||
\ all-vocabs-seq reset-memoized
|
||||
\ all-vocabs-recursive reset-memoized
|
||||
\ all-authors reset-memoized
|
||||
\ all-tags reset-memoized ;
|
||||
|
||||
|
|
|
|||
|
|
@ -7,19 +7,21 @@ $nl
|
|||
"Loading vocabulary hierarchies:"
|
||||
{ $subsection load }
|
||||
{ $subsection load-all }
|
||||
"Getting all vocabularies on disk:"
|
||||
"Getting all vocabularies from disk:"
|
||||
{ $subsection all-vocabs }
|
||||
{ $subsection all-vocabs-seq }
|
||||
"Getting " { $link "vocabs.metadata" } " for all vocabularies on disk:"
|
||||
{ $subsection all-vocabs-recursive }
|
||||
"Getting all vocabularies from disk whose names which match a string prefix:"
|
||||
{ $subsection child-vocabs }
|
||||
{ $subsection child-vocabs-recursive }
|
||||
"Words for modifying output:"
|
||||
{ $subsection no-roots }
|
||||
{ $subsection no-prefixes }
|
||||
"Getting " { $link "vocabs.metadata" } " for all vocabularies from disk:"
|
||||
{ $subsection all-tags }
|
||||
{ $subsection all-authors } ;
|
||||
|
||||
ABOUT: "vocabs.hierarchy"
|
||||
|
||||
HELP: all-vocabs
|
||||
{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }
|
||||
{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;
|
||||
|
||||
HELP: load
|
||||
{ $values { "prefix" string } }
|
||||
{ $description "Load all vocabularies that match the provided prefix." }
|
||||
|
|
@ -28,6 +30,3 @@ HELP: load
|
|||
HELP: load-all
|
||||
{ $description "Load all vocabularies in the source tree." } ;
|
||||
|
||||
HELP: all-vocabs-under
|
||||
{ $values { "prefix" string } { "vocabs" "a sequence of vocabularies" } }
|
||||
{ $description "Return a sequence of vocab or vocab-links for each vocab matching the provided prefix. Unlike " { $link all-child-vocabs } " this word will return both loaded and unloaded vocabularies." } ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,18 @@
|
|||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs combinators.short-circuit fry
|
||||
USING: accessors arrays assocs combinators.short-circuit fry
|
||||
io.directories io.files io.files.info io.pathnames kernel make
|
||||
memoize namespaces sequences sorting splitting vocabs sets
|
||||
vocabs.loader vocabs.metadata vocabs.errors ;
|
||||
RENAME: child-vocabs vocabs => vocabs:child-vocabs
|
||||
IN: vocabs.hierarchy
|
||||
|
||||
TUPLE: vocab-prefix name ;
|
||||
|
||||
C: <vocab-prefix> vocab-prefix
|
||||
|
||||
M: vocab-prefix vocab-name name>> ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: vocab-subdirs ( dir -- dirs )
|
||||
|
|
@ -15,74 +22,92 @@ IN: vocabs.hierarchy
|
|||
] filter
|
||||
] with-directory-files natural-sort ;
|
||||
|
||||
: (all-child-vocabs) ( root name -- vocabs )
|
||||
[
|
||||
vocab-dir append-path dup exists?
|
||||
[ vocab-subdirs ] [ drop { } ] if
|
||||
] keep
|
||||
[ '[ [ _ "." ] dip 3append ] map ] unless-empty ;
|
||||
|
||||
: vocab-dir? ( root name -- ? )
|
||||
over
|
||||
[ ".factor" vocab-dir+ append-path exists? ]
|
||||
[ 2drop f ]
|
||||
if ;
|
||||
|
||||
: vocabs-in-dir ( root name -- )
|
||||
dupd (all-child-vocabs) [
|
||||
2dup vocab-dir? [ dup >vocab-link , ] when
|
||||
vocabs-in-dir
|
||||
] with each ;
|
||||
: (child-vocabs) ( root prefix -- vocabs )
|
||||
[ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]
|
||||
[ nip [ '[ [ _ "." ] dip 3append ] map ] unless-empty ]
|
||||
[ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map ]
|
||||
2tri ;
|
||||
|
||||
PRIVATE>
|
||||
: ((child-vocabs-recursive)) ( root name -- )
|
||||
dupd vocab-name (child-vocabs)
|
||||
[ dup , ((child-vocabs-recursive)) ] with each ;
|
||||
|
||||
: all-vocabs ( -- assoc )
|
||||
vocab-roots get [
|
||||
dup [ "" vocabs-in-dir ] { } make
|
||||
] { } map>assoc ;
|
||||
: (child-vocabs-recursive) ( root name -- seq )
|
||||
[ ((child-vocabs-recursive)) ] { } make ;
|
||||
|
||||
: all-vocabs-under ( prefix -- vocabs )
|
||||
[
|
||||
[ vocab-roots get ] dip '[ _ vocabs-in-dir ] each
|
||||
] { } make ;
|
||||
: no-rooted ( seq -- seq' ) [ find-vocab-root not ] filter ;
|
||||
|
||||
MEMO: all-vocabs-seq ( -- seq )
|
||||
"" all-vocabs-under ;
|
||||
|
||||
<PRIVATE
|
||||
: one-level-only? ( name prefix -- ? )
|
||||
?head [ "." split1 nip not ] dip and ;
|
||||
|
||||
: unrooted-child-vocabs ( prefix -- seq )
|
||||
[ vocabs no-rooted ] dip
|
||||
dup empty? [ CHAR: . suffix ] unless
|
||||
vocabs
|
||||
[ find-vocab-root not ] filter
|
||||
[
|
||||
vocab-name swap ?head CHAR: . rot member? not and
|
||||
] with filter
|
||||
[ vocab ] map ;
|
||||
'[ vocab-name _ one-level-only? ] filter ;
|
||||
|
||||
: unrooted-child-vocabs-recursive ( prefix -- seq )
|
||||
vocabs:child-vocabs no-rooted ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: all-child-vocabs ( prefix -- assoc )
|
||||
vocab-roots get [
|
||||
dup pick (all-child-vocabs) [ >vocab-link ] map
|
||||
] { } map>assoc
|
||||
swap unrooted-child-vocabs f swap 2array suffix ;
|
||||
: no-prefixes ( seq -- seq' ) [ vocab-prefix? not ] filter ;
|
||||
|
||||
: all-child-vocabs-seq ( prefix -- assoc )
|
||||
vocab-roots get swap '[
|
||||
dup _ (all-child-vocabs)
|
||||
[ vocab-dir? ] with filter
|
||||
] map concat ;
|
||||
: convert-prefixes ( seq -- seq' )
|
||||
[ dup vocab-prefix? [ name>> vocab-link boa ] when ] map ;
|
||||
|
||||
: remove-redundant-prefixes ( seq -- seq' )
|
||||
#! Hack.
|
||||
[ vocab-prefix? ] partition
|
||||
[
|
||||
[ vocab-name ] map unique
|
||||
'[ name>> _ key? not ] filter
|
||||
convert-prefixes
|
||||
] keep
|
||||
append ;
|
||||
|
||||
: no-roots ( assoc -- seq ) values concat ;
|
||||
|
||||
: child-vocabs ( prefix -- assoc )
|
||||
[ [ vocab-roots get ] dip '[ dup _ (child-vocabs) ] { } map>assoc ]
|
||||
[ unrooted-child-vocabs [ vocab ] map f swap 2array ]
|
||||
bi suffix ;
|
||||
|
||||
: all-vocabs ( -- assoc )
|
||||
"" child-vocabs ;
|
||||
|
||||
: child-vocabs-recursive ( prefix -- assoc )
|
||||
[ [ vocab-roots get ] dip '[ dup _ (child-vocabs-recursive) ] { } map>assoc ]
|
||||
[ unrooted-child-vocabs-recursive [ vocab ] map f swap 2array ]
|
||||
bi suffix ;
|
||||
|
||||
MEMO: all-vocabs-recursive ( -- assoc )
|
||||
"" child-vocabs-recursive ;
|
||||
|
||||
: all-vocab-names ( -- seq )
|
||||
all-vocabs-recursive no-roots no-prefixes [ vocab-name ] map ;
|
||||
|
||||
: child-vocab-names ( prefix -- seq )
|
||||
child-vocabs no-roots no-prefixes [ vocab-name ] map ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: filter-unportable ( seq -- seq' )
|
||||
[ vocab-name unportable? not ] filter ;
|
||||
|
||||
: collect-vocabs ( quot -- seq )
|
||||
[ all-vocabs-recursive no-roots no-prefixes ] dip
|
||||
gather natural-sort ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: (load) ( prefix -- failures )
|
||||
all-vocabs-under
|
||||
child-vocabs-recursive no-roots no-prefixes
|
||||
filter-unportable
|
||||
require-all ;
|
||||
|
||||
|
|
@ -92,8 +117,6 @@ PRIVATE>
|
|||
: load-all ( -- )
|
||||
"" load ;
|
||||
|
||||
MEMO: all-tags ( -- seq )
|
||||
all-vocabs-seq [ vocab-tags ] gather natural-sort ;
|
||||
MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;
|
||||
|
||||
MEMO: all-authors ( -- seq )
|
||||
all-vocabs-seq [ vocab-authors ] gather natural-sort ;
|
||||
MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ SYMBOL: errors
|
|||
PRIVATE>
|
||||
|
||||
: run-benchmark ( vocab -- )
|
||||
[ "=== " write vocab-name print flush ] [
|
||||
[ "=== " write print flush ] [
|
||||
[ [ require ] [ gc [ run ] benchmark ] [ ] tri timings ]
|
||||
[ swap errors ]
|
||||
recover get set-at
|
||||
|
|
@ -23,7 +23,7 @@ PRIVATE>
|
|||
[
|
||||
V{ } clone timings set
|
||||
V{ } clone errors set
|
||||
"benchmark" all-child-vocabs-seq
|
||||
"benchmark" child-vocab-names
|
||||
[ run-benchmark ] each
|
||||
timings get
|
||||
errors get
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ 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
|
||||
listener ;
|
||||
|
||||
FROM: vocabs.hierarchy => child-vocabs ;
|
||||
IN: fuel.help
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -67,10 +67,10 @@ SYMBOL: describe-words
|
|||
[ fuel-vocab-help-table ] bi*
|
||||
[ 2array ] [ drop f ] if*
|
||||
] if-empty
|
||||
] { } assoc>map [ ] filter ;
|
||||
] { } assoc>map sift ;
|
||||
|
||||
: fuel-vocab-children-help ( name -- element )
|
||||
all-child-vocabs fuel-vocab-list ; inline
|
||||
child-vocabs fuel-vocab-list ; inline
|
||||
|
||||
: fuel-vocab-describe-words ( name -- element )
|
||||
[ words. ] with-string-writer \ describe-words swap 2array ; inline
|
||||
|
|
|
|||
|
|
@ -64,7 +64,7 @@ PRIVATE>
|
|||
|
||||
: article-location ( name -- loc ) article loc>> get-loc ;
|
||||
|
||||
: get-vocabs ( -- seq ) all-vocabs-seq [ vocab-name ] map ;
|
||||
: get-vocabs ( -- seq ) all-vocab-names ;
|
||||
|
||||
: get-vocabs/prefix ( prefix -- seq ) get-vocabs swap filter-prefix ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,12 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel
|
||||
cocoa
|
||||
cocoa.application
|
||||
cocoa.types
|
||||
cocoa.classes
|
||||
cocoa.windows
|
||||
core-graphics.types ;
|
||||
USING: cocoa cocoa.application cocoa.types cocoa.classes cocoa.windows
|
||||
core-graphics.types kernel math.bitwise ;
|
||||
IN: webkit-demo
|
||||
|
||||
FRAMEWORK: /System/Library/Frameworks/WebKit.framework
|
||||
|
|
@ -18,8 +13,16 @@ IMPORT: WebView
|
|||
WebView -> alloc
|
||||
rect f f -> initWithFrame:frameName:groupName: ;
|
||||
|
||||
: window-style ( -- n )
|
||||
{
|
||||
NSClosableWindowMask
|
||||
NSMiniaturizableWindowMask
|
||||
NSResizableWindowMask
|
||||
NSTitledWindowMask
|
||||
} flags ;
|
||||
|
||||
: <WebWindow> ( -- id )
|
||||
<WebView> rect <ViewWindow> ;
|
||||
<WebView> rect window-style <ViewWindow> ;
|
||||
|
||||
: load-url ( window url -- )
|
||||
[ -> contentView ] [ <NSString> ] bi* -> setMainFrameURL: ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue