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,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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
"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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -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