diff --git a/core/io/streams/duplex/duplex.factor b/core/io/streams/duplex/duplex.factor index 83e991b713..574735a9c5 100755 --- a/core/io/streams/duplex/duplex.factor +++ b/core/io/streams/duplex/duplex.factor @@ -1,75 +1,77 @@ -! Copyright (C) 2005 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel continuations io accessors ; IN: io.streams.duplex -USING: kernel continuations io ; ! We ensure that the stream can only be closed once, to preserve ! integrity of duplex I/O ports. -TUPLE: duplex-stream in out closed? ; +TUPLE: duplex-stream in out closed ; : ( in out -- stream ) f duplex-stream construct-boa ; +> [ stream-closed-twice ] when ; inline -: duplex-stream-in+ ( duplex -- stream ) - dup check-closed duplex-stream-in ; +: in ( duplex -- stream ) check-closed in>> ; -: duplex-stream-out+ ( duplex -- stream ) - dup check-closed duplex-stream-out ; +: out ( duplex -- stream ) check-closed out>> ; + +PRIVATE> M: duplex-stream stream-flush - duplex-stream-out+ stream-flush ; + out stream-flush ; M: duplex-stream stream-readln - duplex-stream-in+ stream-readln ; + in stream-readln ; M: duplex-stream stream-read1 - duplex-stream-in+ stream-read1 ; + in stream-read1 ; M: duplex-stream stream-read-until - duplex-stream-in+ stream-read-until ; + in stream-read-until ; M: duplex-stream stream-read-partial - duplex-stream-in+ stream-read-partial ; + in stream-read-partial ; M: duplex-stream stream-read - duplex-stream-in+ stream-read ; + in stream-read ; M: duplex-stream stream-write1 - duplex-stream-out+ stream-write1 ; + out stream-write1 ; M: duplex-stream stream-write - duplex-stream-out+ stream-write ; + out stream-write ; M: duplex-stream stream-nl - duplex-stream-out+ stream-nl ; + out stream-nl ; M: duplex-stream stream-format - duplex-stream-out+ stream-format ; + out stream-format ; M: duplex-stream make-span-stream - duplex-stream-out+ make-span-stream ; + out make-span-stream ; M: duplex-stream make-block-stream - duplex-stream-out+ make-block-stream ; + out make-block-stream ; M: duplex-stream make-cell-stream - duplex-stream-out+ make-cell-stream ; + out make-cell-stream ; M: duplex-stream stream-write-table - duplex-stream-out+ stream-write-table ; + out stream-write-table ; M: duplex-stream dispose #! The output stream is closed first, in case both streams #! are attached to the same file descriptor, the output #! buffer needs to be flushed before we close the fd. - dup duplex-stream-closed? [ - t over set-duplex-stream-closed? - [ dup duplex-stream-out dispose ] - [ dup duplex-stream-in dispose ] [ ] cleanup + dup closed>> [ + t >>closed + [ dup out>> dispose ] + [ dup in>> dispose ] [ ] cleanup ] unless drop ; diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index e7984f7ec3..23363c30ad 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -358,6 +358,18 @@ HELP: scan-word { $errors "Throws an error if the token does not name a word, and does not parse as a number." } $parsing-note ; +HELP: invalid-slot-name +{ $values { "name" string } } +{ $description "Throws an " { $link invalid-slot-name } " error." } +{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." } +{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:" + { $code + "TUPLE: my-mistaken-tuple slot-a slot-b" + "" + ": some-word ( a b c -- ) ... ;" + } +} ; + HELP: unexpected { $values { "want" "a " { $link word } " or " { $link f } } { "got" word } } { $description "Throws an " { $link unexpected } " error." } diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 1e1d6a5606..13f768a810 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -184,6 +184,9 @@ M: parse-error summary M: parse-error compute-restarts error>> compute-restarts ; +M: parse-error error-help + error>> error-help ; + SYMBOL: use SYMBOL: in @@ -298,12 +301,35 @@ M: no-word-error summary ] "" make note. ] with each ; +ERROR: invalid-slot-name name ; + +M: invalid-slot-name summary + drop + "Invalid slot name" ; + +: (parse-tuple-slots) ( -- ) + #! This isn't meant to enforce any kind of policy, just + #! to check for mistakes of this form: + #! + #! TUPLE: blahblah foo bing + #! + #! : ... + scan { + { [ dup not ] [ unexpected-eof ] } + { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] } + { [ dup ";" = ] [ drop ] } + [ , (parse-tuple-slots) ] + } cond ; + +: parse-tuple-slots ( -- seq ) + [ (parse-tuple-slots) ] { } make ; + : parse-tuple-definition ( -- class superclass slots ) CREATE-CLASS scan { { ";" [ tuple f ] } - { "<" [ scan-word ";" parse-tokens ] } - [ >r tuple ";" parse-tokens r> prefix ] + { "<" [ scan-word parse-tuple-slots ] } + [ >r tuple parse-tuple-slots r> prefix ] } case 3dup check-slot-shadowing ; ERROR: staging-violation word ; diff --git a/extra/builder/build/build.factor b/extra/builder/build/build.factor new file mode 100644 index 0000000000..e9f58980ea --- /dev/null +++ b/extra/builder/build/build.factor @@ -0,0 +1,46 @@ + +USING: io.files io.launcher io.encodings.utf8 prettyprint + builder.util builder.common builder.child builder.release + builder.report builder.email builder.cleanup ; + +IN: builder.build + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: create-build-dir ( -- ) + datestamp >stamp + build-dir make-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: enter-build-dir ( -- ) build-dir set-current-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: clone-builds-factor ( -- ) + { "git" "clone" builds/factor } to-strings try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: record-id ( -- ) + "factor" + [ git-id "../git-id" utf8 [ . ] with-file-writer ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: build ( -- ) + reset-status + create-build-dir + enter-build-dir + clone-builds-factor + record-id + build-child + release + report + email-report + cleanup ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: build \ No newline at end of file diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index d81b934f2c..29daa8160b 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,259 +1,21 @@ -USING: kernel namespaces sequences splitting system combinators continuations - parser io io.files io.launcher io.sockets prettyprint threads - bootstrap.image benchmark vars bake smtp builder.util accessors - debugger io.encodings.utf8 - calendar - tools.test +USING: kernel debugger io.files threads calendar builder.common - builder.benchmark - builder.release ; + builder.updates + builder.build ; IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: cd ( path -- ) set-current-directory ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: builds/factor ( -- path ) builds "factor" append-path ; -: build-dir ( -- path ) builds stamp> append-path ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: prepare-build-machine ( -- ) - builds make-directory - builds - [ - { "git" "clone" "git://factorcode.org/git/factor.git" } try-process - ] - with-directory ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: git-clone ( -- desc ) { "git" "clone" "../factor" } ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: enter-build-dir ( -- ) - datestamp >stamp - builds cd - stamp> make-directory - stamp> cd ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: git-id ( -- id ) - { "git" "show" } utf8 - [ readln ] with-stream " " split second ; - -: record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: gnu-make ( -- string ) - os { freebsd openbsd netbsd } member? - [ "gmake" ] - [ "make" ] - if ; - -: do-make-clean ( -- ) { gnu-make "clean" } to-strings try-process ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: make-vm ( -- desc ) - - { gnu-make } to-strings >>command - "../compile-log" >>stdout - +stdout+ >>stderr ; - -: do-make-vm ( -- ) - make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: copy-image ( -- ) - builds/factor my-boot-image-name append-path ".." copy-file-into - builds/factor my-boot-image-name append-path "." copy-file-into ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: bootstrap-cmd ( -- cmd ) - { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ; - -: bootstrap ( -- desc ) - - bootstrap-cmd >>command - +closed+ >>stdin - "../boot-log" >>stdout - +stdout+ >>stderr - 60 minutes >>timeout ; - -: do-bootstrap ( -- ) - bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ; - -: builder-test-cmd ( -- cmd ) - { "./factor" "-run=builder.test" } to-strings ; - -: builder-test ( -- desc ) - - builder-test-cmd >>command - +closed+ >>stdin - "../test-log" >>stdout - +stdout+ >>stderr - 240 minutes >>timeout ; - -: do-builder-test ( -- ) - builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -SYMBOL: build-status - -: (build) ( -- ) - - builds-check - - build-status off - - enter-build-dir - - "report" utf8 - [ - "Build machine: " write host-name print - "CPU: " write cpu . - "OS: " write os . - "Build directory: " write current-directory get print - - git-clone [ "git clone failed" print ] run-or-bail - - "factor" - [ - record-git-id - do-make-clean - do-make-vm - copy-image - do-bootstrap - do-builder-test - ] - with-directory - - "test-log" delete-file - - "git id: " write "git-id" eval-file print nl - - "Boot time: " write "boot-time" eval-file milli-seconds>time print - "Load time: " write "load-time" eval-file milli-seconds>time print - "Test time: " write "test-time" eval-file milli-seconds>time print nl - - "Did not pass load-everything: " print "load-everything-vocabs" cat - - "Did not pass test-all: " print "test-all-vocabs" cat - "test-failures" cat - - "help-lint results:" print "help-lint" cat - - "Benchmarks: " print "benchmarks" eval-file benchmarks. - - nl - - show-benchmark-deltas - - "benchmarks" ".." copy-file-into - - release - ] - with-file-writer - - build-status on ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -SYMBOL: builder-from - -SYMBOL: builder-recipients - -: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ; - -: subject ( -- str ) build-status get [ "report" ] [ "error" ] if tag-subject ; - -: send-builder-email ( -- ) - - builder-from get >>from - builder-recipients get >>to - subject >>subject - "./report" file>string >>body - send-email ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ; - -! : build ( -- ) -! [ (build) ] try -! builds cd stamp> cd -! [ send-builder-email ] try -! { "rm" "-rf" "factor" } [ ] run-or-bail -! [ compress-image ] try ; - -: build ( -- ) - [ - (build) - build-dir - [ - { "rm" "-rf" "factor" } try-process - compress-image - ] - with-directory - ] - try - send-builder-email ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -USE: bootstrap.image.download - -: git-pull ( -- desc ) - { - "git" - "pull" - "--no-summary" - "git://factorcode.org/git/factor.git" - "master" - } ; - -: updates-available? ( -- ? ) - git-id - git-pull try-process - git-id - = not ; - -: new-image-available? ( -- ? ) - my-boot-image-name need-new-image? - [ download-my-image t ] - [ f ] - if ; - : build-loop ( -- ) builds-check [ - builds/factor - [ - updates-available? new-image-available? or - [ build ] - when - ] - with-directory + builds/factor set-current-directory + new-code-available? [ build ] when ] try 5 minutes sleep build-loop ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MAIN: build-loop +MAIN: build-loop \ No newline at end of file diff --git a/extra/builder/child/child.factor b/extra/builder/child/child.factor new file mode 100644 index 0000000000..0f701dfdd7 --- /dev/null +++ b/extra/builder/child/child.factor @@ -0,0 +1,68 @@ + +USING: namespaces debugger io.files io.launcher accessors bootstrap.image + calendar builder.util builder.common ; + +IN: builder.child + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: make-clean ( -- ) { gnu-make "clean" } to-strings try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: make-vm ( -- ) + + gnu-make >>command + "../compile-log" >>stdout + +stdout+ >>stderr + try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: builds-factor-image ( -- img ) builds/factor my-boot-image-name append-path ; + +: copy-image ( -- ) + builds-factor-image ".." copy-file-into + builds-factor-image "." copy-file-into ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: boot-cmd ( -- cmd ) + { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ; + +: boot ( -- ) + + boot-cmd >>command + +closed+ >>stdin + "../boot-log" >>stdout + +stdout+ >>stderr + 60 minutes >>timeout + try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } ; + +: test ( -- ) + + test-cmd >>command + +closed+ >>stdin + "../test-log" >>stdout + +stdout+ >>stderr + 240 minutes >>timeout + try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: (build-child) ( -- ) + make-clean + make-vm status-vm on + copy-image + boot status-boot on + test status-test on + status on ; + +: build-child ( -- ) + "factor" set-current-directory + [ (build-child) ] try + ".." set-current-directory ; \ No newline at end of file diff --git a/extra/builder/cleanup/cleanup.factor b/extra/builder/cleanup/cleanup.factor new file mode 100644 index 0000000000..327b90e01f --- /dev/null +++ b/extra/builder/cleanup/cleanup.factor @@ -0,0 +1,24 @@ + +USING: kernel namespaces io.files io.launcher bootstrap.image + builder.util builder.common ; + +IN: builder.cleanup + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: builder-debug + +: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ; + +: delete-child-factor ( -- ) + build-dir [ { "rm" "-rf" "factor" } try-process ] with-directory ; + +: cleanup ( -- ) + builder-debug get f = + [ + "test-log" delete-file + delete-child-factor + compress-image + ] + when ; + diff --git a/extra/builder/common/common.factor b/extra/builder/common/common.factor index 2fe2aa06ab..e3c207eaaa 100644 --- a/extra/builder/common/common.factor +++ b/extra/builder/common/common.factor @@ -1,5 +1,7 @@ -USING: kernel namespaces io.files sequences vars ; +USING: kernel namespaces sequences splitting + io io.files io.launcher io.encodings.utf8 prettyprint + vars builder.util ; IN: builder.common @@ -16,4 +18,47 @@ SYMBOL: builds-dir VAR: stamp -SYMBOL: upload-to-factorcode \ No newline at end of file +: builds/factor ( -- path ) builds "factor" append-path ; +: build-dir ( -- path ) builds stamp> append-path ; + +: create-build-dir ( -- ) + datestamp >stamp + build-dir make-directory ; + +: enter-build-dir ( -- ) build-dir set-current-directory ; + +: clone-builds-factor ( -- ) + { "git" "clone" builds/factor } to-strings try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: prepare-build-machine ( -- ) + builds make-directory + builds + [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: status-vm +SYMBOL: status-boot +SYMBOL: status-test +SYMBOL: status-build +SYMBOL: status-release +SYMBOL: status + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: reset-status ( -- ) + { status-vm status-boot status-test status-build status-release status } + [ off ] + each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: upload-to-factorcode + diff --git a/extra/builder/email/email.factor b/extra/builder/email/email.factor new file mode 100644 index 0000000000..eed48cb177 --- /dev/null +++ b/extra/builder/email/email.factor @@ -0,0 +1,22 @@ + +USING: kernel namespaces accessors smtp builder.util builder.common ; + +IN: builder.email + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: builder-from +SYMBOL: builder-recipients + +: subject-status ( -- str ) status get [ "report" ] [ "error" ] if ; + +: subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ; + +: email-report ( -- ) + + builder-from get >>from + builder-recipients get >>to + subject >>subject + "report" file>string >>body + send-email ; + diff --git a/extra/builder/release/branch/branch.factor b/extra/builder/release/branch/branch.factor index 838a74394b..6218a2ea90 100644 --- a/extra/builder/release/branch/branch.factor +++ b/extra/builder/release/branch/branch.factor @@ -36,5 +36,5 @@ IN: builder.release.branch : update-clean-branch ( -- ) upload-to-factorcode get - [ update-clean-branch ] + [ (update-clean-branch) ] when ; diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index 33e5edfbf9..8f4c0e30f5 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -1,5 +1,5 @@ -USING: kernel system namespaces sequences splitting combinators +USING: kernel debugger system namespaces sequences splitting combinators io io.files io.launcher prettyprint bootstrap.image bake combinators.cleave builder.util @@ -18,9 +18,10 @@ IN: builder.release tidy make-archive upload - save-archive ; + save-archive + status-release on ; : clean-build? ( -- ? ) { "load-everything-vocabs" "test-all-vocabs" } [ eval-file empty? ] all? ; -: release ( -- ) clean-build? [ (release) ] when ; \ No newline at end of file +: release ( -- ) [ clean-build? [ (release) ] when ] try ; \ No newline at end of file diff --git a/extra/builder/report/report.factor b/extra/builder/report/report.factor new file mode 100644 index 0000000000..101d259f7c --- /dev/null +++ b/extra/builder/report/report.factor @@ -0,0 +1,35 @@ + +USING: kernel namespaces debugger system io io.files io.sockets + io.encodings.utf8 prettyprint benchmark + builder.util builder.common ; + +IN: builder.report + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: (report) ( -- ) + + "Build machine: " write host-name print + "CPU: " write cpu . + "OS: " write os . + "Build directory: " write build-dir print + "git id: " write "git-id" eval-file print nl + + status-vm get f = [ "compile-log" cat "vm compile error" throw ] when + status-boot get f = [ "boot-log" cat "Boot error" throw ] when + status-test get f = [ "test-log" 100 cat-n "Test error" throw ] when + + "Boot time: " write "boot-time" eval-file milli-seconds>time print + "Load time: " write "load-time" eval-file milli-seconds>time print + "Test time: " write "test-time" eval-file milli-seconds>time print nl + + "Did not pass load-everything: " print "load-everything-vocabs" cat + + "Did not pass test-all: " print "test-all-vocabs" cat + "test-failures" cat + + "help-lint results:" print "help-lint" cat + + "Benchmarks: " print "benchmarks" eval-file benchmarks. ; + +: report ( -- ) "report" utf8 [ [ (report) ] try ] with-file-writer ; \ No newline at end of file diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index d5c3e9cd94..957af28dc1 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -1,16 +1,4 @@ -! USING: kernel namespaces sequences assocs continuations -! vocabs vocabs.loader -! io -! io.files -! prettyprint -! tools.vocabs -! tools.test -! io.encodings.utf8 -! combinators.cleave -! help.lint -! bootstrap.stage2 benchmark builder.util ; - USING: kernel namespaces assocs io.files io.encodings.utf8 prettyprint help.lint diff --git a/extra/builder/updates/updates.factor b/extra/builder/updates/updates.factor new file mode 100644 index 0000000000..a8184550e0 --- /dev/null +++ b/extra/builder/updates/updates.factor @@ -0,0 +1,31 @@ + +USING: kernel io.launcher bootstrap.image bootstrap.image.download + builder.util builder.common ; + +IN: builder.updates + +: git-pull-cmd ( -- cmd ) + { + "git" + "pull" + "--no-summary" + "git://factorcode.org/git/factor.git" + "master" + } ; + +: updates-available? ( -- ? ) + git-id + git-pull-cmd try-process + git-id + = not ; + +: new-image-available? ( -- ? ) + my-boot-image-name need-new-image? + [ download-my-image t ] + [ f ] + if ; + +: new-code-available? ( -- ? ) + updates-available? + new-image-available? + or ; \ No newline at end of file diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index e80d83e24c..3b0834b190 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -25,11 +25,11 @@ DEFER: to-strings : to-string ( obj -- str ) dup class { - { string [ ] } - { quotation [ call ] } - { word [ execute ] } - { fixnum [ number>string ] } - { array [ to-strings concat ] } + { \ string [ ] } + { \ quotation [ call ] } + { \ word [ execute ] } + { \ fixnum [ number>string ] } + { \ array [ to-strings concat ] } } case ; @@ -97,4 +97,15 @@ USE: prettyprint : cpu- ( -- cpu ) cpu unparse "." split "-" join ; -: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ; \ No newline at end of file +: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: gnu-make ( -- string ) + os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: git-id ( -- id ) + { "git" "show" } utf8 [ readln ] with-stream + " " split second ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 048a5d7b1c..aa56b507ff 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -3,7 +3,7 @@ USING: math kernel io sequences io.buffers io.timeouts generic byte-vectors system io.streams.duplex io.encodings io.backend continuations debugger classes byte-arrays namespaces -splitting dlists assocs io.encodings.binary accessors ; +splitting dlists assocs io.encodings.binary inspector accessors ; IN: io.nonblocking SYMBOL: default-buffer-size @@ -43,8 +43,13 @@ TUPLE: output-port < port ; : pending-error ( port -- ) [ f ] change-error drop [ throw ] when* ; +ERROR: port-closed-error port ; + +M: port-closed-error summary + drop "Port has been closed" ; + : check-closed ( port -- port ) - dup closed>> [ "Port closed" throw ] when ; + dup closed>> [ port-closed-error ] when ; HOOK: cancel-io io-backend ( port -- ) diff --git a/extra/io/windows/nt/monitors/monitors-tests.factor b/extra/io/windows/nt/monitors/monitors-tests.factor new file mode 100755 index 0000000000..ef36baedc5 --- /dev/null +++ b/extra/io/windows/nt/monitors/monitors-tests.factor @@ -0,0 +1,4 @@ +IN: io.windows.nt.monitors.tests +USING: io.windows.nt.monitors tools.test ; + +\ fill-queue-thread must-infer diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index 7f3a13b281..0dbf08d6a5 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -3,12 +3,14 @@ USING: alien alien.c-types libc destructors locals kernel math assocs namespaces continuations sequences hashtables sorting arrays combinators math.bitfields strings system -io.windows io.windows.nt.backend io.monitors io.nonblocking -io.buffers io.files io.timeouts io accessors threads +accessors threads +io.backend io.windows io.windows.nt.backend io.monitors +io.nonblocking io.buffers io.files io.timeouts io windows windows.kernel32 windows.types ; IN: io.windows.nt.monitors : open-directory ( path -- handle ) + normalize-path FILE_LIST_DIRECTORY share-mode f @@ -28,8 +30,8 @@ TUPLE: win32-monitor < monitor port ; : begin-reading-changes ( port -- overlapped ) { [ handle>> handle>> ] - [ buffer>> buffer-ptr ] - [ buffer>> buffer-size ] + [ buffer>> ptr>> ] + [ buffer>> size>> ] [ recursive>> 1 0 ? ] } cleave FILE_NOTIFY_CHANGE_ALL @@ -39,12 +41,11 @@ TUPLE: win32-monitor < monitor port ; : read-changes ( port -- bytes ) [ - [ - dup begin-reading-changes - swap [ save-callback ] 2keep - check-closed ! we may have closed it... - get-overlapped-result - ] with-timeout + dup begin-reading-changes + swap [ save-callback ] 2keep + check-closed ! we may have closed it... + dup eof>> [ "EOF??" throw ] when + get-overlapped-result ] with-destructors ; : parse-action ( action -- changed ) @@ -55,32 +56,45 @@ TUPLE: win32-monitor < monitor port ; { FILE_ACTION_RENAMED_OLD_NAME [ +rename-file+ ] } { FILE_ACTION_RENAMED_NEW_NAME [ +rename-file+ ] } [ drop +modify-file+ ] - } case ; + } case 1array ; : memory>u16-string ( alien len -- string ) [ memory>byte-array ] keep 2/ c-ushort-array> >string ; -: parse-notify-record ( buffer -- changed path ) - [ FILE_NOTIFY_INFORMATION-Action parse-action ] - [ FILE_NOTIFY_INFORMATION-FileName ] - [ FILE_NOTIFY_INFORMATION-FileNameLength ] tri - memory>u16-string ; +: parse-notify-record ( buffer -- path changed ) + [ + [ FILE_NOTIFY_INFORMATION-FileName ] + [ FILE_NOTIFY_INFORMATION-FileNameLength ] + bi memory>u16-string + ] + [ FILE_NOTIFY_INFORMATION-Action parse-action ] bi ; + +: (file-notify-records) ( buffer -- buffer ) + dup , + dup FILE_NOTIFY_INFORMATION-NextEntryOffset zero? [ + [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep + (file-notify-records) + ] unless ; : file-notify-records ( buffer -- seq ) - [ dup FILE_NOTIFY_INFORMATION-NextEntryOffset 0 > ] - [ [ [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep ] keep ] - [ ] unfold nip ; + [ (file-notify-records) drop ] { } make ; : parse-notify-records ( monitor buffer -- ) file-notify-records [ parse-notify-record rot queue-change ] with each ; : fill-queue ( monitor -- ) - dup port>> [ buffer>> buffer-ptr ] [ read-changes zero? ] bi - [ 2dup parse-notify-records ] unless 2drop ; + dup port>> check-closed + [ buffer>> ptr>> ] [ read-changes zero? ] bi + [ 2dup parse-notify-records ] unless + 2drop ; + +: (fill-queue-thread) ( monitor -- ) + dup fill-queue (fill-queue-thread) ; : fill-queue-thread ( monitor -- ) - dup fill-queue fill-queue ; + [ dup fill-queue (fill-queue-thread) ] + [ dup port-closed-error? [ 2drop ] [ rethrow ] if ] recover ; M:: winnt (monitor) ( path recursive? mailbox -- monitor ) [ diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index a9d487dad7..1617b9f9a0 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -50,7 +50,7 @@ TUPLE: ConnectEx-args port 2dup save-callback get-overlapped-result drop ; -M: winnt (client) ( addrspec -- client-in client-out ) +M: winnt ((client)) ( addrspec -- client-in client-out ) [ \ ConnectEx-args construct-empty over make-sockaddr/size pick init-connect