diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 1a1b2fd65c..abbb86cb16 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -261,4 +261,3 @@ INSN: _reload dst class n ; INSN: _copy dst src class ; INSN: _spill-counts counts ; -SYMBOL: spill-temp diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor index e31fcedace..b2872ace14 100644 --- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor +++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor @@ -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 diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 6b7fdd8ce1..8a9bfa02db 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -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 -- ) diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 63d31dfb4e..e3cd9e105f 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -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 \ No newline at end of file +[ _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 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 ca8140f1c6..61432eefdf 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -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#>> ; diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor index 4c27e5c4eb..7e308cf231 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -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 } } } ] [ { diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index 951e727375..196d8e439f 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -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 ] - [ reg-class>> ] bi \ register->memory boa + [ from>> ] + [ reg-class>> spill-temp ] + [ reg-class>> ] + tri \ register->memory boa ] [ - [ to>> spill-temp swap ] - [ reg-class>> ] bi \ memory->register boa + [ reg-class>> spill-temp ] + [ 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 ; diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index f81490bcf2..da6a589031 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -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 diff --git a/basis/help/apropos/apropos.factor b/basis/help/apropos/apropos.factor index 63cbcb3f1e..3bcc815191 100644 --- a/basis/help/apropos/apropos.factor +++ b/basis/help/apropos/apropos.factor @@ -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 diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index fbfc42829e..84f708a687 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -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 ) [ diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 1fb836427a..e0cea42b4f 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -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 diff --git a/basis/help/vocabs/vocabs.factor b/basis/help/vocabs/vocabs.factor index b23143e572..7d99493691 100644 --- a/basis/help/vocabs/vocabs.factor +++ b/basis/help/vocabs/vocabs.factor @@ -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 ] unless-empty ; : describe-children ( vocab -- ) - vocab-name all-child-vocabs $vocab-roots ; + vocab-name child-vocabs + $vocab-roots ; : files. ( seq -- ) snippet-style get [ diff --git a/basis/present/present-tests.factor b/basis/present/present-tests.factor index e908fd8147..96aa7b24f2 100644 --- a/basis/present/present-tests.factor +++ b/basis/present/present-tests.factor @@ -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 \ No newline at end of file +[ ] [ all-vocabs-recursive no-roots no-prefixes [ present ] map drop ] unit-test \ No newline at end of file diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index c8fd3a6658..fb664c495c 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -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 ; diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index 390e652ac6..3beb0af79f 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -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 ; diff --git a/basis/vocabs/cache/cache.factor b/basis/vocabs/cache/cache.factor index 63a8d6d292..24ccd391f1 100644 --- a/basis/vocabs/cache/cache.factor +++ b/basis/vocabs/cache/cache.factor @@ -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 ; diff --git a/basis/vocabs/hierarchy/hierarchy-docs.factor b/basis/vocabs/hierarchy/hierarchy-docs.factor index 3bea362582..8eb39732c0 100644 --- a/basis/vocabs/hierarchy/hierarchy-docs.factor +++ b/basis/vocabs/hierarchy/hierarchy-docs.factor @@ -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." } ; diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor index 046ccb8c2d..aa3e619660 100644 --- a/basis/vocabs/hierarchy/hierarchy.factor +++ b/basis/vocabs/hierarchy/hierarchy.factor @@ -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 + +M: vocab-prefix vocab-name name>> ; + 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 ] [ ] 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 ; - - -: 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 ; : (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 ; \ No newline at end of file +MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ; diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index 6c64e34835..ca71e22e9f 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -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 diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor index f20e67f9bc..dcf5d69a74 100644 --- a/extra/fuel/help/help.factor +++ b/extra/fuel/help/help.factor @@ -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 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 diff --git a/extra/fuel/xref/xref.factor b/extra/fuel/xref/xref.factor index 608667bae7..86aa215e21 100644 --- a/extra/fuel/xref/xref.factor +++ b/extra/fuel/xref/xref.factor @@ -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 ; diff --git a/extra/webkit-demo/webkit-demo.factor b/extra/webkit-demo/webkit-demo.factor index 728764226e..e6178a55c3 100644 --- a/extra/webkit-demo/webkit-demo.factor +++ b/extra/webkit-demo/webkit-demo.factor @@ -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 ; + : ( -- id ) - rect ; + rect window-style ; : load-url ( window url -- ) [ -> contentView ] [ ] bi* -> setMainFrameURL: ;