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

core/dlists/dlists.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007 Mackenzie Straight, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math ;
+USING: combinators kernel math sequences ;
 IN: dlists
 
 TUPLE: dlist front back length ;
@@ -72,6 +72,9 @@ PRIVATE>
 : push-front ( obj dlist -- )
     push-front* drop ;
 
+: push-all-front ( seq dlist -- )
+    [ push-front ] curry each ;
+
 : push-back* ( obj dlist -- dlist-node )
     [ dlist-back f <dlist-node> ] keep
     [ dlist-back set-next-when ] 2keep
@@ -80,11 +83,10 @@ PRIVATE>
     inc-length ;
 
 : push-back ( obj dlist -- )
-    [ dlist-back f <dlist-node> ] keep
+    push-back* drop ;
-    [ dlist-back set-next-when ] 2keep
+
-    [ set-dlist-back ] keep
+: push-all-back ( seq dlist -- )
-    [ set-front-to-back ] keep
+    [ push-back ] curry each ;
-    inc-length ;
 
 : peek-front ( dlist -- obj )
     dlist-front dlist-node-obj ;
@@ -156,3 +158,6 @@ PRIVATE>
     over dlist-empty?
     [ 2drop ] [ [ >r pop-back r> call ] 2keep dlist-slurp ] if ;
     inline
+
+: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
+

core/io/files/files.factor

@@ -141,37 +141,6 @@ C: <pathname> pathname
 
 M: pathname <=> [ pathname-string ] compare ;
 
-HOOK: library-roots io-backend ( -- seq )
-HOOK: binary-roots io-backend ( -- seq )
-
-: find-file ( seq str -- path/f )
-    [
-        [ path+ exists? ] curry find nip
-    ] keep over [ path+ ] [ drop ] if ;
-
-: find-library ( str -- path/f )
-    library-roots swap find-file ;
-
-: find-binary ( str -- path/f )
-    binary-roots swap find-file ;
-
-<PRIVATE
-: append-path ( path files -- paths )
-    [ path+ ] with map ;
-
-: get-paths ( dir -- paths )
-    dup directory keys append-path ;
-
-: (walk-dir) ( path -- )
-    dup directory? [
-        get-paths dup % [ (walk-dir) ] each
-    ] [
-        drop
-    ] if ;
-PRIVATE>
-
-: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ;
-
 : file-lines ( path -- seq ) <file-reader> lines ;
 
 : file-contents ( path -- str )

extra/builder/builder.factor

@@ -1,6 +1,6 @@
 
 USING: kernel parser io io.files io.launcher io.sockets hashtables math threads
-       system continuations namespaces sequences splitting math.parser
+       arrays system continuations namespaces sequences splitting math.parser
        prettyprint tools.time calendar bake vars http.client
        combinators bootstrap.image bootstrap.image.download
        combinators.cleave ;
@@ -11,21 +11,6 @@ IN: builder
 
 : runtime ( quot -- time ) benchmark nip ;
 
-: log-runtime ( quot file -- )
-  >r runtime r> <file-writer> [ . ] with-stream ;
-
-: log-object ( object file -- ) <file-writer> [ . ] with-stream ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: datestamp ( -- string )
-  now `{ ,[ dup timestamp-year   ]
-         ,[ dup timestamp-month  ]
-         ,[ dup timestamp-day    ]
-         ,[ dup timestamp-hour   ]
-         ,[     timestamp-minute ] }
-  [ pad-00 ] map "-" join ;
-
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 SYMBOL: builder-recipients
@@ -48,23 +33,8 @@ SYMBOL: builder-recipients
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: run-or-notify ( desc message -- )
-  [ [ try-process ]        curry ]
-  [ [ email-string throw ] curry ]
-  bi*
-  recover ;
-
-: run-or-send-file ( desc message file -- )
-  >r >r [ try-process ]         curry
-  r> r> [ email-file throw ] 2curry
-  recover ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : factor-binary ( -- name )
   os
   { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
@@ -72,12 +42,6 @@ SYMBOL: builder-recipients
     [ drop "./factor" ] }
   case ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: stamp
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : git-pull ( -- desc )
   {
     "git"
@@ -89,16 +53,30 @@ VAR: stamp
 
 : git-clone ( -- desc ) { "git" "clone" "../factor" } ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: datestamp ( -- string )
+  now `{ ,[ dup timestamp-year   ]
+         ,[ dup timestamp-month  ]
+         ,[ dup timestamp-day    ]
+         ,[ dup timestamp-hour   ]
+         ,[     timestamp-minute ] }
+  [ pad-00 ] map "-" join ;
+
+VAR: stamp
+
 : enter-build-dir ( -- )
   datestamp >stamp
   "/builds" cd
   stamp> make-directory
   stamp> cd ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : git-id ( -- id )
   { "git" "show" } <process-stream> [ readln ] with-stream " " split second ;
 
-: record-git-id ( -- ) git-id "../git-id" log-object ;
+: record-git-id ( -- ) git-id "../git-id" [ . ] with-file-out ;
 
 : make-clean ( -- desc ) { "make" "clean" } ;
 
@@ -110,13 +88,6 @@ VAR: stamp
    }
   >hashtable ;
 
-: retrieve-boot-image ( -- )
-  [ my-arch download-image ]
-  [ ]
-  [ "builder: image download" email-string ]
-  cleanup
-  flush ;
-
 : bootstrap ( -- desc )
   `{
      { +arguments+ {
@@ -131,129 +102,66 @@ VAR: stamp
 
 : builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ;
   
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 SYMBOL: build-status
 
-! : build ( -- )
-
-!   enter-build-dir
-  
-!   git-clone "git clone error" run-or-notify
-
-!   "factor" cd
-
-!   record-git-id
-
-!   make-clean "make clean error" run-or-notify
-
-!   make-vm "vm compile error" "../compile-log" run-or-send-file
-
-!   retrieve-boot-image
-
-!   bootstrap "bootstrap error" "../boot-log" run-or-send-file
-
-!   builder-test "builder.test fatal error" run-or-notify
-  
-!   "../load-everything-log" exists?
-!   [ "load-everything" "../load-everything-log" email-file ]
-!   when
-
-!   "../failing-tests" exists?
-!   [ "failing tests" "../failing-tests" email-file ]
-!   when ;
-
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-SYMBOL: report
+: milli-seconds>time ( n -- string )
-
+  1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
-: >>>report ( quot -- ) report get swap with-stream* ;
-
-: file>>>report ( file -- ) [ <file-reader> contents write ] curry >>>report ;
 
+: eval-file ( file -- obj ) <file-reader> contents eval ;
+  
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: run-or-report ( desc quot -- )
+: cat ( file -- ) <file-reader> contents print ;
-  [ [ try-process     ] curry ]
+
-  [ [ >>>report throw ] curry ]
+: run-or-bail ( desc quot -- )
+  [ [ try-process ] curry ]
+  [ [ throw       ] curry ]
   bi*
   recover ;
 
-: run-or-report-file ( desc quot file -- )
-  [ [ try-process ] curry ]
-  [ [ >>>report ] curry ]
-  [ [ file>>>report throw ] curry ]
-  tri*
-  compose
-  recover ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ms>minutes ( ms -- minutes ) 1000.0 / 60 / ;
-
-: bootstrap-minutes ( -- )
-  "../bootstrap-time" <file-reader> contents eval ms>minutes unparse ;
-
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : (build) ( -- )
 
   enter-build-dir
 
-  "report" <file-writer> report set
+  "report" [
 
-  [
+    "Build machine:   " write host-name print
-    "Build machine:   " write host-name write nl
+    "Build directory: " write cwd       print
-    "Build directory: " write cwd write nl
-  ] >>>report
 
-  git-clone [ "Builder fatal error: git clone failed" write nl ] run-or-report
+    git-clone [ "git clone failed" print ] run-or-bail
 
-  "factor" cd
+    "factor" cd
 
-  record-git-id
+    record-git-id
 
-  make-clean run-process drop
+    make-clean run-process drop
 
-  make-vm
+    make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail
-    [ "Builder fatal error: vm compile error" write nl ]
-    "../compile-log"
-  run-or-report-file
 
-  [ my-arch download-image ]
+    [ my-arch download-image ] [ "Image download error" print throw ] recover
-    [ [ "Builder fatal error: image download" write nl ] >>>report throw ]
-  recover
 
-  bootstrap [ "Bootstrap error" write nl ] "../boot-log" run-or-report-file
+    bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
 
-  builder-test [ "Builder test error" write nl ] run-or-report
+    [ builder-test try-process ]
+    [ "Builder test error" print throw ]
+    recover
 
-  [ "Bootstrap time: " write bootstrap-minutes write " minutes" write nl ]
+    "Boot time: " write "../boot-time" eval-file milli-seconds>time print
-  >>>report
+    "Load time: " write "../load-time" eval-file milli-seconds>time print
+    "Test time: " write "../test-time" eval-file milli-seconds>time print
 
-  "../load-everything-vocabs" exists?
+    "Did not pass load-everything: " print "../load-everything-vocabs" cat
-    [
+    "Did not pass test-all: "        print "../test-all-vocabs"        cat
-      [ "Did not pass load-everything: " write nl ] >>>report
-      "../load-everything-vocabs" file>>>report
-    ]
-  when
 
-  "../test-all-vocabs" exists?
+  ] with-file-out ;
-    [
-      [ "Did not pass test-all: " write nl ] >>>report
-      "../test-all-vocabs" file>>>report
-    ]
-  when ;
-
-: send-report ( -- )
-  report get dispose
-  "report" "../report" email-file ;
 
 : build ( -- )
-  [ (build) ]
+  [ (build) ] [ drop ] recover
-    [ drop ]
+  "report" "../report" email-file ;
-  recover
-  send-report ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/builder/test/test.factor

@@ -10,28 +10,15 @@ USING: kernel namespaces sequences assocs builder continuations
 
 IN: builder.test
 
-: record-bootstrap-time ( -- )
-  "../bootstrap-time" <file-writer>
-    [ bootstrap-time get . ]
-  with-stream ;
-
 : do-load ( -- )
-  [ try-everything keys ] "../load-everything-time" log-runtime
+  try-everything keys "../load-everything-vocabs" [ . ] with-file-out ;
-  dup empty?
-    [ drop ]
-    [ "../load-everything-vocabs" log-object ]
-  if ;
 
 : do-tests ( -- )
-  [ run-all-tests keys ] "../test-all-time" log-runtime
+  run-all-tests keys "../test-all-vocabs" [ . ] with-file-out ;
-  dup empty?
-    [ drop ]
-    [ "../test-all-vocabs" log-object ]
-  if ;
 
 : do-all ( -- )
-  record-bootstrap-time
+  bootstrap-time get   "../boot-time" [ . ] with-file-out
-  do-load
+  [ do-load  ] runtime "../load-time" [ . ] with-file-out
-  do-tests ;
+  [ do-tests ] runtime "../test-time" [ . ] with-file-out ;
 
 MAIN: do-all

extra/editors/editpadpro/editpadpro.factor

@@ -1,12 +1,12 @@
 USING: definitions kernel parser words sequences math.parser
 namespaces editors io.launcher windows.shell32 io.files
-io.paths strings ;
+io.paths strings unicode.case ;
 IN: editors.editpadpro
 
 : editpadpro-path
     \ editpadpro-path get-global [
-        program-files "JGsoft" path+ walk-dir
+        program-files "JGsoft" path+
-        [ >lower "editpadpro.exe" tail? ] find nip
+        [ >lower "editpadpro.exe" tail? ] find-file-breadth
     ] unless* ;
 
 : editpadpro ( file line -- )

extra/editors/editplus/editplus.factor

@@ -4,7 +4,7 @@ IN: editors.editplus
 
 : editplus-path ( -- path )
     \ editplus-path get-global [
-        program-files "\\EditPlus 2\\editplus.exe" append
+        program-files "\\EditPlus 2\\editplus.exe" path+
     ] unless* ;
 
 : editplus ( file line -- )

extra/editors/gvim/windows/windows.factor

@@ -1,8 +1,9 @@
 USING: editors.gvim.backend io.files io.windows kernel namespaces
-sequences windows.shell32 ;
+sequences windows.shell32 io.paths ;
 IN: editors.gvim.windows
 
 M: windows-io gvim-path
     \ gvim-path get-global [
-        program-files walk-dir [ "gvim.exe" tail? ] find nip
+        program-files "vim" path+
+        [ "gvim.exe" tail? ] find-file-breadth
     ] unless* ;

extra/editors/wordpad/wordpad.factor

@@ -1,10 +1,11 @@
 USING: editors hardware-info.windows io.launcher kernel
-math.parser namespaces sequences windows.shell32 ;
+math.parser namespaces sequences windows.shell32 io.files
+arrays ;
 IN: editors.wordpad
 
 : wordpad-path ( -- path )
     \ wordpad-path get [
-        program-files "\\Windows NT\\Accessories\\wordpad.exe" append
+        program-files "\\Windows NT\\Accessories\\wordpad.exe" path+
     ] unless* ;
 
 : wordpad ( file line -- )

extra/io/paths/paths.factor

@@ -1,24 +1,49 @@
-USING: assocs io.files kernel namespaces sequences ;
+USING: arrays assocs combinators.lib dlists io.files
+kernel namespaces sequences shuffle vectors ;
 IN: io.paths
 
-: find-file ( seq str -- path/f )
+! HOOK: library-roots io-backend ( -- seq )
-    [
+! HOOK: binary-roots io-backend ( -- seq )
-        [ path+ exists? ] curry find nip
-    ] keep over [ path+ ] [ drop ] if ;
 
 <PRIVATE
 : append-path ( path files -- paths )
-    [ path+ ] with map ;
+    [ >r path+ r> ] with* assoc-map ;
 
 : get-paths ( dir -- paths )
-    dup directory keys append-path ;
+    dup directory append-path ;
 
 : (walk-dir) ( path -- )
-    dup directory? [
+    first2 [
-        get-paths dup % [ (walk-dir) ] each
+        get-paths dup keys % [ (walk-dir) ] each
     ] [
         drop
     ] if ;
 PRIVATE>
 
-: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ;
+: walk-dir ( path -- seq )
+    dup directory? 2array [ (walk-dir) ] { } make ;
+
+GENERIC# find-file* 1 ( obj quot -- path/f )
+
+M: dlist find-file* ( dlist quot -- path/f )
+    over dlist-empty? [ 2drop f ] [
+        2dup >r pop-front get-paths dup r> assoc-find
+        [ drop 3nip ]
+        [ 2drop [ nip ] assoc-subset keys pick push-all-back find-file* ] if
+    ] if ;
+
+M: vector find-file* ( vector quot -- path/f )
+    over empty? [ 2drop f ] [
+        2dup >r pop get-paths dup r> assoc-find
+        [ drop 3nip ]
+        [ 2drop [ nip ] assoc-subset keys pick push-all find-file* ] if
+    ] if ;
+
+: prepare-find-file ( quot -- quot )
+    [ drop ] swap compose ;
+
+: find-file-depth ( path quot -- path/f )
+    prepare-find-file >r 1vector r> find-file* ;
+
+: find-file-breadth ( path quot -- path/f )
+    prepare-find-file >r 1dlist r> find-file* ;

extra/shuffle/shuffle.factor

@@ -25,6 +25,8 @@ MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ;
 
 : 3nip ( a b c d -- d ) 3 nnip ; inline
 
+: 4nip ( a b c d e -- e ) 4 nnip ; inline
+
 : 4dup ( a b c d -- a b c d a b c d ) 4 ndup ; inline
 
 : 4drop ( a b c d -- ) 3drop drop ; inline