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

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

db4
Slava Pestov 2008-04-13 00:39:50 -05:00
parent 68c82f88b1 5dae0c4498
commit 4435f5bf96
19 changed files with 418 additions and 322 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
core/io/streams/duplex/duplex.factor
View File

@ -1,75 +1,77 @@
! Copyright (C) 2005 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations io accessors ;
IN: io.streams.duplex IN: io.streams.duplex
USING: kernel continuations io ;
! We ensure that the stream can only be closed once, to preserve ! We ensure that the stream can only be closed once, to preserve
! integrity of duplex I/O ports. ! integrity of duplex I/O ports.
TUPLE: duplex-stream in out closed? ; TUPLE: duplex-stream in out closed ;
: <duplex-stream> ( in out -- stream ) : <duplex-stream> ( in out -- stream )
f duplex-stream construct-boa ; f duplex-stream construct-boa ;
<PRIVATE
ERROR: stream-closed-twice ; ERROR: stream-closed-twice ;
: check-closed ( stream -- ) : check-closed ( stream -- stream )
duplex-stream-closed? [ stream-closed-twice ] when ; dup closed>> [ stream-closed-twice ] when ; inline
: duplex-stream-in+ ( duplex -- stream ) : in ( duplex -- stream ) check-closed in>> ;
dup check-closed duplex-stream-in ;
: duplex-stream-out+ ( duplex -- stream ) : out ( duplex -- stream ) check-closed out>> ;
dup check-closed duplex-stream-out ;
PRIVATE>
M: duplex-stream stream-flush M: duplex-stream stream-flush
duplex-stream-out+ stream-flush ; out stream-flush ;
M: duplex-stream stream-readln M: duplex-stream stream-readln
duplex-stream-in+ stream-readln ; in stream-readln ;
M: duplex-stream stream-read1 M: duplex-stream stream-read1
duplex-stream-in+ stream-read1 ; in stream-read1 ;
M: duplex-stream stream-read-until M: duplex-stream stream-read-until
duplex-stream-in+ stream-read-until ; in stream-read-until ;
M: duplex-stream stream-read-partial M: duplex-stream stream-read-partial
duplex-stream-in+ stream-read-partial ; in stream-read-partial ;
M: duplex-stream stream-read M: duplex-stream stream-read
duplex-stream-in+ stream-read ; in stream-read ;
M: duplex-stream stream-write1 M: duplex-stream stream-write1
duplex-stream-out+ stream-write1 ; out stream-write1 ;
M: duplex-stream stream-write M: duplex-stream stream-write
duplex-stream-out+ stream-write ; out stream-write ;
M: duplex-stream stream-nl M: duplex-stream stream-nl
duplex-stream-out+ stream-nl ; out stream-nl ;
M: duplex-stream stream-format M: duplex-stream stream-format
duplex-stream-out+ stream-format ; out stream-format ;
M: duplex-stream make-span-stream M: duplex-stream make-span-stream
duplex-stream-out+ make-span-stream ; out make-span-stream ;
M: duplex-stream make-block-stream M: duplex-stream make-block-stream
duplex-stream-out+ make-block-stream ; out make-block-stream ;
M: duplex-stream make-cell-stream M: duplex-stream make-cell-stream
duplex-stream-out+ make-cell-stream ; out make-cell-stream ;
M: duplex-stream stream-write-table M: duplex-stream stream-write-table
duplex-stream-out+ stream-write-table ; out stream-write-table ;
M: duplex-stream dispose M: duplex-stream dispose
#! The output stream is closed first, in case both streams #! The output stream is closed first, in case both streams
#! are attached to the same file descriptor, the output #! are attached to the same file descriptor, the output
#! buffer needs to be flushed before we close the fd. #! buffer needs to be flushed before we close the fd.
dup duplex-stream-closed? [ dup closed>> [
t over set-duplex-stream-closed? t >>closed
[ dup duplex-stream-out dispose ] [ dup out>> dispose ]
[ dup duplex-stream-in dispose ] [ ] cleanup [ dup in>> dispose ] [ ] cleanup
] unless drop ; ] unless drop ;

12
core/parser/parser-docs.factor
View File

@ -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." } { $errors "Throws an error if the token does not name a word, and does not parse as a number." }
$parsing-note ; $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 HELP: unexpected
{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } } { $values { "want" "a " { $link word } " or " { $link f } } { "got" word } }
{ $description "Throws an " { $link unexpected } " error." } { $description "Throws an " { $link unexpected } " error." }

30
core/parser/parser.factor
View File

@ -184,6 +184,9 @@ M: parse-error summary
M: parse-error compute-restarts M: parse-error compute-restarts
error>> compute-restarts ; error>> compute-restarts ;
M: parse-error error-help
error>> error-help ;
SYMBOL: use SYMBOL: use
SYMBOL: in SYMBOL: in
@ -298,12 +301,35 @@ M: no-word-error summary
] "" make note. ] "" make note.
] with each ; ] 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 ) : parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS CREATE-CLASS
scan { scan {
{ ";" [ tuple f ] } { ";" [ tuple f ] }
{ "<" [ scan-word ";" parse-tokens ] } { "<" [ scan-word parse-tuple-slots ] }
[ >r tuple ";" parse-tokens r> prefix ] [ >r tuple parse-tuple-slots r> prefix ]
} case 3dup check-slot-shadowing ; } case 3dup check-slot-shadowing ;
ERROR: staging-violation word ; ERROR: staging-violation word ;

46
extra/builder/build/build.factor Normal file
View File

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

250
extra/builder/builder.factor
View File

@ -1,259 +1,21 @@
USING: kernel namespaces sequences splitting system combinators continuations USING: kernel debugger io.files threads calendar
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
builder.common builder.common
builder.benchmark builder.updates
builder.release ; builder.build ;
IN: builder 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 <process-stream>
[ 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 )
<process>
{ 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 )
<process>
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 )
<process>
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 ( -- )
<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 ( -- ) : build-loop ( -- )
builds-check builds-check
[ [
builds/factor builds/factor set-current-directory
[ new-code-available? [ build ] when
updates-available? new-image-available? or
[ build ]
when
]
with-directory
] ]
try try
5 minutes sleep 5 minutes sleep
build-loop ; build-loop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MAIN: build-loop
MAIN: build-loop

68
extra/builder/child/child.factor Normal file
View File

@ -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 ( -- )
<process>
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 ( -- )
<process>
boot-cmd >>command
+closed+ >>stdin
"../boot-log" >>stdout
+stdout+ >>stderr
60 minutes >>timeout
try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } ;
: test ( -- )
<process>
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 ;

24
extra/builder/cleanup/cleanup.factor Normal file
View File

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

49
extra/builder/common/common.factor
View File

@ -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 IN: builder.common
@ -16,4 +18,47 @@ SYMBOL: builds-dir
VAR: stamp VAR: stamp
SYMBOL: upload-to-factorcode : 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

22
extra/builder/email/email.factor Normal file
View File

@ -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 ( -- )
<email>
builder-from get >>from
builder-recipients get >>to
subject >>subject
"report" file>string >>body
send-email ;

2
extra/builder/release/branch/branch.factor
View File

@ -36,5 +36,5 @@ IN: builder.release.branch
: update-clean-branch ( -- ) : update-clean-branch ( -- )
upload-to-factorcode get upload-to-factorcode get
[ update-clean-branch ] [ (update-clean-branch) ]
when ; when ;

7
extra/builder/release/release.factor
View File

@ -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 io io.files io.launcher prettyprint bootstrap.image
bake combinators.cleave bake combinators.cleave
builder.util builder.util
@ -18,9 +18,10 @@ IN: builder.release
tidy tidy
make-archive make-archive
upload upload
save-archive ; save-archive
status-release on ;
: clean-build? ( -- ? ) : clean-build? ( -- ? )
{ "load-everything-vocabs" "test-all-vocabs" } [ eval-file empty? ] all? ; { "load-everything-vocabs" "test-all-vocabs" } [ eval-file empty? ] all? ;
: release ( -- ) clean-build? [ (release) ] when ; : release ( -- ) [ clean-build? [ (release) ] when ] try ;

35
extra/builder/report/report.factor Normal file
View File

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

12
extra/builder/test/test.factor
View File

@ -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 USING: kernel namespaces assocs
io.files io.encodings.utf8 prettyprint io.files io.encodings.utf8 prettyprint
help.lint help.lint

31
extra/builder/updates/updates.factor Normal file
View File

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

23
extra/builder/util/util.factor
View File

@ -25,11 +25,11 @@ DEFER: to-strings
: to-string ( obj -- str ) : to-string ( obj -- str )
dup class dup class
{ {
{ string [ ] } { \ string [ ] }
{ quotation [ call ] } { \ quotation [ call ] }
{ word [ execute ] } { \ word [ execute ] }
{ fixnum [ number>string ] } { \ fixnum [ number>string ] }
{ array [ to-strings concat ] } { \ array [ to-strings concat ] }
} }
case ; case ;
@ -97,4 +97,15 @@ USE: prettyprint
: cpu- ( -- cpu ) cpu unparse "." split "-" join ; : cpu- ( -- cpu ) cpu unparse "." split "-" join ;
: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ; : 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 <process-stream> [ readln ] with-stream
" " split second ;

9
extra/io/nonblocking/nonblocking.factor
View File

@ -3,7 +3,7 @@
USING: math kernel io sequences io.buffers io.timeouts generic USING: math kernel io sequences io.buffers io.timeouts generic
byte-vectors system io.streams.duplex io.encodings byte-vectors system io.streams.duplex io.encodings
io.backend continuations debugger classes byte-arrays namespaces 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 IN: io.nonblocking
SYMBOL: default-buffer-size SYMBOL: default-buffer-size
@ -43,8 +43,13 @@ TUPLE: output-port < port ;
: pending-error ( port -- ) : pending-error ( port -- )
[ f ] change-error drop [ throw ] when* ; [ 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 ) : check-closed ( port -- port )
dup closed>> [ "Port closed" throw ] when ; dup closed>> [ port-closed-error ] when ;
HOOK: cancel-io io-backend ( port -- ) HOOK: cancel-io io-backend ( port -- )

4
extra/io/windows/nt/monitors/monitors-tests.factor Executable file
View File

@ -0,0 +1,4 @@
IN: io.windows.nt.monitors.tests
USING: io.windows.nt.monitors tools.test ;
\ fill-queue-thread must-infer

58
extra/io/windows/nt/monitors/monitors.factor
View File

@ -3,12 +3,14 @@
USING: alien alien.c-types libc destructors locals USING: alien alien.c-types libc destructors locals
kernel math assocs namespaces continuations sequences hashtables kernel math assocs namespaces continuations sequences hashtables
sorting arrays combinators math.bitfields strings system sorting arrays combinators math.bitfields strings system
io.windows io.windows.nt.backend io.monitors io.nonblocking accessors threads
io.buffers io.files io.timeouts io 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 ; windows windows.kernel32 windows.types ;
IN: io.windows.nt.monitors IN: io.windows.nt.monitors
: open-directory ( path -- handle ) : open-directory ( path -- handle )
normalize-path
FILE_LIST_DIRECTORY FILE_LIST_DIRECTORY
share-mode share-mode
f f
@ -28,8 +30,8 @@ TUPLE: win32-monitor < monitor port ;
: begin-reading-changes ( port -- overlapped ) : begin-reading-changes ( port -- overlapped )
{ {
[ handle>> handle>> ] [ handle>> handle>> ]
[ buffer>> buffer-ptr ] [ buffer>> ptr>> ]
[ buffer>> buffer-size ] [ buffer>> size>> ]
[ recursive>> 1 0 ? ] [ recursive>> 1 0 ? ]
} cleave } cleave
FILE_NOTIFY_CHANGE_ALL FILE_NOTIFY_CHANGE_ALL
@ -39,12 +41,11 @@ TUPLE: win32-monitor < monitor port ;
: read-changes ( port -- bytes ) : read-changes ( port -- bytes )
[ [
[ dup begin-reading-changes
dup begin-reading-changes swap [ save-callback ] 2keep
swap [ save-callback ] 2keep check-closed ! we may have closed it...
check-closed ! we may have closed it... dup eof>> [ "EOF??" throw ] when
get-overlapped-result get-overlapped-result
] with-timeout
] with-destructors ; ] with-destructors ;
: parse-action ( action -- changed ) : parse-action ( action -- changed )
@ -55,32 +56,45 @@ TUPLE: win32-monitor < monitor port ;
{ FILE_ACTION_RENAMED_OLD_NAME [ +rename-file+ ] } { FILE_ACTION_RENAMED_OLD_NAME [ +rename-file+ ] }
{ FILE_ACTION_RENAMED_NEW_NAME [ +rename-file+ ] } { FILE_ACTION_RENAMED_NEW_NAME [ +rename-file+ ] }
[ drop +modify-file+ ] [ drop +modify-file+ ]
} case ; } case 1array ;
: memory>u16-string ( alien len -- string ) : memory>u16-string ( alien len -- string )
[ memory>byte-array ] keep 2/ c-ushort-array> >string ; [ memory>byte-array ] keep 2/ c-ushort-array> >string ;
: parse-notify-record ( buffer -- changed path ) : parse-notify-record ( buffer -- path changed )
[ FILE_NOTIFY_INFORMATION-Action parse-action ] [
[ FILE_NOTIFY_INFORMATION-FileName ] [ FILE_NOTIFY_INFORMATION-FileName ]
[ FILE_NOTIFY_INFORMATION-FileNameLength ] tri [ FILE_NOTIFY_INFORMATION-FileNameLength ]
memory>u16-string ; 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 <displaced-alien>
(file-notify-records)
] unless ;
: file-notify-records ( buffer -- seq ) : file-notify-records ( buffer -- seq )
[ dup FILE_NOTIFY_INFORMATION-NextEntryOffset 0 > ] [ (file-notify-records) drop ] { } make ;
[ [ [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep <displaced-alien> ] keep ]
[ ] unfold nip ;
: parse-notify-records ( monitor buffer -- ) : parse-notify-records ( monitor buffer -- )
file-notify-records file-notify-records
[ parse-notify-record rot queue-change ] with each ; [ parse-notify-record rot queue-change ] with each ;
: fill-queue ( monitor -- ) : fill-queue ( monitor -- )
dup port>> [ buffer>> buffer-ptr ] [ read-changes zero? ] bi dup port>> check-closed
[ 2dup parse-notify-records ] unless 2drop ; [ 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 -- ) : 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 ) M:: winnt (monitor) ( path recursive? mailbox -- monitor )
[ [

2
extra/io/windows/nt/sockets/sockets.factor
View File

@ -50,7 +50,7 @@ TUPLE: ConnectEx-args port
2dup save-callback 2dup save-callback
get-overlapped-result drop ; get-overlapped-result drop ;
M: winnt (client) ( addrspec -- client-in client-out ) M: winnt ((client)) ( addrspec -- client-in client-out )
[ [
\ ConnectEx-args construct-empty \ ConnectEx-args construct-empty
over make-sockaddr/size pick init-connect over make-sockaddr/size pick init-connect