Merge git://factorcode.org/git/factor
Joe Groff
commit
c28f6ee6ff
|
|
@ -1,5 +1,6 @@
|
|||
USING: alien alien.c-types alien.structs alien.syntax
|
||||
alien.syntax.private help.markup help.syntax ;
|
||||
IN: alien.syntax
|
||||
USING: alien alien.c-types alien.structs alien.syntax.private
|
||||
help.markup help.syntax ;
|
||||
|
||||
HELP: DLL"
|
||||
{ $syntax "DLL\" path\"" }
|
||||
|
|
|
|||
|
|
@ -48,7 +48,11 @@ IN: bootstrap.stage2
|
|||
|
||||
"Compiling remaining words..." print flush
|
||||
|
||||
all-words [ compiled? not ] subset recompile-hook get call
|
||||
"bootstrap.compiler" vocab [
|
||||
vocabs [
|
||||
words "compile" "compiler" lookup execute
|
||||
] each
|
||||
] when
|
||||
] with-compiler-errors
|
||||
|
||||
f error set-global
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -205,3 +205,36 @@ DEFER: generic-then-not-generic-test-2
|
|||
[ ] [ "IN: temporary USE: math : generic-then-not-generic-test-1 1 + ;" eval ] unit-test
|
||||
|
||||
[ 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
|
||||
|
||||
[ 4 ] [ foldable-test-2 ] unit-test
|
||||
|
||||
DEFER: flushable-test-2
|
||||
|
||||
[ ] [ "IN: temporary USE: kernel : flushable-test-1 drop 3 ; flushable" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USE: kernel : flushable-test-2 V{ } dup flushable-test-1 drop ;" eval ] unit-test
|
||||
|
||||
[ V{ } ] [ flushable-test-2 ] unit-test
|
||||
|
||||
[ ] [ "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
|
||||
|
|
|
|||
|
|
@ -51,14 +51,8 @@ HOOK: %save-dispatch-xt compiler-backend ( -- )
|
|||
|
||||
M: object %save-dispatch-xt %save-word-xt ;
|
||||
|
||||
! Call C primitive
|
||||
HOOK: %call-primitive compiler-backend ( label -- )
|
||||
|
||||
! Call another label
|
||||
HOOK: %call-label compiler-backend ( label -- )
|
||||
|
||||
! Far jump to C primitive
|
||||
HOOK: %jump-primitive compiler-backend ( label -- )
|
||||
! Call another word
|
||||
HOOK: %call compiler-backend ( word -- )
|
||||
|
||||
! Local jump for branches
|
||||
HOOK: %jump-label compiler-backend ( label -- )
|
||||
|
|
|
|||
|
|
@ -97,26 +97,14 @@ M: ppc-backend %epilogue ( n -- )
|
|||
1 1 rot ADDI
|
||||
0 MTLR ;
|
||||
|
||||
: %prepare-primitive ( word -- )
|
||||
#! Save stack pointer to stack_chain->callstack_top, load XT
|
||||
4 1 MR
|
||||
0 11 LOAD32
|
||||
rc-absolute-ppc-2/2 rel-primitive ;
|
||||
|
||||
: (%call) 11 MTLR BLRL ;
|
||||
|
||||
M: ppc-backend %call-primitive ( word -- )
|
||||
%prepare-primitive (%call) ;
|
||||
|
||||
: (%jump) 11 MTCTR BCTR ;
|
||||
|
||||
M: ppc-backend %jump-primitive ( word -- )
|
||||
%prepare-primitive (%jump) ;
|
||||
|
||||
: %load-dlsym ( symbol dll register -- )
|
||||
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
|
||||
M: ppc-backend %call-label ( label -- ) BL ;
|
||||
M: ppc-backend %call ( label -- ) BL ;
|
||||
|
||||
M: ppc-backend %jump-label ( label -- ) B ;
|
||||
|
||||
|
|
|
|||
|
|
@ -70,15 +70,7 @@ M: x86-backend %prepare-alien-invoke
|
|||
temp-reg v>operand 2 cells [+] ds-reg MOV
|
||||
temp-reg v>operand 3 cells [+] rs-reg MOV ;
|
||||
|
||||
M: x86-backend %call-primitive ( word -- )
|
||||
stack-save-reg stack-reg cell neg [+] LEA
|
||||
address-operand CALL ;
|
||||
|
||||
M: x86-backend %jump-primitive ( word -- )
|
||||
stack-save-reg stack-reg MOV
|
||||
address-operand JMP ;
|
||||
|
||||
M: x86-backend %call-label ( label -- ) CALL ;
|
||||
M: x86-backend %call ( label -- ) CALL ;
|
||||
|
||||
M: x86-backend %jump-label ( label -- ) JMP ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -100,21 +100,10 @@ UNION: #terminal
|
|||
! node
|
||||
M: node generate-node drop iterate-next ;
|
||||
|
||||
: %call ( word -- )
|
||||
dup primitive? [ %call-primitive ] [ %call-label ] if ;
|
||||
|
||||
: %jump ( word -- )
|
||||
{
|
||||
{ [ dup compiling-label get eq? ] [
|
||||
drop current-label-start get %jump-label
|
||||
] }
|
||||
{ [ dup primitive? ] [
|
||||
%epilogue-later %jump-primitive
|
||||
] }
|
||||
{ [ t ] [
|
||||
%epilogue-later %jump-label
|
||||
] }
|
||||
} cond ;
|
||||
dup compiling-label get eq?
|
||||
[ drop current-label-start get ] [ %epilogue-later ] if
|
||||
%jump-label ;
|
||||
|
||||
: generate-call ( label -- next )
|
||||
dup maybe-compile
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: temporary
|
||||
USING: sequences inference.transforms tools.test math kernel
|
||||
quotations ;
|
||||
quotations tools.test.inference ;
|
||||
|
||||
: compose-n-quot <repetition> >quotation ;
|
||||
: compose-n compose-n-quot call ;
|
||||
|
|
@ -18,3 +18,5 @@ quotations ;
|
|||
[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test
|
||||
|
||||
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
|
||||
|
||||
\ construct-empty must-infer
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel words sequences generic math namespaces
|
||||
quotations assocs combinators math.bitfields inference.backend
|
||||
inference.dataflow inference.state tuples.private ;
|
||||
inference.dataflow inference.state tuples.private effects ;
|
||||
IN: inference.transforms
|
||||
|
||||
: pop-literals ( n -- rstate seq )
|
||||
|
|
@ -61,11 +61,21 @@ M: pair (bitfield-quot) ( spec -- quot )
|
|||
|
||||
\ set-slots [ <reversed> [get-slots] ] 1 define-transform
|
||||
|
||||
: [construct] ( word quot -- newquot )
|
||||
>r dup +inlined+ depends-on dup tuple-size r> 2curry ;
|
||||
\ construct-boa [
|
||||
dup +inlined+ depends-on
|
||||
dup tuple-size [ <tuple-boa> ] 2curry
|
||||
] 1 define-transform
|
||||
|
||||
\ construct-boa
|
||||
[ [ <tuple-boa> ] [construct] ] 1 define-transform
|
||||
\ construct-empty [
|
||||
1 ensure-values
|
||||
peek-d value? [
|
||||
pop-literal
|
||||
dup +inlined+ depends-on
|
||||
dup tuple-size [ <tuple> ] 2curry
|
||||
swap infer-quot
|
||||
] [
|
||||
\ construct-empty 1 1 <effect> make-call-node
|
||||
] if
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ construct-empty
|
||||
[ [ <tuple> ] [construct] ] 1 define-transform
|
||||
\ construct-empty 1 1 <effect> "inferred-effect" 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." }
|
||||
|
|
|
|||
|
|
@ -35,7 +35,8 @@ GENERIC: stream-write-table ( table-cells style stream -- )
|
|||
! Default stream
|
||||
SYMBOL: stdio
|
||||
|
||||
: close ( -- ) stdio get stream-close ;
|
||||
! Default error stream
|
||||
SYMBOL: stderr
|
||||
|
||||
: readln ( -- str/f ) stdio get stream-readln ;
|
||||
: read1 ( -- ch/f ) stdio get stream-read1 ;
|
||||
|
|
@ -53,7 +54,9 @@ SYMBOL: stdio
|
|||
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
|
||||
|
|
|
|||
|
|
@ -14,9 +14,10 @@ ARTICLE: "io.streams.c" "ANSI C streams"
|
|||
{ $subsection fclose }
|
||||
{ $subsection fgetc }
|
||||
{ $subsection fread }
|
||||
"Two standard file handles:"
|
||||
{ $subsection stdin }
|
||||
{ $subsection stdout } ;
|
||||
"The three standard file handles:"
|
||||
{ $subsection stdin-handle }
|
||||
{ $subsection stdout-handle }
|
||||
{ $subsection stderr-handle } ;
|
||||
|
||||
ABOUT: "io.streams.c"
|
||||
|
||||
|
|
@ -64,10 +65,14 @@ HELP: fread ( n alien -- str/f )
|
|||
{ $description "Reads a sequence of characters from a C FILE* handle, and outputs " { $link f } " on end of file." }
|
||||
{ $errors "Throws an error if the input operation failed." } ;
|
||||
|
||||
HELP: stdin
|
||||
HELP: stdin-handle
|
||||
{ $values { "in" "a C FILE* handle" } }
|
||||
{ $description "Outputs the console standard input file handle." } ;
|
||||
|
||||
HELP: stdout
|
||||
HELP: stdout-handle
|
||||
{ $values { "out" "a C FILE* handle" } }
|
||||
{ $description "Outputs the console standard output file handle." } ;
|
||||
|
||||
HELP: stderr-handle
|
||||
{ $values { "out" "a C FILE* handle" } }
|
||||
{ $description "Outputs the console standard error file handle." } ;
|
||||
|
|
|
|||
|
|
@ -56,12 +56,13 @@ M: c-reader stream-close
|
|||
|
||||
M: object init-io ;
|
||||
|
||||
: stdin 11 getenv ;
|
||||
|
||||
: stdout 12 getenv ;
|
||||
: stdin-handle 11 getenv ;
|
||||
: stdout-handle 12 getenv ;
|
||||
: stderr-handle 38 getenv ;
|
||||
|
||||
M: object init-stdio
|
||||
stdin stdout <duplex-c-stream> stdio set-global ;
|
||||
stdin-handle stdout-handle <duplex-c-stream> stdio set-global
|
||||
stderr-handle <c-writer> <plain-writer> stderr set-global ;
|
||||
|
||||
M: object io-multiplex (sleep) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ ARTICLE: "basic-combinators" "Basic combinators"
|
|||
{ $subsection execute }
|
||||
"These words are used to implement " { $emphasis "combinators" } ", which are words that take code from the stack. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:"
|
||||
{ $code
|
||||
": keep ( x quot -- x | quot: x -- )"
|
||||
": keep ( x quot -- x )"
|
||||
" over >r call r> ; inline"
|
||||
}
|
||||
"Word inlining is documented in " { $link "declarations" } "."
|
||||
|
|
@ -557,7 +557,7 @@ HELP: dip
|
|||
|
||||
HELP: while
|
||||
{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
|
||||
{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "quot" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
|
||||
{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "body" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
|
||||
{ $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used."
|
||||
$nl
|
||||
"Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:"
|
||||
|
|
|
|||
|
|
@ -209,7 +209,7 @@ HELP: bitxor
|
|||
|
||||
HELP: shift
|
||||
{ $values { "x" integer } { "n" integer } { "y" integer } }
|
||||
{ $description "Shifts " { $snippet "x" } " to the left by " { $snippet "y" } " bits if " { $snippet "y" } " is positive, or " { $snippet "-y" } " bits to the right if " { $snippet "y" } " is negative. A left shift of a fixnum may overflow, yielding a bignum. A right shift may result in bits ``falling off'' the right hand side and being discarded." }
|
||||
{ $description "Shifts " { $snippet "x" } " to the left by " { $snippet "n" } " bits if " { $snippet "n" } " is positive, or " { $snippet "-n" } " bits to the right if " { $snippet "n" } " is negative. A left shift of a fixnum may overflow, yielding a bignum. A right shift may result in bits ``falling off'' the right hand side and being discarded." }
|
||||
{ $examples { $example "BIN: 101 5 shift .b" "10100000" } { $example "BIN: 11111 -2 shift .b" "111" } } ;
|
||||
|
||||
HELP: bitnot
|
||||
|
|
|
|||
|
|
@ -15,16 +15,16 @@ IN: namespaces
|
|||
PRIVATE>
|
||||
|
||||
: namespace ( -- namespace ) namestack* peek ;
|
||||
: namestack ( -- namestack ) namestack* clone ; inline
|
||||
: set-namestack ( namestack -- ) >vector 0 setenv ; inline
|
||||
: namestack ( -- namestack ) namestack* clone ;
|
||||
: set-namestack ( namestack -- ) >vector 0 setenv ;
|
||||
: global ( -- g ) 21 getenv { hashtable } declare ; inline
|
||||
: init-namespaces ( -- ) global 1array set-namestack ;
|
||||
: get ( variable -- value ) namestack* assoc-stack ; flushable
|
||||
: set ( value variable -- ) namespace set-at ;
|
||||
: on ( variable -- ) t swap set ; inline
|
||||
: off ( variable -- ) f swap set ; inline
|
||||
: get-global ( variable -- value ) global at ; inline
|
||||
: set-global ( value variable -- ) global set-at ; inline
|
||||
: get-global ( variable -- value ) global at ;
|
||||
: set-global ( value variable -- ) global set-at ;
|
||||
|
||||
: change ( variable quot -- )
|
||||
>r dup get r> rot slip set ; inline
|
||||
|
|
|
|||
|
|
@ -17,17 +17,17 @@ SYMBOL: optimizer-changed
|
|||
|
||||
GENERIC: optimize-node* ( node -- node/t changed? )
|
||||
|
||||
: ?union ( hash/f hash -- hash )
|
||||
: ?union ( assoc/f assoc -- hash )
|
||||
over [ union ] [ nip ] if ;
|
||||
|
||||
: add-node-literals ( hash node -- )
|
||||
: add-node-literals ( assoc node -- )
|
||||
over assoc-empty? [
|
||||
2drop
|
||||
] [
|
||||
[ node-literals ?union ] keep set-node-literals
|
||||
] if ;
|
||||
|
||||
: add-node-classes ( hash node -- )
|
||||
: add-node-classes ( assoc node -- )
|
||||
over assoc-empty? [
|
||||
2drop
|
||||
] [
|
||||
|
|
@ -324,6 +324,7 @@ M: #dispatch optimize-node*
|
|||
] if ;
|
||||
|
||||
: flush-eval ( #call -- node )
|
||||
dup node-param +inlined+ depends-on
|
||||
dup node-out-d length f <repetition> inline-literals ;
|
||||
|
||||
: partial-eval? ( #call -- ? )
|
||||
|
|
@ -337,9 +338,9 @@ M: #dispatch optimize-node*
|
|||
dup node-in-d [ node-literal ] with map ;
|
||||
|
||||
: partial-eval ( #call -- node )
|
||||
dup node-param +inlined+ depends-on
|
||||
dup literal-in-d over node-param 1quotation
|
||||
[ with-datastack ] catch
|
||||
[ 3drop t ] [ inline-literals ] if ;
|
||||
[ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
|
||||
|
||||
: define-identities ( words identities -- )
|
||||
[ "identities" set-word-prop ] curry each ;
|
||||
|
|
|
|||
|
|
@ -44,8 +44,7 @@ ARTICLE: "vocabulary-search-errors" "Word lookup errors"
|
|||
"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies. Then, one of three things happen:"
|
||||
{ $list
|
||||
{ "If there are no words having this name at all, an error is thrown and parsing stops." }
|
||||
{ "If there is exactly one vocabulary having a word with this name, the vocabulary is automatically added to the search path. This behavior is intended for interactive use and exploratory programming only, and production code should contain full " { $link POSTPONE: USING: } " declarations." }
|
||||
{ "If there is more than one vocabulary which contains a word with this name, a restartable error is thrown, with a restart for each vocabulary in question. The restarts add the vocabulary to the search path and continue parsing." }
|
||||
{ "If there are vocabularies which contain words with this name, a restartable error is thrown, with a restart for each vocabulary in question. The restarts add the vocabulary to the search path and continue parsing." }
|
||||
}
|
||||
"When writing a new vocabulary, one approach is to ignore " { $link POSTPONE: USING: } " declarations altogether, then to load the vocabulary and observe any parser notes and restarts and use this information to write the correct " { $link POSTPONE: USING: } " declaration." ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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? [
|
||||
|
|
|
|||
|
|
@ -175,3 +175,14 @@ SYMBOL: quot-uses-b
|
|||
|
||||
[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test
|
||||
[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test
|
||||
|
||||
! Regressions
|
||||
[ ] [ "IN: temporary : decl-forget-test ; foldable" eval ] unit-test
|
||||
[ t ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test
|
||||
[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test
|
||||
[ f ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : decl-forget-test ; flushable" eval ] unit-test
|
||||
[ t ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test
|
||||
[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test
|
||||
[ f ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
@ -127,7 +146,7 @@ SYMBOL: changed-words
|
|||
: reset-word ( word -- )
|
||||
{
|
||||
"unannotated-def"
|
||||
"parsing" "inline" "foldable"
|
||||
"parsing" "inline" "foldable" "flushable"
|
||||
"predicating"
|
||||
"reading" "writing"
|
||||
"constructing"
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -11,14 +11,17 @@ IN: assocs.lib
|
|||
|
||||
! set-hash with alternative stack effects
|
||||
|
||||
: put-hash* ( table key value -- ) swap rot set-at ;
|
||||
: put-hash* ( table key value -- ) spin set-at ;
|
||||
|
||||
: put-hash ( table key value -- table ) swap pick set-at ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: set-hash-stack ( value key seq -- )
|
||||
dupd [ key? ] when find-last nip set-at ;
|
||||
dupd [ key? ] with find-last nip set-at ;
|
||||
|
||||
: at-default ( key assoc -- value/key )
|
||||
dupd at [ nip ] when* ;
|
||||
|
||||
: at-peek ( key assoc -- value ? )
|
||||
at* dup >r [ peek ] when r> ;
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
|
|||
ui.gadgets.packs
|
||||
ui.gadgets.grids
|
||||
ui.gadgets.theme
|
||||
namespaces.lib hashtables.lib vars
|
||||
namespaces.lib assocs.lib vars
|
||||
rewrite-closures automata ;
|
||||
|
||||
IN: automata.ui
|
||||
|
|
@ -85,4 +85,4 @@ over @center grid-add
|
|||
|
||||
: automata-window ( -- ) [ [ automata-window* ] with-scope ] with-ui ;
|
||||
|
||||
MAIN: automata-window
|
||||
MAIN: automata-window
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: crypto.sha1 io.files kernel ;
|
||||
IN: benchmark.sha1
|
||||
|
||||
: sha1-primes-list ( -- seq )
|
||||
"extra/math/primes/list/list.factor" resource-path file>sha1 ;
|
||||
: sha1-primes-list ( -- )
|
||||
"extra/math/primes/list/list.factor" resource-path file>sha1 drop ;
|
||||
|
||||
MAIN: sha1-primes-list
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ USING: kernel namespaces
|
|||
ui.gadgets.grids
|
||||
ui.gestures
|
||||
combinators.cleave
|
||||
hashtables.lib vars rewrite-closures boids ;
|
||||
assocs.lib vars rewrite-closures boids ;
|
||||
|
||||
IN: boids.ui
|
||||
|
||||
|
|
@ -163,4 +163,4 @@ VARS: population-label cohesion-label alignment-label separation-label ;
|
|||
|
||||
: boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;
|
||||
|
||||
MAIN: boids-window
|
||||
MAIN: boids-window
|
||||
|
|
|
|||
|
|
@ -10,6 +10,3 @@ IN: bootstrap.io
|
|||
{ [ wince? ] [ "windows.ce" ] }
|
||||
} cond append require
|
||||
] when
|
||||
|
||||
init-io
|
||||
init-stdio
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@
|
|||
USING: arrays hashtables io io.streams.string kernel math
|
||||
math.vectors math.functions math.parser namespaces sequences
|
||||
strings tuples system debugger combinators vocabs.loader
|
||||
calendar.backend structs alien.c-types math.vectors ;
|
||||
calendar.backend structs alien.c-types math.vectors
|
||||
math.ranges shuffle ;
|
||||
IN: calendar
|
||||
|
||||
TUPLE: timestamp year month day hour minute second gmt-offset ;
|
||||
|
|
@ -115,14 +116,18 @@ GENERIC: +second ( timestamp x -- timestamp )
|
|||
|
||||
: /rem ( f n -- q r )
|
||||
#! q is positive or negative, r is positive from 0 <= r < n
|
||||
[ /f floor >bignum ] 2keep rem ;
|
||||
[ /f floor >integer ] 2keep rem ;
|
||||
|
||||
: float>whole-part ( float -- int float )
|
||||
[ floor >bignum ] keep over - ;
|
||||
[ floor >integer ] keep over - ;
|
||||
|
||||
: leap-year? ( year -- ? )
|
||||
GENERIC: leap-year? ( obj -- ? )
|
||||
M: integer leap-year? ( year -- ? )
|
||||
dup 100 mod zero? 400 4 ? mod zero? ;
|
||||
|
||||
M: timestamp leap-year? ( timestamp -- ? )
|
||||
timestamp-year leap-year? ;
|
||||
|
||||
: adjust-leap-year ( timestamp -- timestamp )
|
||||
dup >date< 29 = swap 2 = and swap leap-year? not and [
|
||||
dup >r timestamp-year 3 1 r> [ set-date ] keep
|
||||
|
|
@ -161,7 +166,7 @@ M: real +minute ( timestamp n -- timestamp )
|
|||
float>whole-part rot swap 60 * +second swap +minute ;
|
||||
|
||||
M: number +second ( timestamp n -- timestamp )
|
||||
over timestamp-second + 60 /rem >r >bignum r>
|
||||
over timestamp-second + 60 /rem >r >integer r>
|
||||
pick set-timestamp-second +minute ;
|
||||
|
||||
: +dt ( timestamp dt -- timestamp )
|
||||
|
|
@ -178,6 +183,9 @@ M: number +second ( timestamp n -- timestamp )
|
|||
<timestamp> [ 0 seconds +dt ] keep
|
||||
[ = [ "invalid timestamp" throw ] unless ] keep ;
|
||||
|
||||
: make-date ( year month day -- timestamp )
|
||||
0 0 0 gmt-offset make-timestamp ;
|
||||
|
||||
: array>dt ( vec -- dt ) { dt f } swap append >tuple ;
|
||||
: +dts ( dt dt -- dt ) [ tuple-slots ] 2apply v+ array>dt ;
|
||||
|
||||
|
|
@ -214,14 +222,14 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
|||
[ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
|
||||
[ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
|
||||
|
||||
: unix-1970
|
||||
: unix-1970 ( -- timestamp )
|
||||
1970 1 1 0 0 0 0 <timestamp> ;
|
||||
|
||||
: unix-time>timestamp ( n -- timestamp )
|
||||
>r unix-1970 r> seconds +dt ;
|
||||
|
||||
: timestamp>unix-time ( timestamp -- n )
|
||||
unix-1970 timestamp- >bignum ;
|
||||
unix-1970 timestamp- >integer ;
|
||||
|
||||
: timestamp>timeval ( timestamp -- timeval )
|
||||
timestamp>unix-time 1000 * make-timeval ;
|
||||
|
|
@ -240,14 +248,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
|||
: from-now ( dt -- timestamp ) now swap +dt ;
|
||||
: ago ( dt -- timestamp ) before from-now ;
|
||||
|
||||
: days-in-year ( year -- n ) leap-year? 366 365 ? ;
|
||||
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ;
|
||||
: days-in-month ( year month -- n )
|
||||
swap leap-year? [
|
||||
[ day-counts nth ] keep 2 = [ 1+ ] when
|
||||
] [
|
||||
day-counts nth
|
||||
] if ;
|
||||
|
||||
: zeller-congruence ( year month day -- n )
|
||||
#! Zeller Congruence
|
||||
|
|
@ -258,33 +259,79 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
|||
[ 1+ 3 * 5 /i + ] keep 2 * + r>
|
||||
1+ + 7 mod ;
|
||||
|
||||
: day-of-week ( timestamp -- n )
|
||||
GENERIC: days-in-year ( obj -- n )
|
||||
|
||||
M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ;
|
||||
M: timestamp days-in-year ( timestamp -- n ) timestamp-year days-in-year ;
|
||||
|
||||
GENERIC: days-in-month ( obj -- n )
|
||||
|
||||
M: array days-in-month ( obj -- n )
|
||||
first2 dup 2 = [
|
||||
drop leap-year? 29 28 ?
|
||||
] [
|
||||
nip day-counts nth
|
||||
] if ;
|
||||
|
||||
M: timestamp days-in-month ( timestamp -- n )
|
||||
{ timestamp-year timestamp-month } get-slots 2array days-in-month ;
|
||||
|
||||
GENERIC: day-of-week ( obj -- n )
|
||||
|
||||
M: timestamp day-of-week ( timestamp -- n )
|
||||
>date< zeller-congruence ;
|
||||
|
||||
: day-of-year ( timestamp -- n )
|
||||
[
|
||||
[ timestamp-year leap-year? ] keep
|
||||
[ >date< 3array ] keep timestamp-year 3 1 3array <=>
|
||||
0 >= and 1 0 ?
|
||||
] keep
|
||||
[ timestamp-month day-counts swap head-slice sum + ] keep
|
||||
timestamp-day + ;
|
||||
M: array day-of-week ( array -- n )
|
||||
first3 zeller-congruence ;
|
||||
|
||||
: print-day ( n -- )
|
||||
GENERIC: day-of-year ( obj -- n )
|
||||
|
||||
M: array day-of-year ( array -- n )
|
||||
first3
|
||||
3dup day-counts rot head-slice sum +
|
||||
swap leap-year? [
|
||||
-roll
|
||||
pick 3 1 make-date >r make-date r>
|
||||
<=> 0 >= [ 1+ ] when
|
||||
] [
|
||||
3nip
|
||||
] if ;
|
||||
|
||||
M: timestamp day-of-year ( timestamp -- n )
|
||||
{ timestamp-year timestamp-month timestamp-day } get-slots
|
||||
3array day-of-year ;
|
||||
|
||||
GENERIC: day. ( obj -- )
|
||||
|
||||
M: integer day. ( n -- )
|
||||
number>string dup length 2 < [ bl ] when write ;
|
||||
|
||||
: print-month ( year month -- )
|
||||
M: timestamp day. ( timestamp -- )
|
||||
timestamp-day day. ;
|
||||
|
||||
GENERIC: month. ( obj -- )
|
||||
|
||||
M: array month. ( pair -- )
|
||||
first2
|
||||
[ month-names nth write bl number>string print ] 2keep
|
||||
[ 1 zeller-congruence ] 2keep
|
||||
days-in-month day-abbreviations2 " " join print
|
||||
2array days-in-month day-abbreviations2 " " join print
|
||||
over " " <repetition> concat write
|
||||
[
|
||||
[ 1+ print-day ] keep
|
||||
[ 1+ day. ] keep
|
||||
1+ + 7 mod zero? [ nl ] [ bl ] if
|
||||
] with each nl ;
|
||||
|
||||
: print-year ( year -- )
|
||||
12 [ 1+ print-month nl ] with each ;
|
||||
M: timestamp month. ( timestamp -- )
|
||||
{ timestamp-year timestamp-month } get-slots 2array month. ;
|
||||
|
||||
GENERIC: year. ( obj -- )
|
||||
|
||||
M: integer year. ( n -- )
|
||||
12 [ 1+ 2array month. nl ] with each ;
|
||||
|
||||
M: timestamp year. ( timestamp -- )
|
||||
timestamp-year year. ;
|
||||
|
||||
: pad-00 number>string 2 CHAR: 0 pad-left write ;
|
||||
|
||||
|
|
@ -298,9 +345,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
|||
timestamp-second >fixnum pad-00 ;
|
||||
|
||||
: timestamp>string ( timestamp -- str )
|
||||
[
|
||||
(timestamp>string)
|
||||
] string-out ;
|
||||
[ (timestamp>string) ] string-out ;
|
||||
|
||||
: timestamp>http-string ( timestamp -- str )
|
||||
#! http timestamp format
|
||||
|
|
@ -319,9 +364,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
|||
timestamp-second >fixnum pad-00 CHAR: Z write1 ;
|
||||
|
||||
: timestamp>rfc3339 ( timestamp -- str )
|
||||
>gmt [
|
||||
(timestamp>rfc3339)
|
||||
] string-out ;
|
||||
>gmt [ (timestamp>rfc3339) ] string-out ;
|
||||
|
||||
: expect read1 assert= ;
|
||||
|
||||
|
|
@ -340,9 +383,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
|||
0 <timestamp> ;
|
||||
|
||||
: rfc3339>timestamp ( str -- timestamp )
|
||||
[
|
||||
(rfc3339>timestamp)
|
||||
] string-in ;
|
||||
[ (rfc3339>timestamp) ] string-in ;
|
||||
|
||||
: file-time-string ( timestamp -- string )
|
||||
[
|
||||
|
|
@ -370,6 +411,23 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
|||
: friday ( timestamp -- timestamp ) 5 day-this-week ;
|
||||
: saturday ( timestamp -- timestamp ) 6 day-this-week ;
|
||||
|
||||
: beginning-of-day ( timestamp -- new-timestamp )
|
||||
clone dup >r 0 0 0 r>
|
||||
{ set-timestamp-hour set-timestamp-minute set-timestamp-second }
|
||||
set-slots ; inline
|
||||
|
||||
: beginning-of-month ( timestamp -- new-timestamp )
|
||||
beginning-of-day 1 over set-timestamp-day ;
|
||||
|
||||
: beginning-of-week ( timestamp -- new-timestamp )
|
||||
beginning-of-day sunday ;
|
||||
|
||||
: beginning-of-year ( timestamp -- new-timestamp )
|
||||
beginning-of-month 1 over set-timestamp-month ;
|
||||
|
||||
: seconds-since-midnight ( timestamp -- x )
|
||||
dup beginning-of-day timestamp- ;
|
||||
|
||||
{
|
||||
{ [ unix? ] [ "calendar.unix" ] }
|
||||
{ [ windows? ] [ "calendar.windows" ] }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -201,3 +201,23 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
|
|||
|
||||
: either ( object first second -- ? )
|
||||
>r keep swap [ r> drop ] [ r> call ] ?if ; inline
|
||||
|
||||
: 2quot-with ( obj seq quot1 quot2 -- seq quot1 quot2 )
|
||||
>r pick >r with r> r> swapd with ;
|
||||
|
||||
: or? ( obj quot1 quot2 -- ? )
|
||||
>r keep r> rot [ 2nip ] [ call ] if* ; inline
|
||||
|
||||
: and? ( obj quot1 quot2 -- ? )
|
||||
>r keep r> rot [ call ] [ 2drop f ] if ; inline
|
||||
|
||||
: prepare-index ( seq quot -- seq n quot )
|
||||
>r dup length r> ; inline
|
||||
|
||||
: each-index ( seq quot -- )
|
||||
#! quot: ( elt index -- )
|
||||
prepare-index 2each ; inline
|
||||
|
||||
: map-index ( seq quot -- )
|
||||
#! quot: ( elt index -- obj )
|
||||
prepare-index 2map ; inline
|
||||
|
|
|
|||
|
|
@ -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,19 +0,0 @@
|
|||
|
||||
USING: kernel sequences assocs ;
|
||||
|
||||
IN: hashtables.lib
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: ref-hash ( table key -- value ) swap at ;
|
||||
|
||||
! set-hash with alternative stack effects
|
||||
|
||||
: put-hash* ( table key value -- ) spin set-at ;
|
||||
|
||||
: put-hash ( table key value -- table ) swap pick set-at ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: set-hash-stack ( value key seq -- )
|
||||
dupd [ key? ] with find-last nip set-at ;
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,11 +9,14 @@ IN: http.client
|
|||
#! Extract the host name and port number from an HTTP URL.
|
||||
":" split1 [ string>number ] [ 80 ] if* ;
|
||||
|
||||
SYMBOL: domain
|
||||
|
||||
: parse-url ( url -- host resource )
|
||||
"http://" ?head [
|
||||
"URL must begin with http://" throw
|
||||
] unless
|
||||
"/" split1 [ "/" swap append ] [ "/" ] if* ;
|
||||
dup "https://" head? [
|
||||
"ssl not yet supported: " swap append throw
|
||||
] when "http://" ?head drop
|
||||
"/" split1 [ "/" swap append ] [ "/" ] if*
|
||||
>r dup empty? [ drop domain get ] [ dup domain set ] if r> ;
|
||||
|
||||
: parse-response ( line -- code )
|
||||
"HTTP/" ?head [ " " split1 nip ] when
|
||||
|
|
@ -52,7 +55,9 @@ DEFER: http-get-stream
|
|||
|
||||
: http-get ( url -- code headers string )
|
||||
#! Opens a stream for reading from an HTTP URL.
|
||||
http-get-stream [ stdio get contents ] with-stream ;
|
||||
[
|
||||
http-get-stream [ stdio get contents ] with-stream
|
||||
] with-scope ;
|
||||
|
||||
: download ( url file -- )
|
||||
#! Downloads the contents of a URL to a file.
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax quotations kernel ;
|
||||
USING: help.markup help.syntax quotations kernel io math ;
|
||||
IN: io.launcher
|
||||
|
||||
HELP: +command+
|
||||
|
|
@ -31,6 +31,36 @@ HELP: +environment-mode+
|
|||
"Default value is " { $link append-environment } "."
|
||||
} ;
|
||||
|
||||
HELP: +stdin+
|
||||
{ $description "Launch descriptor key. Must equal one of the following:"
|
||||
{ $list
|
||||
{ { $link f } " - standard input is inherited" }
|
||||
{ { $link +closed+ } " - standard input is closed" }
|
||||
{ "a path name - standard input is read from the given file, which must exist" }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: +stdout+
|
||||
{ $description "Launch descriptor key. Must equal one of the following:"
|
||||
{ $list
|
||||
{ { $link f } " - standard output is inherited" }
|
||||
{ { $link +closed+ } " - standard output is closed" }
|
||||
{ "a path name - standard output is written to the given file, which is overwritten if it already exists" }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: +stderr+
|
||||
{ $description "Launch descriptor key. Must equal one of the following:"
|
||||
{ $list
|
||||
{ { $link f } " - standard error is inherited" }
|
||||
{ { $link +closed+ } " - standard error is closed" }
|
||||
{ "a path name - standard error is written to the given file, which is overwritten if it already exists" }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: +closed+
|
||||
{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
|
||||
|
||||
HELP: prepend-environment
|
||||
{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence."
|
||||
$nl
|
||||
|
|
@ -58,7 +88,7 @@ HELP: get-environment
|
|||
{ $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ;
|
||||
|
||||
HELP: run-process*
|
||||
{ $values { "desc" "a launch descriptor" } }
|
||||
{ $values { "desc" "a launch descriptor" } { "handle" "a process handle" } }
|
||||
{ $contract "Launches a process using the launch descriptor." }
|
||||
{ $notes "User code should call " { $link run-process } " instead." } ;
|
||||
|
||||
|
|
@ -73,22 +103,41 @@ HELP: >descriptor
|
|||
} ;
|
||||
|
||||
HELP: run-process
|
||||
{ $values { "obj" object } }
|
||||
{ $contract "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." } ;
|
||||
{ $values { "obj" object } { "process" process } }
|
||||
{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
|
||||
{ $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ;
|
||||
|
||||
HELP: run-detached
|
||||
{ $values { "obj" object } }
|
||||
{ $values { "obj" object } { "process" process } }
|
||||
{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
|
||||
{ $notes
|
||||
"This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set."
|
||||
$nl
|
||||
"The output value can be passed to " { $link wait-for-process } " to get an exit code."
|
||||
} ;
|
||||
|
||||
HELP: process
|
||||
{ $class-description "A class representing an active or finished process."
|
||||
$nl
|
||||
"Processes are output by " { $link run-process } " and " { $link run-detached } ", and are stored in the " { $link process-stream-process } " slot of " { $link process-stream } " instances."
|
||||
$nl
|
||||
"Processes can be passed to " { $link wait-for-process } "." } ;
|
||||
|
||||
HELP: process-stream
|
||||
{ $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link <process-stream> } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ;
|
||||
|
||||
HELP: <process-stream>
|
||||
{ $values { "obj" object } { "stream" "a bidirectional stream" } }
|
||||
{ $description "Launches a process and redirects its input and output via a paper of pipes which may be read and written as a 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 ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: io io.buffers io.backend help.markup help.syntax kernel
|
||||
strings sbufs ;
|
||||
strings sbufs words ;
|
||||
IN: io.nonblocking
|
||||
|
||||
ARTICLE: "io.nonblocking" "Non-blocking I/O implementation"
|
||||
|
|
@ -40,7 +40,7 @@ $nl
|
|||
{ { $link port-error } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
|
||||
{ { $link port-timeout } " - a timeout, specifying the maximum length of time, in milliseconds, for which input operations can block before throwing an error. A value of 0 denotes no timeout is desired." }
|
||||
{ { $link port-cutoff } " - the time when the current timeout expires; if no input data arrives before this time, an error is thrown" }
|
||||
{ { $link port-type } " - a symbol identifying the port's intended purpose. Can be " { $link input } ", " { $link output } ", " { $link closed } ", or any other symbol" }
|
||||
{ { $link port-type } " - a symbol identifying the port's intended purpose" }
|
||||
{ { $link port-eof? } " - a flag indicating if the port has reached the end of file while reading" }
|
||||
} } ;
|
||||
|
||||
|
|
@ -55,7 +55,7 @@ HELP: init-handle
|
|||
{ $contract "Prepares a native handle for use by the port; called by " { $link <port> } "." } ;
|
||||
|
||||
HELP: <port>
|
||||
{ $values { "handle" "a native handle identifying an I/O resource" } { "buffer" "a " { $link buffer } " or " { $link f } } { "port" "a new " { $link port } } }
|
||||
{ $values { "handle" "a native handle identifying an I/O resource" } { "buffer" "a " { $link buffer } " or " { $link f } } { "type" symbol } { "port" "a new " { $link port } } }
|
||||
{ $description "Creates a new " { $link port } " using the specified native handle and I/O buffer." }
|
||||
$low-level-note ;
|
||||
|
||||
|
|
|
|||
|
|
@ -12,38 +12,36 @@ SYMBOL: default-buffer-size
|
|||
! Common delegate of native stream readers and writers
|
||||
TUPLE: port handle error timeout cutoff type eof? ;
|
||||
|
||||
SYMBOL: input
|
||||
SYMBOL: output
|
||||
SYMBOL: closed
|
||||
|
||||
PREDICATE: port input-port port-type input eq? ;
|
||||
PREDICATE: port output-port port-type output eq? ;
|
||||
PREDICATE: port input-port port-type input-port eq? ;
|
||||
PREDICATE: port output-port port-type output-port eq? ;
|
||||
|
||||
GENERIC: init-handle ( handle -- )
|
||||
GENERIC: close-handle ( handle -- )
|
||||
|
||||
: <port> ( handle buffer -- port )
|
||||
over init-handle
|
||||
: <port> ( handle buffer type -- port )
|
||||
pick init-handle
|
||||
0 0 {
|
||||
set-port-handle
|
||||
set-delegate
|
||||
set-port-type
|
||||
set-port-timeout
|
||||
set-port-cutoff
|
||||
} port construct ;
|
||||
|
||||
: <buffered-port> ( handle -- port )
|
||||
default-buffer-size get <buffer> <port> ;
|
||||
: <buffered-port> ( handle type -- port )
|
||||
default-buffer-size get <buffer> swap <port> ;
|
||||
|
||||
: <reader> ( handle -- stream )
|
||||
<buffered-port> input over set-port-type <line-reader> ;
|
||||
input-port <buffered-port> <line-reader> ;
|
||||
|
||||
: <writer> ( handle -- stream )
|
||||
<buffered-port> output over set-port-type <plain-writer> ;
|
||||
output-port <buffered-port> <plain-writer> ;
|
||||
|
||||
: handle>duplex-stream ( in-handle out-handle -- stream )
|
||||
<writer>
|
||||
[ >r <reader> r> <duplex-stream> ]
|
||||
[ ] [ stream-close ]
|
||||
[ >r <reader> r> <duplex-stream> ] [ ] [ stream-close ]
|
||||
cleanup ;
|
||||
|
||||
: touch-port ( port -- )
|
||||
|
|
@ -162,7 +160,7 @@ M: output-port stream-flush ( port -- )
|
|||
M: port stream-close
|
||||
dup port-type closed eq? [
|
||||
dup port-type >r closed over set-port-type r>
|
||||
output eq? [ dup port-flush ] when
|
||||
output-port eq? [ dup port-flush ] when
|
||||
dup port-handle close-handle
|
||||
dup delegate [ buffer-free ] when*
|
||||
f over set-delegate
|
||||
|
|
@ -170,8 +168,8 @@ M: port stream-close
|
|||
|
||||
TUPLE: server-port addr client ;
|
||||
|
||||
: <server-port> ( port addr -- server )
|
||||
server-port pick set-port-type
|
||||
: <server-port> ( handle addr -- server )
|
||||
>r f server-port <port> r>
|
||||
{ set-delegate set-server-port-addr }
|
||||
server-port construct ;
|
||||
|
||||
|
|
@ -180,8 +178,8 @@ TUPLE: server-port addr client ;
|
|||
|
||||
TUPLE: datagram-port addr packet packet-addr ;
|
||||
|
||||
: <datagram-port> ( port addr -- datagram )
|
||||
datagram-port pick set-port-type
|
||||
: <datagram-port> ( handle addr -- datagram )
|
||||
>r f datagram-port <port> r>
|
||||
{ set-delegate set-datagram-port-addr }
|
||||
datagram-port construct ;
|
||||
|
||||
|
|
|
|||
|
|
@ -83,7 +83,7 @@ M: unix-io <sniffer> ( obj -- sniffer )
|
|||
] keep
|
||||
dupd sniffer-spec-ifname ioctl-sniffer-fd
|
||||
dup make-ioctl-buffer
|
||||
<port> input over set-port-type <line-reader>
|
||||
input-port <port> <line-reader>
|
||||
\ sniffer construct-delegate
|
||||
] with-destructors ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,22 +1,66 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien bit-arrays generic assocs io kernel
|
||||
kernel.private math io.nonblocking sequences strings structs
|
||||
sbufs threads unix vectors io.buffers io.backend
|
||||
io.streams.duplex math.parser continuations system libc ;
|
||||
USING: alien generic assocs kernel kernel.private math
|
||||
io.nonblocking sequences strings structs sbufs threads unix
|
||||
vectors io.buffers io.backend io.streams.duplex math.parser
|
||||
continuations system libc qualified namespaces ;
|
||||
QUALIFIED: io
|
||||
IN: io.unix.backend
|
||||
|
||||
TUPLE: unix-io ;
|
||||
MIXIN: unix-io
|
||||
|
||||
! We want namespaces::bind to shadow the bind system call from
|
||||
! unix
|
||||
USING: namespaces ;
|
||||
! I/O tasks
|
||||
TUPLE: io-task port callbacks ;
|
||||
|
||||
! Global variables
|
||||
SYMBOL: read-fdset
|
||||
SYMBOL: read-tasks
|
||||
SYMBOL: write-fdset
|
||||
SYMBOL: write-tasks
|
||||
: io-task-fd io-task-port port-handle ;
|
||||
|
||||
: <io-task> ( port continuation class -- task )
|
||||
>r 1vector io-task construct-boa r> construct-delegate ;
|
||||
inline
|
||||
|
||||
TUPLE: input-task ;
|
||||
|
||||
: <input-task> ( port continuation class -- task )
|
||||
>r input-task <io-task> r> construct-delegate ; inline
|
||||
|
||||
TUPLE: output-task ;
|
||||
|
||||
: <output-task> ( port continuation class -- task )
|
||||
>r output-task <io-task> r> construct-delegate ; inline
|
||||
|
||||
GENERIC: do-io-task ( task -- ? )
|
||||
GENERIC: io-task-container ( mx task -- hashtable )
|
||||
|
||||
! I/O multiplexers
|
||||
TUPLE: mx fd reads writes ;
|
||||
|
||||
M: input-task io-task-container drop mx-reads ;
|
||||
|
||||
M: output-task io-task-container drop mx-writes ;
|
||||
|
||||
: <mx> ( -- mx ) f H{ } clone H{ } clone mx construct-boa ;
|
||||
|
||||
: construct-mx ( class -- obj ) <mx> swap construct-delegate ;
|
||||
|
||||
GENERIC: register-io-task ( task mx -- )
|
||||
GENERIC: unregister-io-task ( task mx -- )
|
||||
GENERIC: wait-for-events ( ms mx -- )
|
||||
|
||||
: fd/container ( task mx -- task fd container )
|
||||
over io-task-container >r dup io-task-fd r> ; inline
|
||||
|
||||
: check-io-task ( task mx -- )
|
||||
fd/container key? nip [
|
||||
"Cannot perform multiple reads from the same port" throw
|
||||
] when ;
|
||||
|
||||
M: mx register-io-task ( task mx -- )
|
||||
2dup check-io-task fd/container set-at ;
|
||||
|
||||
: add-io-task ( task -- ) mx get-global register-io-task ;
|
||||
|
||||
M: mx unregister-io-task ( task mx -- )
|
||||
fd/container delete-at drop ;
|
||||
|
||||
! Some general stuff
|
||||
: file-mode OCT: 0666 ;
|
||||
|
|
@ -49,72 +93,16 @@ M: integer close-handle ( fd -- )
|
|||
err_no dup ignorable-error?
|
||||
[ 2drop f ] [ strerror swap report-error t ] if ;
|
||||
|
||||
! Associates a port with a list of continuations waiting on the
|
||||
! port to finish I/O
|
||||
TUPLE: io-task port callbacks ;
|
||||
: pop-callbacks ( mx task -- )
|
||||
dup rot unregister-io-task
|
||||
io-task-callbacks [ schedule-thread ] each ;
|
||||
|
||||
: <io-task> ( port class -- task )
|
||||
>r V{ } clone io-task construct-boa
|
||||
{ set-delegate } r> construct ; inline
|
||||
|
||||
! Multiplexer
|
||||
GENERIC: do-io-task ( task -- ? )
|
||||
GENERIC: task-container ( task -- vector )
|
||||
|
||||
: io-task-fd io-task-port port-handle ;
|
||||
|
||||
: add-io-task ( callback task -- )
|
||||
[ io-task-callbacks push ] keep
|
||||
dup io-task-fd over task-container 2dup at [
|
||||
"Cannot perform multiple reads from the same port" throw
|
||||
] when set-at ;
|
||||
|
||||
: remove-io-task ( task -- )
|
||||
dup io-task-fd swap task-container delete-at ;
|
||||
|
||||
: pop-callbacks ( task -- )
|
||||
dup io-task-callbacks swap remove-io-task
|
||||
[ schedule-thread ] each ;
|
||||
|
||||
: handle-fd ( task -- )
|
||||
: handle-io-task ( mx task -- )
|
||||
dup io-task-port touch-port
|
||||
dup do-io-task [ pop-callbacks ] [ drop ] if ;
|
||||
dup do-io-task [ pop-callbacks ] [ 2drop ] if ;
|
||||
|
||||
: handle-fdset ( fdset tasks -- )
|
||||
swap [
|
||||
swap dup io-task-port timeout? [
|
||||
dup io-task-port "Timeout" swap report-error
|
||||
nip pop-callbacks
|
||||
] [
|
||||
tuck io-task-fd swap nth
|
||||
[ handle-fd ] [ drop ] if
|
||||
] if drop
|
||||
] curry assoc-each ;
|
||||
|
||||
: init-fdset ( fdset tasks -- )
|
||||
swap dup clear-bits
|
||||
[ >r drop t swap r> set-nth ] curry assoc-each ;
|
||||
|
||||
: read-fdset/tasks
|
||||
read-fdset get-global read-tasks get-global ;
|
||||
|
||||
: write-fdset/tasks
|
||||
write-fdset get-global write-tasks get-global ;
|
||||
|
||||
: init-fdsets ( -- read write except )
|
||||
read-fdset/tasks dupd init-fdset
|
||||
write-fdset/tasks dupd init-fdset
|
||||
f ;
|
||||
|
||||
: (io-multiplex) ( ms -- )
|
||||
>r FD_SETSIZE init-fdsets r> make-timeval select 0 < [
|
||||
err_no ignorable-error? [ (io-error) ] unless
|
||||
] when ;
|
||||
|
||||
M: unix-io io-multiplex ( ms -- )
|
||||
(io-multiplex)
|
||||
read-fdset/tasks handle-fdset
|
||||
write-fdset/tasks handle-fdset ;
|
||||
: handle-timeout ( mx task -- )
|
||||
"Timeout" over io-task-port report-error pop-callbacks ;
|
||||
|
||||
! Readers
|
||||
: reader-eof ( reader -- )
|
||||
|
|
@ -137,17 +125,15 @@ M: unix-io io-multiplex ( ms -- )
|
|||
|
||||
TUPLE: read-task ;
|
||||
|
||||
: <read-task> ( port -- task ) read-task <io-task> ;
|
||||
: <read-task> ( port continuation -- task )
|
||||
read-task <input-task> ;
|
||||
|
||||
M: read-task do-io-task
|
||||
io-task-port dup refill
|
||||
[ [ reader-eof ] [ drop ] if ] keep ;
|
||||
|
||||
M: read-task task-container drop read-tasks get-global ;
|
||||
|
||||
M: input-port (wait-to-read)
|
||||
[ swap <read-task> add-io-task stop ] callcc0
|
||||
pending-error ;
|
||||
[ <read-task> add-io-task stop ] callcc0 pending-error ;
|
||||
|
||||
! Writers
|
||||
: write-step ( port -- ? )
|
||||
|
|
@ -156,35 +142,45 @@ M: input-port (wait-to-read)
|
|||
|
||||
TUPLE: write-task ;
|
||||
|
||||
: <write-task> ( port -- task ) write-task <io-task> ;
|
||||
: <write-task> ( port continuation -- task )
|
||||
write-task <output-task> ;
|
||||
|
||||
M: write-task do-io-task
|
||||
io-task-port dup buffer-empty? over port-error or
|
||||
[ 0 swap buffer-reset t ] [ write-step ] if ;
|
||||
|
||||
M: write-task task-container drop write-tasks get-global ;
|
||||
|
||||
: add-write-io-task ( callback task -- )
|
||||
dup io-task-fd write-tasks get-global at
|
||||
[ io-task-callbacks push ] [ add-io-task ] ?if ;
|
||||
: add-write-io-task ( port continuation -- )
|
||||
over port-handle mx get-global mx-writes at*
|
||||
[ io-task-callbacks push drop ]
|
||||
[ drop <write-task> add-io-task ] if ;
|
||||
|
||||
: (wait-to-write) ( port -- )
|
||||
[ swap <write-task> add-write-io-task stop ] callcc0 drop ;
|
||||
[ add-write-io-task stop ] callcc0 drop ;
|
||||
|
||||
M: port port-flush ( port -- )
|
||||
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
|
||||
|
||||
USE: io
|
||||
|
||||
M: unix-io init-io ( -- )
|
||||
#! Should only be called on startup. Calling this at any
|
||||
#! other time can have unintended consequences.
|
||||
global [
|
||||
H{ } clone read-tasks set
|
||||
FD_SETSIZE 8 * <bit-array> read-fdset set
|
||||
H{ } clone write-tasks set
|
||||
FD_SETSIZE 8 * <bit-array> write-fdset set
|
||||
] bind ;
|
||||
M: unix-io io-multiplex ( ms -- )
|
||||
mx get-global wait-for-events ;
|
||||
|
||||
M: unix-io init-stdio ( -- )
|
||||
0 1 handle>duplex-stream stdio set-global ;
|
||||
0 1 handle>duplex-stream io:stdio set-global
|
||||
2 <writer> io:stderr set-global ;
|
||||
|
||||
! mx io-task for embedding an fd-based mx inside another mx
|
||||
TUPLE: mx-port mx ;
|
||||
|
||||
: <mx-port> ( mx -- port )
|
||||
dup mx-fd f mx-port <port>
|
||||
{ set-mx-port-mx set-delegate } mx-port construct ;
|
||||
|
||||
TUPLE: mx-task ;
|
||||
|
||||
: <mx-task> ( port -- task )
|
||||
f io-task construct-boa mx-task construct-delegate ;
|
||||
|
||||
M: mx-task do-io-task
|
||||
io-task-port mx-port-mx 0 swap wait-for-events f ;
|
||||
|
||||
: multiplexer-error ( n -- )
|
||||
0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,29 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! 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.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
|
||||
! notification and process exit notification.
|
||||
|
||||
! kqueue is buggy with files and ptys so we can't use it as the
|
||||
! main multiplexer.
|
||||
|
||||
TUPLE: bsd-io ;
|
||||
|
||||
INSTANCE: bsd-io unix-io
|
||||
|
||||
M: bsd-io init-io ( -- )
|
||||
<select-mx> mx set-global
|
||||
<kqueue-mx> kqueue-mx set-global
|
||||
kqueue-mx get-global <mx-port> <mx-task> dup io-task-fd
|
||||
2dup mx get-global mx-reads set-at
|
||||
mx get-global mx-writes set-at ;
|
||||
|
||||
M: bsd-io register-process ( process -- )
|
||||
process-handle kqueue-mx get-global add-pid-task ;
|
||||
|
||||
T{ bsd-io } set-io-backend
|
||||
|
|
@ -0,0 +1,62 @@
|
|||
! 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 unix.linux.epoll math
|
||||
namespaces structs ;
|
||||
IN: io.unix.epoll
|
||||
|
||||
TUPLE: epoll-mx events ;
|
||||
|
||||
: max-events ( -- n )
|
||||
#! We read up to 256 events at a time. This is an arbitrary
|
||||
#! constant...
|
||||
256 ; inline
|
||||
|
||||
: <epoll-mx> ( -- mx )
|
||||
epoll-mx construct-mx
|
||||
max-events epoll_create dup io-error over set-mx-fd
|
||||
max-events "epoll-event" <c-array> over set-epoll-mx-events ;
|
||||
|
||||
GENERIC: io-task-events ( task -- n )
|
||||
|
||||
M: input-task io-task-events drop EPOLLIN ;
|
||||
|
||||
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
|
||||
swap io-task-fd over set-epoll-event-fd ;
|
||||
|
||||
: do-epoll-ctl ( task mx what -- )
|
||||
>r mx-fd r> rot dup io-task-fd swap make-event
|
||||
epoll_ctl io-error ;
|
||||
|
||||
M: epoll-mx register-io-task ( task mx -- )
|
||||
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-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-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 epoll-event-nth handle-event
|
||||
] with each ;
|
||||
|
||||
M: epoll-mx wait-for-events ( ms mx -- )
|
||||
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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,78 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! 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 io.launcher io.unix.launcher ;
|
||||
IN: io.unix.kqueue
|
||||
|
||||
TUPLE: kqueue-mx events ;
|
||||
|
||||
: max-events ( -- n )
|
||||
#! We read up to 256 events at a time. This is an arbitrary
|
||||
#! constant...
|
||||
256 ; inline
|
||||
|
||||
: <kqueue-mx> ( -- mx )
|
||||
kqueue-mx construct-mx
|
||||
kqueue dup io-error over set-mx-fd
|
||||
max-events "kevent" <c-array> over set-kqueue-mx-events ;
|
||||
|
||||
GENERIC: io-task-filter ( task -- n )
|
||||
|
||||
M: input-task io-task-filter drop EVFILT_READ ;
|
||||
|
||||
M: output-task io-task-filter drop EVFILT_WRITE ;
|
||||
|
||||
: make-kevent ( task flags -- event )
|
||||
"kevent" <c-object>
|
||||
tuck set-kevent-flags
|
||||
over io-task-fd over set-kevent-ident
|
||||
swap io-task-filter over set-kevent-filter ;
|
||||
|
||||
: register-kevent ( kevent mx -- )
|
||||
mx-fd swap 1 f 0 f kevent io-error ;
|
||||
|
||||
M: kqueue-mx register-io-task ( task mx -- )
|
||||
over EV_ADD make-kevent over register-kevent
|
||||
delegate register-io-task ;
|
||||
|
||||
M: kqueue-mx unregister-io-task ( task mx -- )
|
||||
2dup delegate unregister-io-task
|
||||
swap EV_DELETE make-kevent swap register-kevent ;
|
||||
|
||||
: wait-kevent ( mx timespec -- n )
|
||||
>r dup mx-fd f 0 roll kqueue-mx-events max-events r> kevent
|
||||
dup multiplexer-error ;
|
||||
|
||||
: kevent-read-task ( mx fd -- )
|
||||
over mx-reads at handle-io-task ;
|
||||
|
||||
: kevent-write-task ( mx fd -- )
|
||||
over mx-reads at handle-io-task ;
|
||||
|
||||
: 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 drop ] }
|
||||
} cond ;
|
||||
|
||||
: handle-kevents ( mx n -- )
|
||||
[ over kqueue-mx-events kevent-nth handle-kevent ] with each ;
|
||||
|
||||
M: kqueue-mx wait-for-events ( ms mx -- )
|
||||
swap make-timespec dupd wait-kevent handle-kevents ;
|
||||
|
||||
: make-proc-kevent ( pid -- kevent )
|
||||
"kevent" <c-object>
|
||||
tuck set-kevent-ident
|
||||
EV_ADD over set-kevent-flags
|
||||
EVFILT_PROC over set-kevent-filter
|
||||
NOTE_EXIT over set-kevent-fflags ;
|
||||
|
||||
: add-pid-task ( pid mx -- )
|
||||
swap make-proc-kevent swap register-kevent ;
|
||||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io 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
|
||||
|
|
@ -42,31 +43,35 @@ 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 ( -- )
|
||||
[
|
||||
pass-environment? [
|
||||
get-arguments get-environment assoc>env exec-args-with-env
|
||||
] [
|
||||
get-arguments exec-args-with-path
|
||||
] if io-error
|
||||
setup-redirection
|
||||
get-arguments
|
||||
pass-environment?
|
||||
[ get-environment assoc>env exec-args-with-env ]
|
||||
[ exec-args-with-path ] if
|
||||
io-error
|
||||
] [ error. :c flush ] recover 1 exit ;
|
||||
|
||||
: wait-for-process ( pid -- )
|
||||
0 <int> 0 waitpid drop ;
|
||||
|
||||
: spawn-process ( -- pid )
|
||||
[ (spawn-process) ] [ ] with-fork ;
|
||||
|
||||
: spawn-detached ( -- )
|
||||
[ spawn-process 0 exit ] [ ] with-fork wait-for-process ;
|
||||
|
||||
M: unix-io run-process* ( desc -- )
|
||||
M: unix-io run-process* ( desc -- pid )
|
||||
[
|
||||
+detached+ get [
|
||||
spawn-detached
|
||||
] [
|
||||
spawn-process wait-for-process
|
||||
] if
|
||||
[ spawn-process ] [ ] with-fork <process>
|
||||
] with-descriptor ;
|
||||
|
||||
: open-pipe ( -- pair )
|
||||
|
|
@ -80,20 +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 ;
|
||||
|
||||
: <pipe-stream> ( in out pid -- stream )
|
||||
pipe-stream construct-boa
|
||||
-rot handle>duplex-stream over set-delegate ;
|
||||
|
||||
M: pipe-stream stream-close
|
||||
dup delegate stream-close
|
||||
pipe-stream-pid wait-for-process ;
|
||||
] 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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,15 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.unix.linux
|
||||
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 ( -- )
|
||||
<select-mx> mx set-global
|
||||
start-wait-thread ;
|
||||
|
||||
T{ linux-io } set-io-backend
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
! Copyright (C) 2004, 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 ;
|
||||
IN: io.unix.select
|
||||
|
||||
TUPLE: select-mx read-fdset write-fdset ;
|
||||
|
||||
! Factor's bit-arrays are an array of bytes, OS X expects
|
||||
! FD_SET to be an array of cells, so we have to account for
|
||||
! byte order differences on big endian platforms
|
||||
: little-endian? 1 <int> *char 1 = ; foldable
|
||||
|
||||
: munge ( i -- i' )
|
||||
little-endian? [ BIN: 11000 bitxor ] unless ; inline
|
||||
|
||||
: <select-mx> ( -- mx )
|
||||
select-mx construct-mx
|
||||
FD_SETSIZE 8 * <bit-array> over set-select-mx-read-fdset
|
||||
FD_SETSIZE 8 * <bit-array> over set-select-mx-write-fdset ;
|
||||
|
||||
: handle-fd ( fd task fdset mx -- )
|
||||
roll munge rot nth [ swap handle-io-task ] [ 2drop ] if ;
|
||||
|
||||
: handle-fdset ( tasks fdset mx -- )
|
||||
[ handle-fd ] 2curry assoc-each ;
|
||||
|
||||
: init-fdset ( tasks fdset -- )
|
||||
dup clear-bits
|
||||
[ >r drop t swap munge r> set-nth ] curry assoc-each ;
|
||||
|
||||
: read-fdset/tasks
|
||||
{ mx-reads select-mx-read-fdset } get-slots ;
|
||||
|
||||
: write-fdset/tasks
|
||||
{ mx-writes select-mx-write-fdset } get-slots ;
|
||||
|
||||
: init-fdsets ( mx -- read write except )
|
||||
[ read-fdset/tasks tuck init-fdset ] keep
|
||||
write-fdset/tasks tuck init-fdset
|
||||
f ;
|
||||
|
||||
M: select-mx wait-for-events ( ms mx -- )
|
||||
swap >r FD_SETSIZE over init-fdsets r> make-timeval
|
||||
select multiplexer-error
|
||||
dup read-fdset/tasks pick handle-fdset
|
||||
dup write-fdset/tasks rot handle-fdset ;
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov, Ivan Tikhonov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
! We need to fiddle with the exact search order here, since
|
||||
|
|
@ -33,16 +33,15 @@ M: unix-io addrinfo-error ( n -- )
|
|||
|
||||
TUPLE: connect-task ;
|
||||
|
||||
: <connect-task> ( port -- task ) connect-task <io-task> ;
|
||||
: <connect-task> ( port continuation -- task )
|
||||
connect-task <output-task> ;
|
||||
|
||||
M: connect-task do-io-task
|
||||
io-task-port dup port-handle f 0 write
|
||||
0 < [ defer-error ] [ drop t ] if ;
|
||||
|
||||
M: connect-task task-container drop write-tasks get-global ;
|
||||
|
||||
: wait-to-connect ( port -- )
|
||||
[ swap <connect-task> add-io-task stop ] callcc0 drop ;
|
||||
[ <connect-task> add-io-task stop ] callcc0 drop ;
|
||||
|
||||
M: unix-io (client) ( addrspec -- stream )
|
||||
dup make-sockaddr/size >r >r
|
||||
|
|
@ -66,9 +65,8 @@ USE: unix
|
|||
|
||||
TUPLE: accept-task ;
|
||||
|
||||
: <accept-task> ( port -- task ) accept-task <io-task> ;
|
||||
|
||||
M: accept-task task-container drop read-tasks get ;
|
||||
: <accept-task> ( port continuation -- task )
|
||||
accept-task <input-task> ;
|
||||
|
||||
: accept-sockaddr ( port -- fd sockaddr )
|
||||
dup port-handle swap server-port-addr sockaddr-type
|
||||
|
|
@ -85,7 +83,7 @@ M: accept-task do-io-task
|
|||
over 0 >= [ do-accept t ] [ 2drop defer-error ] if ;
|
||||
|
||||
: wait-to-accept ( server -- )
|
||||
[ swap <accept-task> add-io-task stop ] callcc0 drop ;
|
||||
[ <accept-task> add-io-task stop ] callcc0 drop ;
|
||||
|
||||
USE: io.sockets
|
||||
|
||||
|
|
@ -99,7 +97,6 @@ M: unix-io <server> ( addrspec -- stream )
|
|||
[
|
||||
SOCK_STREAM server-fd
|
||||
dup 10 listen zero? [ dup close (io-error) ] unless
|
||||
f <port>
|
||||
] keep <server-port> ;
|
||||
|
||||
M: unix-io accept ( server -- client )
|
||||
|
|
@ -111,7 +108,7 @@ M: unix-io accept ( server -- client )
|
|||
|
||||
! Datagram sockets - UDP and Unix domain
|
||||
M: unix-io <datagram>
|
||||
[ SOCK_DGRAM server-fd f <port> ] keep <datagram-port> ;
|
||||
[ SOCK_DGRAM server-fd ] keep <datagram-port> ;
|
||||
|
||||
SYMBOL: receive-buffer
|
||||
|
||||
|
|
@ -136,7 +133,8 @@ packet-size <byte-array> receive-buffer set-global
|
|||
|
||||
TUPLE: receive-task ;
|
||||
|
||||
: <receive-task> ( stream -- task ) receive-task <io-task> ;
|
||||
: <receive-task> ( stream continuation -- task )
|
||||
receive-task <input-task> ;
|
||||
|
||||
M: receive-task do-io-task
|
||||
io-task-port
|
||||
|
|
@ -149,10 +147,8 @@ M: receive-task do-io-task
|
|||
2drop defer-error
|
||||
] if ;
|
||||
|
||||
M: receive-task task-container drop read-tasks get ;
|
||||
|
||||
: wait-receive ( stream -- )
|
||||
[ swap <receive-task> add-io-task stop ] callcc0 drop ;
|
||||
[ <receive-task> add-io-task stop ] callcc0 drop ;
|
||||
|
||||
M: unix-io receive ( datagram -- packet addrspec )
|
||||
dup check-datagram-port
|
||||
|
|
@ -166,8 +162,8 @@ M: unix-io receive ( datagram -- packet addrspec )
|
|||
|
||||
TUPLE: send-task packet sockaddr len ;
|
||||
|
||||
: <send-task> ( packet sockaddr len port -- task )
|
||||
send-task <io-task> [
|
||||
: <send-task> ( packet sockaddr len stream continuation -- task )
|
||||
send-task <output-task> [
|
||||
{
|
||||
set-send-task-packet
|
||||
set-send-task-sockaddr
|
||||
|
|
@ -182,11 +178,8 @@ M: send-task do-io-task
|
|||
[ send-task-len do-send ] keep
|
||||
swap 0 < [ io-task-port defer-error ] [ drop t ] if ;
|
||||
|
||||
M: send-task task-container drop write-tasks get ;
|
||||
|
||||
: wait-send ( packet sockaddr len stream -- )
|
||||
[ >r <send-task> r> swap add-io-task stop ] callcc0
|
||||
2drop 2drop ;
|
||||
[ <send-task> add-io-task stop ] callcc0 2drop 2drop ;
|
||||
|
||||
M: unix-io send ( packet addrspec datagram -- )
|
||||
3dup check-datagram-send
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
USE: io.unix.backend
|
||||
USE: io.unix.files
|
||||
USE: io.unix.sockets
|
||||
USE: io.unix.launcher
|
||||
USE: io.unix.mmap
|
||||
USE: io.backend
|
||||
USE: namespaces
|
||||
USING: io.unix.backend io.unix.files io.unix.sockets
|
||||
io.unix.launcher io.unix.mmap io.backend combinators namespaces
|
||||
system vocabs.loader ;
|
||||
|
||||
T{ unix-io } io-backend set-global
|
||||
{
|
||||
{ [ bsd? ] [ "io.unix.bsd" ] }
|
||||
{ [ macosx? ] [ "io.unix.bsd" ] }
|
||||
{ [ 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
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ M: windows-ce-io <server> ( addrspec -- duplex-stream )
|
|||
[
|
||||
windows.winsock:SOCK_STREAM server-fd
|
||||
dup listen-on-socket
|
||||
<win32-socket> f <port>
|
||||
<win32-socket>
|
||||
] keep <server-port> ;
|
||||
|
||||
M: windows-ce-io accept ( server -- client )
|
||||
|
|
@ -58,7 +58,7 @@ M: windows-ce-io accept ( server -- client )
|
|||
|
||||
M: windows-ce-io <datagram> ( addrspec -- datagram )
|
||||
[
|
||||
windows.winsock:SOCK_DGRAM server-fd <win32-socket> f <port>
|
||||
windows.winsock:SOCK_DGRAM server-fd <win32-socket>
|
||||
] keep <datagram-port> ;
|
||||
|
||||
: packet-size 65536 ; inline
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -149,7 +149,7 @@ M: windows-nt-io <server> ( addrspec -- server )
|
|||
[
|
||||
SOCK_STREAM server-fd dup listen-on-socket
|
||||
dup add-completion
|
||||
<win32-socket> f <port>
|
||||
<win32-socket>
|
||||
] keep <server-port>
|
||||
] with-destructors ;
|
||||
|
||||
|
|
@ -158,7 +158,7 @@ M: windows-nt-io <datagram> ( addrspec -- datagram )
|
|||
[
|
||||
SOCK_DGRAM server-fd
|
||||
dup add-completion
|
||||
<win32-socket> f <port>
|
||||
<win32-socket>
|
||||
] keep <datagram-port>
|
||||
] with-destructors ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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,8 +1,8 @@
|
|||
|
||||
! USING: kernel quotations namespaces sequences hashtables.lib ;
|
||||
! USING: kernel quotations namespaces sequences assocs.lib ;
|
||||
|
||||
USING: kernel namespaces namespaces.private quotations sequences
|
||||
hashtables.lib ;
|
||||
assocs.lib ;
|
||||
|
||||
IN: namespaces.lib
|
||||
|
||||
|
|
@ -16,4 +16,4 @@ IN: namespaces.lib
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: set* ( val var -- ) namestack* set-hash-stack ;
|
||||
: set* ( val var -- ) namestack* set-hash-stack ;
|
||||
|
|
|
|||
|
|
@ -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,6 +1,6 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays combinators.lib hashtables kernel math math.parser math.ranges
|
||||
USING: hashtables kernel math math.parser math.ranges project-euler.common
|
||||
sequences sorting ;
|
||||
IN: project-euler.004
|
||||
|
||||
|
|
@ -21,9 +21,6 @@ IN: project-euler.004
|
|||
: palindrome? ( n -- ? )
|
||||
number>string dup reverse = ;
|
||||
|
||||
: cartesian-product ( seq1 seq2 -- seq1xseq2 )
|
||||
swap [ swap [ 2array ] map-with ] map-with concat ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: source-004 ( -- seq )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,75 @@
|
|||
! 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
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=27
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! Euler published the remarkable quadratic formula:
|
||||
|
||||
! n² + n + 41
|
||||
|
||||
! It turns out that the formula will produce 40 primes for the consecutive
|
||||
! values n = 0 to 39. However, when n = 40, 402 + 40 + 41 = 40(40 + 1) + 41 is
|
||||
! divisible by 41, and certainly when n = 41, 41² + 41 + 41 is clearly
|
||||
! divisible by 41.
|
||||
|
||||
! Using computers, the incredible formula n² - 79n + 1601 was discovered, which
|
||||
! produces 80 primes for the consecutive values n = 0 to 79. The product of the
|
||||
! coefficients, -79 and 1601, is -126479.
|
||||
|
||||
! Considering quadratics of the form:
|
||||
|
||||
! n² + an + b, where |a| < 1000 and |b| < 1000
|
||||
|
||||
! where |n| is the modulus/absolute value of n
|
||||
! e.g. |11| = 11 and |-4| = 4
|
||||
|
||||
! Find the product of the coefficients, a and b, for the quadratic expression
|
||||
! that produces the maximum number of primes for consecutive values of n,
|
||||
! starting with n = 0.
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
! b must be prime since n = 0 must return a prime
|
||||
! a + b + 1 must be prime since n = 1 must return a prime
|
||||
! 1 - a + b must be prime as well, hence >= 2. Therefore:
|
||||
! 1 - a + b >= 2
|
||||
! b - a >= 1
|
||||
! a < b
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: source-027 ( -- seq )
|
||||
1000 [ prime? ] subset [ dup [ neg ] map append ] keep
|
||||
cartesian-product [ first2 < ] subset ;
|
||||
|
||||
: quadratic ( b a n -- m )
|
||||
dup sq -rot * + + ;
|
||||
|
||||
: (consecutive-primes) ( b a n -- m )
|
||||
3dup quadratic prime? [ 1+ (consecutive-primes) ] [ 2nip ] if ;
|
||||
|
||||
: consecutive-primes ( a b -- m )
|
||||
swap 0 (consecutive-primes) ;
|
||||
|
||||
: max-consecutive ( seq -- elt n )
|
||||
dup [ first2 consecutive-primes ] map dup supremum
|
||||
over index [ swap nth ] curry 2apply ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: euler027 ( -- answer )
|
||||
source-027 max-consecutive drop product ;
|
||||
|
||||
! [ euler027 ] 100 ave-time
|
||||
! 687 ms run / 23 ms GC ave time - 100 trials
|
||||
|
||||
! TODO: generalize max-consecutive/max-product (from #26) into a new word
|
||||
|
||||
MAIN: euler027
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
! 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
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=28
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! Starting with the number 1 and moving to the right in a clockwise direction a
|
||||
! 5 by 5 spiral is formed as follows:
|
||||
|
||||
! 21 22 23 24 25
|
||||
! 20 7 8 9 10
|
||||
! 19 6 1 2 11
|
||||
! 18 5 4 3 12
|
||||
! 17 16 15 14 13
|
||||
|
||||
! It can be verified that the sum of both diagonals is 101.
|
||||
|
||||
! What is the sum of both diagonals in a 1001 by 1001 spiral formed in the same way?
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
! For a square sized n by n, the sum of corners is 4n² - 6n + 6
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: sum-corners ( n -- sum )
|
||||
dup 1 = [ [ sq 4 * ] keep 6 * - 6 + ] unless ;
|
||||
|
||||
: sum-diags ( n -- sum )
|
||||
1 swap 2 <range> [ sum-corners ] sigma ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: euler028 ( -- answer )
|
||||
1001 sum-diags ;
|
||||
|
||||
! [ euler028 ] 100 ave-time
|
||||
! 0 ms run / 0 ms GC ave time - 100 trials
|
||||
|
||||
MAIN: euler028
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
! 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 ;
|
||||
IN: project-euler.029
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=29
|
||||
|
||||
! DESCRIPTION
|
||||
! -----------
|
||||
|
||||
! Consider all integer combinations of a^b for 2 ≤ a ≤ 5 and 2 ≤ b ≤ 5:
|
||||
|
||||
! 2^2 = 4, 2^3 = 8, 2^4 = 16, 2^5 = 32
|
||||
! 3^2 = 9, 3^3 = 27, 3^4 = 81, 3^5 = 243
|
||||
! 4^2 = 16, 4^3 = 64, 4^4 = 256, 4^5 = 1024
|
||||
! 5^2 = 25, 5^3 = 125, 5^4 = 625, 5^5 = 3125
|
||||
|
||||
! If they are then placed in numerical order, with any repeats removed, we get
|
||||
! the following sequence of 15 distinct terms:
|
||||
|
||||
! 4, 8, 9, 16, 25, 27, 32, 64, 81, 125, 243, 256, 625, 1024, 3125
|
||||
|
||||
! How many distinct terms are in the sequence generated by a^b for 2 ≤ a ≤ 100
|
||||
! and 2 ≤ b ≤ 100?
|
||||
|
||||
|
||||
! SOLUTION
|
||||
! --------
|
||||
|
||||
: euler029 ( -- answer )
|
||||
2 100 [a,b] dup cartesian-product [ first2 ^ ] map prune length ;
|
||||
|
||||
! [ euler029 ] 100 ave-time
|
||||
! 951 ms run / 12 ms GC ave time - 100 trials
|
||||
|
||||
MAIN: euler029
|
||||
|
|
@ -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
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
USING: kernel math math.functions math.miller-rabin math.parser
|
||||
math.primes.factors math.ranges namespaces sequences ;
|
||||
USING: arrays combinators.lib kernel math math.functions math.miller-rabin
|
||||
math.parser math.primes.factors math.ranges namespaces sequences ;
|
||||
IN: project-euler.common
|
||||
|
||||
! A collection of words used by more than one Project Euler solution
|
||||
|
|
@ -7,10 +7,11 @@ IN: project-euler.common
|
|||
|
||||
! Problems using each public word
|
||||
! -------------------------------
|
||||
! cartesian-product - #4, #27
|
||||
! 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
|
||||
|
|
@ -45,6 +46,9 @@ IN: project-euler.common
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: cartesian-product ( seq1 seq2 -- seq1xseq2 )
|
||||
swap [ swap [ 2array ] map-with ] map-with concat ;
|
||||
|
||||
: collect-consecutive ( seq width -- seq )
|
||||
[
|
||||
2dup count-shifts [ 2dup head shift-3rd , ] times
|
||||
|
|
|
|||
|
|
@ -8,7 +8,8 @@ USING: definitions io io.files kernel math.parser sequences vocabs
|
|||
project-euler.013 project-euler.014 project-euler.015 project-euler.016
|
||||
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.067 project-euler.134
|
||||
project-euler.025 project-euler.026 project-euler.027 project-euler.028
|
||||
project-euler.029 project-euler.030 project-euler.067 project-euler.134
|
||||
project-euler.169 project-euler.173 project-euler.175 ;
|
||||
IN: project-euler
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: shufflers help.syntax help.markup ;
|
||||
USING: help.syntax help.markup ;
|
||||
IN: shufflers
|
||||
|
||||
HELP: SHUFFLE:
|
||||
{ $syntax "SHUFFLE: alphabet #" }
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ IN: shufflers
|
|||
: define-shuffles ( names max-out -- )
|
||||
in-shuffle over length make-shuffles [
|
||||
[ shuffle>string create-in ] keep
|
||||
shuffle>quot dupd define-compound put-effect
|
||||
shuffle>quot dupd define put-effect
|
||||
] with each out-shuffle ;
|
||||
|
||||
: SHUFFLE:
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: state-machine
|
|||
";" parse-tokens
|
||||
[ length ] keep
|
||||
unclip add
|
||||
[ create-in swap 1quotation define-compound ] 2each ; parsing
|
||||
[ create-in swap 1quotation define ] 2each ; parsing
|
||||
|
||||
TUPLE: state place data ;
|
||||
|
||||
|
|
@ -27,7 +27,7 @@ M: missing-state error.
|
|||
|
||||
: define-machine ( word state-class -- )
|
||||
execute make-machine
|
||||
>r over r> define-compound
|
||||
>r over r> define
|
||||
"state-table" set-word-prop ;
|
||||
|
||||
: MACHINE:
|
||||
|
|
|
|||
|
|
@ -1,8 +1,14 @@
|
|||
|
||||
USING: math arrays sequences ;
|
||||
|
||||
USING: math arrays sequences kernel splitting strings ;
|
||||
IN: strings.lib
|
||||
|
||||
: char>digit ( c -- i ) 48 - ;
|
||||
|
||||
: string>digits ( s -- seq ) [ char>digit ] { } map-as ;
|
||||
|
||||
: >Upper ( str -- str )
|
||||
dup empty? [
|
||||
unclip ch>upper 1string swap append
|
||||
] unless ;
|
||||
|
||||
: >Upper-dashes ( str -- str )
|
||||
"-" split [ >Upper ] map "-" join ;
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue