Merge branch 'master' into jamshred
Alex Chapman
commit
ba4143e43c
|
|
@ -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 )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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." }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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? [
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -10,6 +10,3 @@ IN: bootstrap.io
|
|||
{ [ wince? ] [ "windows.ce" ] }
|
||||
} cond append require
|
||||
] when
|
||||
|
||||
init-io
|
||||
init-stdio
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,13 +1,12 @@
|
|||
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
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -20,9 +19,7 @@ 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 * ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[
|
||||
prepare-resolve-host
|
||||
"addrinfo" <c-object>
|
||||
r> [ AI_PASSIVE over set-addrinfo-flags ] when
|
||||
[ 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 ;
|
||||
freeaddrinfo
|
||||
] with-scope ;
|
||||
|
||||
M: object host-name ( -- name )
|
||||
256 <byte-array> dup dup length gethostname
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[
|
||||
make-CreateProcess-args fill-startup-info
|
||||
dup call-CreateProcess
|
||||
+detached+ get [ dup wait-for-process ] unless
|
||||
dispose-CreateProcess-args
|
||||
] with-descriptor ;
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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" } } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Miller-Rabin probabilistic primality test
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Convert integers to text in multiple languages
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
Loading…
Reference in New Issue