Merge branch 'master' into jamshred

db4
Alex Chapman 2008-01-25 23:51:48 +11:00
commit ba4143e43c
71 changed files with 786 additions and 365 deletions

View File

@ -7,21 +7,6 @@ optimizer definitions math compiler.errors threads graphs
generic ;
IN: compiler
SYMBOL: compiled-crossref
compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- )
2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex* ;
: compiled-unxref ( word -- )
dup "compiled-uses" word-prop
compiled-crossref get remove-vertex* ;
: compiled-usage ( word -- assoc )
compiled-crossref get at ;
: compiled-usages ( words -- seq )
[ [ dup ] H{ } map>assoc dup ] keep [
compiled-usage [ nip +inlined+ eq? ] assoc-subset update
@ -41,7 +26,7 @@ compiled-crossref global [ H{ } assoc-like ] change-at
>r dupd save-effect r>
f pick compiler-error
over compiled-unxref
compiled-xref ;
over word-vocabulary [ compiled-xref ] [ 2drop ] if ;
: compile-succeeded ( word -- effect dependencies )
[

View File

@ -1,6 +1,6 @@
USING: compiler definitions generic assocs inference math
namespaces parser tools.test words kernel sequences arrays io
effects tools.test.inference compiler.units ;
effects tools.test.inference compiler.units inference.state ;
IN: temporary
DEFER: x-1
@ -206,12 +206,15 @@ DEFER: generic-then-not-generic-test-2
[ 4 ] [ generic-then-not-generic-test-2 ] unit-test
DEFER: foldable-test-1
DEFER: foldable-test-2
[ ] [ "IN: temporary : foldable-test-1 3 ; foldable" eval ] unit-test
[ ] [ "IN: temporary : foldable-test-2 foldable-test-1 ;" eval ] unit-test
[ +inlined+ ] [ \ foldable-test-2 \ foldable-test-1 compiled-usage at ] unit-test
[ 3 ] [ foldable-test-2 ] unit-test
[ ] [ "IN: temporary : foldable-test-1 4 ; foldable" eval ] unit-test
@ -229,3 +232,9 @@ DEFER: flushable-test-2
[ ] [ "IN: temporary USING: kernel sequences ; : flushable-test-1 3 over push ;" eval ] unit-test
[ V{ 3 } ] [ flushable-test-2 ] unit-test
: ax ;
: bx ax ;
[ \ bx forget ] with-compilation-unit
[ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test

View File

@ -78,7 +78,8 @@ PRIVATE>
: pop-front ( dlist -- obj )
dup dlist-front [
dlist-node-next
dup dlist-node-next
f rot set-dlist-node-next
f over set-prev-when
swap set-dlist-front
] 2keep dlist-node-obj
@ -87,13 +88,13 @@ PRIVATE>
: pop-front* ( dlist -- ) pop-front drop ;
: pop-back ( dlist -- obj )
[
dlist-back dup dlist-node-prev f over set-next-when
] keep
[ set-dlist-back ] keep
[ normalize-front ] keep
dec-length
dlist-node-obj ;
dup dlist-back [
dup dlist-node-prev
f rot set-dlist-node-prev
f over set-next-when
swap set-dlist-back
] 2keep dlist-node-obj
swap [ normalize-front ] keep dec-length ;
: pop-back* ( dlist -- ) pop-back drop ;

View File

@ -74,7 +74,7 @@ M: pair (bitfield-quot) ( spec -- quot )
dup tuple-size [ <tuple> ] 2curry
swap infer-quot
] [
\ construct-empty declared-infer
\ construct-empty 1 1 <effect> make-call-node
] if
] "infer" set-word-prop

7
core/io/backend/backend.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init kernel system ;
USING: init kernel system namespaces ;
IN: io.backend
SYMBOL: io-backend
@ -21,3 +21,6 @@ M: object normalize-pathname ;
[ init-io embedded? [ init-stdio ] unless ]
"io.backend" add-init-hook
: set-io-backend ( backend -- )
io-backend set-global init-io init-stdio ;

5
core/io/io-docs.factor Normal file → Executable file
View File

@ -29,7 +29,6 @@ ARTICLE: "stdio" "The default stream"
"Various words take an implicit stream parameter from a variable to reduce stack shuffling."
{ $subsection stdio }
"Unless rebound in a child namespace, this variable will be set to a console stream for interacting with the user."
{ $subsection close }
{ $subsection read1 }
{ $subsection read }
{ $subsection read-until }
@ -178,10 +177,6 @@ $io-error ;
HELP: stdio
{ $var-description "Holds a stream, used for various implicit stream operations. Rebound using " { $link with-stream } " and " { $link with-stream* } "." } ;
HELP: close
{ $contract "Closes the " { $link stdio } " stream." }
$io-error ;
HELP: readln
{ $values { "str/f" "a string or " { $link f } } }
{ $contract "Reads a line of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }

View File

@ -38,8 +38,6 @@ SYMBOL: stdio
! Default error stream
SYMBOL: stderr
: close ( -- ) stdio get stream-close ;
: readln ( -- str/f ) stdio get stream-readln ;
: read1 ( -- ch/f ) stdio get stream-read1 ;
: read ( n -- str/f ) stdio get stream-read ;
@ -56,7 +54,9 @@ SYMBOL: stderr
stdio swap with-variable ; inline
: with-stream ( stream quot -- )
swap [ [ close ] [ ] cleanup ] with-stream* ; inline
swap [
[ stdio get stream-close ] [ ] cleanup
] with-stream* ; inline
: tabular-output ( style quot -- )
swap >r { } make r> stdio get stream-write-table ; inline

4
core/prettyprint/prettyprint-docs.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
USING: prettyprint.backend prettyprint.config
prettyprint.sections help.markup help.syntax io kernel words
definitions quotations strings ;
prettyprint.sections prettyprint.private help.markup help.syntax
io kernel words definitions quotations strings ;
IN: prettyprint
ARTICLE: "prettyprint-numbers" "Prettyprinting numbers"

View File

@ -86,14 +86,14 @@ combinators quotations ;
: .s ( -- ) datastack stack. ;
: .r ( -- ) retainstack stack. ;
<PRIVATE
SYMBOL: ->
\ ->
{ { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } }
"word-style" set-word-prop
<PRIVATE
! This code is ugly and could probably be simplified
: remove-step-into
building get dup empty? [

View File

@ -87,6 +87,25 @@ M: wrapper (quot-uses) >r wrapped r> (quot-uses) ;
M: word uses ( word -- seq )
word-def quot-uses keys ;
SYMBOL: compiled-crossref
compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- )
2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex* ;
: compiled-unxref ( word -- )
dup "compiled-uses" word-prop
compiled-crossref get remove-vertex* ;
: delete-compiled-xref ( word -- )
dup compiled-unxref
compiled-crossref get delete-at ;
: compiled-usage ( word -- assoc )
compiled-crossref get at ;
M: word redefined* ( word -- )
{ "inferred-effect" "base-case" "no-effect" } reset-props ;
@ -187,6 +206,7 @@ M: word (forget-word)
: forget-word ( word -- )
dup delete-xref
dup delete-compiled-xref
(forget-word) ;
M: word forget* forget-word ;

View File

@ -10,6 +10,3 @@ IN: bootstrap.io
{ [ wince? ] [ "windows.ce" ] }
} cond append require
] when
init-io
init-stdio

38
extra/calendar/windows/windows.factor Normal file → Executable file
View File

@ -1,5 +1,5 @@
USING: alien alien.c-types kernel math
windows windows.kernel32 namespaces ;
USING: calendar.backend namespaces alien.c-types
windows windows.kernel32 kernel math ;
IN: calendar.windows
TUPLE: windows-calendar ;
@ -11,37 +11,3 @@ M: windows-calendar gmt-offset ( -- float )
[ GetTimeZoneInformation win32-error=0/f ] keep
[ TIME_ZONE_INFORMATION-Bias ] keep
TIME_ZONE_INFORMATION-DaylightBias + 60 /f neg ;
: >64bit ( lo hi -- n )
32 shift bitor ;
: windows-1601 ( -- timestamp )
1601 1 1 0 0 0 0 <timestamp> ;
: FILETIME>windows-time ( FILETIME -- n )
[ FILETIME-dwLowDateTime ] keep
FILETIME-dwHighDateTime >64bit ;
: windows-time>timestamp ( n -- timestamp )
10000000 /i seconds windows-1601 swap +dt ;
: windows-time ( -- n )
"FILETIME" <c-object> [ GetSystemTimeAsFileTime ] keep
FILETIME>windows-time ;
: timestamp>windows-time ( timestamp -- n )
#! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC)
>gmt windows-1601 timestamp- >bignum 10000000 * ;
: windows-time>FILETIME ( n -- FILETIME )
"FILETIME" <c-object>
[
[ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep
>r -32 shift r> set-FILETIME-dwHighDateTime
] keep ;
: timestamp>FILETIME ( timestamp -- FILETIME/f )
[ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ;
: FILETIME>timestamp ( FILETIME -- timestamp/f )
FILETIME>windows-time windows-time>timestamp ;

View File

@ -79,11 +79,11 @@ MACRO: (send) ( selector super? -- quot )
super-message-senders message-senders ? get at
[ slip execute ] 2curry ;
: send ( args... receiver selector -- return... ) f (send) ; inline
: send ( receiver args... selector -- return... ) f (send) ; inline
\ send soft "break-after" set-word-prop
: super-send ( args... receiver selector -- return... ) t (send) ; inline
: super-send ( receiver args... selector -- return... ) t (send) ; inline
\ super-send soft "break-after" set-word-prop

4
extra/editors/editpadpro/editpadpro.factor Normal file → Executable file
View File

@ -10,6 +10,8 @@ IN: editors.editpadpro
] unless* ;
: editpadpro ( file line -- )
[ editpadpro-path % " /l" % # " \"" % % "\"" % ] "" make run-detached ;
[
editpadpro-path , "/l" swap number>string append , ,
] { } make run-detached drop ;
[ editpadpro ] edit-hook set-global

View File

@ -9,7 +9,7 @@ IN: editors.editplus
: editplus ( file line -- )
[
editplus-path % " -cursor " % # " " % %
] "" make run-detached ;
editplus-path , "-cursor" , number>string , ,
] { } make run-detached drop ;
[ editplus ] edit-hook set-global

7
extra/editors/emacs/emacs.factor Normal file → Executable file
View File

@ -4,8 +4,11 @@ IN: editors.emacs
: emacsclient ( file line -- )
[
"emacsclient --no-wait +" % # " " % %
] "" make run-process ;
"emacsclient" ,
"--no-wait" ,
"+" swap number>string append ,
,
] { } make run-process drop ;
: emacs ( word -- )
where first2 emacsclient ;

View File

@ -9,8 +9,7 @@ IN: editors.emeditor
: emeditor ( file line -- )
[
emeditor-path % " /l " % #
" " % "\"" % % "\"" %
] "" make run-detached ;
emeditor-path , "/l" , number>string , ,
] { } make run-detached drop ;
[ emeditor ] edit-hook set-global

5
extra/editors/notepadpp/notepadpp.factor Normal file → Executable file
View File

@ -9,7 +9,8 @@ IN: editors.notepadpp
: notepadpp ( file line -- )
[
notepadpp-path % " -n" % # " " % %
] "" make run-detached ;
notepadpp-path ,
"-n" swap number>string append , ,
] "" make run-detached drop ;
[ notepadpp ] edit-hook set-global

13
extra/editors/scite/scite.factor Normal file → Executable file
View File

@ -18,14 +18,13 @@ SYMBOL: scite-path
: scite-command ( file line -- cmd )
swap
[ scite-path get %
" \"" %
%
"\" -goto:" %
#
] "" make ;
[
scite-path get ,
,
"-goto:" swap number>string append ,
] { } make ;
: scite-location ( file line -- )
scite-command run-detached ;
scite-command run-detached drop ;
[ scite-location ] edit-hook set-global

5
extra/editors/ted-notepad/ted-notepad.factor Normal file → Executable file
View File

@ -9,8 +9,7 @@ IN: editors.ted-notepad
: ted-notepad ( file line -- )
[
ted-notepad-path % " /l" % #
" " % %
] "" make run-detached ;
ted-notepad-path , "/l" swap number>string append , ,
] { } make run-detached drop ;
[ ted-notepad ] edit-hook set-global

3
extra/editors/textmate/textmate.factor Normal file → Executable file
View File

@ -4,6 +4,7 @@ namespaces prettyprint editors ;
IN: editors.textmate
: textmate-location ( file line -- )
[ "mate -a -l " % # " " % unparse % ] "" make run-process ;
[ "mate" , "-a" , "-l" , number>string , , ] { } make
run-process drop ;
[ textmate-location ] edit-hook set-global

4
extra/editors/ultraedit/ultraedit.factor Normal file → Executable file
View File

@ -10,8 +10,8 @@ IN: editors.ultraedit
: ultraedit ( file line -- )
[
ultraedit-path % " " % swap % "/" % # "/1" %
] "" make run-detached ;
ultraedit-path , [ % "/" % # "/1" % ] "" make ,
] { } make run-detached drop ;
[ ultraedit ] edit-hook set-global

8
extra/editors/vim/vim.factor Normal file → Executable file
View File

@ -10,13 +10,15 @@ HOOK: vim-command vim-editor
TUPLE: vim ;
M: vim vim-command ( file line -- string )
[ "\"" % vim-path get % "\" \"" % swap % "\" +" % # ] "" make ;
M: vim vim-command ( file line -- array )
[
vim-path get , swap , "+" swap number>string append ,
] { } make ;
: vim-location ( file line -- )
vim-command
vim-detach get-global
[ run-detached ] [ run-process ] if ;
[ run-detached ] [ run-process ] if drop ;
"vim" vim-path set-global
[ vim-location ] edit-hook set-global

4
extra/editors/wordpad/wordpad.factor Normal file → Executable file
View File

@ -8,8 +8,6 @@ IN: editors.wordpad
] unless* ;
: wordpad ( file line -- )
[
wordpad-path % drop " " % "\"" % % "\"" %
] "" make run-detached ;
drop wordpad-path swap 2array run-detached drop ;
[ wordpad ] edit-hook set-global

View File

@ -1,28 +1,25 @@
USING: kernel namespaces math math.constants math.functions
arrays sequences opengl opengl.gl opengl.glu ui ui.render
ui.gadgets ui.gadgets.theme ui.gadgets.slate colors ;
USING: kernel namespaces math math.constants math.functions arrays sequences
opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
ui.gadgets.slate colors ;
IN: golden-section
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! To run:
!
! "demos.golden-section" run
! "golden-section" run
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: disk ( quadric radius center -- )
glPushMatrix
gl-translate
dup 0 glScalef
0 1 10 10 gluDisk
glPopMatrix ;
glPushMatrix
gl-translate
dup 0 glScalef
0 1 10 10 gluDisk
glPopMatrix ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: phi ( -- phi ) 5 sqrt 1 + 2 / 1 - ;
: omega ( i -- omega ) phi * 2 * pi * ;
: omega ( i -- omega ) phi 1- * 2 * pi * ;
: x ( i -- x ) dup omega cos * 0.5 * ;
@ -35,10 +32,10 @@ glPopMatrix ;
: color ( i -- color ) 360.0 / dup 0.25 1 4array ;
: rim ( quadric i -- )
black gl-color dup radius 1.5 * swap center disk ;
black gl-color dup radius 1.5 * swap center disk ;
: inner ( quadric i -- )
dup color gl-color dup radius swap center disk ;
dup color gl-color dup radius swap center disk ;
: dot ( quadric i -- ) 2dup rim inner ;
@ -47,21 +44,21 @@ dup color gl-color dup radius swap center disk ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: with-quadric ( quot -- )
gluNewQuadric [ swap call ] keep gluDeleteQuadric ; inline
gluNewQuadric [ swap call ] keep gluDeleteQuadric ; inline
: display ( -- )
GL_PROJECTION glMatrixMode
glLoadIdentity
-400 400 -400 400 -1 1 glOrtho
GL_MODELVIEW glMatrixMode
glLoadIdentity
[ golden-section ] with-quadric ;
GL_PROJECTION glMatrixMode
glLoadIdentity
-400 400 -400 400 -1 1 glOrtho
GL_MODELVIEW glMatrixMode
glLoadIdentity
[ golden-section ] with-quadric ;
: golden-section-window ( -- )
[
[ display ] <slate>
{ 600 600 } over set-slate-dim
"Golden Section" open-window
] with-ui ;
[
[ display ] <slate>
{ 600 600 } over set-slate-dim
"Golden Section" open-window
] with-ui ;
MAIN: golden-section-window
MAIN: golden-section-window

View File

@ -1,4 +1,6 @@
USING: arrays io io.streams.string kernel math math.parser namespaces prettyprint sequences splitting strings ;
USING: arrays combinators.lib io io.streams.string
kernel math math.parser namespaces prettyprint
sequences splitting strings ;
IN: hexdump
<PRIVATE
@ -6,12 +8,16 @@ IN: hexdump
: header. ( len -- )
"Length: " write dup unparse write ", " write >hex write "h" write nl ;
: offset. ( lineno -- ) 16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
: h-pad. ( digit -- ) >hex 2 CHAR: 0 pad-left write ;
: offset. ( lineno -- )
16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
: h-pad. ( digit -- )
>hex 2 CHAR: 0 pad-left write ;
: line. ( str n -- )
offset.
dup [ h-pad. " " write ] each
16 over length - " " <array> concat write
16 over length - 3 * CHAR: \s <string> write
[ dup printable? [ drop CHAR: . ] unless write1 ] each
nl ;
@ -19,9 +25,8 @@ PRIVATE>
: hexdump ( seq -- str )
[
dup length header.
16 <sliced-groups> dup length [ line. ] 2each
16 <sliced-groups> [ line. ] each-index
] string-out ;
: hexdump. ( seq -- )
hexdump write ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax quotations kernel ;
USING: help.markup help.syntax quotations kernel io math ;
IN: io.launcher
HELP: +command+
@ -31,6 +31,36 @@ HELP: +environment-mode+
"Default value is " { $link append-environment } "."
} ;
HELP: +stdin+
{ $description "Launch descriptor key. Must equal one of the following:"
{ $list
{ { $link f } " - standard input is inherited" }
{ { $link +closed+ } " - standard input is closed" }
{ "a path name - standard input is read from the given file, which must exist" }
}
} ;
HELP: +stdout+
{ $description "Launch descriptor key. Must equal one of the following:"
{ $list
{ { $link f } " - standard output is inherited" }
{ { $link +closed+ } " - standard output is closed" }
{ "a path name - standard output is written to the given file, which is overwritten if it already exists" }
}
} ;
HELP: +stderr+
{ $description "Launch descriptor key. Must equal one of the following:"
{ $list
{ { $link f } " - standard error is inherited" }
{ { $link +closed+ } " - standard error is closed" }
{ "a path name - standard error is written to the given file, which is overwritten if it already exists" }
}
} ;
HELP: +closed+
{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
HELP: prepend-environment
{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence."
$nl
@ -58,7 +88,7 @@ HELP: get-environment
{ $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ;
HELP: run-process*
{ $values { "desc" "a launch descriptor" } }
{ $values { "desc" "a launch descriptor" } { "handle" "a process handle" } }
{ $contract "Launches a process using the launch descriptor." }
{ $notes "User code should call " { $link run-process } " instead." } ;
@ -73,22 +103,41 @@ HELP: >descriptor
} ;
HELP: run-process
{ $values { "obj" object } }
{ $contract "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." } ;
{ $values { "obj" object } { "process" process } }
{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
{ $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ;
HELP: run-detached
{ $values { "obj" object } }
{ $values { "obj" object } { "process" process } }
{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
{ $notes
"This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set."
$nl
"The output value can be passed to " { $link wait-for-process } " to get an exit code."
} ;
HELP: process
{ $class-description "A class representing an active or finished process."
$nl
"Processes are output by " { $link run-process } " and " { $link run-detached } ", and are stored in the " { $link process-stream-process } " slot of " { $link process-stream } " instances."
$nl
"Processes can be passed to " { $link wait-for-process } "." } ;
HELP: process-stream
{ $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link <process-stream> } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ;
HELP: <process-stream>
{ $values { "obj" object } { "stream" "a bidirectional stream" } }
{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream." }
{ $notes "Closing the stream will block until the process exits." } ;
{ run-process run-detached <process-stream> } related-words
HELP: with-process-stream
{ $values { "obj" object } { "quot" quotation } { "process" process } }
{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". When the quotation returns, the " { $link process } " instance is output." } ;
HELP: wait-for-process
{ $values { "process" process } { "status" integer } }
{ $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ;
ARTICLE: "io.launcher" "Launching OS processes"
"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
@ -105,9 +154,19 @@ $nl
{ $subsection +detached+ }
{ $subsection +environment+ }
{ $subsection +environment-mode+ }
"Redirecting standard input and output to files:"
{ $subsection +stdin+ }
{ $subsection +stdout+ }
{ $subsection +stderr+ }
"The following words are used to launch processes:"
{ $subsection run-process }
{ $subsection run-detached }
{ $subsection <process-stream> } ;
"Redirecting standard input and output to a pipe:"
{ $subsection <process-stream> }
{ $subsection with-process-stream }
"A class representing an active or finished process:"
{ $subsection process }
"Waiting for a process to end, or getting the exit code of a finished process:"
{ $subsection wait-for-process } ;
ABOUT: "io.launcher"

View File

@ -1,14 +1,39 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend system kernel namespaces strings hashtables
sequences assocs combinators vocabs.loader ;
USING: io io.backend system kernel namespaces strings hashtables
sequences assocs combinators vocabs.loader init threads
continuations ;
IN: io.launcher
! Non-blocking process exit notification facility
SYMBOL: processes
[ H{ } clone processes set-global ] "io.launcher" add-init-hook
TUPLE: process handle status ;
HOOK: register-process io-backend ( process -- )
M: object register-process drop ;
: <process> ( handle -- process )
f process construct-boa
V{ } clone over processes get set-at
dup register-process ;
M: process equal? 2drop f ;
M: process hashcode* process-handle hashcode* ;
SYMBOL: +command+
SYMBOL: +arguments+
SYMBOL: +detached+
SYMBOL: +environment+
SYMBOL: +environment-mode+
SYMBOL: +stdin+
SYMBOL: +stdout+
SYMBOL: +stderr+
SYMBOL: +closed+
SYMBOL: prepend-environment
SYMBOL: replace-environment
@ -42,17 +67,38 @@ GENERIC: >descriptor ( obj -- desc )
M: string >descriptor +command+ associate ;
M: sequence >descriptor +arguments+ associate ;
M: assoc >descriptor ;
M: assoc >descriptor >hashtable ;
HOOK: run-process* io-backend ( desc -- )
HOOK: run-process* io-backend ( desc -- handle )
: run-process ( obj -- )
>descriptor run-process* ;
: wait-for-process ( process -- status )
dup process-handle [
dup [ processes get at push stop ] curry callcc0
] when process-status ;
: run-detached ( obj -- )
>descriptor H{ { +detached+ t } } union run-process* ;
: run-process ( obj -- process )
>descriptor
dup run-process*
+detached+ rot at [ dup wait-for-process drop ] unless ;
HOOK: process-stream* io-backend ( desc -- stream )
: run-detached ( obj -- process )
>descriptor H{ { +detached+ t } } union run-process ;
HOOK: process-stream* io-backend ( desc -- stream process )
TUPLE: process-stream process ;
: <process-stream> ( obj -- stream )
>descriptor process-stream* ;
>descriptor process-stream*
{ set-delegate set-process-stream-process }
process-stream construct ;
: with-process-stream ( obj quot -- process )
swap <process-stream>
[ swap with-stream ] keep
process-stream-process ; inline
: notify-exit ( status process -- )
[ set-process-status ] keep
[ processes get delete-at* drop [ schedule-thread ] each ] keep
f swap set-process-handle ;

View File

@ -51,10 +51,13 @@ M: inet4 make-sockaddr ( inet -- sockaddr )
"0.0.0.0" or
rot inet-pton *uint over set-sockaddr-in-addr ;
SYMBOL: port-override
: (port) port-override get [ ] [ ] ?if ;
M: inet4 parse-sockaddr
>r dup sockaddr-in-addr <uint> r> inet-ntop
swap sockaddr-in-port ntohs <inet4> ;
swap sockaddr-in-port ntohs (port) <inet4> ;
M: inet6 inet-ntop ( data addrspec -- str )
drop 16 memory>string 2 <groups> [ be> >hex ] map ":" join ;
@ -80,7 +83,7 @@ M: inet6 make-sockaddr ( inet -- sockaddr )
M: inet6 parse-sockaddr
>r dup sockaddr-in6-addr r> inet-ntop
swap sockaddr-in6-port ntohs <inet6> ;
swap sockaddr-in6-port ntohs (port) <inet6> ;
: addrspec-of-family ( af -- addrspec )
{
@ -102,15 +105,28 @@ M: f parse-sockaddr nip ;
[ dup addrinfo-next swap addrinfo>addrspec ]
[ ] unfold nip [ ] subset ;
: prepare-resolve-host ( host serv passive? -- host' serv' flags )
#! If the port is a number, we resolve for 'http' then
#! change it later. This is a workaround for a FreeBSD
#! getaddrinfo() limitation -- on Windows, Linux and Mac,
#! we can convert a number to a string and pass that as the
#! service name, but on FreeBSD this gives us an unknown
#! service error.
>r
dup integer? [ port-override set "http" ] when
r> AI_PASSIVE 0 ? ;
M: object resolve-host ( host serv passive? -- seq )
>r dup integer? [ number>string ] when
"addrinfo" <c-object>
r> [ AI_PASSIVE over set-addrinfo-flags ] when
PF_UNSPEC over set-addrinfo-family
IPPROTO_TCP over set-addrinfo-protocol
f <void*> [ getaddrinfo addrinfo-error ] keep *void*
[ parse-addrinfo-list ] keep
freeaddrinfo ;
[
prepare-resolve-host
"addrinfo" <c-object>
[ set-addrinfo-flags ] keep
PF_UNSPEC over set-addrinfo-family
IPPROTO_TCP over set-addrinfo-protocol
f <void*> [ getaddrinfo addrinfo-error ] keep *void*
[ parse-addrinfo-list ] keep
freeaddrinfo
] with-scope ;
M: object host-name ( -- name )
256 <byte-array> dup dup length gethostname

0
extra/io/sockets/sockets.factor Normal file → Executable file
View File

10
extra/io/unix/bsd/bsd.factor Normal file → Executable file
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
IN: io.unix.bsd
USING: io.backend io.unix.backend io.unix.kqueue io.unix.select
io.unix.launcher namespaces kernel assocs threads continuations
;
io.launcher io.unix.launcher namespaces kernel assocs threads
continuations ;
! On *BSD and Mac OS X, we use select() for the top-level
! multiplexer, and we hang a kqueue off of it but file change
@ -23,7 +23,7 @@ M: bsd-io init-io ( -- )
2dup mx get-global mx-reads set-at
mx get-global mx-writes set-at ;
M: bsd-io wait-for-process ( pid -- status )
[ kqueue-mx get-global add-pid-task stop ] curry callcc1 ;
M: bsd-io register-process ( process -- )
process-handle kqueue-mx get-global add-pid-task ;
T{ bsd-io } io-backend set-global
T{ bsd-io } set-io-backend

View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel io.nonblocking io.unix.backend
bit-arrays sequences assocs unix math namespaces structs ;
bit-arrays sequences assocs unix unix.linux.epoll math
namespaces structs ;
IN: io.unix.epoll
TUPLE: epoll-mx events ;
@ -18,40 +19,44 @@ TUPLE: epoll-mx events ;
GENERIC: io-task-events ( task -- n )
M: input-task drop EPOLLIN ;
M: input-task io-task-events drop EPOLLIN ;
M: output-task drop EPOLLOUT ;
M: output-task io-task-events drop EPOLLOUT ;
: make-event ( task -- event )
"epoll-event" <c-object>
over io-task-events over set-epoll-event-events
over io-task-fd over set-epoll-fd ;
swap io-task-fd over set-epoll-event-fd ;
: do-epoll-ctl ( task mx what -- )
>r >r make-event r> mx-fd r> pick event-data *int roll
>r mx-fd r> rot dup io-task-fd swap make-event
epoll_ctl io-error ;
M: epoll-mx register-io-task ( task mx -- )
EPOLL_CTL_ADD do-epoll-ctl ;
2dup EPOLL_CTL_ADD do-epoll-ctl
delegate register-io-task ;
M: epoll-mx unregister-io-task ( task mx -- )
2dup delegate unregister-io-task
EPOLL_CTL_DEL do-epoll-ctl ;
: wait-kevent ( mx timeout -- n )
>r mx-fd epoll-mx-events max-events r> epoll_wait
dup multiplexer-error ;
: wait-event ( mx timeout -- n )
>r { mx-fd epoll-mx-events } get-slots max-events
r> epoll_wait dup multiplexer-error ;
: epoll-read-task ( mx fd -- )
over mx-reads at* [ handle-io-task ] [ 2drop ] if ;
: epoll-write-task ( mx fd -- )
over mx-reads at* [ handle-io-task ] [ 2drop ] if ;
over mx-writes at* [ handle-io-task ] [ 2drop ] if ;
: handle-event ( mx kevent -- )
epoll-event-fd 2dup epoll-read-task epoll-write-task ;
: handle-events ( mx n -- )
[ over epoll-mx-events kevent-nth handle-kevent ] with each ;
[
over epoll-mx-events epoll-event-nth handle-event
] with each ;
M: epoll-mx wait-for-events ( ms mx -- )
dup rot wait-kevent handle-kevents ;
dup rot wait-event handle-events ;

View File

@ -4,13 +4,15 @@ USING: io.backend io.nonblocking io.unix.backend io.files io
unix kernel math continuations ;
IN: io.unix.files
: read-flags O_RDONLY ; inline
: open-read ( path -- fd )
O_RDONLY file-mode open dup io-error ;
M: unix-io <file-reader> ( path -- stream )
open-read <reader> ;
: write-flags O_WRONLY O_CREAT O_TRUNC bitor bitor ;
: write-flags O_WRONLY O_CREAT O_TRUNC bitor bitor ; inline
: open-write ( path -- fd )
write-flags file-mode open dup io-error ;
@ -18,7 +20,7 @@ M: unix-io <file-reader> ( path -- stream )
M: unix-io <file-writer> ( path -- stream )
open-write <writer> ;
: append-flags O_WRONLY O_APPEND O_CREAT bitor bitor ;
: append-flags O_WRONLY O_APPEND O_CREAT bitor bitor ; inline
: open-append ( path -- fd )
append-flags file-mode open dup io-error

24
extra/io/unix/kqueue/kqueue.factor Normal file → Executable file
View File

@ -2,10 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel io.nonblocking io.unix.backend
sequences assocs unix unix.kqueue unix.process math namespaces
combinators threads vectors ;
combinators threads vectors io.launcher io.unix.launcher ;
IN: io.unix.kqueue
TUPLE: kqueue-mx events processes ;
TUPLE: kqueue-mx events ;
: max-events ( -- n )
#! We read up to 256 events at a time. This is an arbitrary
@ -15,7 +15,6 @@ TUPLE: kqueue-mx events processes ;
: <kqueue-mx> ( -- mx )
kqueue-mx construct-mx
kqueue dup io-error over set-mx-fd
H{ } clone over set-kqueue-mx-processes
max-events "kevent" <c-array> over set-kqueue-mx-events ;
GENERIC: io-task-filter ( task -- n )
@ -51,16 +50,15 @@ M: kqueue-mx unregister-io-task ( task mx -- )
: kevent-write-task ( mx fd -- )
over mx-reads at handle-io-task ;
: kevent-proc-task ( mx pid -- )
dup (wait-for-pid) spin kqueue-mx-processes delete-at* [
[ schedule-thread-with ] with each
] [ 2drop ] if ;
: kevent-proc-task ( pid -- )
dup wait-for-pid swap find-process
dup [ notify-exit ] [ 2drop ] if ;
: handle-kevent ( mx kevent -- )
dup kevent-ident swap kevent-filter {
{ [ dup EVFILT_READ = ] [ drop kevent-read-task ] }
{ [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] }
{ [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] }
{ [ dup EVFILT_PROC = ] [ drop kevent-proc-task drop ] }
} cond ;
: handle-kevents ( mx n -- )
@ -76,11 +74,5 @@ M: kqueue-mx wait-for-events ( ms mx -- )
EVFILT_PROC over set-kevent-filter
NOTE_EXIT over set-kevent-fflags ;
: add-pid-task ( continuation pid mx -- )
2dup kqueue-mx-processes at* [
2nip push
] [
drop
over make-proc-kevent over register-kevent
>r >r 1vector r> r> kqueue-mx-processes set-at
] if ;
: add-pid-task ( pid mx -- )
swap make-proc-kevent swap register-kevent ;

View File

@ -1,18 +1,15 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.backend io.launcher io.unix.backend io.nonblocking
sequences kernel namespaces math system alien.c-types debugger
continuations arrays assocs combinators unix.process
parser-combinators memoize promises strings ;
USING: io io.backend io.launcher io.unix.backend io.unix.files
io.nonblocking sequences kernel namespaces math system
alien.c-types debugger continuations arrays assocs
combinators unix.process parser-combinators memoize
promises strings threads ;
IN: io.unix.launcher
! Search unix first
USE: unix
HOOK: wait-for-process io-backend ( pid -- status )
M: unix-io wait-for-process ( pid -- status ) wait-for-pid ;
! Our command line parser. Supported syntax:
! foo bar baz -- simple tokens
! foo\ bar -- escaping the space
@ -46,8 +43,25 @@ MEMO: 'arguments' ( -- parser )
: assoc>env ( assoc -- env )
[ "=" swap 3append ] { } assoc>map ;
: (spawn-process) ( -- )
: (redirect) ( path mode fd -- )
>r file-mode open dup io-error dup
r> dup2 io-error close ;
: redirect ( obj mode fd -- )
{
{ [ pick not ] [ 3drop ] }
{ [ pick +closed+ eq? ] [ close 2drop ] }
{ [ pick string? ] [ (redirect) ] }
} cond ;
: setup-redirection ( -- )
+stdin+ get read-flags 0 redirect
+stdout+ get write-flags 1 redirect
+stderr+ get write-flags 2 redirect ;
: spawn-process ( -- )
[
setup-redirection
get-arguments
pass-environment?
[ get-environment assoc>env exec-args-with-env ]
@ -55,20 +69,9 @@ MEMO: 'arguments' ( -- parser )
io-error
] [ error. :c flush ] recover 1 exit ;
: spawn-process ( -- pid )
[ (spawn-process) ] [ ] with-fork ;
: spawn-detached ( -- )
[ spawn-process 0 exit ] [ ] with-fork
wait-for-process drop ;
M: unix-io run-process* ( desc -- )
M: unix-io run-process* ( desc -- pid )
[
+detached+ get [
spawn-detached
] [
spawn-process wait-for-process drop
] if
[ spawn-process ] [ ] with-fork <process>
] with-descriptor ;
: open-pipe ( -- pair )
@ -82,21 +85,36 @@ M: unix-io run-process* ( desc -- )
: spawn-process-stream ( -- in out pid )
open-pipe open-pipe [
setup-stdio-pipe
(spawn-process)
spawn-process
] [
-rot 2dup second close first close
] with-fork first swap second rot ;
TUPLE: pipe-stream pid status ;
: <pipe-stream> ( in out pid -- stream )
f pipe-stream construct-boa
-rot handle>duplex-stream over set-delegate ;
M: pipe-stream stream-close
dup delegate stream-close
dup pipe-stream-pid wait-for-process
swap set-pipe-stream-status ;
] with-fork first swap second rot <process> ;
M: unix-io process-stream*
[ spawn-process-stream <pipe-stream> ] with-descriptor ;
[
spawn-process-stream >r handle>duplex-stream r>
] with-descriptor ;
: find-process ( handle -- process )
processes get swap [ nip swap process-handle = ] curry
assoc-find 2drop ;
! Inefficient process wait polling, used on Linux and Solaris.
! On BSD and Mac OS X, we use kqueue() which scales better.
: wait-for-processes ( -- ? )
-1 0 <int> tuck WNOHANG waitpid
dup 0 <= [
2drop t
] [
find-process dup [
>r *uint r> notify-exit f
] [
2drop f
] if
] if ;
: wait-loop ( -- )
wait-for-processes [ 250 sleep ] when wait-loop ;
: start-wait-thread ( -- )
[ wait-loop ] in-thread ;

12
extra/io/unix/linux/linux.factor Normal file → Executable file
View File

@ -1,17 +1,15 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.unix.linux
USING: io.unix.backend io.unix.select namespaces kernel assocs ;
USING: io.backend io.unix.backend io.unix.launcher io.unix.select
namespaces kernel assocs unix.process ;
TUPLE: linux-io ;
INSTANCE: linux-io unix-io
M: linux-io init-io ( -- )
start-wait-loop
<epoll-mx> mx set-global ;
<select-mx> mx set-global
start-wait-thread ;
M: linux-io wait-for-pid ( pid -- status )
[ kqueue-mx get-global add-pid-task stop ] curry callcc1 ;
T{ linux-io } io-backend set-global
T{ linux-io } set-io-backend

View File

@ -5,6 +5,6 @@ system vocabs.loader ;
{
{ [ bsd? ] [ "io.unix.bsd" ] }
{ [ macosx? ] [ "io.unix.bsd" ] }
{ [ linux? ] [ "io.unix.backend.linux" ] }
{ [ solaris? ] [ "io.unix.backend.solaris" ] }
{ [ linux? ] [ "io.unix.linux" ] }
{ [ solaris? ] [ "io.unix.solaris" ] }
} cond require

View File

@ -3,4 +3,4 @@ io.windows.ce.files io.windows.ce.sockets io.windows.ce.launcher
namespaces io.windows.mmap ;
IN: io.windows.ce
T{ windows-ce-io } io-backend set-global
T{ windows-ce-io } set-io-backend

View File

@ -1,9 +1,10 @@
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system ;
io.windows io.windows.pipes libc io.nonblocking
io.streams.duplex windows.types math windows.kernel32 windows
namespaces io.launcher kernel sequences windows.errors assocs
splitting system threads init strings combinators io.backend ;
IN: io.windows.launcher
TUPLE: CreateProcess-args
@ -19,24 +20,17 @@ TUPLE: CreateProcess-args
lpProcessInformation
stdout-pipe stdin-pipe ;
: dispose-CreateProcess-args ( args -- )
#! From MSDN: "Handles in PROCESS_INFORMATION must be closed
#! with CloseHandle when they are no longer needed."
CreateProcess-args-lpProcessInformation dup
PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when*
PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ;
: default-CreateProcess-args ( -- obj )
0
0
"STARTUPINFO" <c-object>
"STARTUPINFO" heap-size over set-STARTUPINFO-cb
"PROCESS_INFORMATION" <c-object>
TRUE
{
set-CreateProcess-args-bInheritHandles
set-CreateProcess-args-dwCreateFlags
set-CreateProcess-args-lpStartupInfo
set-CreateProcess-args-lpProcessInformation
set-CreateProcess-args-bInheritHandles
} \ CreateProcess-args construct ;
: call-CreateProcess ( CreateProcess-args -- )
@ -93,10 +87,58 @@ TUPLE: CreateProcess-args
over set-CreateProcess-args-lpEnvironment
] when ;
: wait-for-process ( args -- )
CreateProcess-args-lpProcessInformation
PROCESS_INFORMATION-hProcess INFINITE
WaitForSingleObject drop ;
: (redirect) ( path access-mode create-mode -- handle )
>r >r
normalize-pathname
r> ! access-mode
share-mode
security-attributes-inherit
r> ! create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file
CreateFile dup invalid-handle? dup close-later ;
: redirect ( obj access-mode create-mode -- handle )
{
{ [ pick not ] [ 3drop f ] }
{ [ pick +closed+ eq? ] [ 3drop t ] }
{ [ pick string? ] [ (redirect) ] }
} cond ;
: ?closed or dup t eq? [ drop f ] when ;
: inherited-stdout ( args -- handle )
CreateProcess-args-stdout-pipe
[ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
: redirect-stdout ( args -- handle )
+stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stdout ?closed ;
: inherited-stderr ( args -- handle )
drop STD_ERROR_HANDLE GetStdHandle ;
: redirect-stderr ( args -- handle )
+stderr+ get GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stderr ?closed ;
: inherited-stdin ( args -- handle )
CreateProcess-args-stdin-pipe
[ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
: redirect-stdin ( args -- handle )
+stdin+ get GENERIC_READ OPEN_EXISTING redirect
swap inherited-stdin ?closed ;
: fill-startup-info
dup CreateProcess-args-lpStartupInfo
STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
over redirect-stdout over set-STARTUPINFO-hStdOutput
over redirect-stderr over set-STARTUPINFO-hStdError
over redirect-stdin over set-STARTUPINFO-hStdInput
drop ;
: make-CreateProcess-args ( -- args )
default-CreateProcess-args
@ -104,10 +146,46 @@ TUPLE: CreateProcess-args
fill-dwCreateFlags
fill-lpEnvironment ;
M: windows-io run-process* ( desc -- )
M: windows-io run-process* ( desc -- handle )
[
make-CreateProcess-args
dup call-CreateProcess
+detached+ get [ dup wait-for-process ] unless
dispose-CreateProcess-args
] with-descriptor ;
[
make-CreateProcess-args fill-startup-info
dup call-CreateProcess
CreateProcess-args-lpProcessInformation <process>
] with-descriptor
] with-destructors ;
: dispose-process ( process-information -- )
#! From MSDN: "Handles in PROCESS_INFORMATION must be closed
#! with CloseHandle when they are no longer needed."
dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when*
PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ;
: exit-code ( process -- n )
PROCESS_INFORMATION-hProcess
0 <ulong> [ GetExitCodeProcess ] keep *ulong
swap win32-error=0/f ;
: process-exited ( process -- )
dup process-handle exit-code
over process-handle dispose-process
swap notify-exit ;
: wait-for-processes ( processes -- ? )
keys dup
[ process-handle PROCESS_INFORMATION-hProcess ] map
dup length swap >c-void*-array 0 0
WaitForMultipleObjects
dup HEX: ffffffff = [ win32-error ] when
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
: wait-loop ( -- )
processes get dup assoc-empty?
[ drop t ] [ wait-for-processes ] if
[ 250 sleep ] when
wait-loop ;
: start-wait-thread ( -- )
[ wait-loop ] in-thread ;
[ start-wait-thread ] "io.windows.launcher" add-init-hook

View File

@ -116,25 +116,27 @@ M: windows-nt-io add-completion ( handle -- )
: lookup-callback ( GetQueuedCompletion-args -- callback )
io-hash get-global delete-at* drop ;
: wait-for-io ( timeout -- continuation/f )
: handle-overlapped ( timeout -- ? )
wait-for-overlapped [
GetLastError dup expected-io-error? [
2drop f
2drop t
] [
dup eof? [
drop lookup-callback
dup io-callback-port t swap set-port-eof?
io-callback-continuation
] [
(win32-error-string) swap lookup-callback
[ io-callback-port set-port-error ] keep
io-callback-continuation
] if
] if io-callback-continuation schedule-thread f
] if
] [
lookup-callback io-callback-continuation
lookup-callback
io-callback-continuation schedule-thread f
] if ;
: drain-overlapped ( timeout -- )
handle-overlapped [ 0 drain-overlapped ] unless ;
: maybe-expire ( io-callbck -- )
io-callback-port
dup timeout? [
@ -144,10 +146,10 @@ M: windows-nt-io add-completion ( handle -- )
] if ;
: cancel-timeout ( -- )
io-hash get-global values [ maybe-expire ] each ;
io-hash get-global [ nip maybe-expire ] assoc-each ;
M: windows-nt-io io-multiplex ( ms -- )
cancel-timeout wait-for-io [ schedule-thread ] when* ;
cancel-timeout drain-overlapped ;
M: windows-nt-io init-io ( -- )
<master-completion-port> master-completion-port set-global

View File

@ -4,7 +4,7 @@ USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system
io.windows.launcher io.windows.nt.pipes ;
io.windows.launcher io.windows.pipes ;
IN: io.windows.nt.launcher
! The below code is based on the example given in
@ -30,22 +30,10 @@ IN: io.windows.nt.launcher
dup pipe-out f set-inherit
over set-CreateProcess-args-stdin-pipe ;
: fill-startup-info
dup CreateProcess-args-lpStartupInfo
STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
over CreateProcess-args-stdout-pipe
pipe-out over set-STARTUPINFO-hStdOutput
over CreateProcess-args-stdout-pipe
pipe-out over set-STARTUPINFO-hStdError
over CreateProcess-args-stdin-pipe
pipe-in swap set-STARTUPINFO-hStdInput ;
M: windows-io process-stream*
[
[
make-CreateProcess-args
TRUE over set-CreateProcess-args-bInheritHandles
fill-stdout-pipe
fill-stdin-pipe
@ -59,6 +47,6 @@ M: windows-io process-stream*
dup CreateProcess-args-stdout-pipe pipe-in
over CreateProcess-args-stdin-pipe pipe-out <win32-duplex-stream>
swap dispose-CreateProcess-args
swap CreateProcess-args-lpProcessInformation <process>
] with-destructors
] with-descriptor ;

View File

@ -9,4 +9,4 @@ USE: io.windows.mmap
USE: io.backend
USE: namespaces
T{ windows-nt-io } io-backend set-global
T{ windows-nt-io } set-io-backend

View File

@ -3,19 +3,11 @@
USING: alien alien.c-types arrays destructors io io.windows libc
windows.types math windows.kernel32 windows namespaces kernel
sequences windows.errors assocs math.parser system random ;
IN: io.windows.nt.pipes
IN: io.windows.pipes
! This code is based on
! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
: default-security-attributes ( -- obj )
"SECURITY_ATTRIBUTES" <c-object>
"SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ;
: security-attributes-inherit ( -- obj )
default-security-attributes
TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ; foldable
: create-named-pipe ( name mode -- handle )
FILE_FLAG_OVERLAPPED bitor
PIPE_TYPE_BYTE

View File

@ -4,7 +4,7 @@ USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.nonblocking io.sockets io.binary
io.sockets.impl windows.errors strings io.streams.duplex kernel
math namespaces sequences windows windows.kernel32
windows.shell32 windows.winsock splitting ;
windows.shell32 windows.types windows.winsock splitting ;
IN: io.windows
TUPLE: windows-nt-io ;
@ -34,6 +34,14 @@ M: windows-io normalize-directory ( string -- string )
FILE_SHARE_READ FILE_SHARE_WRITE bitor
FILE_SHARE_DELETE bitor ; foldable
: default-security-attributes ( -- obj )
"SECURITY_ATTRIBUTES" <c-object>
"SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ;
: security-attributes-inherit ( -- obj )
default-security-attributes
TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ; foldable
M: win32-file init-handle ( handle -- )
drop ;

View File

@ -4,6 +4,8 @@ IN: math.constants
ARTICLE: "math-constants" "Constants"
"Standard mathematical constants:"
{ $subsection e }
{ $subsection gamma }
{ $subsection phi }
{ $subsection pi }
"Various limits:"
{ $subsection most-positive-fixnum }
@ -15,6 +17,13 @@ ABOUT: "math-constants"
HELP: e
{ $values { "e" "base of natural logarithm" } } ;
HELP: gamma
{ $values { "gamma" "Euler-Mascheroni constant" } }
{ $description "The Euler-Mascheroni constant, also called \"Euler's constant\" or \"the Euler constant\"." } ;
HELP: phi
{ $values { "phi" "golden ratio" } } ;
HELP: pi
{ $values { "pi" "circumference of circle with diameter 1" } } ;

View File

@ -3,5 +3,7 @@
IN: math.constants
: e ( -- e ) 2.7182818284590452354 ; inline
: gamma ( -- gamma ) 0.57721566490153286060 ; inline
: pi ( -- pi ) 3.14159265358979323846 ; inline
: phi ( -- phi ) 1.61803398874989484820 ; inline
: epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline

View File

@ -1,4 +1,5 @@
USING: math.miller-rabin kernel math namespaces tools.test ;
USING: math.miller-rabin tools.test ;
IN: temporary
[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
[ t ] [ 2 miller-rabin ] unit-test
@ -7,4 +8,3 @@ USING: math.miller-rabin kernel math namespaces tools.test ;
[ t ] [ 37 miller-rabin ] unit-test
[ 101 ] [ 100 next-prime ] unit-test
[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test

View File

@ -0,0 +1 @@
Miller-Rabin probabilistic primality test

View File

@ -12,10 +12,10 @@ IN: math.text.english
"Seventeen" "Eighteen" "Nineteen" } nth ;
: tens ( n -- str )
{ "" "" "Twenty" "Thirty" "Forty" "Fifty" "Sixty" "Seventy" "Eighty" "Ninety" } nth ;
{ f f "Twenty" "Thirty" "Forty" "Fifty" "Sixty" "Seventy" "Eighty" "Ninety" } nth ;
: scale-numbers ( n -- str ) ! up to 10^99
{ "" "Thousand" "Million" "Billion" "Trillion" "Quadrillion" "Quintillion"
{ f "Thousand" "Million" "Billion" "Trillion" "Quadrillion" "Quintillion"
"Sextillion" "Septillion" "Octillion" "Nonillion" "Decillion" "Undecillion"
"Duodecillion" "Tredecillion" "Quattuordecillion" "Quindecillion"
"Sexdecillion" "Septendecillion" "Octodecillion" "Novemdecillion"
@ -45,7 +45,7 @@ SYMBOL: and-needed?
: tens-place ( n -- str )
100 mod dup 20 >= [
10 /mod >r tens r>
10 /mod [ tens ] dip
dup zero? [ drop ] [ "-" swap small-numbers 3append ] if
] [
dup zero? [ drop "" ] [ small-numbers ] if
@ -97,3 +97,4 @@ PRIVATE>
] [
[ (number>text) ] with-scope
] if ;

View File

@ -0,0 +1 @@
Convert integers to text in multiple languages

View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Aaron Schaefer.
! Copyright (c) 2007 Aaron Schaefer, Alexander Solovyov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences ;
USING: kernel math sequences shuffle ;
IN: project-euler.002
! http://projecteuler.net/index.php?section=problems&id=2
@ -22,12 +22,12 @@ IN: project-euler.002
<PRIVATE
: (fib-upto) ( seq n limit -- seq )
2dup <= [ >r add dup 2 tail* sum r> (fib-upto) ] [ 2drop ] if ;
2dup <= [ [ over push dup 2 tail* sum ] dip (fib-upto) ] [ 2drop ] if ;
PRIVATE>
: fib-upto ( n -- seq )
{ 0 } 1 rot (fib-upto) ;
V{ 0 } clone 1 rot (fib-upto) ;
: euler002 ( -- answer )
1000000 fib-upto [ even? ] subset sum ;
@ -35,4 +35,18 @@ PRIVATE>
! [ euler002 ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
MAIN: euler002
! ALTERNATE SOLUTIONS
! -------------------
: fib-upto* ( n -- seq )
0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip
1 head-slice* { 0 1 } swap append ;
: euler002a ( -- answer )
1000000 fib-upto* [ even? ] subset sum ;
! [ euler002a ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
MAIN: euler002a

View File

@ -1,4 +1,4 @@
! Copyright (c) 2007 Aaron Schaefer.
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math math.ranges project-euler.common sequences
sorting ;

View File

@ -1,4 +1,4 @@
! Copyright (c) 2007 Aaron Schaefer.
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser math.ranges namespaces sequences ;
IN: project-euler.024

View File

@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel math math.functions math.parser math.ranges memoize
project-euler.common sequences ;
USING: alien.syntax kernel math math.constants math.functions math.parser
math.ranges memoize project-euler.common sequences ;
IN: project-euler.025
! http://projecteuler.net/index.php?section=problems&id=25
@ -67,9 +67,6 @@ PRIVATE>
<PRIVATE
: phi ( -- phi )
5 sqrt 1+ 2 / ;
: digit-fib* ( n -- term )
1- 5 log10 2 / + phi log10 / ceiling >integer ;

View File

@ -1,4 +1,4 @@
! Copyright (c) 2007 Aaron Schaefer.
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.primes math.ranges sequences ;
IN: project-euler.026

View File

@ -1,4 +1,4 @@
! Copyright (c) 2007 Aaron Schaefer.
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.primes project-euler.common sequences ;
IN: project-euler.027

View File

@ -1,4 +1,4 @@
! Copyright (c) 2007 Aaron Schaefer.
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.ranges ;
IN: project-euler.028

View File

@ -1,4 +1,4 @@
! Copyright (c) 2007 Aaron Schaefer.
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math.functions math.ranges project-euler.common
sequences ;

View File

@ -0,0 +1,46 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.functions project-euler.common sequences ;
IN: project-euler.030
! http://projecteuler.net/index.php?section=problems&id=30
! DESCRIPTION
! -----------
! Surprisingly there are only three numbers that can be written as the sum of
! fourth powers of their digits:
! 1634 = 1^4 + 6^4 + 3^4 + 4^4
! 8208 = 8^4 + 2^4 + 0^4 + 8^4
! 9474 = 9^4 + 4^4 + 7^4 + 4^4
! As 1 = 1^4 is not a sum it is not included.
! The sum of these numbers is 1634 + 8208 + 9474 = 19316.
! Find the sum of all the numbers that can be written as the sum of fifth
! powers of their digits.
! SOLUTION
! --------
! if n is the number of digits
! n * 9^5 = 10^n when n ≈ 5.513
! 10^5.513 ≈ 325537
<PRIVATE
: sum-fifth-powers ( n -- sum )
number>digits [ 5 ^ ] sigma ;
PRIVATE>
: euler030 ( -- answer )
325537 [ dup sum-fifth-powers = ] subset sum 1- ;
! [ euler030 ] 100 ave-time
! 2537 ms run / 125 ms GC ave time - 100 trials
MAIN: euler030

View File

@ -0,0 +1,63 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math ;
IN: project-euler.031
! http://projecteuler.net/index.php?section=problems&id=31
! DESCRIPTION
! -----------
! In England the currency is made up of pound, £, and pence, p, and there are
! eight coins in general circulation:
! 1p, 2p, 5p, 10p, 20p, 50p, £1 (100p) and £2 (200p).
! It is possible to make £2 in the following way:
! 1×£1 + 1×50p + 2×20p + 1×5p + 1×2p + 3×1p
! How many different ways can £2 be made using any number of coins?
! SOLUTION
! --------
<PRIVATE
: 1p ( m -- n )
drop 1 ;
: 2p ( m -- n )
dup 0 >= [ [ 2 - 2p ] keep 1p + ] [ drop 0 ] if ;
: 5p ( m -- n )
dup 0 >= [ [ 5 - 5p ] keep 2p + ] [ drop 0 ] if ;
: 10p ( m -- n )
dup 0 >= [ [ 10 - 10p ] keep 5p + ] [ drop 0 ] if ;
: 20p ( m -- n )
dup 0 >= [ [ 20 - 20p ] keep 10p + ] [ drop 0 ] if ;
: 50p ( m -- n )
dup 0 >= [ [ 50 - 50p ] keep 20p + ] [ drop 0 ] if ;
: 100p ( m -- n )
dup 0 >= [ [ 100 - 100p ] keep 50p + ] [ drop 0 ] if ;
: 200p ( m -- n )
dup 0 >= [ [ 200 - 200p ] keep 100p + ] [ drop 0 ] if ;
PRIVATE>
: euler031 ( -- answer )
200 200p ;
! [ euler031 ] 100 ave-time
! 4 ms run / 0 ms GC ave time - 100 trials
! TODO: generalize to eliminate duplication; use a sequence to specify denominations?
MAIN: euler031

View File

@ -0,0 +1,81 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib hashtables kernel math math.combinatorics math.parser
math.ranges project-euler.common project-euler.024 sequences sorting ;
IN: project-euler.032
! http://projecteuler.net/index.php?section=problems&id=32
! DESCRIPTION
! -----------
! The product 7254 is unusual, as the identity, 39 × 186 = 7254, containing
! multiplicand, multiplier, and product is 1 through 9 pandigital.
! Find the sum of all products whose multiplicand/multiplier/product identity
! can be written as a 1 through 9 pandigital.
! HINT: Some products can be obtained in more than one way so be sure to only
! include it once in your sum.
! SOLUTION
! --------
! Generate all pandigital numbers and then check if they fit the identity
<PRIVATE
: source-032 ( -- seq )
9 factorial [ 9 permutation [ 1+ ] map 10 swap digits>integer ] map ;
: 1and4 ( n -- ? )
number>string 1 cut-slice 4 cut-slice
[ 10 string>integer ] 3apply [ * ] dip = ;
: 2and3 ( n -- ? )
number>string 2 cut-slice 3 cut-slice
[ 10 string>integer ] 3apply [ * ] dip = ;
: valid? ( n -- ? )
dup 1and4 swap 2and3 or ;
: products ( seq -- m )
[ number>string 4 tail* 10 string>integer ] map ;
PRIVATE>
: euler032 ( -- answer )
source-032 [ valid? ] subset products prune sum ;
! [ euler032 ] 10 ave-time
! 27609 ms run / 2484 ms GC ave time - 10 trials
! ALTERNATE SOLUTIONS
! -------------------
! Generate all reasonable multiplicand/multiplier pairs, then multiply and see
! if the equation is pandigital
<PRIVATE
: source-032a ( -- seq )
50 [1,b] 2000 [1,b] cartesian-product ;
: pandigital? ( n -- ? )
number>string natural-sort "123456789" = ;
! multiplicand/multiplier/product
: mmp ( pair -- n )
first2 2dup * [ number>string ] 3apply 3append 10 string>integer ;
PRIVATE>
: euler032a ( -- answer )
source-032a [ mmp ] map [ pandigital? ] subset products prune sum ;
! [ euler032a ] 100 ave-time
! 5978 ms run / 327 ms GC ave time - 100 trials
MAIN: euler032a

View File

@ -11,7 +11,7 @@ IN: project-euler.common
! collect-consecutive - #8, #11
! log10 - #25, #134
! max-path - #18, #67
! number>digits - #16, #20
! number>digits - #16, #20, #30
! propagate-all - #18, #67
! sum-proper-divisors - #21
! tau* - #12

View File

@ -9,8 +9,8 @@ USING: definitions io io.files kernel math.parser sequences vocabs
project-euler.017 project-euler.018 project-euler.019 project-euler.020
project-euler.021 project-euler.022 project-euler.023 project-euler.024
project-euler.025 project-euler.026 project-euler.027 project-euler.028
project-euler.029 project-euler.067 project-euler.134 project-euler.169
project-euler.173 project-euler.175 ;
project-euler.029 project-euler.030 project-euler.067 project-euler.134
project-euler.169 project-euler.173 project-euler.175 ;
IN: project-euler
<PRIVATE

View File

@ -8,10 +8,10 @@ QUALIFIED: unix
IN: tools.deploy.macosx
: touch ( path -- )
{ "touch" } swap add run-process ;
{ "touch" } swap add run-process drop ;
: rm ( path -- )
{ "rm" "-rf" } swap add run-process ;
{ "rm" "-rf" } swap add run-process drop ;
: bundle-dir ( -- dir )
vm parent-directory parent-directory ;

View File

@ -6,7 +6,7 @@ ARTICLE: "tools.test" "Unit testing"
$nl
"For example, if you were developing a word for computing symbolic derivatives, your unit tests would apply the word to certain input functions, comparing the results against the correct values. While the passing of these tests would not guarantee the algorithm is correct, it would at least ensure that what used to work keeps working, in that as soon as something breaks due to a change in another part of your program, failing tests will let you know."
$nl
"Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } " -tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details."
"Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } "-tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details."
$nl
"If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run. Test harness files consist mostly of calls to the following two words:"
{ $subsection unit-test }

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: unix.linux.epoll
USING: alien.syntax ;
USING: alien.syntax math ;
FUNCTION: int epoll_create ( int size ) ;
@ -9,7 +9,8 @@ FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll_event* event ) ;
C-STRUCT: epoll-event
{ "uint" "events" }
{ "uint" "fd" } ;
{ "uint" "fd" }
{ "uint" "padding" } ;
FUNCTION: int epoll_wait ( int epfd, epoll_event* events, int maxevents, int timeout ) ;

22
extra/unix/process/process.factor Normal file → Executable file
View File

@ -31,25 +31,5 @@ IN: unix.process
: with-fork ( child parent -- )
fork dup zero? -roll swap curry if ; inline
! Lame polling strategy for getting process exit codes. On
! BSD, we use kqueue which is more efficient.
SYMBOL: pid-wait
: (wait-for-pid) ( pid -- status )
0 <int> [ 0 waitpid drop ] keep *int ;
: wait-for-pid ( pid -- status )
[ pid-wait get-global [ ?push ] change-at stop ] curry
callcc1 ;
: wait-loop ( -- )
-1 0 <int> tuck WNOHANG waitpid ! &status return
[ *int ] [ pid-wait get delete-at* drop ] bi* ! status ?
[ schedule-thread-with ] with each
250 sleep
wait-loop ;
: start-wait-loop ( -- )
H{ } clone pid-wait set-global
[ wait-loop ] in-thread ;
0 <int> [ 0 waitpid drop ] keep *int ;

View File

@ -13,7 +13,7 @@ TYPEDEF: longlong quad_t
TYPEDEF: uint gid_t
TYPEDEF: uint in_addr_t
TYPEDEF: uint ino_t
TYPEDEF: uint pid_t
TYPEDEF: int pid_t
TYPEDEF: uint socklen_t
TYPEDEF: uint time_t
TYPEDEF: uint uid_t

View File

@ -898,7 +898,7 @@ FUNCTION: HANDLE GetCurrentThread ( ) ;
! FUNCTION: GetEnvironmentStringsW
! FUNCTION: GetEnvironmentVariableA
! FUNCTION: GetEnvironmentVariableW
! FUNCTION: GetExitCodeProcess
FUNCTION: BOOL GetExitCodeProcess ( HANDLE hProcess, LPDWORD lpExitCode ) ;
! FUNCTION: GetExitCodeThread
! FUNCTION: GetExpandedNameA
! FUNCTION: GetExpandedNameW
@ -1496,7 +1496,7 @@ FUNCTION: BOOL VirtualQueryEx ( HANDLE hProcess, void* lpAddress, MEMORY_BASIC_I
! FUNCTION: VirtualUnlock
! FUNCTION: WaitCommEvent
! FUNCTION: WaitForDebugEvent
! FUNCTION: WaitForMultipleObjects
FUNCTION: DWORD WaitForMultipleObjects ( DWORD nCount, HANDLE* lpHandles, BOOL bWaitAll, DWORD dwMilliseconds ) ;
! FUNCTION: WaitForMultipleObjectsEx
FUNCTION: BOOL WaitForSingleObject ( HANDLE hHandle, DWORD dwMilliseconds ) ;
! FUNCTION: WaitForSingleObjectEx

39
extra/windows/time/time.factor Executable file
View File

@ -0,0 +1,39 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types kernel math windows windows.kernel32
namespaces calendar.backend ;
IN: windows.time
: >64bit ( lo hi -- n )
32 shift bitor ;
: windows-1601 ( -- timestamp )
1601 1 1 0 0 0 0 <timestamp> ;
: FILETIME>windows-time ( FILETIME -- n )
[ FILETIME-dwLowDateTime ] keep
FILETIME-dwHighDateTime >64bit ;
: windows-time>timestamp ( n -- timestamp )
10000000 /i seconds windows-1601 swap +dt ;
: windows-time ( -- n )
"FILETIME" <c-object> [ GetSystemTimeAsFileTime ] keep
FILETIME>windows-time ;
: timestamp>windows-time ( timestamp -- n )
#! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC)
>gmt windows-1601 timestamp- >bignum 10000000 * ;
: windows-time>FILETIME ( n -- FILETIME )
"FILETIME" <c-object>
[
[ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep
>r -32 shift r> set-FILETIME-dwHighDateTime
] keep ;
: timestamp>FILETIME ( timestamp -- FILETIME/f )
[ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ;
: FILETIME>timestamp ( FILETIME -- timestamp/f )
FILETIME>windows-time windows-time>timestamp ;