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
<process>
console-vm "-script" "env.factor" 3array >>command
ascii <process-reader> 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 <process-reader> 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 <process-reader> 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 <process-reader> contents
- ] with-directory eval
+ ] with-directory eval( -- alist )
"USERPROFILE" swap at "XXX" =
] unit-test
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/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 )
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> 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> 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 ;
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
diff --git a/extra/fuel/eval/eval.factor b/extra/fuel/eval/eval.factor
index c3b1a8a3f2..ae1c5863a8 100644
--- a/extra/fuel/eval/eval.factor
+++ b/extra/fuel/eval/eval.factor
@@ -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,37 +39,37 @@ 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) ( lines -- )
- [ [ parse-lines ] with-compilation-unit call ] curry
- [ print-error ] recover ; inline
+ [ [ parse-lines ] with-compilation-unit call( -- ) ] curry
+ [ print-error ] recover ;
: (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 ;
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 <process-reader*>
+ [ 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 ;
<process>
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
<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
+ <process>
+ 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:
<pre><-error-></pre>
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 <tr><td><-></td><td><-></td></tr> XML]
] map [XML <h2>Timings</h2> <table><-></table> 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 <li><-></li> XML] ] map [XML <ul><-></ul> 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/test/test.factor b/extra/mason/test/test.factor
index 11a15328fb..912fbaa17a 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 ( -- )
@@ -43,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
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
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
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
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);