steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Doug Coleman 2009-04-17 21:21:51 -05:00
parent 7eaa20a4c5 af600d5aac
commit 2fe4560e6c
35 changed files with 253 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
basis/io/launcher/windows/nt/nt-tests.factor
View File

@ -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

6
basis/tools/deploy/shaker/shaker.factor
View File

@ -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

8
extra/4DNav/file-chooser/file-chooser.factor
View File

@ -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 )

4
extra/bank/bank.factor
View File

@ -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 ;

2
extra/dns/util/util.factor
View File

@ -28,4 +28,4 @@ TUPLE: packet data addr socket ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: forever ( quot -- ) [ call ] [ forever ] bi ; inline recursive
: forever ( quot: ( -- ) -- ) [ call ] [ forever ] bi ; inline recursive

28
extra/fuel/eval/eval.factor
View File

@ -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) ;

2
extra/fuel/fuel.factor
View File

@ -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 ;

20
extra/mason/build/build.factor
View File

@ -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

20
extra/mason/child/child-tests.factor
View File

@ -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

43
extra/mason/child/child.factor
View File

@ -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 ;
{ [ notify-make-vm make-vm ] [ compile-failed ] }
{ [ notify-boot boot ] [ boot-failed ] }
{ [ notify-test test ] [ test-failed ] }
[ success ]
} recover-cond ;

9
extra/mason/cleanup/cleanup.factor
View File

@ -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 [

22
extra/mason/common/common.factor
View File

@ -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

15
extra/mason/config/config.factor
View File

@ -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.

10
extra/mason/email/email.factor
View File

@ -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 -- )
[

11
extra/mason/help/help.factor
View File

@ -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 ;

3
extra/mason/mason.factor
View File

@ -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

1
extra/mason/notify/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

48
extra/mason/notify/notify.factor Normal file
View File

@ -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 ;

22
extra/mason/release/archive/archive.factor
View File

@ -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 ;
: save-archive ( archive-name -- )
releases move-file-into ;

19
extra/mason/release/release.factor
View File

@ -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 ;
archive-name {
[ make-archive ]
[ upload ]
[ save-archive ]
[ notify-release ]
} cleave ;

11
extra/mason/release/upload/upload.factor
View File

@ -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 ;

39
extra/mason/report/report.factor
View File

@ -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 ;
] 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 ? ;

16
extra/mason/test/test.factor
View File

@ -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

1
extra/mason/twitter/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

14
extra/mason/twitter/twitter.factor Normal file
View File

@ -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 ;

6
extra/math/function-tools/function-tools.factor
View File

@ -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

0
extra/advice/advice-docs.factor → unmaintained/advice/advice-docs.factor
View File

0
extra/advice/advice-tests.factor → unmaintained/advice/advice-tests.factor
View File

0
extra/advice/advice.factor → unmaintained/advice/advice.factor
View File

0
extra/advice/authors.txt → unmaintained/advice/authors.txt
View File

0
extra/advice/summary.txt → unmaintained/advice/summary.txt
View File

0
extra/advice/tags.txt → unmaintained/advice/tags.txt
View File

3
vm/data_gc.c
View File

@ -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;
}

1
vm/data_gc.h
View File

@ -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

2
vm/image.c
View File

@ -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);