From a6ea915e09ee6be408207a71ed302927fff503e7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:21:51 -0500 Subject: [PATCH 01/12] mason: filter out linakge errors from build reports --- extra/mason/test/test.factor | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 11a15328fb..88ccf93942 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs benchmark bootstrap.stage2 -compiler.errors generic help.html help.lint io.directories +USING: accessors assocs benchmark bootstrap.stage2 compiler.errors +source-files.errors generic help.html help.lint io.directories io.encodings.utf8 io.files kernel mason.common math namespaces -prettyprint sequences sets sorting tools.test tools.time -tools.vocabs words system io tools.errors locals ; +prettyprint sequences sets sorting tools.test tools.time tools.vocabs +words system io tools.errors locals ; IN: mason.test : do-load ( -- ) @@ -20,7 +20,9 @@ M: word word-vocabulary vocabulary>> ; M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; :: do-step ( errors summary-file details-file -- ) - errors [ file>> ] map prune natural-sort summary-file to-file + errors + [ error-type +linkage-error+ eq? not ] filter + [ file>> ] map prune natural-sort summary-file to-file errors details-file utf8 [ errors. ] with-file-writer ; : do-compile-errors ( -- ) From f4cdcaa1ce3ef2c86f26e833c91fd68ccea39eb4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:38:55 -0500 Subject: [PATCH 02/12] Fix compiler warnings in tools.deploy.shaker --- basis/tools/deploy/shaker/shaker.factor | 6 +++--- vm/data_gc.c | 3 ++- vm/data_gc.h | 1 + vm/image.c | 2 ++ 4 files changed, 8 insertions(+), 4 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 2fc1ada108..37eec5eae2 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -357,7 +357,7 @@ IN: tools.deploy.shaker V{ } set-namestack V{ } set-catchstack "Saving final image" show - [ save-image-and-exit ] call-clear ; + save-image-and-exit ; SYMBOL: deploy-vocab @@ -421,10 +421,10 @@ SYMBOL: deploy-vocab : deploy-error-handler ( quot -- ) [ strip-debugger? - [ error-continuation get call>> callstack>array die ] + [ error-continuation get call>> callstack>array die 1 exit ] ! Don't reference these words literally, if we're stripping the ! debugger out we don't want to load the prettyprinter at all - [ [:c] execute nl [print-error] execute flush ] if + [ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if 1 exit ] recover ; inline diff --git a/vm/data_gc.c b/vm/data_gc.c index a91eff6783..11c1639fea 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -160,7 +160,8 @@ void copy_roots(void) copy_handle(&stacks->catchstack_save); copy_handle(&stacks->current_callback_save); - mark_active_blocks(stacks); + if(!performing_compaction) + mark_active_blocks(stacks); stacks = stacks->next; } diff --git a/vm/data_gc.h b/vm/data_gc.h index 354c9398a5..feae26706d 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -5,6 +5,7 @@ DLLEXPORT void minor_gc(void); F_ZONE *newspace; bool performing_gc; +bool performing_compaction; CELL collecting_gen; /* if true, we collecting AGING space for the second time, so if it is still diff --git a/vm/image.c b/vm/image.c index a1987180d0..9cc97df0d9 100755 --- a/vm/image.c +++ b/vm/image.c @@ -187,7 +187,9 @@ void primitive_save_image_and_exit(void) userenv[i] = F; /* do a full GC + code heap compaction */ + performing_compaction = true; compact_code_heap(); + performing_compaction = false; UNREGISTER_C_STRING(path); From bbd496e3043fb7cbff9d2a58706054b4db277bfd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:42:51 -0500 Subject: [PATCH 03/12] 4DNav.file-chooser: fix compiler warning --- extra/4DNav/file-chooser/file-chooser.factor | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/extra/4DNav/file-chooser/file-chooser.factor b/extra/4DNav/file-chooser/file-chooser.factor index ad799f75c9..51bebc3877 100755 --- a/extra/4DNav/file-chooser/file-chooser.factor +++ b/extra/4DNav/file-chooser/file-chooser.factor @@ -92,11 +92,9 @@ file-chooser H{ ; : fc-load-file ( file-chooser file -- ) - dupd [ selected-file>> ] [ name>> ] bi* swap set-model - [ path>> value>> ] - [ selected-file>> value>> append ] - [ hook>> ] tri - call + over [ name>> ] [ selected-file>> ] bi* set-model + [ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi + call( path -- ) ; inline ! : fc-ok-action ( file-chooser -- quot ) From 7db33912a0419a74a85f9962e4134f7d894c50b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:42:58 -0500 Subject: [PATCH 04/12] bank: fix compiler warning --- extra/bank/bank.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor index f06bc2fb81..31a4b75eb2 100644 --- a/extra/bank/bank.factor +++ b/extra/bank/bank.factor @@ -54,7 +54,7 @@ C: transaction : process-day ( account date -- ) 2dup accumulate-interest ?pay-interest ; -: each-day ( quot start end -- ) +: each-day ( quot: ( -- ) start end -- ) 2dup before? [ [ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day ] [ @@ -63,7 +63,7 @@ C: transaction : process-to-date ( account date -- account ) over interest-last-paid>> 1 days time+ - [ dupd process-day ] spin each-day ; inline + [ dupd process-day ] spin each-day ; : inserting-transactions ( account transactions -- account ) [ [ date>> process-to-date ] keep >>transaction ] each ; From f36a3c47133798232a5d55ccec45c7a3349ccbb6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:49:36 -0500 Subject: [PATCH 05/12] fuel: Fix compiler warnings --- extra/fuel/eval/eval.factor | 15 +++++++-------- extra/fuel/fuel.factor | 2 +- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/extra/fuel/eval/eval.factor b/extra/fuel/eval/eval.factor index c3b1a8a3f2..b4a138459f 100644 --- a/extra/fuel/eval/eval.factor +++ b/extra/fuel/eval/eval.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays compiler.units continuations debugger fuel.pprint io io.streams.string kernel namespaces parser sequences -vectors vocabs.parser ; +vectors vocabs.parser eval fry ; IN: fuel.eval @@ -55,21 +55,20 @@ t fuel-eval-res-flag set-global : (fuel-end-eval) ( output -- ) fuel-eval-output set-global fuel-send-retort fuel-pop-status ; inline -: (fuel-eval) ( lines -- ) - [ [ parse-lines ] with-compilation-unit call ] curry - [ print-error ] recover ; inline +: (fuel-eval) ( string -- ) + '[ _ eval( -- ) ] try ; : (fuel-eval-each) ( lines -- ) - [ 1vector (fuel-eval) ] each ; inline + [ (fuel-eval) ] each ; : (fuel-eval-usings) ( usings -- ) - [ "USING: " prepend " ;" append ] map + [ "USE: " prepend ] map (fuel-eval-each) fuel-forget-error fuel-forget-output ; : (fuel-eval-in) ( in -- ) - [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline + [ dup "IN: " prepend (fuel-eval) in set ] when* ; : (fuel-eval-in-context) ( lines in usings -- ) (fuel-begin-eval) - [ (fuel-eval-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer + [ (fuel-eval-usings) (fuel-eval-in) "\n" join (fuel-eval) ] with-string-writer (fuel-end-eval) ; diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 403708e880..413aefdc76 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -104,7 +104,7 @@ PRIVATE> : fuel-vocab-summary ( name -- ) (fuel-vocab-summary) fuel-eval-set-result ; -: fuel-index ( quot -- ) call format-index fuel-eval-set-result ; +: fuel-index ( quot -- ) call( -- seq ) format-index fuel-eval-set-result ; : fuel-get-vocabs/tag ( tag -- ) (fuel-get-vocabs/tag) fuel-eval-set-result ; From d929134ad712736b4f0506a04787edd04e43f08e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:49:46 -0500 Subject: [PATCH 06/12] dns: Fix compiler warning --- extra/dns/util/util.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/dns/util/util.factor b/extra/dns/util/util.factor index 5b2e63838a..f47eb7010c 100644 --- a/extra/dns/util/util.factor +++ b/extra/dns/util/util.factor @@ -28,4 +28,4 @@ TUPLE: packet data addr socket ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: forever ( quot -- ) [ call ] [ forever ] bi ; inline recursive \ No newline at end of file +: forever ( quot: ( -- ) -- ) [ call ] [ forever ] bi ; inline recursive \ No newline at end of file From aff996a58fdb4edde75b1ff894aaa86dbd33ec45 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:49:59 -0500 Subject: [PATCH 07/12] math.function-tools: Fix compiler warning --- extra/math/function-tools/function-tools.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/math/function-tools/function-tools.factor b/extra/math/function-tools/function-tools.factor index 11e57d2639..78c726d370 100644 --- a/extra/math/function-tools/function-tools.factor +++ b/extra/math/function-tools/function-tools.factor @@ -9,10 +9,10 @@ IN: math.function-tools [ bi - ] 2curry ; inline : eval ( x func -- pt ) - dupd call 2array ; inline + dupd call( x -- y ) 2array ; inline : eval-inverse ( y func -- pt ) - dupd call swap 2array ; inline + dupd call( y -- x ) swap 2array ; inline : eval3d ( x y func -- pt ) - [ 2dup ] dip call 3array ; inline + [ 2dup ] dip call( x y -- z ) 3array ; inline From 1b4e778102c68fd05213cb35ca7a36f2bed247fc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:50:14 -0500 Subject: [PATCH 08/12] advice: move to unmaintained --- {extra => unmaintained}/advice/advice-docs.factor | 0 {extra => unmaintained}/advice/advice-tests.factor | 0 {extra => unmaintained}/advice/advice.factor | 0 {extra => unmaintained}/advice/authors.txt | 0 {extra => unmaintained}/advice/summary.txt | 0 {extra => unmaintained}/advice/tags.txt | 0 6 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/advice/advice-docs.factor (100%) rename {extra => unmaintained}/advice/advice-tests.factor (100%) rename {extra => unmaintained}/advice/advice.factor (100%) rename {extra => unmaintained}/advice/authors.txt (100%) rename {extra => unmaintained}/advice/summary.txt (100%) rename {extra => unmaintained}/advice/tags.txt (100%) diff --git a/extra/advice/advice-docs.factor b/unmaintained/advice/advice-docs.factor similarity index 100% rename from extra/advice/advice-docs.factor rename to unmaintained/advice/advice-docs.factor diff --git a/extra/advice/advice-tests.factor b/unmaintained/advice/advice-tests.factor similarity index 100% rename from extra/advice/advice-tests.factor rename to unmaintained/advice/advice-tests.factor diff --git a/extra/advice/advice.factor b/unmaintained/advice/advice.factor similarity index 100% rename from extra/advice/advice.factor rename to unmaintained/advice/advice.factor diff --git a/extra/advice/authors.txt b/unmaintained/advice/authors.txt similarity index 100% rename from extra/advice/authors.txt rename to unmaintained/advice/authors.txt diff --git a/extra/advice/summary.txt b/unmaintained/advice/summary.txt similarity index 100% rename from extra/advice/summary.txt rename to unmaintained/advice/summary.txt diff --git a/extra/advice/tags.txt b/unmaintained/advice/tags.txt similarity index 100% rename from extra/advice/tags.txt rename to unmaintained/advice/tags.txt From c6072d7b4b24a585fb28a26d1eced500ff4922e8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:55:59 -0500 Subject: [PATCH 09/12] fuel.eval: fix --- extra/fuel/eval/eval.factor | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/extra/fuel/eval/eval.factor b/extra/fuel/eval/eval.factor index b4a138459f..ae1c5863a8 100644 --- a/extra/fuel/eval/eval.factor +++ b/extra/fuel/eval/eval.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays compiler.units continuations debugger fuel.pprint io io.streams.string kernel namespaces parser sequences -vectors vocabs.parser eval fry ; +vectors vocabs.parser ; IN: fuel.eval @@ -21,7 +21,7 @@ SYMBOL: fuel-eval-res-flag t fuel-eval-res-flag set-global : fuel-eval-restartable? ( -- ? ) - fuel-eval-res-flag get-global ; inline + fuel-eval-res-flag get-global ; : fuel-push-status ( -- ) in get use get clone restarts get-global clone @@ -29,7 +29,7 @@ t fuel-eval-res-flag set-global fuel-status-stack get push ; : fuel-pop-restarts ( restarts -- ) - fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ; inline + fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ; : fuel-pop-status ( -- ) fuel-status-stack get empty? [ @@ -39,24 +39,25 @@ t fuel-eval-res-flag set-global [ restarts>> fuel-pop-restarts ] tri ] unless ; -: fuel-forget-error ( -- ) f error set-global ; inline -: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline -: fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline +: fuel-forget-error ( -- ) f error set-global ; +: fuel-forget-result ( -- ) f fuel-eval-result set-global ; +: fuel-forget-output ( -- ) f fuel-eval-output set-global ; : fuel-forget-status ( -- ) - fuel-forget-error fuel-forget-result fuel-forget-output ; inline + fuel-forget-error fuel-forget-result fuel-forget-output ; : fuel-send-retort ( -- ) error get fuel-eval-result get-global fuel-eval-output get-global 3array fuel-pprint flush nl "<~FUEL~>" write nl flush ; : (fuel-begin-eval) ( -- ) - fuel-push-status fuel-forget-status ; inline + fuel-push-status fuel-forget-status ; : (fuel-end-eval) ( output -- ) - fuel-eval-output set-global fuel-send-retort fuel-pop-status ; inline + fuel-eval-output set-global fuel-send-retort fuel-pop-status ; -: (fuel-eval) ( string -- ) - '[ _ eval( -- ) ] try ; +: (fuel-eval) ( lines -- ) + [ [ parse-lines ] with-compilation-unit call( -- ) ] curry + [ print-error ] recover ; : (fuel-eval-each) ( lines -- ) [ (fuel-eval) ] each ; From 394a4ec315df0dc7b0567f90a1d61b929f6e4000 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:58:58 -0500 Subject: [PATCH 10/12] io.launcher.windows.nt: update for eval( --- basis/io/launcher/windows/nt/nt-tests.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor index 04202365fd..53b3d3ce7e 100755 --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -98,7 +98,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) os-envs = ] unit-test @@ -110,7 +110,7 @@ IN: io.launcher.windows.nt.tests +replace-environment+ >>environment-mode os-envs >>environment ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) os-envs = ] unit-test @@ -121,7 +121,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command { { "A" "B" } } >>environment ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) "A" swap at ] unit-test @@ -133,7 +133,7 @@ IN: io.launcher.windows.nt.tests { { "USERPROFILE" "XXX" } } >>environment +prepend-environment+ >>environment-mode ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) "USERPROFILE" swap at "XXX" = ] unit-test From 3586736b34181ecb09e1e157e268c0cd69fbe9eb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:59:11 -0500 Subject: [PATCH 11/12] mason.test: benchmark files were read in wrong order --- extra/mason/test/test.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 88ccf93942..912fbaa17a 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -45,10 +45,10 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; : do-benchmarks ( -- ) run-benchmarks - [ + [ benchmarks-file to-file ] [ [ keys benchmark-error-vocabs-file to-file ] [ benchmark-error-messages-file utf8 [ benchmark-errors. ] with-file-writer ] bi - ] [ benchmarks-file to-file ] bi* ; + ] bi* ; : benchmark-ms ( quot -- ms ) benchmark 1000 /i ; inline From af600d5aacbb32dd6de7eb680f41ad02fdd65317 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:59:59 -0500 Subject: [PATCH 12/12] mason: working on a big overhaul of mason. Status updates sent to a web service, binary upload notification via Twitter --- extra/mason/build/build.factor | 20 +++++---- extra/mason/child/child-tests.factor | 20 +++++++++ extra/mason/child/child.factor | 43 ++++++++----------- extra/mason/cleanup/cleanup.factor | 9 ++-- extra/mason/common/common.factor | 22 +++++++--- extra/mason/config/config.factor | 15 ++++++- extra/mason/email/email.factor | 10 ++--- extra/mason/help/help.factor | 11 ++--- extra/mason/mason.factor | 3 +- extra/mason/notify/authors.txt | 1 + extra/mason/notify/notify.factor | 48 ++++++++++++++++++++++ extra/mason/release/archive/archive.factor | 22 +++++----- extra/mason/release/release.factor | 19 +++++---- extra/mason/release/upload/upload.factor | 11 +++-- extra/mason/report/report.factor | 39 ++++++++++++------ extra/mason/twitter/authors.txt | 1 + extra/mason/twitter/twitter.factor | 14 +++++++ 17 files changed, 208 insertions(+), 100 deletions(-) create mode 100644 extra/mason/notify/authors.txt create mode 100644 extra/mason/notify/notify.factor create mode 100644 extra/mason/twitter/authors.txt create mode 100644 extra/mason/twitter/twitter.factor diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor index 90ca1d31ff..199d48dec0 100644 --- a/extra/mason/build/build.factor +++ b/extra/mason/build/build.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays calendar io.directories io.encodings.utf8 +USING: arrays kernel calendar io.directories io.encodings.utf8 io.files io.launcher mason.child mason.cleanup mason.common -mason.help mason.release mason.report namespaces prettyprint ; +mason.help mason.release mason.report mason.email mason.notify +namespaces prettyprint ; IN: mason.build QUALIFIED: continuations @@ -14,20 +15,21 @@ QUALIFIED: continuations : enter-build-dir ( -- ) build-dir set-current-directory ; : clone-builds-factor ( -- ) - "git" "clone" builds/factor 3array try-process ; + "git" "clone" builds/factor 3array try-output-process ; -: record-id ( -- ) - "factor" [ git-id ] with-directory "git-id" to-file ; +: begin-build ( -- ) + "factor" [ git-id ] with-directory + [ "git-id" to-file ] [ notify-begin-build ] bi ; : build ( -- ) create-build-dir enter-build-dir clone-builds-factor [ - record-id + begin-build build-child - upload-help - release + [ notify-report ] + [ status-clean eq? [ upload-help release ] when ] bi ] [ cleanup ] [ ] continuations:cleanup ; MAIN: build diff --git a/extra/mason/child/child-tests.factor b/extra/mason/child/child-tests.factor index 27bb42ed07..a83e7282da 100644 --- a/extra/mason/child/child-tests.factor +++ b/extra/mason/child/child-tests.factor @@ -40,3 +40,23 @@ USING: mason.child mason.config tools.test namespaces ; boot-cmd ] with-scope ] unit-test + +[ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] must-infer + +[ 4 ] [ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] unit-test + +[ 3 ] [ [ "Hi" throw ] [ drop 3 ] [ 4 ] recover-else ] unit-test + +[ "A" ] [ + { + { [ 3 throw ] [ { "X" "Y" "Z" "A" } nth ] } + [ "B" ] + } recover-cond +] unit-test + +[ "B" ] [ + { + { [ ] [ ] } + [ "B" ] + } recover-cond +] unit-test \ No newline at end of file diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor index aa44088c2d..8132e62078 100755 --- a/extra/mason/child/child.factor +++ b/extra/mason/child/child.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays calendar combinators.short-circuit +USING: accessors arrays calendar combinators.short-circuit fry continuations debugger io.directories io.files io.launcher io.pathnames io.encodings.ascii kernel make mason.common mason.config -mason.platform mason.report mason.email namespaces sequences ; +mason.platform mason.report mason.notify namespaces sequences +quotations macros ; IN: mason.child : make-cmd ( -- args ) @@ -58,30 +59,18 @@ IN: mason.child try-process ] with-directory ; -: return-with ( obj -- * ) return-continuation get continue-with ; +: recover-else ( try catch else -- ) + [ [ '[ @ f t ] ] [ '[ @ f ] ] bi* recover ] dip '[ drop @ ] when ; inline -: build-clean? ( -- ? ) +MACRO: recover-cond ( alist -- ) + dup { [ length 1 = ] [ first callable? ] } 1&& + [ first ] [ [ first first2 ] [ rest ] bi '[ _ _ [ _ recover-cond ] recover-else ] ] if ; + +: build-child ( -- status ) + copy-image { - [ load-everything-vocabs-file eval-file empty? ] - [ test-all-vocabs-file eval-file empty? ] - [ help-lint-vocabs-file eval-file empty? ] - [ compiler-errors-file eval-file empty? ] - [ benchmark-error-vocabs-file eval-file empty? ] - } 0&& ; - -: build-child ( -- ) - [ - return-continuation set - - copy-image - - [ make-vm ] [ compile-failed-report status-error return-with ] recover - [ boot ] [ boot-failed-report status-error return-with ] recover - [ test ] [ test-failed-report status-error return-with ] recover - - successful-report - - build-clean? status-clean status-dirty ? return-with - ] callcc1 - status set - email-report ; \ No newline at end of file + { [ notify-make-vm make-vm ] [ compile-failed ] } + { [ notify-boot boot ] [ boot-failed ] } + { [ notify-test test ] [ test-failed ] } + [ success ] + } recover-cond ; \ No newline at end of file diff --git a/extra/mason/cleanup/cleanup.factor b/extra/mason/cleanup/cleanup.factor index a273696f51..3e6209fed0 100755 --- a/extra/mason/cleanup/cleanup.factor +++ b/extra/mason/cleanup/cleanup.factor @@ -5,13 +5,14 @@ io.directories.hierarchy io.files io.launcher kernel mason.common mason.config mason.platform namespaces ; IN: mason.cleanup +: compress ( filename -- ) + dup exists? [ "bzip2" swap 2array try-output-process ] [ drop ] if ; + : compress-image ( -- ) - "bzip2" boot-image-name 2array try-process ; + boot-image-name compress ; : compress-test-log ( -- ) - "test-log" exists? [ - { "bzip2" "test-log" } try-process - ] when ; + "test-log" compress ; : cleanup ( -- ) builder-debug get [ diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index a3ff1a8ff5..285a684f06 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -4,15 +4,27 @@ USING: kernel namespaces sequences splitting system accessors math.functions make io io.files io.pathnames io.directories io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint combinators.short-circuit parser combinators calendar -calendar.format arrays mason.config locals system ; +calendar.format arrays mason.config locals system debugger ; IN: mason.common +ERROR: output-process-error output process ; + +M: output-process-error error. + [ "Process:" print process>> . nl ] + [ "Output:" print output>> print ] + bi ; + +: try-output-process ( command -- ) + >process +stdout+ >>stderr utf8 + [ contents ] [ dup wait-for-process ] bi* + 0 = [ 2drop ] [ output-process-error ] if ; + HOOK: really-delete-tree os ( path -- ) M: windows really-delete-tree #! Workaround: Cygwin GIT creates read-only files for #! some reason. - [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-process ] + [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-output-process ] [ delete-tree ] bi ; @@ -23,7 +35,7 @@ M: unix really-delete-tree delete-tree ; swap >>command 15 minutes >>timeout - try-process ; + try-output-process ; :: upload-safely ( local username host remote -- ) [let* | temp [ remote ".incomplete" append ] @@ -68,7 +80,7 @@ SYMBOL: stamp : prepare-build-machine ( -- ) builds-dir get make-directories builds-dir get - [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ] + [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-output-process ] with-directory ; : git-id ( -- id ) @@ -101,8 +113,6 @@ CONSTANT: benchmarks-file "benchmarks" CONSTANT: benchmark-error-messages-file "benchmark-error-messages" CONSTANT: benchmark-error-vocabs-file "benchmark-error-vocabs" -SYMBOL: status - SYMBOL: status-error ! didn't bootstrap, or crashed SYMBOL: status-dirty ! bootstrapped but not all tests passed SYMBOL: status-clean ! everything good diff --git a/extra/mason/config/config.factor b/extra/mason/config/config.factor index 51b09543f4..5ec44df0a9 100644 --- a/extra/mason/config/config.factor +++ b/extra/mason/config/config.factor @@ -11,12 +11,17 @@ builds-dir get-global [ home "builds" append-path builds-dir set-global ] unless -! Who sends build reports. +! Who sends build report e-mails. SYMBOL: builder-from -! Who receives build reports. +! Who receives build report e-mails. SYMBOL: builder-recipients +! (Optional) twitter credentials for status updates. +SYMBOL: builder-twitter-username + +SYMBOL: builder-twitter-password + ! (Optional) CPU architecture to build for. SYMBOL: target-cpu @@ -34,6 +39,12 @@ target-os get-global [ ! Keep test-log around? SYMBOL: builder-debug +! Host to send status notifications to. +SYMBOL: status-host + +! Username to log in. +SYMBOL: status-username + SYMBOL: upload-help? ! The below are only needed if upload-help is true. diff --git a/extra/mason/email/email.factor b/extra/mason/email/email.factor index 55edfcb30b..23203e5222 100644 --- a/extra/mason/email/email.factor +++ b/extra/mason/email/email.factor @@ -12,20 +12,20 @@ IN: mason.email builder-from get >>from builder-recipients get >>to - swap >>content-type swap prefix-subject >>subject + swap >>content-type swap >>body send-email ; -: subject ( -- str ) - status get { +: subject ( status -- str ) + { { status-clean [ "clean" ] } { status-dirty [ "dirty" ] } { status-error [ "error" ] } } case ; -: email-report ( -- ) - "report" utf8 file-contents "text/html" subject email-status ; +: email-report ( report status -- ) + [ "text/html" ] dip subject email-status ; : email-error ( error callstack -- ) [ diff --git a/extra/mason/help/help.factor b/extra/mason/help/help.factor index 9a4e2be996..9ed9653a08 100644 --- a/extra/mason/help/help.factor +++ b/extra/mason/help/help.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays help.html io.directories io.files io.launcher kernel make mason.common mason.config namespaces sequences ; @@ -6,7 +6,7 @@ IN: mason.help : make-help-archive ( -- ) "factor/temp" [ - { "tar" "cfz" "docs.tar.gz" "docs" } try-process + { "tar" "cfz" "docs.tar.gz" "docs" } try-output-process ] with-directory ; : upload-help-archive ( -- ) @@ -16,11 +16,8 @@ IN: mason.help help-directory get "/docs.tar.gz" append upload-safely ; -: (upload-help) ( -- ) +: upload-help ( -- ) upload-help? get [ make-help-archive upload-help-archive - ] when ; - -: upload-help ( -- ) - status get status-clean eq? [ (upload-help) ] when ; + ] when ; \ No newline at end of file diff --git a/extra/mason/mason.factor b/extra/mason/mason.factor index 299a2f4e1f..d425985e76 100644 --- a/extra/mason/mason.factor +++ b/extra/mason/mason.factor @@ -6,7 +6,8 @@ mason.email mason.updates namespaces threads ; IN: mason : build-loop-error ( error -- ) - error-continuation get call>> email-error ; + [ "Build loop error:" print flush error. flush ] + [ error-continuation get call>> email-error ] bi ; : build-loop-fatal ( error -- ) "FATAL BUILDER ERROR:" print diff --git a/extra/mason/notify/authors.txt b/extra/mason/notify/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/mason/notify/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor new file mode 100644 index 0000000000..6bf4ae090d --- /dev/null +++ b/extra/mason/notify/notify.factor @@ -0,0 +1,48 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays accessors io io.sockets io.encodings.utf8 io.files +io.launcher kernel make mason.config mason.common mason.email +mason.twitter namespaces sequences ; +IN: mason.notify + +: status-notify ( input-file args -- ) + status-host get [ + [ + "ssh" , status-host get , "-l" , status-username get , + "./mason-notify" , + host-name , + target-cpu get , + target-os get , + ] { } make prepend + + swap >>command + swap [ +closed+ ] unless* >>stdin + try-output-process + ] [ 2drop ] if ; + +: notify-begin-build ( git-id -- ) + [ "Starting build of GIT ID " write print flush ] + [ f swap "git-id" swap 2array status-notify ] + bi ; + +: notify-make-vm ( -- ) + "Compiling VM" print flush + f { "make-vm" } status-notify ; + +: notify-boot ( -- ) + "Bootstrapping" print flush + f { "boot" } status-notify ; + +: notify-test ( -- ) + "Running tests" print flush + f { "test" } status-notify ; + +: notify-report ( status -- ) + [ "Build finished with status: " write print flush ] + [ + [ "report" utf8 file-contents ] dip email-report + "report" { "report" } status-notify + ] bi ; + +: notify-release ( archive-name -- ) + "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ; \ No newline at end of file diff --git a/extra/mason/release/archive/archive.factor b/extra/mason/release/archive/archive.factor index fff8b83c23..79d6993a91 100755 --- a/extra/mason/release/archive/archive.factor +++ b/extra/mason/release/archive/archive.factor @@ -18,23 +18,23 @@ IN: mason.release.archive : archive-name ( -- string ) base-name extension append ; -: make-windows-archive ( -- ) - [ "zip" , "-r" , archive-name , "factor" , ] { } make try-process ; +: make-windows-archive ( archive-name -- ) + [ "zip" , "-r" , , "factor" , ] { } make try-output-process ; -: make-macosx-archive ( -- ) - { "mkdir" "dmg-root" } try-process - { "cp" "-R" "factor" "dmg-root" } try-process +: make-macosx-archive ( archive-name -- ) + { "mkdir" "dmg-root" } try-output-process + { "cp" "-R" "factor" "dmg-root" } try-output-process { "hdiutil" "create" "-srcfolder" "dmg-root" "-fs" "HFS+" "-volname" "factor" } - archive-name suffix try-process + swap suffix try-output-process "dmg-root" really-delete-tree ; -: make-unix-archive ( -- ) - [ "tar" , "-cvzf" , archive-name , "factor" , ] { } make try-process ; +: make-unix-archive ( archive-name -- ) + [ "tar" , "-cvzf" , , "factor" , ] { } make try-output-process ; -: make-archive ( -- ) +: make-archive ( archive-name -- ) target-os get { { "winnt" [ make-windows-archive ] } { "macosx" [ make-macosx-archive ] } @@ -44,5 +44,5 @@ IN: mason.release.archive : releases ( -- path ) builds-dir get "releases" append-path dup make-directories ; -: save-archive ( -- ) - archive-name releases move-file-into ; \ No newline at end of file +: save-archive ( archive-name -- ) + releases move-file-into ; \ No newline at end of file diff --git a/extra/mason/release/release.factor b/extra/mason/release/release.factor index bbb47ba0d3..fc4ad0b08a 100644 --- a/extra/mason/release/release.factor +++ b/extra/mason/release/release.factor @@ -1,16 +1,17 @@ -! Copyright (C) 2008 Eduardo Cavazos. +! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel debugger namespaces sequences splitting +USING: kernel debugger namespaces sequences splitting combinators combinators io io.files io.launcher prettyprint bootstrap.image mason.common mason.release.branch mason.release.tidy -mason.release.archive mason.release.upload ; +mason.release.archive mason.release.upload mason.notify ; IN: mason.release -: (release) ( -- ) +: release ( -- ) update-clean-branch tidy - make-archive - upload - save-archive ; - -: release ( -- ) status get status-clean eq? [ (release) ] when ; \ No newline at end of file + archive-name { + [ make-archive ] + [ upload ] + [ save-archive ] + [ notify-release ] + } cleave ; \ No newline at end of file diff --git a/extra/mason/release/upload/upload.factor b/extra/mason/release/upload/upload.factor index 68f2ffcdb5..d3e11c3fc3 100644 --- a/extra/mason/release/upload/upload.factor +++ b/extra/mason/release/upload/upload.factor @@ -8,14 +8,13 @@ IN: mason.release.upload : remote-location ( -- dest ) upload-directory get "/" platform 3append ; -: remote-archive-name ( -- dest ) - remote-location "/" archive-name 3append ; +: remote-archive-name ( archive-name -- dest ) + [ remote-location "/" ] dip 3append ; -: upload ( -- ) +: upload ( archive-name -- ) upload-to-factorcode? get [ - archive-name upload-username get upload-host get - remote-archive-name + pick remote-archive-name upload-safely - ] when ; + ] [ drop ] if ; diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 79ec15651d..d6732adb1d 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -3,7 +3,7 @@ USING: benchmark combinators.smart debugger fry io assocs io.encodings.utf8 io.files io.sockets io.streams.string kernel locals mason.common mason.config mason.platform math namespaces -prettyprint sequences xml.syntax xml.writer ; +prettyprint sequences xml.syntax xml.writer combinators.short-circuit ; IN: mason.report : common-report ( -- xml ) @@ -30,7 +30,7 @@ IN: mason.report pprint-xml ] with-file-writer ; inline -:: failed-report ( error file what -- ) +:: failed-report ( error file what -- status ) [ error [ error. ] with-string-writer :> error file utf8 file-contents 400 short tail* :> output @@ -42,15 +42,16 @@ IN: mason.report Launcher error: 
<-error->
XML] - ] with-report ; + ] with-report + status-error ; -: compile-failed-report ( error -- ) +: compile-failed ( error -- status ) "compile-log" "VM compilation failed" failed-report ; -: boot-failed-report ( error -- ) +: boot-failed ( error -- status ) "boot-log" "Bootstrap failed" failed-report ; -: test-failed-report ( error -- ) +: test-failed ( error -- status ) "test-log" "Tests failed" failed-report ; : timings-table ( -- xml ) @@ -66,7 +67,7 @@ IN: mason.report [XML <-><-> XML] ] map [XML

Timings

<->
XML] ; -: fail-dump ( heading vocabs-file messages-file -- xml ) +: error-dump ( heading vocabs-file messages-file -- xml ) [ eval-file ] dip over empty? [ 3drop f ] [ [ ] [ [ [XML
  • <->
    • XML] ] map [XML
      <->
    XML] ] @@ -89,29 +90,41 @@ IN: mason.report "Load failures" load-everything-vocabs-file load-everything-errors-file - fail-dump + error-dump "Compiler warnings and errors" compiler-errors-file compiler-error-messages-file - fail-dump + error-dump "Unit test failures" test-all-vocabs-file test-all-errors-file - fail-dump + error-dump "Help lint failures" help-lint-vocabs-file help-lint-errors-file - fail-dump + error-dump "Benchmark errors" benchmark-error-vocabs-file benchmark-error-messages-file - fail-dump + error-dump "Benchmark timings" benchmarks-file eval-file benchmarks-table ] output>array - ] with-report ; \ No newline at end of file + ] with-report ; + +: build-clean? ( -- ? ) + { + [ load-everything-vocabs-file eval-file empty? ] + [ test-all-vocabs-file eval-file empty? ] + [ help-lint-vocabs-file eval-file empty? ] + [ compiler-errors-file eval-file empty? ] + [ benchmark-error-vocabs-file eval-file empty? ] + } 0&& ; + +: success ( -- status ) + successful-report build-clean? status-clean status-dirty ? ; \ No newline at end of file diff --git a/extra/mason/twitter/authors.txt b/extra/mason/twitter/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/mason/twitter/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/mason/twitter/twitter.factor b/extra/mason/twitter/twitter.factor new file mode 100644 index 0000000000..21f1bcabc3 --- /dev/null +++ b/extra/mason/twitter/twitter.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: debugger fry kernel mason.config namespaces twitter ; +IN: mason.twitter + +: mason-tweet ( message -- ) + builder-twitter-username get builder-twitter-password get and + [ + [ + builder-twitter-username get twitter-username set + builder-twitter-password get twitter-password set + '[ _ tweet ] try + ] with-scope + ] [ drop ] if ; \ No newline at end of file