From ab7849f71105559a337f81f408cdecccb48bc8f9 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 18 Jan 2008 17:11:06 -0500 Subject: [PATCH 01/38] Use vectors instead of arrays in solution to Project Euler problem 2 --- extra/project-euler/002/002.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index b9375b7d1e..55c1b153cc 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -22,12 +22,12 @@ IN: project-euler.002 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 ; From 827faa205c661af763dd916385330475a2dac8b0 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 18 Jan 2008 20:07:41 -0500 Subject: [PATCH 02/38] Alternate solution to Project Euler problem 2 --- extra/project-euler/002/002.factor | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index 55c1b153cc..b0b21e76e1 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! 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 @@ -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 From 44e9d1fdd098023b6043b0f86c57598c0d00b70e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 19 Jan 2008 05:26:59 -0600 Subject: [PATCH 03/38] Typo in Unit testing docs --- extra/tools/test/test-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor index 48a1192282..32825c965d 100644 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -6,7 +6,7 @@ ARTICLE: "tools.test" "Unit testing" $nl "For example, if you were developing a word for computing symbolic derivatives, your unit tests would apply the word to certain input functions, comparing the results against the correct values. While the passing of these tests would not guarantee the algorithm is correct, it would at least ensure that what used to work keeps working, in that as soon as something breaks due to a change in another part of your program, failing tests will let you know." $nl -"Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } " -tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details." +"Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } "-tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details." $nl "If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run. Test harness files consist mostly of calls to the following two words:" { $subsection unit-test } From 3355b075bbd3b5c3f68162e92835bcdffc70686b Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 19 Jan 2008 15:19:21 -0500 Subject: [PATCH 04/38] Add attribution for alternate solution on PE problem 2 --- extra/project-euler/002/002.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index b0b21e76e1..0b8f773887 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -1,4 +1,4 @@ -! 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 shuffle ; IN: project-euler.002 From 654574181b0c3e5fd481192cc7c10fdfd44018c4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 20 Jan 2008 09:52:50 -0700 Subject: [PATCH 05/38] fix up some old code --- extra/hexdump/hexdump.factor | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/extra/hexdump/hexdump.factor b/extra/hexdump/hexdump.factor index 57bbbe2481..6a91cd65c5 100644 --- a/extra/hexdump/hexdump.factor +++ b/extra/hexdump/hexdump.factor @@ -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 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 - " " concat write + 16 over length - 3 * CHAR: \s write [ dup printable? [ drop CHAR: . ] unless write1 ] each nl ; @@ -19,9 +25,8 @@ PRIVATE> : hexdump ( seq -- str ) [ dup length header. - 16 dup length [ line. ] 2each + 16 [ line. ] each-index ] string-out ; : hexdump. ( seq -- ) hexdump write ; - From 6812eac271fa5beea592ef9630e5371f4e3ca168 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 20 Jan 2008 19:20:28 -0500 Subject: [PATCH 06/38] Solution to Project Euler problem 30 --- extra/project-euler/030/030.factor | 46 ++++++++++++++++++++++++ extra/project-euler/common/common.factor | 2 +- extra/project-euler/project-euler.factor | 4 +-- 3 files changed, 49 insertions(+), 3 deletions(-) create mode 100644 extra/project-euler/030/030.factor diff --git a/extra/project-euler/030/030.factor b/extra/project-euler/030/030.factor new file mode 100644 index 0000000000..854b7ca5ca --- /dev/null +++ b/extra/project-euler/030/030.factor @@ -0,0 +1,46 @@ +! Copyright (c) 2007 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 + +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 diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index d21a780773..c875a440ba 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -11,7 +11,7 @@ IN: project-euler.common ! collect-consecutive - #8, #11 ! log10 - #25, #134 ! max-path - #18, #67 -! number>digits - #16, #20 +! number>digits - #16, #20, #30 ! propagate-all - #18, #67 ! sum-proper-divisors - #21 ! tau* - #12 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 513eeba020..329a1b9668 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -9,8 +9,8 @@ USING: definitions io io.files kernel math.parser sequences vocabs project-euler.017 project-euler.018 project-euler.019 project-euler.020 project-euler.021 project-euler.022 project-euler.023 project-euler.024 project-euler.025 project-euler.026 project-euler.027 project-euler.028 - project-euler.029 project-euler.067 project-euler.134 project-euler.169 - project-euler.173 project-euler.175 ; + project-euler.029 project-euler.030 project-euler.067 project-euler.134 + project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler Date: Sun, 20 Jan 2008 22:30:58 -0500 Subject: [PATCH 07/38] Solution to Project Euler problem 31 --- extra/project-euler/031/031.factor | 63 ++++++++++++++++++++++++++++++ 1 file changed, 63 insertions(+) create mode 100644 extra/project-euler/031/031.factor diff --git a/extra/project-euler/031/031.factor b/extra/project-euler/031/031.factor new file mode 100644 index 0000000000..b4402d8904 --- /dev/null +++ b/extra/project-euler/031/031.factor @@ -0,0 +1,63 @@ +! Copyright (c) 2007 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 +! -------- + += [ [ 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 From 62415768cad61332ea1768e3bb6ee6a1405807dc Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 21 Jan 2008 22:36:20 -0500 Subject: [PATCH 08/38] Minor tweak to math.text.english --- extra/math/text/english/english.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor index a6179382bd..645d7e2054 100644 --- a/extra/math/text/english/english.factor +++ b/extra/math/text/english/english.factor @@ -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 ; + From 7fbee3e810fc8598f899ca74c198461270f91450 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 22 Jan 2008 00:08:27 -0500 Subject: [PATCH 09/38] Solutions to Project Euler problem 32 --- extra/project-euler/032/032.factor | 81 ++++++++++++++++++++++++++++++ 1 file changed, 81 insertions(+) create mode 100644 extra/project-euler/032/032.factor diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor new file mode 100644 index 0000000000..f4d5704e21 --- /dev/null +++ b/extra/project-euler/032/032.factor @@ -0,0 +1,81 @@ +! Copyright (c) 2007 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 + +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 + +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 From cd92504288148cf80310bd553372bf9421d4a2c7 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 22 Jan 2008 17:02:02 -0500 Subject: [PATCH 10/38] Fix copyright date on PE solutions after the new year --- extra/project-euler/023/023.factor | 2 +- extra/project-euler/024/024.factor | 2 +- extra/project-euler/025/025.factor | 2 +- extra/project-euler/026/026.factor | 2 +- extra/project-euler/027/027.factor | 2 +- extra/project-euler/028/028.factor | 2 +- extra/project-euler/029/029.factor | 2 +- extra/project-euler/030/030.factor | 2 +- extra/project-euler/031/031.factor | 2 +- extra/project-euler/032/032.factor | 2 +- 10 files changed, 10 insertions(+), 10 deletions(-) diff --git a/extra/project-euler/023/023.factor b/extra/project-euler/023/023.factor index 06f6555ea3..526bb4c446 100644 --- a/extra/project-euler/023/023.factor +++ b/extra/project-euler/023/023.factor @@ -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 ; diff --git a/extra/project-euler/024/024.factor b/extra/project-euler/024/024.factor index 44434b4a88..230aea02b9 100644 --- a/extra/project-euler/024/024.factor +++ b/extra/project-euler/024/024.factor @@ -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 diff --git a/extra/project-euler/025/025.factor b/extra/project-euler/025/025.factor index 2819e210a7..4eed8b55cb 100644 --- a/extra/project-euler/025/025.factor +++ b/extra/project-euler/025/025.factor @@ -1,4 +1,4 @@ -! 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 ; diff --git a/extra/project-euler/026/026.factor b/extra/project-euler/026/026.factor index d79effed02..3ad1908aa6 100644 --- a/extra/project-euler/026/026.factor +++ b/extra/project-euler/026/026.factor @@ -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 diff --git a/extra/project-euler/027/027.factor b/extra/project-euler/027/027.factor index c208caaf9e..2bc7894684 100644 --- a/extra/project-euler/027/027.factor +++ b/extra/project-euler/027/027.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.primes project-euler.common sequences ; IN: project-euler.027 diff --git a/extra/project-euler/028/028.factor b/extra/project-euler/028/028.factor index 5d20032ea9..c8ac19ef82 100644 --- a/extra/project-euler/028/028.factor +++ b/extra/project-euler/028/028.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: combinators.lib kernel math math.ranges ; IN: project-euler.028 diff --git a/extra/project-euler/029/029.factor b/extra/project-euler/029/029.factor index 47855c0bf1..459a3a4bd6 100644 --- a/extra/project-euler/029/029.factor +++ b/extra/project-euler/029/029.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: hashtables kernel math.functions math.ranges project-euler.common sequences ; diff --git a/extra/project-euler/030/030.factor b/extra/project-euler/030/030.factor index 854b7ca5ca..22d05524b2 100644 --- a/extra/project-euler/030/030.factor +++ b/extra/project-euler/030/030.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: combinators.lib kernel math math.functions project-euler.common sequences ; IN: project-euler.030 diff --git a/extra/project-euler/031/031.factor b/extra/project-euler/031/031.factor index b4402d8904..4be866dc03 100644 --- a/extra/project-euler/031/031.factor +++ b/extra/project-euler/031/031.factor @@ -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 ; IN: project-euler.031 diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor index f4d5704e21..67a8befb0a 100644 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: combinators.lib hashtables kernel math math.combinatorics math.parser math.ranges project-euler.common project-euler.024 sequences sorting ; From 817dfbfbbe18e67da2ee361fc1045e862b1aa34b Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 22 Jan 2008 17:17:04 -0500 Subject: [PATCH 11/38] Add summary for Miller-Rabin vocab, and cleanup tests --- extra/math/miller-rabin/miller-rabin-tests.factor | 4 ++-- extra/math/miller-rabin/summary.txt | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) create mode 100644 extra/math/miller-rabin/summary.txt diff --git a/extra/math/miller-rabin/miller-rabin-tests.factor b/extra/math/miller-rabin/miller-rabin-tests.factor index 42e4164ef3..f8bc9d4970 100644 --- a/extra/math/miller-rabin/miller-rabin-tests.factor +++ b/extra/math/miller-rabin/miller-rabin-tests.factor @@ -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 - diff --git a/extra/math/miller-rabin/summary.txt b/extra/math/miller-rabin/summary.txt new file mode 100644 index 0000000000..b2591a3182 --- /dev/null +++ b/extra/math/miller-rabin/summary.txt @@ -0,0 +1 @@ +Miller-Rabin probabilistic primality test From cf670bd2348fa84cdd51d94de9b67e54a514a0b1 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 22 Jan 2008 17:37:54 -0500 Subject: [PATCH 12/38] Add summary for math.text --- extra/math/text/summary.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 extra/math/text/summary.txt diff --git a/extra/math/text/summary.txt b/extra/math/text/summary.txt new file mode 100644 index 0000000000..95dc6939e2 --- /dev/null +++ b/extra/math/text/summary.txt @@ -0,0 +1 @@ +Convert integers to text in multiple languages From 157043ad199b75d5b09b98fd56bf7519e95a2572 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Jan 2008 02:45:55 -0400 Subject: [PATCH 13/38] Minor I/O backend tweak --- core/io/backend/backend.factor | 3 +++ extra/bootstrap/io/io.factor | 3 --- extra/io/unix/bsd/bsd.factor | 2 +- extra/io/unix/linux/linux.factor | 2 +- extra/io/windows/ce/ce.factor | 2 +- extra/io/windows/nt/nt.factor | 2 +- 6 files changed, 7 insertions(+), 7 deletions(-) mode change 100644 => 100755 core/io/backend/backend.factor mode change 100644 => 100755 extra/io/unix/bsd/bsd.factor mode change 100644 => 100755 extra/io/unix/linux/linux.factor diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor old mode 100644 new mode 100755 index a7736ae47e..6d0a6d5ec5 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -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 ; diff --git a/extra/bootstrap/io/io.factor b/extra/bootstrap/io/io.factor index 238a971e67..065f7dd5c4 100755 --- a/extra/bootstrap/io/io.factor +++ b/extra/bootstrap/io/io.factor @@ -10,6 +10,3 @@ IN: bootstrap.io { [ wince? ] [ "windows.ce" ] } } cond append require ] when - -init-io -init-stdio diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor old mode 100644 new mode 100755 index 8ed84dc305..39eb8b6fb9 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -26,4 +26,4 @@ M: bsd-io init-io ( -- ) M: bsd-io wait-for-process ( pid -- status ) [ kqueue-mx get-global add-pid-task stop ] curry callcc1 ; -T{ bsd-io } io-backend set-global +T{ bsd-io } set-io-backend diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor old mode 100644 new mode 100755 index 180e81e30a..34afc16246 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -14,4 +14,4 @@ M: linux-io init-io ( -- ) M: linux-io wait-for-pid ( pid -- status ) [ kqueue-mx get-global add-pid-task stop ] curry callcc1 ; -T{ linux-io } io-backend set-global +T{ linux-io } set-io-backend diff --git a/extra/io/windows/ce/ce.factor b/extra/io/windows/ce/ce.factor index 9fb0d700d9..a5e0cb6b4a 100755 --- a/extra/io/windows/ce/ce.factor +++ b/extra/io/windows/ce/ce.factor @@ -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 diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index 9ec97b33c6..000d1362b6 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -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 From 81c5b413f489337abf9ea4255d21d4a0ccf23328 Mon Sep 17 00:00:00 2001 From: Slava Date: Wed, 23 Jan 2008 01:49:01 -0500 Subject: [PATCH 14/38] Working on epoll --- extra/io/unix/epoll/epoll.factor | 23 +++++++++++++---------- extra/io/unix/linux/linux.factor | 11 ++++++----- extra/io/unix/unix.factor | 4 ++-- extra/unix/linux/epoll/epoll.factor | 2 +- 4 files changed, 22 insertions(+), 18 deletions(-) diff --git a/extra/io/unix/epoll/epoll.factor b/extra/io/unix/epoll/epoll.factor index f2230f6e81..f0280aac78 100644 --- a/extra/io/unix/epoll/epoll.factor +++ b/extra/io/unix/epoll/epoll.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types kernel io.nonblocking io.unix.backend -bit-arrays sequences assocs unix math namespaces structs ; +bit-arrays sequences assocs unix unix.linux.epoll math +namespaces structs ; IN: io.unix.epoll TUPLE: epoll-mx events ; @@ -18,17 +19,17 @@ TUPLE: epoll-mx events ; GENERIC: io-task-events ( task -- n ) -M: input-task drop EPOLLIN ; +M: input-task io-task-events drop EPOLLIN ; -M: output-task drop EPOLLOUT ; +M: output-task io-task-events drop EPOLLOUT ; : make-event ( task -- event ) "epoll-event" over io-task-events over set-epoll-event-events - over io-task-fd over set-epoll-fd ; + swap io-task-fd over set-epoll-event-fd ; : do-epoll-ctl ( task mx what -- ) - >r >r make-event r> mx-fd r> pick event-data *int roll + >r >r make-event r> mx-fd r> pick epoll-event-fd roll epoll_ctl io-error ; M: epoll-mx register-io-task ( task mx -- ) @@ -37,9 +38,9 @@ M: epoll-mx register-io-task ( task mx -- ) M: epoll-mx unregister-io-task ( task mx -- ) EPOLL_CTL_DEL do-epoll-ctl ; -: wait-kevent ( mx timeout -- n ) - >r mx-fd epoll-mx-events max-events r> epoll_wait - dup multiplexer-error ; +: wait-event ( mx timeout -- n ) + >r { mx-fd epoll-mx-events } get-slots max-events + r> epoll_wait dup multiplexer-error ; : epoll-read-task ( mx fd -- ) over mx-reads at* [ handle-io-task ] [ 2drop ] if ; @@ -51,7 +52,9 @@ M: epoll-mx unregister-io-task ( task mx -- ) epoll-event-fd 2dup epoll-read-task epoll-write-task ; : handle-events ( mx n -- ) - [ over epoll-mx-events kevent-nth handle-kevent ] with each ; + [ + over epoll-mx-events epoll-event-nth handle-event + ] with each ; M: epoll-mx wait-for-events ( ms mx -- ) - dup rot wait-kevent handle-kevents ; + dup rot wait-event handle-events ; diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 180e81e30a..919fba8d5d 100644 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -1,17 +1,18 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.unix.linux -USING: io.unix.backend io.unix.select namespaces kernel assocs ; +USING: io.backend io.unix.backend io.unix.launcher io.unix.epoll +namespaces kernel assocs unix.process ; TUPLE: linux-io ; INSTANCE: linux-io unix-io M: linux-io init-io ( -- ) - start-wait-loop - mx set-global ; + mx set-global + start-wait-loop ; -M: linux-io wait-for-pid ( pid -- status ) - [ kqueue-mx get-global add-pid-task stop ] curry callcc1 ; +M: linux-io wait-for-process ( pid -- status ) + wait-for-pid ; T{ linux-io } io-backend set-global diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index d6d0a9cc22..7dc66a05ad 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -5,6 +5,6 @@ system vocabs.loader ; { { [ bsd? ] [ "io.unix.bsd" ] } { [ macosx? ] [ "io.unix.bsd" ] } - { [ linux? ] [ "io.unix.backend.linux" ] } - { [ solaris? ] [ "io.unix.backend.solaris" ] } + { [ linux? ] [ "io.unix.linux" ] } + { [ solaris? ] [ "io.unix.solaris" ] } } cond require diff --git a/extra/unix/linux/epoll/epoll.factor b/extra/unix/linux/epoll/epoll.factor index 946c387acc..6606c11568 100644 --- a/extra/unix/linux/epoll/epoll.factor +++ b/extra/unix/linux/epoll/epoll.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: unix.linux.epoll -USING: alien.syntax ; +USING: alien.syntax math ; FUNCTION: int epoll_create ( int size ) ; From 09eb56d0c2975a1f5182d721f200536f402f48fd Mon Sep 17 00:00:00 2001 From: Slava Date: Wed, 23 Jan 2008 03:07:15 -0500 Subject: [PATCH 15/38] epoll almost works --- core/io/backend/backend.factor | 4 ++-- extra/io/unix/epoll/epoll.factor | 8 +++++--- extra/io/unix/linux/linux.factor | 2 +- extra/unix/linux/epoll/epoll.factor | 3 ++- 4 files changed, 10 insertions(+), 7 deletions(-) diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 6d0a6d5ec5..9aa1299871 100755 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -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 diff --git a/extra/io/unix/epoll/epoll.factor b/extra/io/unix/epoll/epoll.factor index f0280aac78..1459549f9e 100644 --- a/extra/io/unix/epoll/epoll.factor +++ b/extra/io/unix/epoll/epoll.factor @@ -29,13 +29,15 @@ M: output-task io-task-events drop EPOLLOUT ; swap io-task-fd over set-epoll-event-fd ; : do-epoll-ctl ( task mx what -- ) - >r >r make-event r> mx-fd r> pick epoll-event-fd roll + >r mx-fd r> rot dup io-task-fd swap make-event epoll_ctl io-error ; M: epoll-mx register-io-task ( task mx -- ) - EPOLL_CTL_ADD do-epoll-ctl ; + 2dup EPOLL_CTL_ADD do-epoll-ctl + delegate register-io-task ; M: epoll-mx unregister-io-task ( task mx -- ) + 2dup delegate unregister-io-task EPOLL_CTL_DEL do-epoll-ctl ; : wait-event ( mx timeout -- n ) @@ -46,7 +48,7 @@ M: epoll-mx unregister-io-task ( task mx -- ) over mx-reads at* [ handle-io-task ] [ 2drop ] if ; : epoll-write-task ( mx fd -- ) - over mx-reads at* [ handle-io-task ] [ 2drop ] if ; + over mx-writes at* [ handle-io-task ] [ 2drop ] if ; : handle-event ( mx kevent -- ) epoll-event-fd 2dup epoll-read-task epoll-write-task ; diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index bd1d166252..56032ad019 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -15,4 +15,4 @@ M: linux-io init-io ( -- ) M: linux-io wait-for-process ( pid -- status ) wait-for-pid ; -T{ linux-io } set-io-backend +T{ linux-io } io-backend set-global ! set-io-backend diff --git a/extra/unix/linux/epoll/epoll.factor b/extra/unix/linux/epoll/epoll.factor index 6606c11568..c18fa2ee6c 100644 --- a/extra/unix/linux/epoll/epoll.factor +++ b/extra/unix/linux/epoll/epoll.factor @@ -9,7 +9,8 @@ FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll_event* event ) ; C-STRUCT: epoll-event { "uint" "events" } - { "uint" "fd" } ; + { "uint" "fd" } + { "uint" "padding" } ; FUNCTION: int epoll_wait ( int epfd, epoll_event* events, int maxevents, int timeout ) ; From 42e97d4629fef0610c6fed0198ea6295f168962f Mon Sep 17 00:00:00 2001 From: Slava Date: Wed, 23 Jan 2008 03:30:16 -0500 Subject: [PATCH 16/38] epoll works but not for files; disable it for now --- extra/io/unix/linux/linux.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 56032ad019..06380c7e1e 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -1,7 +1,7 @@ ! 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.epoll +USING: io.backend io.unix.backend io.unix.launcher io.unix.select namespaces kernel assocs unix.process ; TUPLE: linux-io ; @@ -9,10 +9,10 @@ TUPLE: linux-io ; INSTANCE: linux-io unix-io M: linux-io init-io ( -- ) - mx set-global + mx set-global start-wait-loop ; M: linux-io wait-for-process ( pid -- status ) wait-for-pid ; -T{ linux-io } io-backend set-global ! set-io-backend +T{ linux-io } set-io-backend From bc5bc22072f8c1833e82f4631c8ef601e972a183 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Jan 2008 06:31:30 -0400 Subject: [PATCH 17/38] Better dlists behavior --- core/dlists/dlists.factor | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index a3c869efaf..84d68b28aa 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -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 ; From 83d6e10ac030d98f65284b71b373f04ae0d867ed Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Jan 2008 06:32:51 -0400 Subject: [PATCH 18/38] Fix resolver on FreeBSD --- extra/io/sockets/impl/impl.factor | 33 ++++++++++++++++++++----------- 1 file changed, 22 insertions(+), 11 deletions(-) diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor index e490b9312b..e8ab957482 100755 --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -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 r> inet-ntop - swap sockaddr-in-port ntohs ; - + swap sockaddr-in-port ntohs (port) ; M: inet6 inet-ntop ( data addrspec -- str ) drop 16 memory>string 2 [ 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 ; + swap sockaddr-in6-port ntohs (port) ; : addrspec-of-family ( af -- addrspec ) { @@ -102,15 +105,23 @@ M: f parse-sockaddr nip ; [ dup addrinfo-next swap addrinfo>addrspec ] [ ] unfold nip [ ] subset ; +: prepare-resolve-host ( host serv passive? -- host' serv' flags ) + >r + >r string>char-alien r> + dup integer? [ port-override set f ] [ string>char-alien ] if + r> AI_PASSIVE 0 ? ; + M: object resolve-host ( host serv passive? -- seq ) - >r dup integer? [ number>string ] when - "addrinfo" - r> [ AI_PASSIVE over set-addrinfo-flags ] when - PF_UNSPEC over set-addrinfo-family - IPPROTO_TCP over set-addrinfo-protocol - f [ getaddrinfo addrinfo-error ] keep *void* - [ parse-addrinfo-list ] keep - freeaddrinfo ; + [ + prepare-resolve-host + "addrinfo" + [ set-addrinfo-flags ] keep + PF_UNSPEC over set-addrinfo-family + IPPROTO_TCP over set-addrinfo-protocol + f [ getaddrinfo addrinfo-error ] keep *void* + [ parse-addrinfo-list ] keep + freeaddrinfo + ] with-scope ; M: object host-name ( -- name ) 256 dup dup length gethostname From ecc0170afab550777f005235e24a8d2deeb1f878 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 03:20:05 -0400 Subject: [PATCH 19/38] Forgetting a word clears compiled usage --- core/compiler/compiler.factor | 17 +---------------- core/compiler/test/redefine.factor | 11 ++++++++++- core/words/words.factor | 20 ++++++++++++++++++++ 3 files changed, 31 insertions(+), 17 deletions(-) diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 784104d57f..8d9f004270 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -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 ) [ diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 718e98c9c2..266b331ffc 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -1,6 +1,6 @@ USING: compiler definitions generic assocs inference math namespaces parser tools.test words kernel sequences arrays io -effects tools.test.inference compiler.units ; +effects tools.test.inference compiler.units inference.state ; IN: temporary DEFER: x-1 @@ -206,12 +206,15 @@ DEFER: generic-then-not-generic-test-2 [ 4 ] [ generic-then-not-generic-test-2 ] unit-test +DEFER: foldable-test-1 DEFER: foldable-test-2 [ ] [ "IN: temporary : foldable-test-1 3 ; foldable" eval ] unit-test [ ] [ "IN: temporary : foldable-test-2 foldable-test-1 ;" eval ] unit-test +[ +inlined+ ] [ \ foldable-test-2 \ foldable-test-1 compiled-usage at ] unit-test + [ 3 ] [ foldable-test-2 ] unit-test [ ] [ "IN: temporary : foldable-test-1 4 ; foldable" eval ] unit-test @@ -229,3 +232,9 @@ DEFER: flushable-test-2 [ ] [ "IN: temporary USING: kernel sequences ; : flushable-test-1 3 over push ;" eval ] unit-test [ V{ 3 } ] [ flushable-test-2 ] unit-test + +: ax ; +: bx ax ; +[ \ bx forget ] with-compilation-unit + +[ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index 6d8bad4f9e..5dc89212a8 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -87,6 +87,25 @@ M: wrapper (quot-uses) >r wrapped r> (quot-uses) ; M: word uses ( word -- seq ) word-def quot-uses keys ; +SYMBOL: compiled-crossref + +compiled-crossref global [ H{ } assoc-like ] change-at + +: compiled-xref ( word dependencies -- ) + 2dup "compiled-uses" set-word-prop + compiled-crossref get add-vertex* ; + +: compiled-unxref ( word -- ) + dup "compiled-uses" word-prop + compiled-crossref get remove-vertex* ; + +: delete-compiled-xref ( word -- ) + dup compiled-unxref + compiled-crossref get delete-at ; + +: compiled-usage ( word -- assoc ) + compiled-crossref get at ; + M: word redefined* ( word -- ) { "inferred-effect" "base-case" "no-effect" } reset-props ; @@ -187,6 +206,7 @@ M: word (forget-word) : forget-word ( word -- ) dup delete-xref + dup delete-compiled-xref (forget-word) ; M: word forget* forget-word ; From af915caaa358ba74282f1f42997b206517723864 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 03:27:15 -0400 Subject: [PATCH 20/38] Add wait-for-process word to io.launcher; run-process and run-detached now return process tuples --- extra/io/launcher/launcher-docs.factor | 40 +++++++++--- extra/io/launcher/launcher.factor | 43 ++++++++++--- extra/io/windows/launcher/launcher.factor | 66 +++++++++++++++----- extra/io/windows/nt/launcher/launcher.factor | 2 +- extra/windows/kernel32/kernel32.factor | 4 +- 5 files changed, 118 insertions(+), 37 deletions(-) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 7ad5e064bf..2c30431714 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -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+ @@ -58,7 +58,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 +73,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 } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ; + HELP: { $values { "obj" object } { "stream" "a bidirectional stream" } } { $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream." } { $notes "Closing the stream will block until the process exits." } ; -{ run-process run-detached } 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." @@ -108,6 +127,11 @@ $nl "The following words are used to launch processes:" { $subsection run-process } { $subsection run-detached } -{ $subsection } ; +{ $subsection } +{ $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" diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 806b56a092..decf4f3434 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -1,9 +1,17 @@ -! 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 +USING: io io.backend system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader ; IN: io.launcher +TUPLE: process handle status ; + +: ( handle -- process ) f process construct-boa ; + +M: process equal? 2drop f ; + +M: process hashcode* process-handle hashcode* ; + SYMBOL: +command+ SYMBOL: +arguments+ SYMBOL: +detached+ @@ -44,15 +52,32 @@ M: string >descriptor +command+ associate ; M: sequence >descriptor +arguments+ associate ; M: assoc >descriptor ; -HOOK: run-process* io-backend ( desc -- ) +HOOK: run-process* io-backend ( desc -- handle ) -: run-process ( obj -- ) - >descriptor run-process* ; +HOOK: wait-for-process* io-backend ( process -- ) -: run-detached ( obj -- ) - >descriptor H{ { +detached+ t } } union run-process* ; +: wait-for-process ( process -- status ) + dup process-handle [ dup wait-for-process* ] when + process-status ; -HOOK: process-stream* io-backend ( desc -- stream ) +: run-process ( obj -- process ) + >descriptor + dup run-process* + +detached+ rot at [ dup wait-for-process drop ] unless ; + +: run-detached ( obj -- process ) + >descriptor H{ { +detached+ t } } union run-process ; + +HOOK: process-stream* io-backend ( desc -- stream process ) + +TUPLE: process-stream process ; : ( obj -- stream ) - >descriptor process-stream* ; + >descriptor process-stream* + { set-delegate set-process-stream-process } + process-stream construct ; + +: with-process-stream ( obj quot -- process ) + swap + [ swap with-stream ] keep + process-stream-process ; inline diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 136c8197fc..603fa2a638 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -1,11 +1,19 @@ -! 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 ; +sequences windows.errors assocs splitting system threads init ; IN: io.windows.launcher +SYMBOL: processes + +[ H{ } clone processes set-global ] +"io.windows.launcher" add-init-hook + +: ( handle -- process ) + V{ } clone over processes get set-at ; + TUPLE: CreateProcess-args lpApplicationName lpCommandLine @@ -19,13 +27,6 @@ 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 @@ -93,21 +94,52 @@ TUPLE: CreateProcess-args over set-CreateProcess-args-lpEnvironment ] when ; -: wait-for-process ( args -- ) - CreateProcess-args-lpProcessInformation - PROCESS_INFORMATION-hProcess INFINITE - WaitForSingleObject drop ; - : make-CreateProcess-args ( -- args ) default-CreateProcess-args wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if 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 + CreateProcess-args-lpProcessInformation ] with-descriptor ; + +M: windows-io wait-for-process* + [ processes get at push stop ] curry callcc0 ; + +: 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 [ GetExitCodeProcess ] keep *ulong + swap win32-error=0/f ; + +: notify-exit ( process -- ) + dup process-handle exit-code over set-process-status + dup process-handle dispose-process + dup processes get delete-at* drop [ schedule-thread ] each + f swap set-process-handle ; + +: 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 notify-exit 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 ; diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index 3ee0e05e32..6e788003ea 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -59,6 +59,6 @@ M: windows-io process-stream* dup CreateProcess-args-stdout-pipe pipe-in over CreateProcess-args-stdin-pipe pipe-out - swap dispose-CreateProcess-args + swap CreateProcess-args-lpProcessInformation ] with-destructors ] with-descriptor ; diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 5e0f4ddc65..1c75e33698 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -898,7 +898,7 @@ FUNCTION: HANDLE GetCurrentThread ( ) ; ! FUNCTION: GetEnvironmentStringsW ! FUNCTION: GetEnvironmentVariableA ! FUNCTION: GetEnvironmentVariableW -! FUNCTION: GetExitCodeProcess +FUNCTION: BOOL GetExitCodeProcess ( HANDLE hProcess, LPDWORD lpExitCode ) ; ! FUNCTION: GetExitCodeThread ! FUNCTION: GetExpandedNameA ! FUNCTION: GetExpandedNameW @@ -1496,7 +1496,7 @@ FUNCTION: BOOL VirtualQueryEx ( HANDLE hProcess, void* lpAddress, MEMORY_BASIC_I ! FUNCTION: VirtualUnlock ! FUNCTION: WaitCommEvent ! FUNCTION: WaitForDebugEvent -! FUNCTION: WaitForMultipleObjects +FUNCTION: DWORD WaitForMultipleObjects ( DWORD nCount, HANDLE* lpHandles, BOOL bWaitAll, DWORD dwMilliseconds ) ; ! FUNCTION: WaitForMultipleObjectsEx FUNCTION: BOOL WaitForSingleObject ( HANDLE hHandle, DWORD dwMilliseconds ) ; ! FUNCTION: WaitForSingleObjectEx From d621b9852eb6ab3c2127da859f3ef4875c525942 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 03:50:40 -0400 Subject: [PATCH 21/38] Updating extra/ for launcher changes --- extra/editors/editpadpro/editpadpro.factor | 4 +++- extra/editors/editplus/editplus.factor | 4 ++-- extra/editors/emacs/emacs.factor | 7 +++++-- extra/editors/emeditor/emeditor.factor | 5 ++--- extra/editors/notepadpp/notepadpp.factor | 5 +++-- extra/editors/scite/scite.factor | 13 ++++++------- extra/editors/ted-notepad/ted-notepad.factor | 5 ++--- extra/editors/textmate/textmate.factor | 3 ++- extra/editors/ultraedit/ultraedit.factor | 4 ++-- extra/editors/vim/vim.factor | 8 +++++--- extra/editors/wordpad/wordpad.factor | 4 +--- extra/tools/deploy/macosx/macosx.factor | 4 ++-- 12 files changed, 35 insertions(+), 31 deletions(-) mode change 100644 => 100755 extra/editors/editpadpro/editpadpro.factor mode change 100644 => 100755 extra/editors/emacs/emacs.factor mode change 100644 => 100755 extra/editors/notepadpp/notepadpp.factor mode change 100644 => 100755 extra/editors/scite/scite.factor mode change 100644 => 100755 extra/editors/ted-notepad/ted-notepad.factor mode change 100644 => 100755 extra/editors/textmate/textmate.factor mode change 100644 => 100755 extra/editors/ultraedit/ultraedit.factor mode change 100644 => 100755 extra/editors/vim/vim.factor mode change 100644 => 100755 extra/editors/wordpad/wordpad.factor diff --git a/extra/editors/editpadpro/editpadpro.factor b/extra/editors/editpadpro/editpadpro.factor old mode 100644 new mode 100755 index 69a9e2badd..885349e27b --- a/extra/editors/editpadpro/editpadpro.factor +++ b/extra/editors/editpadpro/editpadpro.factor @@ -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 diff --git a/extra/editors/editplus/editplus.factor b/extra/editors/editplus/editplus.factor index bff523b50d..feaa177954 100755 --- a/extra/editors/editplus/editplus.factor +++ b/extra/editors/editplus/editplus.factor @@ -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 diff --git a/extra/editors/emacs/emacs.factor b/extra/editors/emacs/emacs.factor old mode 100644 new mode 100755 index e131179755..31e0761043 --- a/extra/editors/emacs/emacs.factor +++ b/extra/editors/emacs/emacs.factor @@ -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 ; diff --git a/extra/editors/emeditor/emeditor.factor b/extra/editors/emeditor/emeditor.factor index 2caa42b480..bed333694c 100755 --- a/extra/editors/emeditor/emeditor.factor +++ b/extra/editors/emeditor/emeditor.factor @@ -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 diff --git a/extra/editors/notepadpp/notepadpp.factor b/extra/editors/notepadpp/notepadpp.factor old mode 100644 new mode 100755 index 4f3fde917d..f9fa95f175 --- a/extra/editors/notepadpp/notepadpp.factor +++ b/extra/editors/notepadpp/notepadpp.factor @@ -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 diff --git a/extra/editors/scite/scite.factor b/extra/editors/scite/scite.factor old mode 100644 new mode 100755 index 529d11b722..bc9a98a051 --- a/extra/editors/scite/scite.factor +++ b/extra/editors/scite/scite.factor @@ -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 diff --git a/extra/editors/ted-notepad/ted-notepad.factor b/extra/editors/ted-notepad/ted-notepad.factor old mode 100644 new mode 100755 index b56ee0a08b..5d58e182a3 --- a/extra/editors/ted-notepad/ted-notepad.factor +++ b/extra/editors/ted-notepad/ted-notepad.factor @@ -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 diff --git a/extra/editors/textmate/textmate.factor b/extra/editors/textmate/textmate.factor old mode 100644 new mode 100755 index 18c7dbd07e..0145ccae81 --- a/extra/editors/textmate/textmate.factor +++ b/extra/editors/textmate/textmate.factor @@ -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 diff --git a/extra/editors/ultraedit/ultraedit.factor b/extra/editors/ultraedit/ultraedit.factor old mode 100644 new mode 100755 index 50c241daea..7da4b807ce --- a/extra/editors/ultraedit/ultraedit.factor +++ b/extra/editors/ultraedit/ultraedit.factor @@ -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 diff --git a/extra/editors/vim/vim.factor b/extra/editors/vim/vim.factor old mode 100644 new mode 100755 index 040e3fb4b4..8d60942d67 --- a/extra/editors/vim/vim.factor +++ b/extra/editors/vim/vim.factor @@ -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 diff --git a/extra/editors/wordpad/wordpad.factor b/extra/editors/wordpad/wordpad.factor old mode 100644 new mode 100755 index eb882a9e38..0a86250a92 --- a/extra/editors/wordpad/wordpad.factor +++ b/extra/editors/wordpad/wordpad.factor @@ -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 diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 7b44703013..7efb34a6ae 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -8,10 +8,10 @@ QUALIFIED: unix IN: tools.deploy.macosx : touch ( path -- ) - { "touch" } swap add run-process ; + { "touch" } swap add run-process drop ; : rm ( path -- ) - { "rm" "-rf" } swap add run-process ; + { "rm" "-rf" } swap add run-process drop ; : bundle-dir ( -- dir ) vm parent-directory parent-directory ; From 6afa4119c8e3519e182b2163bd0402c79ba5cec4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 04:19:15 -0400 Subject: [PATCH 22/38] Clean up non-blocking wait-for-process support, implement on Unix (untested) --- extra/io/launcher/launcher.factor | 29 +++++++-- extra/io/unix/bsd/bsd.factor | 4 +- extra/io/unix/kqueue/kqueue.factor | 18 ++---- extra/io/unix/launcher/launcher.factor | 63 ++++++++++---------- extra/io/unix/linux/linux.factor | 5 +- extra/io/windows/launcher/launcher.factor | 26 +++----- extra/io/windows/nt/launcher/launcher.factor | 2 +- extra/unix/process/process.factor | 22 +------ 8 files changed, 72 insertions(+), 97 deletions(-) mode change 100644 => 100755 extra/io/unix/kqueue/kqueue.factor mode change 100644 => 100755 extra/unix/process/process.factor diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index decf4f3434..c646358b2e 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -1,12 +1,25 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io io.backend system kernel namespaces strings hashtables -sequences assocs combinators vocabs.loader ; +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 ; -: ( handle -- process ) f process construct-boa ; +HOOK: register-process io-backend ( process -- ) + +M: object register-process drop ; + +: ( handle -- process ) + f process construct-boa + V{ } clone over processes get set-at + dup register-process ; M: process equal? 2drop f ; @@ -54,11 +67,10 @@ M: assoc >descriptor ; HOOK: run-process* io-backend ( desc -- handle ) -HOOK: wait-for-process* io-backend ( process -- ) - : wait-for-process ( process -- status ) - dup process-handle [ dup wait-for-process* ] when - process-status ; + dup process-handle [ + dup [ processes get at push stop ] curry callcc0 + ] when process-status ; : run-process ( obj -- process ) >descriptor @@ -81,3 +93,8 @@ TUPLE: process-stream process ; swap [ 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 ; diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index 39eb8b6fb9..3319324c3d 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -23,7 +23,7 @@ M: bsd-io init-io ( -- ) 2dup mx get-global mx-reads set-at mx get-global mx-writes set-at ; -M: bsd-io wait-for-process ( pid -- status ) - [ kqueue-mx get-global add-pid-task stop ] curry callcc1 ; +M: bsd-io register-process ( process -- ) + process-handle kqueue-mx get-global add-pid-task ; T{ bsd-io } set-io-backend diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor old mode 100644 new mode 100755 index 4fbfbcaaf0..3df2d7cd57 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -5,7 +5,7 @@ sequences assocs unix unix.kqueue unix.process math namespaces combinators threads vectors ; IN: io.unix.kqueue -TUPLE: kqueue-mx events processes ; +TUPLE: kqueue-mx events ; : max-events ( -- n ) #! We read up to 256 events at a time. This is an arbitrary @@ -15,7 +15,6 @@ TUPLE: kqueue-mx events processes ; : ( -- mx ) kqueue-mx construct-mx kqueue dup io-error over set-mx-fd - H{ } clone over set-kqueue-mx-processes max-events "kevent" over set-kqueue-mx-events ; GENERIC: io-task-filter ( task -- n ) @@ -52,9 +51,8 @@ M: kqueue-mx unregister-io-task ( task mx -- ) over mx-reads at handle-io-task ; : kevent-proc-task ( mx pid -- ) - dup (wait-for-pid) spin kqueue-mx-processes delete-at* [ - [ schedule-thread-with ] with each - ] [ 2drop ] if ; + dup (wait-for-pid) swap find-process + dup [ notify-exit ] [ 2drop ] if ; : handle-kevent ( mx kevent -- ) dup kevent-ident swap kevent-filter { @@ -76,11 +74,5 @@ M: kqueue-mx wait-for-events ( ms mx -- ) EVFILT_PROC over set-kevent-filter NOTE_EXIT over set-kevent-fflags ; -: add-pid-task ( continuation pid mx -- ) - 2dup kqueue-mx-processes at* [ - 2nip push - ] [ - drop - over make-proc-kevent over register-kevent - >r >r 1vector r> r> kqueue-mx-processes set-at - ] if ; +: add-pid-task ( pid mx -- ) + swap make-proc-kevent swap register-kevent ; diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index adf571a8b7..3cd21e6c51 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -9,10 +9,6 @@ IN: io.unix.launcher ! Search unix first USE: unix -HOOK: wait-for-process io-backend ( pid -- status ) - -M: unix-io wait-for-process ( pid -- status ) wait-for-pid ; - ! Our command line parser. Supported syntax: ! foo bar baz -- simple tokens ! foo\ bar -- escaping the space @@ -46,7 +42,7 @@ MEMO: 'arguments' ( -- parser ) : assoc>env ( assoc -- env ) [ "=" swap 3append ] { } assoc>map ; -: (spawn-process) ( -- ) +: spawn-process ( -- ) [ get-arguments pass-environment? @@ -55,20 +51,9 @@ MEMO: 'arguments' ( -- parser ) io-error ] [ error. :c flush ] recover 1 exit ; -: spawn-process ( -- pid ) - [ (spawn-process) ] [ ] with-fork ; - -: spawn-detached ( -- ) - [ spawn-process 0 exit ] [ ] with-fork - wait-for-process drop ; - -M: unix-io run-process* ( desc -- ) +M: unix-io run-process* ( desc -- pid ) [ - +detached+ get [ - spawn-detached - ] [ - spawn-process wait-for-process drop - ] if + [ spawn-process ] [ ] with-fork ] with-descriptor ; : open-pipe ( -- pair ) @@ -82,21 +67,35 @@ M: unix-io run-process* ( desc -- ) : spawn-process-stream ( -- in out pid ) open-pipe open-pipe [ setup-stdio-pipe - (spawn-process) + spawn-process ] [ -rot 2dup second close first close - ] with-fork first swap second rot ; - -TUPLE: pipe-stream pid status ; - -: ( in out pid -- stream ) - f pipe-stream construct-boa - -rot handle>duplex-stream over set-delegate ; - -M: pipe-stream stream-close - dup delegate stream-close - dup pipe-stream-pid wait-for-process - swap set-pipe-stream-status ; + ] with-fork first swap second rot ; M: unix-io process-stream* - [ spawn-process-stream ] with-descriptor ; + [ + spawn-process-stream >r handle>duplex-stream r> + ] with-descriptor ; + +: find-process ( handle -- process ) + f process construct-boa processes get at ; + +! 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 tuck WNOHANG waitpid + dup zero? [ + 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 ; diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 06380c7e1e..fcb48dd577 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -10,9 +10,6 @@ INSTANCE: linux-io unix-io M: linux-io init-io ( -- ) mx set-global - start-wait-loop ; - -M: linux-io wait-for-process ( pid -- status ) - wait-for-pid ; + start-wait-thread ; T{ linux-io } set-io-backend diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 603fa2a638..79284b265b 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -6,14 +6,6 @@ math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system threads init ; IN: io.windows.launcher -SYMBOL: processes - -[ H{ } clone processes set-global ] -"io.windows.launcher" add-init-hook - -: ( handle -- process ) - V{ } clone over processes get set-at ; - TUPLE: CreateProcess-args lpApplicationName lpCommandLine @@ -104,12 +96,9 @@ M: windows-io run-process* ( desc -- handle ) [ make-CreateProcess-args dup call-CreateProcess - CreateProcess-args-lpProcessInformation + CreateProcess-args-lpProcessInformation ] with-descriptor ; -M: windows-io wait-for-process* - [ processes get at push stop ] curry callcc0 ; - : dispose-process ( process-information -- ) #! From MSDN: "Handles in PROCESS_INFORMATION must be closed #! with CloseHandle when they are no longer needed." @@ -121,11 +110,10 @@ M: windows-io wait-for-process* 0 [ GetExitCodeProcess ] keep *ulong swap win32-error=0/f ; -: notify-exit ( process -- ) - dup process-handle exit-code over set-process-status - dup process-handle dispose-process - dup processes get delete-at* drop [ schedule-thread ] each - f swap set-process-handle ; +: process-exited ( process -- ) + dup process-handle exit-code + over process-handle dispose-process + swap notify-exit ; : wait-for-processes ( processes -- ? ) keys dup @@ -133,7 +121,7 @@ M: windows-io wait-for-process* dup length swap >c-void*-array 0 0 WaitForMultipleObjects dup HEX: ffffffff = [ win32-error ] when - dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth notify-exit f ] if ; + dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ; : wait-loop ( -- ) processes get dup assoc-empty? @@ -143,3 +131,5 @@ M: windows-io wait-for-process* : start-wait-thread ( -- ) [ wait-loop ] in-thread ; + +[ start-wait-thread ] "io.windows.launcher" add-init-hook diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index 6e788003ea..bfce92e17d 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -59,6 +59,6 @@ M: windows-io process-stream* dup CreateProcess-args-stdout-pipe pipe-in over CreateProcess-args-stdin-pipe pipe-out - swap CreateProcess-args-lpProcessInformation + swap CreateProcess-args-lpProcessInformation ] with-destructors ] with-descriptor ; diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor old mode 100644 new mode 100755 index b2877dc4a1..fb4271ea23 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -31,25 +31,5 @@ IN: unix.process : with-fork ( child parent -- ) fork dup zero? -roll swap curry if ; inline -! Lame polling strategy for getting process exit codes. On -! BSD, we use kqueue which is more efficient. - -SYMBOL: pid-wait - -: (wait-for-pid) ( pid -- status ) - 0 [ 0 waitpid drop ] keep *int ; - : wait-for-pid ( pid -- status ) - [ pid-wait get-global [ ?push ] change-at stop ] curry - callcc1 ; - -: wait-loop ( -- ) - -1 0 tuck WNOHANG waitpid ! &status return - [ *int ] [ pid-wait get delete-at* drop ] bi* ! status ? - [ schedule-thread-with ] with each - 250 sleep - wait-loop ; - -: start-wait-loop ( -- ) - H{ } clone pid-wait set-global - [ wait-loop ] in-thread ; \ No newline at end of file + 0 [ 0 waitpid drop ] keep *int ; \ No newline at end of file From 6d5c1bf1d2ce420da8b9ceafe4a396e6acfec361 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 24 Jan 2008 18:12:39 -0500 Subject: [PATCH 23/38] Add more math.constants --- extra/math/constants/constants-docs.factor | 9 +++++++++ extra/math/constants/constants.factor | 2 ++ 2 files changed, 11 insertions(+) diff --git a/extra/math/constants/constants-docs.factor b/extra/math/constants/constants-docs.factor index 92c96985c3..653444376a 100755 --- a/extra/math/constants/constants-docs.factor +++ b/extra/math/constants/constants-docs.factor @@ -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" } } ; diff --git a/extra/math/constants/constants.factor b/extra/math/constants/constants.factor index e2d7c4f433..7e2b8842ad 100755 --- a/extra/math/constants/constants.factor +++ b/extra/math/constants/constants.factor @@ -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 From 6df78419b9930e3d3a95a39a8abb533c333a63e8 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 24 Jan 2008 18:18:12 -0500 Subject: [PATCH 24/38] Fix uses of new math constants --- extra/golden-section/golden-section.factor | 53 ++++++++++------------ extra/project-euler/025/025.factor | 7 +-- 2 files changed, 27 insertions(+), 33 deletions(-) diff --git a/extra/golden-section/golden-section.factor b/extra/golden-section/golden-section.factor index 9dd3a747ed..ef6f1ca4c2 100644 --- a/extra/golden-section/golden-section.factor +++ b/extra/golden-section/golden-section.factor @@ -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 ] - { 600 600 } over set-slate-dim - "Golden Section" open-window -] with-ui ; + [ + [ display ] + { 600 600 } over set-slate-dim + "Golden Section" open-window + ] with-ui ; -MAIN: golden-section-window \ No newline at end of file +MAIN: golden-section-window diff --git a/extra/project-euler/025/025.factor b/extra/project-euler/025/025.factor index 4eed8b55cb..2786d9f0e6 100644 --- a/extra/project-euler/025/025.factor +++ b/extra/project-euler/025/025.factor @@ -1,7 +1,7 @@ ! 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> integer ; From 42a710e96531576b94011b77aff9a57111b9f3a3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 19:19:45 -0400 Subject: [PATCH 25/38] Update calendar for Windows --- extra/calendar/windows/windows.factor | 38 +----------------- .../time/time-tests.factor} | 0 extra/windows/time/time.factor | 39 +++++++++++++++++++ 3 files changed, 41 insertions(+), 36 deletions(-) mode change 100644 => 100755 extra/calendar/windows/windows.factor rename extra/{calendar/windows/windows-tests.factor => windows/time/time-tests.factor} (100%) create mode 100755 extra/windows/time/time.factor diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor old mode 100644 new mode 100755 index 6c3a7a71e7..320400822c --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -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 ; - -: 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" [ 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" - [ - [ >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 ; diff --git a/extra/calendar/windows/windows-tests.factor b/extra/windows/time/time-tests.factor similarity index 100% rename from extra/calendar/windows/windows-tests.factor rename to extra/windows/time/time-tests.factor diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor new file mode 100755 index 0000000000..3ccb4cfa67 --- /dev/null +++ b/extra/windows/time/time.factor @@ -0,0 +1,39 @@ +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types kernel math windows windows.kernel32 +namespaces calendar.backend ; +IN: windows.time + +: >64bit ( lo hi -- n ) + 32 shift bitor ; + +: windows-1601 ( -- timestamp ) + 1601 1 1 0 0 0 0 ; + +: 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" [ 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" + [ + [ >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 ; From 1249e3a720bd526fb2e61f746a5df50fb480737b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 19:20:07 -0400 Subject: [PATCH 26/38] Move prettyprint:-> to prettyprint.private --- core/prettyprint/prettyprint-docs.factor | 4 ++-- core/prettyprint/prettyprint.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) mode change 100644 => 100755 core/prettyprint/prettyprint-docs.factor diff --git a/core/prettyprint/prettyprint-docs.factor b/core/prettyprint/prettyprint-docs.factor old mode 100644 new mode 100755 index 2b01df8faa..69400d2527 --- a/core/prettyprint/prettyprint-docs.factor +++ b/core/prettyprint/prettyprint-docs.factor @@ -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" diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 45ff0c0572..ed52f0238c 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -86,14 +86,14 @@ combinators quotations ; : .s ( -- ) datastack stack. ; : .r ( -- ) retainstack stack. ; + \ -> { { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } } "word-style" set-word-prop - Date: Thu, 24 Jan 2008 19:20:27 -0400 Subject: [PATCH 27/38] Fix erronous stack effect comment --- extra/cocoa/messages/messages.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor index 33d635c8b7..e2072f441c 100755 --- a/extra/cocoa/messages/messages.factor +++ b/extra/cocoa/messages/messages.factor @@ -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 From 783e63781f1ebdd7c3b3ebc592606c1049d00d78 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 19:21:10 -0400 Subject: [PATCH 28/38] I/O fixes --- extra/io/sockets/impl/impl.factor | 9 +++++++-- extra/io/sockets/sockets.factor | 0 extra/io/windows/nt/backend/backend.factor | 18 ++++++++++-------- 3 files changed, 17 insertions(+), 10 deletions(-) mode change 100644 => 100755 extra/io/sockets/sockets.factor diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor index e8ab957482..ce4d5ad566 100755 --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -106,9 +106,14 @@ M: f parse-sockaddr nip ; [ ] 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 - >r string>char-alien r> - dup integer? [ port-override set f ] [ string>char-alien ] if + dup integer? [ port-override set "http" ] when r> AI_PASSIVE 0 ? ; M: object resolve-host ( host serv passive? -- seq ) diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor old mode 100644 new mode 100755 diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 0d1f2cec0b..82d609c371 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -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 set-global From b5a337bb2a72c6daa5a64127a78ba483dd800a68 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 21:10:17 -0400 Subject: [PATCH 29/38] Fix Linux I/O --- extra/io/unix/launcher/launcher.factor | 2 +- extra/unix/unix.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 3cd21e6c51..769e905b6e 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -84,7 +84,7 @@ M: unix-io process-stream* ! On BSD and Mac OS X, we use kqueue() which scales better. : wait-for-processes ( -- ? ) -1 0 tuck WNOHANG waitpid - dup zero? [ + dup 0 <= [ 2drop t ] [ find-process dup [ diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 16b279765f..f5c484568e 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -13,7 +13,7 @@ TYPEDEF: longlong quad_t TYPEDEF: uint gid_t TYPEDEF: uint in_addr_t TYPEDEF: uint ino_t -TYPEDEF: uint pid_t +TYPEDEF: int pid_t TYPEDEF: uint socklen_t TYPEDEF: uint time_t TYPEDEF: uint uid_t From 0b4be5f0a2e30f9879e9b3106bf79fa7866700d3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 24 Jan 2008 22:41:55 -0600 Subject: [PATCH 30/38] Fix Unix io.launcher --- extra/io/unix/bsd/bsd.factor | 4 ++-- extra/io/unix/kqueue/kqueue.factor | 8 ++++---- extra/io/unix/launcher/launcher.factor | 5 +++-- 3 files changed, 9 insertions(+), 8 deletions(-) diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index 3319324c3d..a4315ce5d0 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.unix.bsd USING: io.backend io.unix.backend io.unix.kqueue io.unix.select -io.unix.launcher namespaces kernel assocs threads continuations -; +io.launcher io.unix.launcher namespaces kernel assocs threads +continuations ; ! On *BSD and Mac OS X, we use select() for the top-level ! multiplexer, and we hang a kqueue off of it but file change diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index 3df2d7cd57..19005df404 100755 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types kernel io.nonblocking io.unix.backend sequences assocs unix unix.kqueue unix.process math namespaces -combinators threads vectors ; +combinators threads vectors io.launcher io.unix.launcher ; IN: io.unix.kqueue TUPLE: kqueue-mx events ; @@ -50,15 +50,15 @@ M: kqueue-mx unregister-io-task ( task mx -- ) : kevent-write-task ( mx fd -- ) over mx-reads at handle-io-task ; -: kevent-proc-task ( mx pid -- ) - dup (wait-for-pid) swap find-process +: kevent-proc-task ( pid -- ) + dup wait-for-pid swap find-process dup [ notify-exit ] [ 2drop ] if ; : handle-kevent ( mx kevent -- ) dup kevent-ident swap kevent-filter { { [ dup EVFILT_READ = ] [ drop kevent-read-task ] } { [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] } - { [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] } + { [ dup EVFILT_PROC = ] [ drop kevent-proc-task drop ] } } cond ; : handle-kevents ( mx n -- ) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 769e905b6e..50c41380d0 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -3,7 +3,7 @@ USING: io io.backend io.launcher io.unix.backend io.nonblocking sequences kernel namespaces math system alien.c-types debugger continuations arrays assocs combinators unix.process -parser-combinators memoize promises strings ; +parser-combinators memoize promises strings threads ; IN: io.unix.launcher ! Search unix first @@ -78,7 +78,8 @@ M: unix-io process-stream* ] with-descriptor ; : find-process ( handle -- process ) - f process construct-boa processes get at ; + 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. From 9cc5f5c78ed1ed0013fab524081de5b95ce7252a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 24 Jan 2008 23:07:14 -0600 Subject: [PATCH 31/38] Fix construct-empty transform --- core/inference/transforms/transforms.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index eabe4b8c2a..c4eeb98145 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -74,7 +74,7 @@ M: pair (bitfield-quot) ( spec -- quot ) dup tuple-size [ ] 2curry swap infer-quot ] [ - \ construct-empty declared-infer + \ construct-empty 1 1 make-call-node ] if ] "infer" set-word-prop From 00d2122a4c3f10419a0a379e0d2861c73ce4c5e5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 23:45:56 -0400 Subject: [PATCH 32/38] Working on Unix io.launcher redirection --- extra/io/launcher/launcher-docs.factor | 30 ++++++++++++++++++++++++++ extra/io/launcher/launcher.factor | 4 ++++ extra/io/unix/files/files.factor | 6 ++++-- extra/io/unix/launcher/launcher.factor | 13 +++++++++++ 4 files changed, 51 insertions(+), 2 deletions(-) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 2c30431714..495894b25d 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -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 diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index c646358b2e..fe3244916d 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -30,6 +30,10 @@ SYMBOL: +arguments+ SYMBOL: +detached+ SYMBOL: +environment+ SYMBOL: +environment-mode+ +SYMBOL: +stdin+ +SYMBOL: +stdout+ +SYMBOL: +stderr+ +SYMBOL: +closed+ SYMBOL: prepend-environment SYMBOL: replace-environment diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index f9d642d661..b56e62d3c4 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -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 ( path -- stream ) open-read ; -: 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 ( path -- stream ) M: unix-io ( path -- stream ) open-write ; -: 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 diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 50c41380d0..6439fc0848 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -42,8 +42,21 @@ MEMO: 'arguments' ( -- parser ) : assoc>env ( assoc -- env ) [ "=" swap 3append ] { } assoc>map ; +: redirect ( obj mode fd -- ) + { + { [ pick not ] [ 3drop ] } + { [ pick +closed+ eq? ] [ close 3drop ] } + { [ t ] [ >r file-mode open dup io-error r> dup2 io-error ] } + } cond ; + +: setup-redirection ( -- ) + +stdin+ get read-flags 0 redirect + +stdout+ get write-flags 1 redirect + +stderr+ get read-flags 2 redirect ; + : spawn-process ( -- ) [ + setup-redirection get-arguments pass-environment? [ get-environment assoc>env exec-args-with-env ] From 62f076d0c3fa2fe1f880449d7473689b9e39e9a8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 23:48:28 -0400 Subject: [PATCH 33/38] Fix FD leak --- extra/io/unix/launcher/launcher.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 6439fc0848..1e4d5fab52 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -42,11 +42,15 @@ MEMO: 'arguments' ( -- parser ) : assoc>env ( assoc -- env ) [ "=" swap 3append ] { } assoc>map ; +: (redirect) + >r file-mode open dup io-error dup + r> dup2 io-error close drop ; + : redirect ( obj mode fd -- ) { { [ pick not ] [ 3drop ] } { [ pick +closed+ eq? ] [ close 3drop ] } - { [ t ] [ >r file-mode open dup io-error r> dup2 io-error ] } + { [ t ] [ (redirect) ] } } cond ; : setup-redirection ( -- ) From 35f390e8ca17adaa3e277e479e03b135631b49cd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 23:50:00 -0400 Subject: [PATCH 34/38] Remove unnecessary word --- core/io/io-docs.factor | 5 ----- core/io/io.factor | 6 +++--- 2 files changed, 3 insertions(+), 8 deletions(-) mode change 100644 => 100755 core/io/io-docs.factor diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor old mode 100644 new mode 100755 index 5c71714c64..cf867d7945 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -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." } diff --git a/core/io/io.factor b/core/io/io.factor index 56b284eaaf..edd0fa938f 100755 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -38,8 +38,6 @@ SYMBOL: stdio ! Default error stream SYMBOL: stderr -: close ( -- ) stdio get stream-close ; - : readln ( -- str/f ) stdio get stream-readln ; : read1 ( -- ch/f ) stdio get stream-read1 ; : read ( n -- str/f ) stdio get stream-read ; @@ -56,7 +54,9 @@ SYMBOL: stderr stdio swap with-variable ; inline : with-stream ( stream quot -- ) - swap [ [ close ] [ ] cleanup ] with-stream* ; inline + swap [ + [ stdio get stream-close ] [ ] cleanup + ] with-stream* ; inline : tabular-output ( style quot -- ) swap >r { } make r> stdio get stream-write-table ; inline From d09bc942ac96acbeb1287dd4e143176c4e7f2b56 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 25 Jan 2008 00:21:49 -0600 Subject: [PATCH 35/38] Get file redirection working in Unix io.launcher --- extra/io/launcher/launcher.factor | 2 +- extra/io/unix/launcher/launcher.factor | 19 ++++++++++--------- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index fe3244916d..7cf9d51ed0 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -67,7 +67,7 @@ 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 -- handle ) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 1e4d5fab52..0135b55a7e 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.backend io.launcher io.unix.backend io.nonblocking -sequences kernel namespaces math system alien.c-types debugger -continuations arrays assocs combinators unix.process -parser-combinators memoize promises strings threads ; +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,21 +43,21 @@ MEMO: 'arguments' ( -- parser ) : assoc>env ( assoc -- env ) [ "=" swap 3append ] { } assoc>map ; -: (redirect) +: (redirect) ( path mode fd -- ) >r file-mode open dup io-error dup - r> dup2 io-error close drop ; + r> dup2 io-error close ; : redirect ( obj mode fd -- ) { { [ pick not ] [ 3drop ] } - { [ pick +closed+ eq? ] [ close 3drop ] } - { [ t ] [ (redirect) ] } + { [ 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 read-flags 2 redirect ; + +stderr+ get write-flags 2 redirect ; : spawn-process ( -- ) [ From 034b4dcaa66a557b439ce46e2c4bfd8be8ef8afd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 25 Jan 2008 01:49:03 -0400 Subject: [PATCH 36/38] Windows launcher work in progress --- extra/io/windows/launcher/launcher.factor | 72 +++++++++++++++++--- extra/io/windows/nt/launcher/launcher.factor | 14 +--- extra/io/windows/{nt => }/pipes/pipes.factor | 10 +-- extra/io/windows/windows.factor | 10 ++- 4 files changed, 75 insertions(+), 31 deletions(-) rename extra/io/windows/{nt => }/pipes/pipes.factor (84%) diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 79284b265b..6d7a96b069 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -1,9 +1,10 @@ ! 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 threads init ; +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 @@ -86,18 +87,73 @@ TUPLE: CreateProcess-args over set-CreateProcess-args-lpEnvironment ] when ; +: (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 f ] } + { [ pick string? ] [ (redirect) ] } + } cond ; + +: 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 or ; + +: inherited-stderr ( args -- handle ) + CreateProcess-args-stdout-pipe + [ pipe-out ] [ STD_ERROR_HANDLE GetStdHandle ] if* ; + +: redirect-stderr ( args -- handle ) + +stderr+ get GENERIC_WRITE CREATE_ALWAYS redirect + swap inherited-stderr or ; + +: 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 or ; + +: 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 wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if fill-dwCreateFlags - fill-lpEnvironment ; + fill-lpEnvironment + fill-startup-info ; M: windows-io run-process* ( desc -- handle ) [ - make-CreateProcess-args - dup call-CreateProcess - CreateProcess-args-lpProcessInformation - ] with-descriptor ; + [ + make-CreateProcess-args + dup call-CreateProcess + CreateProcess-args-lpProcessInformation + ] with-descriptor + ] with-destructors ; : dispose-process ( process-information -- ) #! From MSDN: "Handles in PROCESS_INFORMATION must be closed diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index bfce92e17d..f548c5945c 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -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,17 +30,6 @@ 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* [ [ @@ -49,7 +38,6 @@ M: windows-io process-stream* fill-stdout-pipe fill-stdin-pipe - fill-startup-info dup call-CreateProcess diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/pipes/pipes.factor similarity index 84% rename from extra/io/windows/nt/pipes/pipes.factor rename to extra/io/windows/pipes/pipes.factor index a10a98bd30..8c2acc4009 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/pipes/pipes.factor @@ -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" - "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 diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 8dcb138999..efac6cb1cc 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -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" + "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 ; From 993684ebb001b01521dd472809b54e4e4d9ddc8a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 25 Jan 2008 02:21:27 -0400 Subject: [PATCH 37/38] More work in progress --- extra/io/windows/launcher/launcher.factor | 7 ++++--- extra/io/windows/nt/launcher/launcher.factor | 2 +- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 6d7a96b069..bd2a4adb6e 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -26,11 +26,13 @@ TUPLE: CreateProcess-args "STARTUPINFO" "STARTUPINFO" heap-size over set-STARTUPINFO-cb "PROCESS_INFORMATION" + 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 -- ) @@ -143,13 +145,12 @@ TUPLE: CreateProcess-args default-CreateProcess-args wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if fill-dwCreateFlags - fill-lpEnvironment - fill-startup-info ; + fill-lpEnvironment ; M: windows-io run-process* ( desc -- handle ) [ [ - make-CreateProcess-args + make-CreateProcess-args fill-startup-info dup call-CreateProcess CreateProcess-args-lpProcessInformation ] with-descriptor diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index f548c5945c..c2f14c21bb 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -34,10 +34,10 @@ M: windows-io process-stream* [ [ make-CreateProcess-args - TRUE over set-CreateProcess-args-bInheritHandles fill-stdout-pipe fill-stdin-pipe + fill-startup-info dup call-CreateProcess From 76e4702f38b04f23be87671a7d0539a769406708 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 25 Jan 2008 02:37:37 -0400 Subject: [PATCH 38/38] Got Windows launcher redirection working --- extra/io/launcher/launcher-docs.factor | 5 +++++ extra/io/windows/launcher/launcher.factor | 15 +++++++-------- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 495894b25d..28063bae0d 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -154,9 +154,14 @@ $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 } +"Redirecting standard input and output to a pipe:" { $subsection } { $subsection with-process-stream } "A class representing an active or finished process:" diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index bd2a4adb6e..7b793ef74d 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -21,14 +21,12 @@ TUPLE: CreateProcess-args stdout-pipe stdin-pipe ; : default-CreateProcess-args ( -- obj ) - 0 0 "STARTUPINFO" "STARTUPINFO" heap-size over set-STARTUPINFO-cb "PROCESS_INFORMATION" TRUE { - set-CreateProcess-args-bInheritHandles set-CreateProcess-args-dwCreateFlags set-CreateProcess-args-lpStartupInfo set-CreateProcess-args-lpProcessInformation @@ -103,25 +101,26 @@ TUPLE: CreateProcess-args : redirect ( obj access-mode create-mode -- handle ) { { [ pick not ] [ 3drop f ] } - { [ pick +closed+ eq? ] [ 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 or ; + swap inherited-stdout ?closed ; : inherited-stderr ( args -- handle ) - CreateProcess-args-stdout-pipe - [ pipe-out ] [ STD_ERROR_HANDLE GetStdHandle ] if* ; + drop STD_ERROR_HANDLE GetStdHandle ; : redirect-stderr ( args -- handle ) +stderr+ get GENERIC_WRITE CREATE_ALWAYS redirect - swap inherited-stderr or ; + swap inherited-stderr ?closed ; : inherited-stdin ( args -- handle ) CreateProcess-args-stdin-pipe @@ -129,7 +128,7 @@ TUPLE: CreateProcess-args : redirect-stdin ( args -- handle ) +stdin+ get GENERIC_READ OPEN_EXISTING redirect - swap inherited-stdin or ; + swap inherited-stdin ?closed ; : fill-startup-info dup CreateProcess-args-lpStartupInfo