Merge branch 'master' of git://factorcode.org/git/factor

basis/sorting/functor/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/sorting/functor/functor.factor

@@ -0,0 +1,16 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: functors kernel math.order sequences sorting ;
+IN: sorting.functor
+
+FUNCTOR: define-sorting ( NAME QUOT -- )
+
+NAME<=> DEFINES ${NAME}<=>
+NAME>=< DEFINES ${NAME}>=<
+
+WHERE
+
+: NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ;
+: NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ;
+
+;FUNCTOR

basis/sorting/human/human-docs.factor

@@ -25,46 +25,11 @@ HELP: human>=<
 }
 { $description "Compares two objects using the " { $link human<=> } " word and inverts the result." } ;
 
-HELP: human-compare
-{ $values
-     { "obj1" object } { "obj2" object } { "quot" quotation }
-     { "<=>" "an ordering specifier" }
-}
-{ $description "Compares the results of applying the quotation to both objects via <=>." } ;
-
-HELP: human-sort
-{ $values
-     { "seq" sequence }
-     { "seq'" sequence }
-}
-{ $description "Sorts a sequence of objects by comparing the magnitude of any integers in the input string using the <=> word." } ;
-
-HELP: human-sort-keys
-{ $values
-     { "seq" "an alist" }
-     { "sortedseq" "a new sorted sequence" }
-}
-{ $description "Sorts the elements comparing first elements of pairs using the " { $link human<=> } " word." } ;
-
-HELP: human-sort-values
-{ $values
-     { "seq" "an alist" }
-     { "sortedseq" "a new sorted sequence" }
-}
-{ $description "Sorts the elements comparing second elements of pairs using the " { $link human<=> } " word." } ;
-
-{ <=> >=< human-compare human-sort human-sort-keys human-sort-values } related-words
-
 ARTICLE: "sorting.human" "Human-friendly sorting"
 "The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl
 "Comparing two objects:"
 { $subsection human<=> }
 { $subsection human>=< }
-{ $subsection human-compare }
-"Sort a sequence:"
-{ $subsection human-sort }
-{ $subsection human-sort-keys }
-{ $subsection human-sort-values }
 "Splitting a string into substrings and integers:"
 { $subsection find-numbers } ;
 

basis/sorting/human/human-tests.factor

@@ -1,6 +1,6 @@
-USING: sorting.human tools.test ;
+USING: sorting.human tools.test sorting.slots ;
 IN: sorting.human.tests
 
 \ human-sort must-infer
 
-[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } human-sort ] unit-test
+[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test

basis/sorting/human/human.factor

@@ -1,22 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: peg.ebnf math.parser kernel assocs sorting fry
+USING: math.parser peg.ebnf sorting.functor ;
-math.order sequences ascii splitting.monotonic ;
 IN: sorting.human
 
 : find-numbers ( string -- seq )
     [EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
 
-: human<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ;
+<< "human" [ find-numbers ] define-sorting >>
-
-: human>=< ( obj1 obj2 -- >=< ) human<=> invert-comparison ; inline
-
-: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ; inline
-
-: human-sort ( seq -- seq' ) [ human<=> ] sort ;
-
-: human-sort-keys ( seq -- sortedseq )
-    [ [ first ] human-compare ] sort ;
-
-: human-sort-values ( seq -- sortedseq )
-    [ [ second ] human-compare ] sort ;

basis/sorting/slots/slots-docs.factor

@@ -14,7 +14,7 @@ HELP: compare-slots
 HELP: sort-by-slots
 { $values
      { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
-     { "seq'" sequence }
+     { "sortedseq" sequence }
 }
 { $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
 { $examples
@@ -39,11 +39,20 @@ HELP: split-by-slots
 }
 { $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ;
 
+HELP: sort-by
+{ $values
+    { "seq" sequence } { "sort-seq" "a sequence of comparators" }
+    { "sortedseq" sequence }
+}
+{ $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ;
+
 ARTICLE: "sorting.slots" "Sorting by slots"
 "The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
 "Comparing two objects by a sequence of slots:"
 { $subsection compare-slots }
-"Sorting a sequence by a sequence of slots:"
+"Sorting a sequence of tuples by a slot/comparator pairs:"
-{ $subsection sort-by-slots } ;
+{ $subsection sort-by-slots }
+"Sorting a sequence by a sequence of comparators:"
+{ $subsection sort-by } ;
 
 ABOUT: "sorting.slots"

basis/sorting/slots/slots-tests.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors math.order sorting.slots tools.test
-sorting.human arrays sequences kernel assocs multiline ;
+sorting.human arrays sequences kernel assocs multiline
+sorting.functor ;
 IN: sorting.literals.tests
 
 TUPLE: sort-test a b c tuple2 ;
@@ -76,6 +77,9 @@ TUPLE: tuple2 d ;
 [ { } ]
 [ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test
 
+[ { } ]
+[ { } { } sort-by-slots ] unit-test
+
 [
     {
         T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
@@ -143,3 +147,15 @@ TUPLE: tuple2 d ;
         T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
     } { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map
 ] unit-test
+
+
+[ { "a" "b" "c" } ] [ { "b" "c" "a" } { <=> <=> } sort-by ] unit-test
+[ { "b" "c" "a" } ] [ { "b" "c" "a" } { } sort-by ] unit-test
+
+<< "length-test" [ length ] define-sorting >>
+
+[ { { 1 } { 1 2 3 } { 1 3 2 } { 3 2 1 } } ]
+[
+    { { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } }
+    { length-test<=> <=> } sort-by
+] unit-test

basis/sorting/slots/slots.factor

@@ -7,13 +7,16 @@ IN: sorting.slots
 
 <PRIVATE
 
+: short-circuit-comparator ( obj1 obj2 word --  comparator/? )
+    execute dup +eq+ eq? [ drop f ] when ;
+
 : slot-comparator ( seq -- quot )
     [
         but-last-slice
         [ '[ [ _ execute ] bi@ ] ] map concat
     ] [
         peek
-        '[ @ _ execute dup +eq+ eq? [ drop f ] when ]
+        '[ @ _ short-circuit-comparator ]
     ] bi ;
 
 PRIVATE>
@@ -22,9 +25,21 @@ MACRO: compare-slots ( sort-specs -- <=> )
     #! sort-spec: { accessors comparator }
     [ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
 
-: sort-by-slots ( seq sort-specs -- seq' )
+: sort-by-slots ( seq sort-specs -- sortedseq )
     '[ _ compare-slots ] sort ;
 
+MACRO: compare-seq ( seq -- quot )
+    [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ;
+
+: sort-by ( seq sort-seq -- sortedseq )
+    '[ _ compare-seq ] sort ;
+
+: sort-keys-by ( seq sort-seq -- sortedseq )
+    '[ [ first ] bi@ _ compare-seq ] sort ;
+
+: sort-values-by ( seq sort-seq -- sortedseq )
+    '[ [ second ] bi@ _ compare-seq ] sort ;
+
 MACRO: split-by-slots ( accessor-seqs -- quot )
     [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
     '[ [ _ 2&& ] slice monotonic-slice ] ;

basis/sorting/title/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/sorting/title/title-tests.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test sorting.title sorting.slots ;
+IN: sorting.title.tests
+
+: sort-me ( -- seq )
+    {
+        "The Beatles"
+        "A river runs through it"
+        "Another"
+        "la vida loca"
+        "Basketball"
+        "racquetball"
+        "Los Fujis"
+        "los Fujis"
+        "La cucaracha"
+        "a day to remember"
+        "of mice and men"
+        "on belay"
+        "for the horde"
+    } ;
+[
+    {
+        "Another"
+        "Basketball"
+        "The Beatles"
+        "La cucaracha"
+        "a day to remember"
+        "for the horde"
+        "Los Fujis"
+        "los Fujis"
+        "of mice and men"
+        "on belay"
+        "racquetball"
+        "A river runs through it"
+        "la vida loca"
+    }
+] [
+    sort-me { title<=> } sort-by
+] unit-test

basis/sorting/title/title.factor

@@ -0,0 +1,7 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sorting.functor regexp kernel accessors sequences
+unicode.case ;
+IN: sorting.title
+
+<< "title" [ >lower dup R/ ^(the|a|an|el|la|los|las|il) / first-match [ to>> tail-slice ] when* ] define-sorting >>

basis/ui/gadgets/editors/editors.factor

@@ -141,7 +141,7 @@ M: editor ungraft*
 : scroll>caret ( editor -- )
     dup graft-state>> second [
         [
-            [ caret-loc ] [ caret-dim { 1 0 } v+ ] bi <rect>
+            [ caret-loc ] [ caret-dim { 2 1 } v+ ] bi <rect>
         ] keep scroll>rect
     ] [ drop ] if ;
 

basis/ui/gadgets/line-support/line-support.factor

@@ -30,6 +30,9 @@ M: line-gadget line-height font>> font-metrics height>> ceiling ;
 : validate-line ( m gadget -- n )
     control-value [ drop f ] [ length 1- min 0 max ] if-empty ;
 
+: valid-line? ( n gadget -- ? )
+    control-value length 1- 0 swap between? ;
+
 : visible-line ( gadget quot -- n )
     '[
         [ clip get @ origin get [ second ] bi@ - ] dip

basis/ui/gadgets/scrollers/scrollers.factor

@@ -54,10 +54,10 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ;
     2dup control-value = [ 2drop ] [ set-control-value ] if ;
 
 : (scroll>rect) ( rect scroller -- )
-    [ [ loc>> ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
     {
         [ scroller-value vneg offset-rect ]
         [ viewport>> dim>> rect-min ]
+        [ viewport>> loc>> offset-rect ]
         [ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ]
         [ scroller-value v+ ]
         [ scroll ]

basis/ui/gadgets/tables/tables.factor

@@ -268,12 +268,13 @@ M: table model-changed
 : mouse-row ( table -- n )
     [ hand-rel second ] keep y>line ;
 
+: if-mouse-row ( table true: ( table mouse-index -- ) false: ( table -- ) -- )
+    [ [ mouse-row ] keep 2dup valid-line? ]
+    [ ] [ '[ nip @ ] ] tri* if ; inline
+
 : table-button-down ( table -- )
     dup takes-focus?>> [ dup request-focus ] when
-    dup control-value empty? [ drop ] [
+    [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ;
-        dup [ mouse-row ] keep validate-line
-        [ >>mouse-index ] [ (select-row) ] bi
-    ] if ;
 
 PRIVATE>
 
@@ -283,11 +284,14 @@ PRIVATE>
     [ 2drop ]
     if ;
 
+: row-action? ( table -- ? )
+    [ [ mouse-row ] keep valid-line? ]
+    [ single-click?>> hand-click# get 2 = or ] bi and ;
+
 <PRIVATE
 
 : table-button-up ( table -- )
-    dup single-click?>> hand-click# get 2 = or
+    dup row-action? [ row-action ] [ update-selected-value ] if ;
-    [ row-action ] [ update-selected-value ] if ;
 
 : select-row ( table n -- )
     over validate-line
@@ -320,13 +324,6 @@ PRIVATE>
 : next-page ( table -- )
     1 prev/next-page ;
 
-: valid-row? ( row table -- ? )
-    control-value length 1- 0 swap between? ;
-
-: if-mouse-row ( table true false -- )
-    [ [ mouse-row ] keep 2dup valid-row? ]
-    [ ] [ '[ nip @ ] ] tri* if ; inline
-
 : show-mouse-help ( table -- )
     [
         swap

basis/ui/tools/listener/completion/completion.factor

@@ -141,6 +141,7 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
         t >>selection-required?
         t >>single-click?
         30 >>min-cols
+        10 >>min-rows
         10 >>max-rows
         dup '[ _ accept-completion ] >>action ;
 

extra/html/parser/analyzer/analyzer.factor

@@ -127,11 +127,13 @@ TUPLE: link attributes clickable ;
         [ name>> "a" = ]
         [ attributes>> "href" swap key? ] bi and ] filter
     ] map sift
-    [ [ attributes>> "href" swap at ] map ] map concat ;
+    [ [ attributes>> "href" swap at ] map ] map concat
+    [ >url ] map ;
 
 : find-frame-links ( vector -- vector' )
     [ name>> "frame" = ] find-between-all
-    [ [ attributes>> "src" swap at ] map sift ] map concat sift ;
+    [ [ attributes>> "src" swap at ] map sift ] map concat sift
+    [ >url ] map ;
 
 : find-all-links ( vector -- vector' )
     [ find-hrefs ] [ find-frame-links ] bi append prune ;

extra/html/parser/state/state-tests.factor

@@ -99,3 +99,6 @@ IN: html.parser.state.tests
 
 [ "" ]
 [ "abc" <state-parser> dup "abc" take-sequence drop take-rest ] unit-test
+
+[ f ]
+[ "abc" <state-parser> "abcdefg" take-sequence ] unit-test

extra/html/parser/state/state.factor

@@ -51,9 +51,16 @@ TUPLE: state-parser sequence n ;
 : take-while ( state-parser quot: ( obj -- ? ) -- sequence/f )
     [ not ] compose take-until ; inline
 
+: <safe-slice> ( from to seq -- slice/f )
+    3dup {
+        [ 2drop 0 < ]
+        [ [ drop ] 2dip length > ]
+        [ drop > ]
+    } 3|| [ 3drop f ] [ slice boa ] if ; inline
+
 :: take-sequence ( state-parser sequence -- obj/f )
-    state-parser [ n>> dup sequence length + ] [ sequence>> ] bi <slice>
+    state-parser [ n>> dup sequence length + ] [ sequence>> ] bi
-    sequence sequence= [
+    <safe-slice> sequence sequence= [
         sequence
         state-parser [ sequence length + ] change-n drop
     ] [

extra/mason/child/child-tests.factor

@@ -32,3 +32,11 @@ USING: mason.child mason.config tools.test namespaces ;
         boot-cmd
     ] with-scope
 ] unit-test
+
+[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" } ] [
+    [
+        "winnt" target-os set
+        "x86.32" target-cpu set
+        boot-cmd
+    ] with-scope
+] unit-test

extra/mason/child/child.factor

@@ -25,8 +25,11 @@ IN: mason.child
     builds-factor-image "." copy-file-into
     builds-factor-image "factor" copy-file-into ;
 
+: factor-vm ( -- string )
+    target-os get "winnt" = "./factor.com" "./factor" ? ;
+
 : boot-cmd ( -- cmd )
-    "./factor"
+    factor-vm
     "-i=" boot-image-name append
     "-no-user-init"
     3array ;
@@ -42,7 +45,7 @@ IN: mason.child
         try-process
     ] with-directory ;
 
-: test-cmd ( -- cmd ) { "./factor" "-run=mason.test" } ;
+: test-cmd ( -- cmd ) factor-vm "-run=mason.test" 2array ;
 
 : test ( -- )
     "factor" [

extra/spider/report/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/spider/report/report.factor

@@ -0,0 +1,113 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators kernel math
+math.statistics namespaces sequences sorting xml.syntax
+spider ;
+IN: spider.report
+
+SYMBOL: network-failures
+SYMBOL: broken-pages
+SYMBOL: timings
+
+: record-broken-page ( url spider-result -- )
+    headers>> [ code>> ] [ message>> ] bi 2array 2array
+    broken-pages push ;
+
+: record-page-timings ( url spider-result -- )
+    fetch-time>> 2array timings get push ;
+
+: record-network-failure ( url -- )
+    network-failures get push ;
+
+: process-result ( url spider-result -- )
+    {
+        { f [ record-network-failure ] }
+        [
+            dup headers>> code>> 200 =
+            [ record-page-timings ] [ record-broken-page ] if
+        ]
+    } case ;
+
+CONSTANT: slowest 5
+
+SYMBOL: slowest-pages
+SYMBOL: mean-time
+SYMBOL: median-time
+SYMBOL: time-std
+
+: process-timings ( -- )
+    timings get sort-values
+    [ slowest short tail* reverse slowest-pages set ]
+    [
+        values
+        [ mean 1000000 /f mean-time set ]
+        [ median 1000000 /f median-time set ]
+        [ std 1000000 /f time-std set ] tri
+    ] bi ;
+
+: process-results ( results -- )
+    V{ } clone network-failures set
+    V{ } clone broken-pages set
+    V{ } clone timings set
+    [ process-result ] assoc-each
+    process-timings ;
+
+: info-table ( alist -- html )
+    [
+        first2 dupd 1000000 /f
+        [XML
+        <tr><td><a href=<->><-></a></td><td><-> seconds</td></tr>
+        XML]
+    ] map [XML <table border="1"><-></table> XML] ;
+
+: report-broken-pages ( -- html )
+    broken-pages get info-table ;
+
+: report-network-failures ( -- html )
+    network-failures get [
+        dup [XML <li><a href=<->><-></a></li> XML]
+    ] map [XML <ul><-></ul> XML] ;
+
+: slowest-pages-table ( -- html )
+    slowest-pages get info-table ;
+
+: timing-summary-table ( -- html )
+    mean-time get
+    median-time get
+    time-std get
+    [XML
+    <table border="1">
+    <tr><th>Mean</th><td><-> seconds</td></tr>
+    <tr><th>Median</th><td><-> seconds</td></tr>
+    <tr><th>Standard deviation</th><td><-> seconds</td></tr>
+    </table>
+    XML] ;
+
+: report-timings ( -- html )
+    slowest-pages-table
+    timing-summary-table
+    [XML
+    <h2>Slowest pages</h2>
+    <->
+
+    <h2>Summary</h2>
+    <->
+    XML] ;
+
+: generate-report ( -- html )
+    report-broken-pages
+    report-network-failures
+    report-timings
+    [XML
+    <h1>Broken pages</h1>
+    <->
+
+    <h1>Network failures</h1>
+    <->
+
+    <h1>Load times</h1>
+    <->
+    XML] ;
+
+: spider-report ( spider -- html )
+    [ spidered>> process-results generate-report ] with-scope ;

extra/spider/spider.factor

@@ -4,15 +4,15 @@ USING: accessors fry html.parser html.parser.analyzer
 http.client kernel tools.time sets assocs sequences
 concurrency.combinators io threads namespaces math multiline
 math.parser inspector urls logging combinators.short-circuit
-continuations calendar prettyprint dlists deques locals
+continuations calendar prettyprint dlists deques locals ;
-present ;
 IN: spider
 
 TUPLE: spider base count max-count sleep max-depth initial-links
-filters spidered todo nonmatching quiet currently-spidering ;
+filters spidered todo nonmatching quiet currently-spidering
+#threads follow-robots ;
 
-TUPLE: spider-result url depth headers fetch-time parsed-html
+TUPLE: spider-result url depth headers
-links processing-time timestamp ;
+fetched-in parsed-html links processed-in fetched-at ;
 
 TUPLE: todo-url url depth ;
 
@@ -51,7 +51,8 @@ TUPLE: unique-deque assoc deque ;
         0 >>max-depth
         0 >>count
         1/0. >>max-count
-        H{ } clone >>spidered ;
+        H{ } clone >>spidered
+        1 >>#threads ;
 
 <PRIVATE
 
@@ -79,12 +80,8 @@ TUPLE: unique-deque assoc deque ;
     [ add-nonmatching ]
     [ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
 
-: url-absolute? ( url -- ? )
+: normalize-hrefs ( base links -- links' )
-    present "http://" head? ;
+    [ derive-url ] with map ;
-
-: normalize-hrefs ( links spider -- links' )
-    currently-spidering>> present swap
-    [ dup url-absolute? [ derive-url ] [ url-append-path >url ] if ] with map ;
 
 : print-spidering ( url depth -- )
     "depth: " write number>string write
@@ -94,7 +91,9 @@ TUPLE: unique-deque assoc deque ;
     f url spider spidered>> set-at
     [ url http-get ] benchmark :> fetch-time :> html :> headers
     [
-        html parse-html [ ] [ find-all-links spider normalize-hrefs ] bi
+        html parse-html
+        spider currently-spidering>>
+        over find-all-links normalize-hrefs
     ] benchmark :> processing-time :> links :> parsed-html
     url depth headers fetch-time parsed-html links processing-time
     now spider-result boa ;
@@ -107,11 +106,12 @@ TUPLE: unique-deque assoc deque ;
 
 \ spider-page ERROR add-error-logging
 
-: spider-sleep ( spider -- )
+: spider-sleep ( spider -- ) sleep>> [ sleep ] when* ;
-    sleep>> [ sleep ] when* ;
 
-:: queue-initial-links ( spider -- spider )
+: queue-initial-links ( spider -- )
-    spider initial-links>> spider normalize-hrefs 0 spider add-todo spider ;
+    [
+        [ currently-spidering>> ] [ initial-links>> ] bi normalize-hrefs 0
+    ] keep add-todo ;
 
 : spider-page? ( spider -- ? )
     {
@@ -121,7 +121,7 @@ TUPLE: unique-deque assoc deque ;
     } 1&& ;
 
 : setup-next-url ( spider -- spider url depth )
-    dup todo>> peek-url url>> present >>currently-spidering
+    dup todo>> peek-url url>> >>currently-spidering
     dup todo>> pop-url [ url>> ] [ depth>> ] bi ;
 
 : spider-next-page ( spider -- )
@@ -138,5 +138,5 @@ PRIVATE>
 
 : run-spider ( spider -- spider )
     "spider" [
-        queue-initial-links [ run-spider-loop ] keep
+        dup queue-initial-links [ run-spider-loop ] keep
     ] with-logging ;

extra/ui/offscreen/offscreen-docs.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax kernel quotations ui.gadgets
-images.bitmap strings ui.gadgets.worlds ;
+images strings ui.gadgets.worlds ;
 IN: ui.offscreen
 
 HELP: <offscreen-world>
@@ -26,9 +26,9 @@ HELP: do-offscreen
 HELP: gadget>bitmap
 { $values
      { "gadget" gadget }
-     { "bitmap" bitmap }
+     { "image" image }
 }
-{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates a " { $link bitmap } " from its contents." } ;
+{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates an " { $link image } " from its contents." } ;
 
 HELP: offscreen-world
 { $class-description "The class of " { $link world } " objects that render to an offscreen buffer." } ;
@@ -36,9 +36,9 @@ HELP: offscreen-world
 HELP: offscreen-world>bitmap
 { $values
      { "world" offscreen-world }
-     { "bitmap" bitmap }
+     { "image" image }
 }
-{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link bitmap } " object." } ;
+{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link image } " object." } ;
 
 HELP: open-offscreen
 { $values

extra/ui/offscreen/offscreen.factor

@@ -1,7 +1,7 @@
 ! (c) 2008 Joe Groff, see license for details
-USING: accessors continuations images.bitmap kernel math
+USING: accessors alien.c-types continuations images kernel math
 sequences ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.private ui ui.backend destructors ;
+ui.private ui ui.backend destructors locals ;
 IN: ui.offscreen
 
 TUPLE: offscreen-world < world ;
@@ -19,18 +19,24 @@ M: offscreen-world ungraft*
 
 : open-offscreen ( gadget -- world )
     "" f <offscreen-world>
-    [ open-world-window dup relayout-1 ] keep
+    [ open-world-window ] [ relayout-1 ] [ ] tri
     notify-queued ;
 
 : close-offscreen ( world -- )
     ungraft notify-queued ;
 
-: offscreen-world>bitmap ( world -- bitmap )
+:: bgrx>bitmap ( alien w h -- image )
-    offscreen-pixels bgra>bitmap ;
+    <image>
+        { w h } >>dim
+        alien w h * 4 * memory>byte-array >>bitmap
+        BGRX >>component-order ;
+
+: offscreen-world>bitmap ( world -- image )
+    offscreen-pixels bgrx>bitmap ;
 
 : do-offscreen ( gadget quot: ( offscreen-world -- ) -- )
     [ open-offscreen ] dip
     over [ slip ] [ close-offscreen ] [ ] cleanup ; inline
 
-: gadget>bitmap ( gadget -- bitmap )
+: gadget>bitmap ( gadget -- image )
     [ offscreen-world>bitmap ] do-offscreen ;

vm/io.c

@@ -179,7 +179,7 @@ void primitive_fseek(void)
 		break;
 	}
 
-	if(fseeko(file,offset,whence) == -1)
+	if(FSEEK(file,offset,whence) == -1)
 	{
 		io_error();
 

vm/os-unix.h

@@ -23,6 +23,8 @@ typedef char F_SYMBOL;
 #define STRNCMP strncmp
 #define STRDUP strdup
 
+#define FSEEK fseeko
+
 #define FIXNUM_FORMAT "%ld"
 #define CELL_FORMAT "%lu"
 #define CELL_HEX_FORMAT "%lx"

vm/os-windows.h

@@ -20,6 +20,7 @@ typedef wchar_t F_CHAR;
 #define STRNCMP wcsncmp
 #define STRDUP _wcsdup
 #define MIN(a,b) ((a)>(b)?(b):(a))
+#define FSEEK fseek
 
 #ifdef WIN64
 	#define CELL_FORMAT "%Iu"