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.
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 ;
: <duplex-stream> ( in out -- stream )
f duplex-stream construct-boa ;
<PRIVATE
ERROR: stream-closed-twice ;
: check-closed ( stream -- )
duplex-stream-closed? [ stream-closed-twice ] when ;
: check-closed ( stream -- stream )
dup closed>> [ 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 ;

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." }
$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." }

30
core/parser/parser.factor
View File

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

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

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
@ -16,4 +18,47 @@ SYMBOL: builds-dir
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 ( -- )
upload-to-factorcode get
[ update-clean-branch ]
[ (update-clean-branch) ]
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
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 ;
: 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
io.files io.encodings.utf8 prettyprint
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 )
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 ;
: 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
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 -- )

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
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 <displaced-alien>
(file-notify-records)
] unless ;
: file-notify-records ( buffer -- seq )
[ dup FILE_NOTIFY_INFORMATION-NextEntryOffset 0 > ]
[ [ [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep <displaced-alien> ] 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 )
[

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

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