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

db4
Eric Mertens 2008-04-13 03:34:31 -07:00
commit e6546e62e1
42 changed files with 522 additions and 381 deletions

View File

@ -7,9 +7,10 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
{ { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } } { { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
{ { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" } { { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
{ { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" } { { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
{ { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must be >= 2" } { { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must equal 1, 2 or 3" }
{ { $snippet "-young=" { $emphasis "n" } } { "Size of " { $snippet { $emphasis "n" } "-1" } " youngest generations, megabytes" } } { { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
{ { $snippet "-aging=" { $emphasis "n" } } "Size of tenured and semi-spaces, megabytes" } { { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" } { { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" } { { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
} }

View File

@ -20,7 +20,7 @@ IN: compiler
: finish-compile ( word effect dependencies -- ) : finish-compile ( word effect dependencies -- )
>r dupd save-effect r> >r dupd save-effect r>
over compiled-unxref over compiled-unxref
over crossref? [ compiled-xref ] [ 2drop ] if ; over compiled-crossref? [ compiled-xref ] [ 2drop ] if ;
: compile-succeeded ( word -- effect dependencies ) : compile-succeeded ( word -- effect dependencies )
[ [

View File

@ -66,7 +66,7 @@ GENERIC: definitions-changed ( assoc obj -- )
: compile ( words -- ) : compile ( words -- )
recompile-hook get call recompile-hook get call
dup [ drop crossref? ] assoc-contains? dup [ drop compiled-crossref? ] assoc-contains?
modify-code-heap ; modify-code-heap ;
SYMBOL: outdated-tuples SYMBOL: outdated-tuples
@ -82,7 +82,7 @@ SYMBOL: update-tuples-hook
: finish-compilation-unit ( -- ) : finish-compilation-unit ( -- )
call-recompile-hook call-recompile-hook
call-update-tuples-hook call-update-tuples-hook
dup [ drop crossref? ] assoc-contains? modify-code-heap dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
updated-definitions notify-definition-observers ; updated-definitions notify-definition-observers ;
: with-compilation-unit ( quot -- ) : with-compilation-unit ( quot -- )

View File

@ -63,14 +63,14 @@ M: trivial-tuple-dispatch-engine engine>quot
] "" make ; ] "" make ;
PREDICATE: tuple-dispatch-engine-word < word PREDICATE: tuple-dispatch-engine-word < word
"tuple-dispatch-engine" word-prop ; "tuple-dispatch-generic" word-prop generic? ;
M: tuple-dispatch-engine-word stack-effect M: tuple-dispatch-engine-word stack-effect
"tuple-dispatch-generic" word-prop "tuple-dispatch-generic" word-prop
[ extra-values ] [ stack-effect clone ] bi [ extra-values ] [ stack-effect ] bi
[ length + ] change-in ; dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
M: tuple-dispatch-engine-word crossref? M: tuple-dispatch-engine-word compiled-crossref?
drop t ; drop t ;
: remember-engine ( word -- ) : remember-engine ( word -- )
@ -78,12 +78,10 @@ M: tuple-dispatch-engine-word crossref?
: <tuple-dispatch-engine-word> ( engine -- word ) : <tuple-dispatch-engine-word> ( engine -- word )
tuple-dispatch-engine-word-name f <word> tuple-dispatch-engine-word-name f <word>
{ [ generic get "tuple-dispatch-generic" set-word-prop ]
[ t "tuple-dispatch-engine" set-word-prop ] [ remember-engine ]
[ generic get "tuple-dispatch-generic" set-word-prop ] [ ]
[ remember-engine ] tri ;
[ ]
} cleave ;
: define-tuple-dispatch-engine-word ( engine quot -- word ) : define-tuple-dispatch-engine-word ( engine quot -- word )
>r <tuple-dispatch-engine-word> dup r> define ; >r <tuple-dispatch-engine-word> dup r> define ;

View File

@ -2,7 +2,8 @@ IN: generic.standard.tests
USING: tools.test math math.functions math.constants USING: tools.test math math.functions math.constants
generic.standard strings sequences arrays kernel accessors generic.standard strings sequences arrays kernel accessors
words float-arrays byte-arrays bit-arrays parser namespaces words float-arrays byte-arrays bit-arrays parser namespaces
quotations inference vectors growable ; quotations inference vectors growable hashtables sbufs
prettyprint ;
GENERIC: lo-tag-test GENERIC: lo-tag-test
@ -268,3 +269,13 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
[ "vector growable sequence" ] [ [ "vector growable sequence" ] [
V{ } my-var [ call-next-hooker ] with-variable V{ } my-var [ call-next-hooker ] with-variable
] unit-test ] unit-test
GENERIC: no-stack-effect-decl
M: hashtable no-stack-effect-decl ;
M: vector no-stack-effect-decl ;
M: sbuf no-stack-effect-decl ;
[ ] [ \ no-stack-effect-decl see ] unit-test
[ ] [ \ no-stack-effect-decl word-def . ] unit-test

View File

@ -39,11 +39,19 @@ ARTICLE: "symbolic-links" "Symbolic links"
"Not all operating systems support symbolic links." "Not all operating systems support symbolic links."
{ $see-also link-info } ; { $see-also link-info } ;
ARTICLE: "directories" "Directories" ARTICLE: "current-directory" "Current working directory"
"Current directory:" "File system I/O operations use the value of a variable to resolve relative pathnames:"
{ $subsection current-directory } { $subsection current-directory }
"This variable can be changed with a pair of words:"
{ $subsection set-current-directory } { $subsection set-current-directory }
{ $subsection with-directory } { $subsection with-directory }
"This variable is independent of the operating system notion of ``current working directory''. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:"
{ $subsection (normalize-path) }
"The second is to change the working directory of the current process:"
{ $subsection cd }
{ $subsection cwd } ;
ARTICLE: "directories" "Directories"
"Home directory:" "Home directory:"
{ $subsection home } { $subsection home }
"Directory listing:" "Directory listing:"
@ -51,7 +59,8 @@ ARTICLE: "directories" "Directories"
{ $subsection directory* } { $subsection directory* }
"Creating directories:" "Creating directories:"
{ $subsection make-directory } { $subsection make-directory }
{ $subsection make-directories } ; { $subsection make-directories }
{ $subsection "current-directory" } ;
ARTICLE: "file-types" "File Types" ARTICLE: "file-types" "File Types"
"Platform-independent types:" "Platform-independent types:"
@ -242,11 +251,21 @@ HELP: cd
{ cd cwd current-directory set-current-directory with-directory } related-words { cd cwd current-directory set-current-directory with-directory } related-words
HELP: current-directory HELP: current-directory
{ $description "A variable holding the current directory. Words that use the filesystem do so in relation to this variable. On startup, an init hook sets this word to the directory from which Factor was run." } ; { $description "A variable holding the current directory as an absolute path. Words that use the filesystem do so in relation to this variable."
$nl
"This variable should never be set directly; instead, use " { $link set-current-directory } " or " { $link with-directory } ". This preserves the invariant that the value of this variable is an absolute path." } ;
HELP: set-current-directory
{ $values { "path" "a pathname string" } }
{ $description "Changes the " { $link current-directory } " variable."
$nl
"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
HELP: with-directory HELP: with-directory
{ $values { "path" "a pathname string" } { "quot" quotation } } { $values { "path" "a pathname string" } { "quot" quotation } }
{ $description "Changes the " { $link current-directory } " variable for the duration of a quotation's execution. Words that use the file-system should call " { $link normalize-path } " in order to obtain a path relative to the current directory." } ; { $description "Calls the quotation in a new dynamic scope with the " { $link current-directory } " variable rebound."
$nl
"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
HELP: append-path HELP: append-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
@ -300,7 +319,7 @@ HELP: directory*
HELP: resource-path HELP: resource-path
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } } { $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
{ $description "Resolve a path relative to the Factor source code location. This first checks if the " { $link resource-path } " variable is set to a path, and if not, uses the parent directory of the current image." } ; { $description "Resolve a path relative to the Factor source code location." } ;
HELP: pathname HELP: pathname
{ $class-description "Class of pathname presentations. Path name presentations can be created by calling " { $link <pathname> } ". Instances can be passed to " { $link write-object } " to output a clickable pathname." } ; { $class-description "Class of pathname presentations. Path name presentations can be created by calling " { $link <pathname> } ". Instances can be passed to " { $link write-object } " to output a clickable pathname." } ;

View File

@ -4,8 +4,7 @@ IN: io.streams.duplex
ARTICLE: "io.streams.duplex" "Duplex streams" ARTICLE: "io.streams.duplex" "Duplex streams"
"Duplex streams combine an input stream and an output stream into a bidirectional stream." "Duplex streams combine an input stream and an output stream into a bidirectional stream."
{ $subsection duplex-stream } { $subsection duplex-stream }
{ $subsection <duplex-stream> } { $subsection <duplex-stream> } ;
{ $subsection check-closed } ;
ABOUT: "io.streams.duplex" ABOUT: "io.streams.duplex"
@ -16,7 +15,5 @@ HELP: <duplex-stream>
{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } } { $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }
{ $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ; { $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ;
HELP: check-closed HELP: stream-closed-twice
{ $values { "stream" "a duplex stream" } }
{ $description "Throws a " { $link check-closed } " error if the stream has already been closed." }
{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ; { $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;

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

View File

@ -62,6 +62,8 @@ M: object zero? drop f ;
: neg ( x -- -x ) 0 swap - ; foldable : neg ( x -- -x ) 0 swap - ; foldable
: recip ( x -- y ) 1 swap / ; foldable : recip ( x -- y ) 1 swap / ; foldable
: ?1+ [ 1+ ] [ 0 ] if* ; inline
: /f ( x y -- z ) >r >float r> >float float/f ; inline : /f ( x y -- z ) >r >float r> >float float/f ; inline
: max ( x y -- z ) [ > ] most ; foldable : max ( x y -- z ) [ > ] most ; foldable

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

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 ;

View File

@ -71,6 +71,10 @@ M: word crossref?
word-vocabulary >boolean word-vocabulary >boolean
] if ; ] if ;
GENERIC: compiled-crossref? ( word -- ? )
M: word compiled-crossref? crossref? ;
GENERIC# (quot-uses) 1 ( obj assoc -- ) GENERIC# (quot-uses) 1 ( obj assoc -- )
M: object (quot-uses) 2drop ; M: object (quot-uses) 2drop ;
@ -97,7 +101,7 @@ SYMBOL: compiled-crossref
compiled-crossref global [ H{ } assoc-like ] change-at compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- ) : compiled-xref ( word dependencies -- )
[ drop crossref? ] assoc-subset [ drop compiled-crossref? ] assoc-subset
2dup "compiled-uses" set-word-prop 2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex* ; compiled-crossref get add-vertex* ;

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

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

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 ;

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 ;

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

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 ;

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 ;

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 ;

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 ;

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

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 ;

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 ;

View File

@ -1,6 +1,7 @@
! Copyright (C) 2005, 2006 Alex Chapman, Daniel Ehrenberg ! Copyright (C) 2005, 2006 Alex Chapman, Daniel Ehrenberg
! See http;//factorcode.org/license.txt for BSD license ! See http;//factorcode.org/license.txt for BSD license
USING: kernel sequences math sequences.private strings ; USING: kernel sequences math sequences.private strings
accessors ;
IN: circular IN: circular
! a circular sequence wraps another sequence, but begins at an ! a circular sequence wraps another sequence, but begins at an
@ -11,27 +12,27 @@ TUPLE: circular seq start ;
0 circular construct-boa ; 0 circular construct-boa ;
: circular-wrap ( n circular -- n circular ) : circular-wrap ( n circular -- n circular )
[ circular-start + ] keep [ start>> + ] keep
[ circular-seq length rem ] keep ; inline [ seq>> length rem ] keep ; inline
M: circular length circular-seq length ; M: circular length seq>> length ;
M: circular virtual@ circular-wrap circular-seq ; M: circular virtual@ circular-wrap seq>> ;
M: circular nth virtual@ nth ; M: circular nth virtual@ nth ;
M: circular set-nth virtual@ set-nth ; M: circular set-nth virtual@ set-nth ;
M: circular virtual-seq seq>> ;
: change-circular-start ( n circular -- ) : change-circular-start ( n circular -- )
#! change start to (start + n) mod length #! change start to (start + n) mod length
circular-wrap set-circular-start ; circular-wrap (>>start) ;
: push-circular ( elt circular -- ) : push-circular ( elt circular -- )
[ set-first ] keep 1 swap change-circular-start ; [ set-first ] [ 1 swap change-circular-start ] bi ;
: <circular-string> ( n -- circular ) : <circular-string> ( n -- circular )
0 <string> <circular> ; 0 <string> <circular> ;
M: circular virtual-seq circular-seq ;
INSTANCE: circular virtual-sequence INSTANCE: circular virtual-sequence

View File

@ -153,7 +153,6 @@ SYMBOL: event-stream-callbacks
[ [
event-stream-callbacks global event-stream-callbacks global
[ [ drop expired? not ] assoc-subset H{ } assoc-like ] change-at [ [ drop expired? not ] assoc-subset H{ } assoc-like ] change-at
1 \ event-stream-counter set-global
] "core-foundation" add-init-hook ] "core-foundation" add-init-hook
: add-event-source-callback ( quot -- id ) : add-event-source-callback ( quot -- id )

View File

@ -184,8 +184,7 @@ M: one-char-elt next-elt 2drop ;
[ >r blank? r> xor ] curry ; inline [ >r blank? r> xor ] curry ; inline
: (prev-word) ( ? col str -- col ) : (prev-word) ( ? col str -- col )
rot break-detector find-last* rot break-detector find-last* drop ?1+ ;
drop [ 1+ ] [ 0 ] if* ;
: (next-word) ( ? col str -- col ) : (next-word) ( ? col str -- col )
[ rot break-detector find* drop ] keep [ rot break-detector find* drop ] keep

View File

@ -195,6 +195,10 @@ DEFER: _
\ first3 [ 3array ] define-inverse \ first3 [ 3array ] define-inverse
\ first4 [ 4array ] define-inverse \ first4 [ 4array ] define-inverse
\ prefix [ unclip ] define-inverse
\ unclip [ prefix ] define-inverse
\ suffix [ dup 1 head* swap peek ] define-inverse
! Constructor inverse ! Constructor inverse
: deconstruct-pred ( class -- quot ) : deconstruct-pred ( class -- quot )
"predicate" word-prop [ dupd call assure ] curry ; "predicate" word-prop [ dupd call assure ] curry ;

View File

@ -75,13 +75,13 @@ os { winnt linux macosx } member? [
[ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test
[ ] [ "c1" get 15 seconds await-timeout ] unit-test [ ] [ "c1" get 1 minutes await-timeout ] unit-test
[ ] [ "monitor-test/subdir/blah/yxy" temp-file make-directories ] unit-test [ ] [ "monitor-test/subdir/blah/yxy" temp-file make-directories ] unit-test
[ ] [ "monitor-test/subdir/blah/yxy/test.txt" temp-file touch-file ] unit-test [ ] [ "monitor-test/subdir/blah/yxy/test.txt" temp-file touch-file ] unit-test
[ ] [ "c2" get 15 seconds await-timeout ] unit-test [ ] [ "c2" get 1 minutes await-timeout ] unit-test
! Dispose twice ! Dispose twice
[ ] [ "m" get dispose ] unit-test [ ] [ "m" get dispose ] unit-test

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

View File

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

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

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

View File

@ -1 +1 @@
Utility for defining compiler transforms, and short-circuiting boolean operators Utility for defining compiler transforms

View File

@ -227,8 +227,8 @@ PRIVATE>
: ?nth* ( n seq -- elt/f ? ) : ?nth* ( n seq -- elt/f ? )
2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable 2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable
: nths ( indices seq -- seq' ) : nths ( seq indices -- seq' )
[ swap nth ] with map ; swap [ nth ] curry map ;
: replace ( str oldseq newseq -- str' ) : replace ( str oldseq newseq -- str' )
zip >hashtable substitute ; zip >hashtable substitute ;

View File

@ -111,7 +111,7 @@ M: gadget children-on nip gadget-children ;
: fast-children-on ( rect axis children -- from to ) : fast-children-on ( rect axis children -- from to )
3dup 3dup
>r >r dup rect-loc swap rect-dim v+ >r >r dup rect-loc swap rect-dim v+
r> r> (fast-children-on) [ 1+ ] [ 0 ] if* r> r> (fast-children-on) ?1+
>r >r
>r >r rect-loc >r >r rect-loc
r> r> (fast-children-on) 0 or r> r> (fast-children-on) 0 or

View File

@ -281,4 +281,16 @@ M: button-down gesture>string
button-down-# [ " " % # ] when* button-down-# [ " " % # ] when*
] "" make ; ] "" make ;
M: left-action gesture>string drop "Swipe left" ;
M: right-action gesture>string drop "Swipe right" ;
M: up-action gesture>string drop "Swipe up" ;
M: down-action gesture>string drop "Swipe down" ;
M: zoom-in-action gesture>string drop "Zoom in" ;
M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
M: object gesture>string drop f ; M: object gesture>string drop f ;

View File

@ -2,8 +2,9 @@ USING: editors help.markup help.syntax inspector io listener
parser prettyprint tools.profiler tools.walker ui.commands parser prettyprint tools.profiler tools.walker ui.commands
ui.gadgets.editors ui.gadgets.panes ui.gadgets.presentations ui.gadgets.editors ui.gadgets.panes ui.gadgets.presentations
ui.gadgets.slots ui.operations ui.tools.browser ui.gadgets.slots ui.operations ui.tools.browser
ui.tools.interactor ui.tools.listener ui.tools.operations ui.tools.interactor ui.tools.inspector ui.tools.listener
ui.tools.profiler ui.tools.walker ui.tools.workspace vocabs ; ui.tools.operations ui.tools.profiler ui.tools.walker
ui.tools.workspace vocabs ;
IN: ui.tools IN: ui.tools
ARTICLE: "ui-presentations" "Presentations in the UI" ARTICLE: "ui-presentations" "Presentations in the UI"
@ -46,12 +47,14 @@ $nl
$nl $nl
"The slot editor has a toolbar containing various commands." "The slot editor has a toolbar containing various commands."
{ $command-map slot-editor "toolbar" } { $command-map slot-editor "toolbar" }
{ $command-map inspector-gadget "multi-touch" }
"The following commands are also available." "The following commands are also available."
{ $command-map source-editor "word" } ; { $command-map source-editor "word" } ;
ARTICLE: "ui-browser" "UI browser" ARTICLE: "ui-browser" "UI browser"
"The browser is used to display Factor code, documentation, and vocabularies." "The browser is used to display Factor code, documentation, and vocabularies."
{ $command-map browser-gadget "toolbar" } { $command-map browser-gadget "toolbar" }
{ $command-map browser-gadget "multi-touch" }
"Browsers are instances of " { $link browser-gadget } "." ; "Browsers are instances of " { $link browser-gadget } "." ;
ARTICLE: "ui-profiler" "UI profiler" ARTICLE: "ui-profiler" "UI profiler"
@ -110,6 +113,7 @@ ARTICLE: "ui-workspace-keys" "UI keyboard shortcuts"
{ $command-map workspace "tool-switching" } { $command-map workspace "tool-switching" }
{ $command-map workspace "scrolling" } { $command-map workspace "scrolling" }
{ $command-map workspace "workflow" } { $command-map workspace "workflow" }
{ $command-map workspace "multi-touch" }
{ $heading "Implementation" } { $heading "Implementation" }
"Workspaces are instances of " { $link workspace } "." ; "Workspaces are instances of " { $link workspace } "." ;

View File

@ -21,7 +21,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
} case ; } case ;
: trim-blank ( str -- newstr ) : trim-blank ( str -- newstr )
dup [ blank? not ] find-last 1+* head ; [ blank? ] right-trim ;
: process-other-extend ( lines -- set ) : process-other-extend ( lines -- set )
[ "#" split1 drop ";" split1 drop trim-blank ] map [ "#" split1 drop ";" split1 drop trim-blank ] map
@ -110,8 +110,7 @@ VALUE: grapheme-table
: last-grapheme ( str -- i ) : last-grapheme ( str -- i )
unclip-last-slice grapheme-class swap unclip-last-slice grapheme-class swap
[ grapheme-class dup rot grapheme-break? ] find-last-index [ grapheme-class dup rot grapheme-break? ] find-last-index ?1+ nip ;
nip -1 or 1+ ;
[ [
other-extend-lines process-other-extend \ other-extend set-value other-extend-lines process-other-extend \ other-extend set-value

View File

@ -12,9 +12,6 @@ IN: unicode.data
>> >>
! Convenience functions ! Convenience functions
: 1+* ( n/f _ -- n+1 )
drop [ 1+ ] [ 0 ] if* ;
: ?between? ( n/f from to -- ? ) : ?between? ( n/f from to -- ? )
pick [ between? ] [ 3drop f ] if ; pick [ between? ] [ 3drop f ] if ;

View File

@ -67,7 +67,7 @@ IN: unicode.normalize
0 reorder-loop ; 0 reorder-loop ;
: reorder-back ( string i -- ) : reorder-back ( string i -- )
over [ non-starter? not ] find-last* 1+* reorder-next 2drop ; over [ non-starter? not ] find-last* drop ?1+ reorder-next 2drop ;
: decompose ( string quot -- decomposed ) : decompose ( string quot -- decomposed )
! When there are 8 and 32-bit strings, this'll be ! When there are 8 and 32-bit strings, this'll be

View File

@ -29,9 +29,7 @@ SYMBOL: indenter
xml-pprint? get [ -1 indentation +@ ] when ; xml-pprint? get [ -1 indentation +@ ] when ;
: trim-whitespace ( string -- no-whitespace ) : trim-whitespace ( string -- no-whitespace )
[ [ blank? not ] find drop 0 or ] keep [ blank? ] trim ;
[ [ blank? not ] find-last drop [ 1+ ] [ 0 ] if* ] keep
subseq ;
: ?filter-children ( children -- no-whitespace ) : ?filter-children ( children -- no-whitespace )
xml-pprint? get [ xml-pprint? get [