From 83f1bc5d8c04394d6fa7675e2de424dbd3b6fa90 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 12 Feb 2008 01:27:57 -0600
Subject: [PATCH 1/9] builder: tweaking the report
---
extra/builder/builder.factor | 24 +++++++++++++++++++-----
1 file changed, 19 insertions(+), 5 deletions(-)
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 3e7efcc404..7b959787f4 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -189,11 +189,22 @@ SYMBOL: report
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: ms>minutes ( ms -- minutes ) 1000.0 / 60 / ;
+! : ms>minutes ( ms -- minutes ) 1000.0 / 60 / ;
-: bootstrap-minutes ( -- )
- "../bootstrap-time" <file-reader> contents eval ms>minutes unparse ;
+! : bootstrap-minutes ( -- )
+! "../bootstrap-time" <file-reader> contents eval ms>minutes unparse ;
+: min-and-sec ( milliseconds -- str )
+ 1000 /i 60 /mod swap
+ `{ ,[ number>string ] " minutes and " ,[ number>string ] " seconds" }
+ concat ;
+
+: eval-file ( file -- obj ) <file-reader> contents eval ;
+
+: boot-time ( -- string ) "../bootstrap-time" eval-file min-and-sec ;
+: load-time ( -- string ) "../load-everything-time" eval-file min-and-sec ;
+: test-time ( -- string ) "../test-all-time" eval-file min-and-sec ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (build) ( -- )
@@ -228,8 +239,11 @@ SYMBOL: report
builder-test [ "Builder test error" write nl ] run-or-report
- [ "Bootstrap time: " write bootstrap-minutes write " minutes" write nl ]
- >>>report
+ [
+ "Bootstrap time: " write boot-time write nl
+ "Load all time: " write load-time write nl
+ "Test all time: " write test-time write nl
+ ] >>>report
"../load-everything-vocabs" exists?
[
From 336ad674d7c5681127970354699ecd1e4630f4d5 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 12 Feb 2008 04:42:47 -0600
Subject: [PATCH 2/9] builder: another refactoring
---
extra/builder/builder.factor | 231 +++++++++++++++++++++------------
extra/builder/test/test.factor | 23 +---
2 files changed, 150 insertions(+), 104 deletions(-)
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 7b959787f4..6aa8662095 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,10 +11,10 @@ IN: builder
: runtime ( quot -- time ) benchmark nip ;
-: log-runtime ( quot file -- )
- >r runtime r> <file-writer> [ . ] with-stream ;
+! : log-runtime ( quot file -- )
+! >r runtime r> <file-writer> [ . ] with-stream ;
-: log-object ( object file -- ) <file-writer> [ . ] with-stream ;
+! : log-object ( object file -- ) <file-writer> [ . ] with-stream ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -48,16 +48,16 @@ SYMBOL: builder-recipients
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: run-or-notify ( desc message -- )
- [ [ try-process ] curry ]
- [ [ email-string throw ] curry ]
- bi*
- recover ;
+! : 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 ;
+! : run-or-send-file ( desc message file -- )
+! >r >r [ try-process ] curry
+! r> r> [ email-file throw ] 2curry
+! recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -98,7 +98,9 @@ VAR: stamp
: 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" log-object ;
+
+: record-git-id ( -- ) git-id "../git-id" [ . ] with-file-out ;
: make-clean ( -- desc ) { "make" "clean" } ;
@@ -110,12 +112,12 @@ VAR: stamp
}
>hashtable ;
-: retrieve-boot-image ( -- )
- [ my-arch download-image ]
- [ ]
- [ "builder: image download" email-string ]
- cleanup
- flush ;
+! : retrieve-boot-image ( -- )
+! [ my-arch download-image ]
+! [ ]
+! [ "builder: image download" email-string ]
+! cleanup
+! flush ;
: bootstrap ( -- desc )
`{
@@ -165,27 +167,27 @@ SYMBOL: build-status
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-SYMBOL: report
+! SYMBOL: report
-: >>>report ( quot -- ) report get swap with-stream* ;
+! : >>>report ( quot -- ) report get swap with-stream* ;
-: file>>>report ( file -- ) [ <file-reader> contents write ] curry >>>report ;
+! : file>>>report ( file -- ) [ <file-reader> contents write ] curry >>>report ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: run-or-report ( desc quot -- )
- [ [ try-process ] curry ]
- [ [ >>>report throw ] curry ]
- bi*
- recover ;
+! : run-or-report ( desc quot -- )
+! [ [ try-process ] curry ]
+! [ [ >>>report throw ] curry ]
+! bi*
+! recover ;
-: run-or-report-file ( desc quot file -- )
- [ [ try-process ] curry ]
- [ [ >>>report ] curry ]
- [ [ file>>>report throw ] curry ]
- tri*
- compose
- recover ;
+! : run-or-report-file ( desc quot file -- )
+! [ [ try-process ] curry ]
+! [ [ >>>report ] curry ]
+! [ [ file>>>report throw ] curry ]
+! tri*
+! compose
+! recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -194,80 +196,137 @@ SYMBOL: report
! : bootstrap-minutes ( -- )
! "../bootstrap-time" <file-reader> contents eval ms>minutes unparse ;
-: min-and-sec ( milliseconds -- str )
- 1000 /i 60 /mod swap
- `{ ,[ number>string ] " minutes and " ,[ number>string ] " seconds" }
- concat ;
+! : min-and-sec ( milliseconds -- str )
+! 1000 /i 60 /mod swap
+! `{ ,[ number>string ] " minutes and " ,[ number>string ] " seconds" }
+! concat ;
+
+! : boot-time ( -- string ) "../bootstrap-time" eval-file min-and-sec ;
+! : load-time ( -- string ) "../load-everything-time" eval-file min-and-sec ;
+! : test-time ( -- string ) "../test-all-time" eval-file min-and-sec ;
+
+: milli-seconds>time ( n -- string )
+ 1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
: eval-file ( file -- obj ) <file-reader> contents eval ;
-
-: boot-time ( -- string ) "../bootstrap-time" eval-file min-and-sec ;
-: load-time ( -- string ) "../load-everything-time" eval-file min-and-sec ;
-: test-time ( -- string ) "../test-all-time" eval-file min-and-sec ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! : (build) ( -- )
+
+! enter-build-dir
+
+! "report" <file-writer> report set
+
+! [
+! "Build machine: " write host-name write nl
+! "Build directory: " write cwd write nl
+! ] >>>report
+
+! git-clone [ "Builder fatal error: git clone failed" write nl ] run-or-report
+
+! "factor" cd
+
+! record-git-id
+
+! make-clean run-process drop
+
+! make-vm
+! [ "Builder fatal error: vm compile error" write nl ]
+! "../compile-log"
+! run-or-report-file
+
+! [ my-arch download-image ]
+! [ [ "Builder fatal error: image download" write nl ] >>>report throw ]
+! recover
+
+! bootstrap [ "Bootstrap error" write nl ] "../boot-log" run-or-report-file
+
+! builder-test [ "Builder test error" write nl ] run-or-report
+
+! [
+! "Bootstrap time: " write boot-time write nl
+! "Load all time: " write load-time write nl
+! "Test all time: " write test-time write nl
+! ] >>>report
+
+! "../load-everything-vocabs" exists?
+! [
+! [ "Did not pass load-everything: " write nl ] >>>report
+! "../load-everything-vocabs" file>>>report
+! ]
+! when
+
+! "../test-all-vocabs" exists?
+! [
+! [ "Did not pass test-all: " write nl ] >>>report
+! "../test-all-vocabs" file>>>report
+! ]
+! when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cat ( file -- ) <file-reader> contents print ;
+
+: run-or-bail ( desc quot -- )
+ [ [ try-process ] curry ]
+ [ [ throw ] curry ]
+ bi*
+ recover ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: (build) ( -- )
enter-build-dir
- "report" <file-writer> 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 boot-time write nl
- "Load all time: " write load-time write nl
- "Test all time: " write test-time 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 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : send-report ( -- )
+! report get dispose
+! "report" "../report" email-file ;
+
+! : build ( -- )
+! [ (build) ]
+! [ drop ]
+! recover
+! send-report ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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" <file-writer>
- [ 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
From 47566fbfac33341e843671b7a5896ccd46ce2c58 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 12 Feb 2008 05:38:09 -0600
Subject: [PATCH 3/9] builder: minor cleanups
---
extra/builder/builder.factor | 193 +++--------------------------------
1 file changed, 14 insertions(+), 179 deletions(-)
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 6aa8662095..a5411e6129 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -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,17 +53,29 @@ 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" } ;
@@ -112,13 +88,6 @@ VAR: stamp
}
>hashtable ;
-! : retrieve-boot-image ( -- )
-! [ my-arch download-image ]
-! [ ]
-! [ "builder: image download" email-string ]
-! cleanup
-! flush ;
-
: bootstrap ( -- desc )
`{
{ +arguments+ {
@@ -133,78 +102,10 @@ 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 -- ) [ <file-reader> contents write ] curry >>>report ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : run-or-report ( desc quot -- )
-! [ [ try-process ] curry ]
-! [ [ >>>report 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 ;
-
-! : min-and-sec ( milliseconds -- str )
-! 1000 /i 60 /mod swap
-! `{ ,[ number>string ] " minutes and " ,[ number>string ] " seconds" }
-! concat ;
-
-! : boot-time ( -- string ) "../bootstrap-time" eval-file min-and-sec ;
-! : load-time ( -- string ) "../load-everything-time" eval-file min-and-sec ;
-! : test-time ( -- string ) "../test-all-time" eval-file min-and-sec ;
-
: milli-seconds>time ( n -- string )
1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
@@ -212,60 +113,6 @@ SYMBOL: build-status
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! : (build) ( -- )
-
-! enter-build-dir
-
-! "report" <file-writer> report set
-
-! [
-! "Build machine: " write host-name write nl
-! "Build directory: " write cwd write nl
-! ] >>>report
-
-! git-clone [ "Builder fatal error: git clone failed" write nl ] run-or-report
-
-! "factor" cd
-
-! record-git-id
-
-! make-clean run-process drop
-
-! make-vm
-! [ "Builder fatal error: vm compile error" write nl ]
-! "../compile-log"
-! run-or-report-file
-
-! [ my-arch download-image ]
-! [ [ "Builder fatal error: image download" write nl ] >>>report throw ]
-! recover
-
-! bootstrap [ "Bootstrap error" write nl ] "../boot-log" run-or-report-file
-
-! builder-test [ "Builder test error" write nl ] run-or-report
-
-! [
-! "Bootstrap time: " write boot-time write nl
-! "Load all time: " write load-time write nl
-! "Test all time: " write test-time write nl
-! ] >>>report
-
-! "../load-everything-vocabs" exists?
-! [
-! [ "Did not pass load-everything: " write nl ] >>>report
-! "../load-everything-vocabs" file>>>report
-! ]
-! when
-
-! "../test-all-vocabs" exists?
-! [
-! [ "Did not pass test-all: " write nl ] >>>report
-! "../test-all-vocabs" file>>>report
-! ]
-! when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: cat ( file -- ) <file-reader> contents print ;
: run-or-bail ( desc quot -- )
@@ -318,18 +165,6 @@ SYMBOL: build-status
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! : send-report ( -- )
-! report get dispose
-! "report" "../report" email-file ;
-
-! : build ( -- )
-! [ (build) ]
-! [ drop ]
-! recover
-! send-report ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: minutes>ms ( min -- ms ) 60 * 1000 * ;
: updates-available? ( -- ? )
From d283d57c2d2683d0811e96c222fd00ec34d7e649 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 12 Feb 2008 11:58:47 -0600
Subject: [PATCH 4/9] clean up pop-front, add dlist1, add push-all-front and
push-all-back
---
core/dlists/dlists.factor | 17 +++++++++++------
1 file changed, 11 insertions(+), 6 deletions(-)
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 <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
- [ 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 ) <dlist> [ push-front ] keep ;
+
From 023255d6ade9550b1c0b6522bd22a92e269a9053 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 12 Feb 2008 11:59:50 -0600
Subject: [PATCH 5/9] add 4nip to shuffle
---
extra/shuffle/shuffle.factor | 2 ++
1 file changed, 2 insertions(+)
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
From f80694183d4c9a6dc9fc6722b6dfcfa76e6ceaf1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 12 Feb 2008 12:00:56 -0600
Subject: [PATCH 6/9] find gvim binary faster on windows
---
extra/editors/gvim/windows/windows.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor
index 5b51738eea..36af79b697 100644
--- a/extra/editors/gvim/windows/windows.factor
+++ b/extra/editors/gvim/windows/windows.factor
@@ -4,5 +4,6 @@ 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* ;
From 1f78e14b6b7013fe4a5d4f147364342b3f567976 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 12 Feb 2008 12:14:57 -0600
Subject: [PATCH 7/9] change append to path+ use find-file-breadth fix load
errors
---
extra/editors/editpadpro/editpadpro.factor | 6 +++---
extra/editors/editplus/editplus.factor | 2 +-
extra/editors/gvim/windows/windows.factor | 2 +-
extra/editors/wordpad/wordpad.factor | 5 +++--
4 files changed, 8 insertions(+), 7 deletions(-)
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 36af79b697..e68bf04732 100644
--- a/extra/editors/gvim/windows/windows.factor
+++ b/extra/editors/gvim/windows/windows.factor
@@ -1,5 +1,5 @@
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
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 -- )
From 873b7dd214da61365210cfb09a36ec3ced8f0ae3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 12 Feb 2008 12:15:42 -0600
Subject: [PATCH 8/9] remove two unused hooks move walk-dir to extra/io/paths
---
core/io/files/files.factor | 31 -------------------------------
1 file changed, 31 deletions(-)
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> 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 )
From 19154db59628f1d9fc6dbe54aa9498e48ddd3ff5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 12 Feb 2008 12:16:12 -0600
Subject: [PATCH 9/9] add find-file-breadth, find-file-depth redo walk-dir
---
extra/io/paths/paths.factor | 45 ++++++++++++++++++++++++++++---------
1 file changed, 35 insertions(+), 10 deletions(-)
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 )
<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? [
- 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* ;