diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index 12b1cd51ad..38c4ee233e 100755 --- a/core/dlists/dlists.factor +++ b/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 ] keep [ dlist-back set-next-when ] 2keep @@ -80,11 +83,10 @@ PRIVATE> inc-length ; : push-back ( obj dlist -- ) - [ dlist-back f ] keep - [ dlist-back set-next-when ] 2keep - [ set-dlist-back ] keep - [ set-front-to-back ] keep - inc-length ; + push-back* drop ; + +: push-all-back ( seq dlist -- ) + [ push-back ] curry each ; : 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 ) [ push-front ] keep ; + diff --git a/core/io/files/files.factor b/core/io/files/files.factor index aa9f8686ce..9afe9362cf 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -141,37 +141,6 @@ C: 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 ; - - - -: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ; - : file-lines ( path -- seq ) lines ; : file-contents ( path -- str ) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 3e7efcc404..a5411e6129 100644 --- a/extra/builder/builder.factor +++ b/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> [ . ] with-stream ; - -: log-object ( object file -- ) [ . ] 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" } [ 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 - -: >>>report ( quot -- ) report get swap with-stream* ; - -: file>>>report ( file -- ) [ contents write ] curry >>>report ; +: milli-seconds>time ( n -- string ) + 1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ; +: eval-file ( file -- obj ) contents eval ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run-or-report ( desc quot -- ) - [ [ try-process ] curry ] - [ [ >>>report throw ] curry ] +: cat ( file -- ) contents print ; + +: 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" contents eval ms>minutes unparse ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : (build) ( -- ) enter-build-dir - "report" report set + "report" [ - [ - "Build machine: " write host-name write nl - "Build directory: " write cwd write nl - ] >>>report + "Build machine: " write host-name print + "Build directory: " write cwd print - 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 - [ "Builder fatal error: vm compile error" write nl ] - "../compile-log" - run-or-report-file + make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail - [ my-arch download-image ] - [ [ "Builder fatal error: image download" write nl ] >>>report throw ] - recover + [ my-arch download-image ] [ "Image download error" print 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 ] - >>>report + "Boot time: " write "../boot-time" eval-file milli-seconds>time print + "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: " write nl ] >>>report - "../load-everything-vocabs" file>>>report - ] - when + "Did not pass load-everything: " print "../load-everything-vocabs" cat + "Did not pass test-all: " print "../test-all-vocabs" cat - "../test-all-vocabs" exists? - [ - [ "Did not pass test-all: " write nl ] >>>report - "../test-all-vocabs" file>>>report - ] - when ; - -: send-report ( -- ) - report get dispose - "report" "../report" email-file ; + ] with-file-out ; : build ( -- ) - [ (build) ] - [ drop ] - recover - send-report ; + [ (build) ] [ drop ] recover + "report" "../report" email-file ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index 0a5750a030..f521af1b7c 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -10,28 +10,15 @@ USING: kernel namespaces sequences assocs builder continuations IN: builder.test -: record-bootstrap-time ( -- ) - "../bootstrap-time" - [ bootstrap-time get . ] - with-stream ; - : do-load ( -- ) - [ try-everything keys ] "../load-everything-time" log-runtime - dup empty? - [ drop ] - [ "../load-everything-vocabs" log-object ] - if ; + try-everything keys "../load-everything-vocabs" [ . ] with-file-out ; : do-tests ( -- ) - [ run-all-tests keys ] "../test-all-time" log-runtime - dup empty? - [ drop ] - [ "../test-all-vocabs" log-object ] - if ; + run-all-tests keys "../test-all-vocabs" [ . ] with-file-out ; : do-all ( -- ) - record-bootstrap-time - do-load - do-tests ; + bootstrap-time get "../boot-time" [ . ] with-file-out + [ do-load ] runtime "../load-time" [ . ] with-file-out + [ do-tests ] runtime "../test-time" [ . ] with-file-out ; MAIN: do-all \ No newline at end of file diff --git a/extra/editors/editpadpro/editpadpro.factor b/extra/editors/editpadpro/editpadpro.factor index 885349e27b..5a8168a181 100755 --- a/extra/editors/editpadpro/editpadpro.factor +++ b/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 - [ >lower "editpadpro.exe" tail? ] find nip + program-files "JGsoft" path+ + [ >lower "editpadpro.exe" tail? ] find-file-breadth ] unless* ; : editpadpro ( file line -- ) diff --git a/extra/editors/editplus/editplus.factor b/extra/editors/editplus/editplus.factor index feaa177954..ee24c99463 100755 --- a/extra/editors/editplus/editplus.factor +++ b/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 -- ) diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor index 5b51738eea..e68bf04732 100644 --- a/extra/editors/gvim/windows/windows.factor +++ b/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* ; diff --git a/extra/editors/wordpad/wordpad.factor b/extra/editors/wordpad/wordpad.factor index 0a86250a92..5ad08b613b 100755 --- a/extra/editors/wordpad/wordpad.factor +++ b/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 -- ) diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index 3740382e58..a393cef7fa 100644 --- a/extra/io/paths/paths.factor +++ b/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 ) - [ - [ path+ exists? ] curry find nip - ] keep over [ path+ ] [ drop ] if ; +! HOOK: library-roots io-backend ( -- seq ) +! HOOK: binary-roots io-backend ( -- seq ) r path+ r> ] with* assoc-map ; : get-paths ( dir -- paths ) - dup directory keys append-path ; + dup directory append-path ; : (walk-dir) ( path -- ) - dup directory? [ - get-paths dup % [ (walk-dir) ] each + first2 [ + 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* ; diff --git a/extra/shuffle/shuffle.factor b/extra/shuffle/shuffle.factor index f139a4864e..33587bb7fa 100644 --- a/extra/shuffle/shuffle.factor +++ b/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