From d5ac6de191b6d627a9783c8abb4a82a814b98cc2 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 25 Jan 2008 01:44:43 -0600 Subject: [PATCH 01/66] Add 'compiler' tag to some vocabs --- core/cpu/architecture/tags.txt | 1 + core/cpu/arm/tags.txt | 1 + core/cpu/ppc/tags.txt | 1 + core/cpu/x86/32/tags.txt | 1 + core/cpu/x86/64/tags.txt | 1 + 5 files changed, 5 insertions(+) create mode 100644 core/cpu/architecture/tags.txt create mode 100644 core/cpu/arm/tags.txt create mode 100644 core/cpu/ppc/tags.txt create mode 100644 core/cpu/x86/32/tags.txt create mode 100644 core/cpu/x86/64/tags.txt diff --git a/core/cpu/architecture/tags.txt b/core/cpu/architecture/tags.txt new file mode 100644 index 0000000000..86a7c8e637 --- /dev/null +++ b/core/cpu/architecture/tags.txt @@ -0,0 +1 @@ +compiler diff --git a/core/cpu/arm/tags.txt b/core/cpu/arm/tags.txt new file mode 100644 index 0000000000..86a7c8e637 --- /dev/null +++ b/core/cpu/arm/tags.txt @@ -0,0 +1 @@ +compiler diff --git a/core/cpu/ppc/tags.txt b/core/cpu/ppc/tags.txt new file mode 100644 index 0000000000..86a7c8e637 --- /dev/null +++ b/core/cpu/ppc/tags.txt @@ -0,0 +1 @@ +compiler diff --git a/core/cpu/x86/32/tags.txt b/core/cpu/x86/32/tags.txt new file mode 100644 index 0000000000..86a7c8e637 --- /dev/null +++ b/core/cpu/x86/32/tags.txt @@ -0,0 +1 @@ +compiler diff --git a/core/cpu/x86/64/tags.txt b/core/cpu/x86/64/tags.txt new file mode 100644 index 0000000000..86a7c8e637 --- /dev/null +++ b/core/cpu/x86/64/tags.txt @@ -0,0 +1 @@ +compiler From c770e5d5862cdc807f2ca5cb525e2d840061dbdf Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 27 Jan 2008 20:00:31 -0500 Subject: [PATCH 02/66] Fix nPk and add permutation words to math.combinatorics; including docs/tests --- extra/math/combinatorics/authors.txt | 1 + .../combinatorics/combinatorics-docs.factor | 49 +++++++++++++++++ .../combinatorics/combinatorics-tests.factor | 50 +++++++++++++++++ extra/math/combinatorics/combinatorics.factor | 54 +++++++++++++++---- extra/math/constants/constants.factor | 2 +- 5 files changed, 144 insertions(+), 12 deletions(-) create mode 100644 extra/math/combinatorics/combinatorics-docs.factor create mode 100644 extra/math/combinatorics/combinatorics-tests.factor diff --git a/extra/math/combinatorics/authors.txt b/extra/math/combinatorics/authors.txt index f372b574ae..708cc3e23e 100644 --- a/extra/math/combinatorics/authors.txt +++ b/extra/math/combinatorics/authors.txt @@ -1,2 +1,3 @@ Slava Pestov Doug Coleman +Aaron Schaefer diff --git a/extra/math/combinatorics/combinatorics-docs.factor b/extra/math/combinatorics/combinatorics-docs.factor new file mode 100644 index 0000000000..c763cc32cf --- /dev/null +++ b/extra/math/combinatorics/combinatorics-docs.factor @@ -0,0 +1,49 @@ +USING: help.markup help.syntax kernel math sequences ; +IN: math.combinatorics + +HELP: factorial +{ $values { "n" "a non-negative integer" } { "n!" integer } } +{ $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." } +{ $examples { $example "4 factorial ." "24" } } ; + +HELP: nPk +{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } } +{ $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." } +{ $examples { $example "10 4 nPk ." "5040" } } ; + +HELP: nCk +{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } } +{ $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." } +{ $examples { $example "10 4 nCk ." "210" } } ; + +HELP: permutation +{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } } +{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." } +{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." } +{ $examples { $example "1 3 permutation ." "{ 0 2 1 }" } { $example "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\"}" } } ; + +HELP: all-permutations +{ $values { "seq" sequence } { "seq" sequence } } +{ $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." } +{ $examples { $example "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ; + +HELP: inverse-permutation +{ $values { "seq" sequence } { "permutation" sequence } } +{ $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." } +{ $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." } +{ $examples { $example "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ; + + +IN: math.combinatorics.private + +HELP: factoradic +{ $values { "n" integer } { "seq" sequence } } +{ $description "Converts a positive integer " { $snippet "n" } " to factoradic form. The factoradic of an integer is its representation based on a mixed radix numerical system that corresponds to the values of " { $snippet "n" } " factorial." } +{ $examples { $example "859 factoradic ." "{ 1 1 0 3 0 1 0 }" } } ; + +HELP: >permutation +{ $values { "factoradic" sequence } { "permutation" sequence } } +{ $description "Converts an integer represented in factoradic form into its corresponding unique permutation (0-based)." } +{ $notes "For clarification, the following two statements are equivalent:" { $code "10 factoradic >permutation" "{ 1 2 0 0 } >permutation" } } +{ $examples { $example "{ 0 0 0 0 } >permutation ." "{ 0 1 2 3 }" } } ; + diff --git a/extra/math/combinatorics/combinatorics-tests.factor b/extra/math/combinatorics/combinatorics-tests.factor new file mode 100644 index 0000000000..440630e38f --- /dev/null +++ b/extra/math/combinatorics/combinatorics-tests.factor @@ -0,0 +1,50 @@ +USING: math.combinatorics math.combinatorics.private tools.test ; +IN: temporary + +[ { } ] [ 0 factoradic ] unit-test +[ { 1 0 } ] [ 1 factoradic ] unit-test +[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test + +[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test +[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test +[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test + +[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test +[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test +[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test + +[ { "b" "d" } ] [ { "a" "b" "c" "d" } { 1 3 } reorder ] unit-test +[ { "a" "b" "c" "d" } ] [ { "a" "b" "c" "d" } { 0 1 2 3 } reorder ] unit-test +[ { "d" "c" "b" "a" } ] [ { "a" "b" "c" "d" } { 3 2 1 0 } reorder ] unit-test +[ { "d" "a" "b" "c" } ] [ { "a" "b" "c" "d" } { 3 0 1 2 } reorder ] unit-test + +[ 1 ] [ 0 factorial ] unit-test +[ 1 ] [ 1 factorial ] unit-test +[ 3628800 ] [ 10 factorial ] unit-test + +[ 1 ] [ 3 0 nPk ] unit-test +[ 6 ] [ 3 2 nPk ] unit-test +[ 6 ] [ 3 3 nPk ] unit-test +[ 0 ] [ 3 4 nPk ] unit-test +[ 311875200 ] [ 52 5 nPk ] unit-test +[ 672151459757865654763838640470031391460745878674027315200000000000 ] [ 52 47 nPk ] unit-test + +[ 1 ] [ 3 0 nCk ] unit-test +[ 3 ] [ 3 2 nCk ] unit-test +[ 1 ] [ 3 3 nCk ] unit-test +[ 0 ] [ 3 4 nCk ] unit-test +[ 2598960 ] [ 52 5 nCk ] unit-test +[ 2598960 ] [ 52 47 nCk ] unit-test + +[ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test +[ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test +[ { "d" "a" "b" "c" } ] [ 18 { "a" "b" "c" "d" } permutation ] unit-test + +[ { { "a" "b" "c" } { "a" "c" "b" } + { "b" "a" "c" } { "b" "c" "a" } + { "c" "a" "b" } { "c" "b" "a" } } ] [ { "a" "b" "c" } all-permutations ] unit-test + +[ { 0 1 2 } ] [ { "a" "b" "c" } inverse-permutation ] unit-test +[ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test +[ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test + diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor index a0f331e6f6..99a098ca09 100644 --- a/extra/math/combinatorics/combinatorics.factor +++ b/extra/math/combinatorics/combinatorics.factor @@ -1,21 +1,53 @@ -USING: kernel math math.ranges math.vectors -sequences sorting mirrors assocs ; +! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs kernel math math.ranges mirrors namespaces sequences sorting ; IN: math.combinatorics -: possible? 0 rot between? ; inline + [ dupd - ] when ; inline -: (nCk) ( n k -- nCk ) - [ nPk ] 2keep - factorial / ; +! See this article for explanation of the factoradic-based permutation methodology: +! http://msdn2.microsoft.com/en-us/library/aa302371.aspx -: twiddle 2dup - dupd < [ dupd - ] when ; inline +: factoradic ( n -- factoradic ) + 0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] unfold reverse 2nip ; + +: (>permutation) ( seq n -- seq ) + [ [ dupd >= [ 1+ ] when ] curry map ] keep add* ; + +: >permutation ( factoradic -- permutation ) + reverse 1 cut [ (>permutation) ] each ; + +: permutation-indices ( n seq -- permutation ) + length [ factoradic ] dip 0 pad-left >permutation ; + +: reorder ( seq indices -- seq ) + [ [ over nth , ] each drop ] { } make ; + +PRIVATE> + +: factorial ( n -- n! ) + 1 [ 1+ * ] reduce ; + +: nPk ( n k -- nPk ) + 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ; : nCk ( n k -- nCk ) - 2dup possible? [ twiddle (nCk) ] [ 2drop 0 ] if ; + twiddle [ nPk ] keep factorial / ; -: inverse-permutation ( seq -- seq ) +: permutation ( n seq -- seq ) + tuck permutation-indices reorder ; + +: all-permutations ( seq -- seq ) + [ + [ length factorial ] keep [ permutation , ] curry each + ] { } make ; + +: inverse-permutation ( seq -- permutation ) >alist sort-values keys ; + diff --git a/extra/math/constants/constants.factor b/extra/math/constants/constants.factor index 7e2b8842ad..c4abeca0eb 100755 --- a/extra/math/constants/constants.factor +++ b/extra/math/constants/constants.factor @@ -4,6 +4,6 @@ IN: math.constants : e ( -- e ) 2.7182818284590452354 ; inline : gamma ( -- gamma ) 0.57721566490153286060 ; inline -: pi ( -- pi ) 3.14159265358979323846 ; inline : phi ( -- phi ) 1.61803398874989484820 ; inline +: pi ( -- pi ) 3.14159265358979323846 ; inline : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline From 5da9faa71c6e24307b468f216511c896adc91824 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 27 Jan 2008 20:09:31 -0500 Subject: [PATCH 03/66] Update math.combinatorics dependencies in PE solutions --- extra/project-euler/024/024.factor | 19 +------------------ extra/project-euler/032/032.factor | 2 +- 2 files changed, 2 insertions(+), 19 deletions(-) diff --git a/extra/project-euler/024/024.factor b/extra/project-euler/024/024.factor index 230aea02b9..c795fc0169 100644 --- a/extra/project-euler/024/024.factor +++ b/extra/project-euler/024/024.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.parser math.ranges namespaces sequences ; +USING: kernel math.combinatorics math.parser ; IN: project-euler.024 ! http://projecteuler.net/index.php?section=problems&id=24 @@ -22,23 +22,6 @@ IN: project-euler.024 ! SOLUTION ! -------- -permutation) ( seq n -- seq ) - [ [ dupd >= [ 1+ ] when ] curry map ] keep add* ; - -PRIVATE> - -: >permutation ( factoradic -- permutation ) - reverse 1 cut [ (>permutation) ] each ; - -: factoradic ( k order -- factoradic ) - [ [1,b] [ 2dup mod , /i ] each ] { } make reverse nip ; - -: permutation ( k seq -- seq ) - dup length swapd factoradic >permutation - [ [ dupd swap nth , ] each drop ] { } make ; - : euler024 ( -- answer ) 999999 10 permutation 10 swap digits>integer ; diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor index 67a8befb0a..d10326a076 100644 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -1,7 +1,7 @@ ! 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 ; + math.ranges project-euler.common sequences sorting ; IN: project-euler.032 ! http://projecteuler.net/index.php?section=problems&id=32 From 83aa8d0d6e437f245e464d6079056da2e5111ab0 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 27 Jan 2008 19:10:28 -0600 Subject: [PATCH 04/66] Fix wait loop bug (fixed by Slava) --- extra/io/unix/linux/linux.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index fcb48dd577..6d55decb5a 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -2,14 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.unix.linux USING: io.backend io.unix.backend io.unix.launcher io.unix.select -namespaces kernel assocs unix.process ; +namespaces kernel assocs unix.process init ; TUPLE: linux-io ; INSTANCE: linux-io unix-io M: linux-io init-io ( -- ) - mx set-global - start-wait-thread ; + mx set-global ; T{ linux-io } set-io-backend + +[ start-wait-thread ] "io.unix.linux" add-init-hook \ No newline at end of file From cf299210838b5cdb485f3c213589ce0f47fe157b Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 27 Jan 2008 23:54:38 -0600 Subject: [PATCH 05/66] Unicode breaks fix and deletion of repetition in syntax --- extra/unicode/breaks/breaks-tests.factor | 4 +- extra/unicode/breaks/breaks.factor | 47 ++++++++++-------------- extra/unicode/syntax/syntax.factor | 8 ---- 3 files changed, 22 insertions(+), 37 deletions(-) diff --git a/extra/unicode/breaks/breaks-tests.factor b/extra/unicode/breaks/breaks-tests.factor index c183c3a86e..26f419ff0e 100644 --- a/extra/unicode/breaks/breaks-tests.factor +++ b/extra/unicode/breaks/breaks-tests.factor @@ -3,5 +3,5 @@ USING: tools.test unicode.breaks sequences math kernel ; [ "\u1112\u1161\u11abA\u0300a\r\r\n" ] [ "\r\n\raA\u0300\u1112\u1161\u11ab" string-reverse ] unit-test [ "dcba" ] [ "abcd" string-reverse ] unit-test -[ 3 ] [ "\u1112\u1161\u11abA\u0300a" [ length 1- ] keep - [ prev-grapheme ] keep prev-grapheme ] unit-test +[ 3 ] [ "\u1112\u1161\u11abA\u0300a" + dup last-grapheme head last-grapheme ] unit-test diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index fb893ed51b..9c9242edc3 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -85,45 +85,38 @@ DEFER: grapheme-table : chars ( i str n -- str[i] str[i+n] ) swap >r dupd + r> [ ?nth ] curry 2apply ; -: next-grapheme-step ( i str -- i+1 str prev-class ) - 2dup nth grapheme-class >r >r 1+ r> r> ; +: find-index ( seq quot -- i ) find drop ; inline +: find-last-index ( seq quot -- i ) find-last drop ; inline -: (next-grapheme) ( i str prev-class -- next-i ) - 3dup drop bounds-check? [ - >r next-grapheme-step r> over grapheme-break? - [ 2drop 1- ] [ (next-grapheme) ] if - ] [ 2drop ] if ; +: first-grapheme ( str -- i ) + unclip-slice grapheme-class over + [ grapheme-class tuck grapheme-break? ] find-index + nip swap length or 1+ ; -: next-grapheme ( i str -- next-i ) - next-grapheme-step (next-grapheme) ; +: (>graphemes) ( str -- ) + dup empty? [ drop ] [ + dup first-grapheme cut-slice + swap , (>graphemes) + ] if ; -: (>graphemes) ( i str -- ) - 2dup bounds-check? [ - dupd [ next-grapheme ] keep - [ subseq , ] 2keep (>graphemes) - ] [ 2drop ] if ; : >graphemes ( str -- graphemes ) - [ 0 swap (>graphemes) ] { } make* ; + [ (>graphemes) ] { } make ; : string-reverse ( str -- rts ) >graphemes reverse concat ; -: prev-grapheme-step ( i str -- i-1 str prev-class ) - 2dup nth grapheme-class >r >r 1- r> r> ; +: unclip-last-slice ( seq -- beginning last ) + dup 1 head-slice* swap peek ; -: (prev-grapheme) ( i str next-class -- prev-i ) - pick zero? [ - >r prev-grapheme-step r> dupd grapheme-break? - [ 2drop 1- ] [ (prev-grapheme) ] if - ] [ 2drop ] if ; +: last-grapheme ( str -- i ) + unclip-last-slice grapheme-class swap + [ grapheme-class dup rot grapheme-break? ] find-last-index + nip -1 or 1+ ; -: prev-grapheme ( i str -- prev-i ) - prev-grapheme-step (prev-grapheme) ; - -[ +<< other-extend-lines process-other-extend \ other-extend define-value init-grapheme-table table [ make-grapheme-table finish-table ] with-variable \ grapheme-table define-value -] with-compilation-unit +>> diff --git a/extra/unicode/syntax/syntax.factor b/extra/unicode/syntax/syntax.factor index 91d46d179f..5119663872 100644 --- a/extra/unicode/syntax/syntax.factor +++ b/extra/unicode/syntax/syntax.factor @@ -47,14 +47,6 @@ IN: unicode.syntax CREATE ";" parse-tokens categories swap seq-minus define-category ; parsing -TUPLE: code-point lower title upper ; - -C: code-point - -: set-code-point ( seq -- ) - 4 head [ multihex ] map first4 - swap first set ; - : UNICHAR: ! This should be part of CHAR: scan name>char [ parsed ] [ "Invalid character" throw ] if* ; parsing From 840c401cb5fb8d2fc1739708589e960e0035bb50 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 28 Jan 2008 02:19:04 -0500 Subject: [PATCH 06/66] Solution to Project Euler problem 33 --- extra/project-euler/033/033.factor | 55 ++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) create mode 100644 extra/project-euler/033/033.factor diff --git a/extra/project-euler/033/033.factor b/extra/project-euler/033/033.factor new file mode 100644 index 0000000000..6f29c3519e --- /dev/null +++ b/extra/project-euler/033/033.factor @@ -0,0 +1,55 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.ranges project-euler.common sequences ; +IN: project-euler.033 + +! http://projecteuler.net/index.php?section=problems&id=33 + +! DESCRIPTION +! ----------- + +! The fraction 49/98 is a curious fraction, as an inexperienced mathematician +! in attempting to simplify it may incorrectly believe that 49/98 = 4/8, which +! is correct, is obtained by cancelling the 9s. + +! We shall consider fractions like, 30/50 = 3/5, to be trivial examples. + +! There are exactly four non-trivial examples of this type of fraction, less +! than one in value, and containing two digits in the numerator and +! denominator. + +! If the product of these four fractions is given in its lowest common terms, +! find the value of the denominator. + + +! SOLUTION +! -------- + +! Through analysis, you only need to check fractions fitting the pattern ax/xb + + + +: euler033 ( -- answer ) + source-033 curious-fractions product denominator ; + +! [ euler033 ] 100 ave-time +! 5 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler033 From 38bc7d7f7542af4b90f6d1803fea4c9c00f18f77 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 28 Jan 2008 03:37:14 -0500 Subject: [PATCH 07/66] Solution to Project Euler problem 34 --- extra/project-euler/034/034.factor | 47 ++++++++++++++++++++++++ extra/project-euler/common/common.factor | 4 +- extra/project-euler/project-euler.factor | 5 ++- 3 files changed, 52 insertions(+), 4 deletions(-) create mode 100644 extra/project-euler/034/034.factor diff --git a/extra/project-euler/034/034.factor b/extra/project-euler/034/034.factor new file mode 100644 index 0000000000..83cffeb248 --- /dev/null +++ b/extra/project-euler/034/034.factor @@ -0,0 +1,47 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib kernel math.ranges project-euler.common sequences ; +IN: project-euler.034 + +! http://projecteuler.net/index.php?section=problems&id=34 + +! DESCRIPTION +! ----------- + +! 145 is a curious number, as 1! + 4! + 5! = 1 + 24 + 120 = 145. + +! Find the sum of all numbers which are equal to the sum of the factorial of +! their digits. + +! Note: as 1! = 1 and 2! = 2 are not sums they are not included. + + +! SOLUTION +! -------- + +! We can reduce the upper bound a little by calculating 7 * 9! = 2540160, and +! then reducing one of the 9! to 2! (since the 7th digit cannot exceed 2), so we +! get 2! + 6 * 9! = 2177282 as an upper bound. + +! We can then take that one more step, and notice that the largest factorial +! sum a 7 digit number starting with 21 or 20 is 2! + 1! + 5 * 9! or 1814403. +! So there can't be any 7 digit solutions starting with 21 or 20, and therefore +! our numbers must be less that 2000000. + +digits [ digit-factorial ] sigma = ; + +PRIVATE> + +: euler034 ( -- answer ) + 3 2000000 [a,b] [ factorion? ] subset sum ; + +! [ euler034 ] 10 ave-time +! 15089 ms run / 725 ms GC ave time - 10 trials + +MAIN: euler034 diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index c875a440ba..2e718ab5a2 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -7,11 +7,11 @@ IN: project-euler.common ! Problems using each public word ! ------------------------------- -! cartesian-product - #4, #27 +! cartesian-product - #4, #27, #29, #32, #33 ! collect-consecutive - #8, #11 ! log10 - #25, #134 ! max-path - #18, #67 -! number>digits - #16, #20, #30 +! number>digits - #16, #20, #30, #34 ! 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 329a1b9668..74577debd9 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2007, 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: definitions io io.files kernel math.parser sequences vocabs vocabs.loader project-euler.ave-time project-euler.common math @@ -9,7 +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.030 project-euler.067 project-euler.134 + project-euler.029 project-euler.030 project-euler.031 project-euler.032 + project-euler.033 project-euler.034 project-euler.067 project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler From 03db080df75662a01c0bb15bcdfef16cebe370f7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 28 Jan 2008 18:15:21 -0600 Subject: [PATCH 08/66] Working on new resizables --- core/bit-arrays/bit-arrays.factor | 3 + core/bit-vectors/bit-vectors.factor | 31 +++++++++ core/bootstrap/primitives.factor | 86 +++++++++++++++---------- core/byte-arrays/byte-arrays.factor | 3 + core/byte-vectors/byte-vectors.factor | 31 +++++++++ core/float-arrays/float-arrays.factor | 3 + core/float-vectors/float-vectors.factor | 31 +++++++++ core/slots/slots.factor | 19 ++++-- core/tuples/tuples.factor | 2 +- vm/types.c | 28 ++++++++ 10 files changed, 197 insertions(+), 40 deletions(-) create mode 100755 core/bit-vectors/bit-vectors.factor create mode 100755 core/byte-vectors/byte-vectors.factor create mode 100755 core/float-vectors/float-vectors.factor mode change 100644 => 100755 core/tuples/tuples.factor diff --git a/core/bit-arrays/bit-arrays.factor b/core/bit-arrays/bit-arrays.factor index 3b847a0060..4c68d94aad 100755 --- a/core/bit-arrays/bit-arrays.factor +++ b/core/bit-arrays/bit-arrays.factor @@ -48,6 +48,9 @@ M: bit-array new drop ; M: bit-array equal? over bit-array? [ sequence= ] [ 2drop f ] if ; +M: bit-array resize + resize-bit-array ; + INSTANCE: bit-array sequence INSTANCE: bit-array simple-c-ptr INSTANCE: bit-array c-ptr diff --git a/core/bit-vectors/bit-vectors.factor b/core/bit-vectors/bit-vectors.factor new file mode 100755 index 0000000000..713f7b8a93 --- /dev/null +++ b/core/bit-vectors/bit-vectors.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel kernel.private math sequences +sequences.private growable ; +IN: bit-vectors + +vector ( bit-array -- bit-vector ) + bit-vector construct-boa ; inline + +PRIVATE> + +: ( n -- bit-vector ) + 0 bit-array>vector ; inline + +: >bit-vector ( seq -- bit-vector ) V{ } clone-like ; + +M: bit-vector like + drop dup bit-vector? [ + dup bit-array? + [ dup length bit-array>vector ] [ >bit-vector ] if + ] unless ; + +M: bit-vector new + drop [ ] keep >fixnum bit-array>vector ; + +M: bit-vector equal? + over bit-vector? [ sequence= ] [ 2drop f ] if ; + +INSTANCE: bit-vector growable diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index a88729f539..5a928693bc 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -39,11 +39,14 @@ call "alien" "arrays" "bit-arrays" + "bit-vectors" "byte-arrays" + "byte-vectors" "classes.private" "compiler.units" "continuations.private" "float-arrays" + "float-vectors" "generator" "growable" "hashtables" @@ -96,12 +99,6 @@ H{ } clone update-map set : register-builtin ( class -- ) dup "type" word-prop builtins get set-nth ; -: intern-slots ( spec -- spec ) - [ - [ dup array? [ first2 create ] when ] map - { slot-spec f } swap append >tuple - ] map ; - : lookup-type-number ( word -- n ) global [ target-word ] bind type-number ; @@ -110,8 +107,8 @@ H{ } clone update-map set dup dup lookup-type-number "type" set-word-prop dup f f builtin-class define-class dup r> builtin-predicate - dup r> intern-slots 2dup "slots" set-word-prop - define-slots + dup r> 1 simple-slots 2dup "slots" set-word-prop + dupd define-slots register-builtin ; H{ } clone typemap set @@ -137,14 +134,12 @@ num-types get f builtins set { { "integer" "math" } "numerator" - 1 { "numerator" "math" } f } { { "integer" "math" } "denominator" - 2 { "denominator" "math" } f } @@ -158,14 +153,12 @@ num-types get f builtins set { { "real" "math" } "real-part" - 1 { "real-part" "math" } f } { { "real" "math" } "imaginary-part" - 2 { "imaginary-part" "math" } f } @@ -182,7 +175,6 @@ num-types get f builtins set { { "object" "kernel" } "wrapped" - 1 { "wrapped" "kernel" } f } @@ -193,19 +185,16 @@ num-types get f builtins set { { "array-capacity" "sequences.private" } "count" - 1 { "hash-count" "hashtables.private" } { "set-hash-count" "hashtables.private" } } { { "array-capacity" "sequences.private" } "deleted" - 2 { "hash-deleted" "hashtables.private" } { "set-hash-deleted" "hashtables.private" } } { { "array" "arrays" } "array" - 3 { "hash-array" "hashtables.private" } { "set-hash-array" "hashtables.private" } } @@ -216,13 +205,11 @@ num-types get f builtins set { { "array-capacity" "sequences.private" } "fill" - 1 { "length" "sequences" } { "set-fill" "growable" } } { { "array" "arrays" } "underlying" - 2 { "underlying" "growable" } { "set-underlying" "growable" } } @@ -233,7 +220,6 @@ num-types get f builtins set { { "array-capacity" "sequences.private" } "length" - 1 { "length" "sequences" } f } @@ -244,14 +230,12 @@ num-types get f builtins set { { "array-capacity" "sequences.private" } "length" - 1 { "length" "sequences" } { "set-fill" "growable" } } { { "string" "strings" } "underlying" - 2 { "underlying" "growable" } { "set-underlying" "growable" } } @@ -262,14 +246,12 @@ num-types get f builtins set { { "object" "kernel" } "array" - 1 { "quotation-array" "quotations.private" } f } { { "object" "kernel" } "compiled?" - 2 { "quotation-compiled?" "quotations" } f } @@ -280,7 +262,6 @@ num-types get f builtins set { { "byte-array" "byte-arrays" } "path" - 1 { "(dll-path)" "alien" } f } @@ -292,13 +273,11 @@ define-builtin { { "c-ptr" "alien" } "alien" - 1 { "underlying-alien" "alien" } f } { { "object" "kernel" } "expired?" - 2 { "expired?" "alien" } f } @@ -307,45 +286,40 @@ define-builtin "word" "words" create "word?" "words" create { + f { { "object" "kernel" } "name" - 2 { "word-name" "words" } { "set-word-name" "words" } } { { "object" "kernel" } "vocabulary" - 3 { "word-vocabulary" "words" } { "set-word-vocabulary" "words" } } { { "quotation" "quotations" } "def" - 4 { "word-def" "words" } { "set-word-def" "words.private" } } { { "object" "kernel" } "props" - 5 { "word-props" "words" } { "set-word-props" "words" } } { { "object" "kernel" } "?" - 6 { "compiled?" "words" } f } { { "fixnum" "math" } "counter" - 7 { "profile-counter" "tools.profiler.private" } { "set-profile-counter" "tools.profiler.private" } } @@ -369,14 +343,12 @@ define-builtin { { "object" "kernel" } "obj" - 1 { "curry-obj" "kernel" } f } { { "object" "kernel" } "obj" - 2 { "curry-quot" "kernel" } f } @@ -414,6 +386,52 @@ builtins get num-tags get tail f union-class define-class "tombstone" "hashtables.private" lookup t 2array >tuple 1quotation define-inline +! Some tuple classes +"byte-vector" "byte-vectors" create +{ + { + { "array-capacity" "sequences.private" } + "fill" + { "length" "sequences" } + { "set-fill" "growable" } + } { + { "byte-array" "byte-arrays" } + "underlying" + { "underlying" "growable" } + { "set-underlying" "growable" } + } +} define-tuple-class + +"bit-vector" "bit-vectors" create +{ + { + { "array-capacity" "sequences.private" } + "fill" + { "length" "sequences" } + { "set-fill" "growable" } + } { + { "bit-array" "bit-arrays" } + "underlying" + { "underlying" "growable" } + { "set-underlying" "growable" } + } +} define-tuple-class + +"float-vector" "float-vectors" create +{ + { + { "array-capacity" "sequences.private" } + "fill" + { "length" "sequences" } + { "set-fill" "growable" } + } { + { "float-array" "float-arrays" } + "underlying" + { "underlying" "growable" } + { "set-underlying" "growable" } + } +} define-tuple-class + ! Primitive words : make-primitive ( word vocab n -- ) >r create dup reset-word r> [ do-primitive ] curry [ ] like define ; diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index f82569c270..401b151ad0 100755 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -15,6 +15,9 @@ M: byte-array new drop ; M: byte-array equal? over byte-array? [ sequence= ] [ 2drop f ] if ; +M: byte-array resize + resize-byte-array ; + INSTANCE: byte-array sequence INSTANCE: byte-array simple-c-ptr INSTANCE: byte-array c-ptr diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor new file mode 100755 index 0000000000..bf3f01fb72 --- /dev/null +++ b/core/byte-vectors/byte-vectors.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel kernel.private math sequences +sequences.private growable ; +IN: byte-vectors + +vector ( byte-array -- byte-vector ) + byte-vector construct-boa ; inline + +PRIVATE> + +: ( n -- byte-vector ) + 0 byte-array>vector ; inline + +: >byte-vector ( seq -- byte-vector ) V{ } clone-like ; + +M: byte-vector like + drop dup byte-vector? [ + dup byte-array? + [ dup length byte-array>vector ] [ >byte-vector ] if + ] unless ; + +M: byte-vector new + drop [ ] keep >fixnum byte-array>vector ; + +M: byte-vector equal? + over byte-vector? [ sequence= ] [ 2drop f ] if ; + +INSTANCE: byte-vector growable diff --git a/core/float-arrays/float-arrays.factor b/core/float-arrays/float-arrays.factor index ba0b2bb61d..445edd550a 100755 --- a/core/float-arrays/float-arrays.factor +++ b/core/float-arrays/float-arrays.factor @@ -29,6 +29,9 @@ M: float-array new drop 0.0 ; M: float-array equal? over float-array? [ sequence= ] [ 2drop f ] if ; +M: float-array resize + resize-float-array ; + INSTANCE: float-array sequence INSTANCE: float-array simple-c-ptr INSTANCE: float-array c-ptr diff --git a/core/float-vectors/float-vectors.factor b/core/float-vectors/float-vectors.factor new file mode 100755 index 0000000000..fe623801dd --- /dev/null +++ b/core/float-vectors/float-vectors.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel kernel.private math sequences +sequences.private growable ; +IN: float-vectors + +vector ( float-array -- float-vector ) + float-vector construct-boa ; inline + +PRIVATE> + +: ( n -- float-vector ) + 0 float-array>vector ; inline + +: >float-vector ( seq -- float-vector ) V{ } clone-like ; + +M: float-vector like + drop dup float-vector? [ + dup float-array? + [ dup length float-array>vector ] [ >float-vector ] if + ] unless ; + +M: float-vector new + drop [ ] keep >fixnum float-array>vector ; + +M: float-vector equal? + over float-vector? [ sequence= ] [ 2drop f ] if ; + +INSTANCE: float-vector growable diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 4517ee4363..cd523b05c1 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math namespaces sequences strings words effects generic generic.standard -classes slots.private ; +classes slots.private combinators ; IN: slots TUPLE: slot-spec type name offset reader writer ; @@ -87,14 +87,23 @@ PREDICATE: word slot-writer "writing" word-prop >boolean ; : simple-writer-word ( class name -- word ) (simple-slot-word) writer-word ; -: simple-slot ( class name # -- spec ) +: short-slot ( class name # -- spec ) >r object bootstrap-word over r> f f 2over simple-reader-word over set-slot-spec-reader -rot simple-writer-word over set-slot-spec-writer ; +: long-slot ( spec # -- spec ) + >r [ dup array? [ first2 create ] when ] map first4 r> + -rot ; + : simple-slots ( class slots base -- specs ) - over length [ + ] with map - [ >r >r dup r> r> simple-slot ] 2map nip ; + over length [ + ] with map [ + { + { [ over not ] [ 2drop f ] } + { [ over string? ] [ >r dupd r> short-slot ] } + { [ over array? ] [ long-slot ] } + } cond + ] 2map [ ] subset nip ; : slot-of-reader ( reader specs -- spec/f ) [ slot-spec-reader eq? ] with find nip ; diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor old mode 100644 new mode 100755 index 9c7b5c960a..306c7f4726 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -80,8 +80,8 @@ PRIVATE> } ; : define-tuple-slots ( class slots -- ) - 2dup "slot-names" set-word-prop dupd 4 simple-slots + 2dup [ slot-spec-name ] map "slot-names" set-word-prop 2dup delegate-slot-spec add* "slots" set-word-prop define-slots ; diff --git a/vm/types.c b/vm/types.c index 51dd4c3da4..063b5e966a 100755 --- a/vm/types.c +++ b/vm/types.c @@ -235,6 +235,34 @@ DEFINE_PRIMITIVE(resize_array) dpush(tag_object(reallot_array(array,capacity,F))); } +F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) +{ + CELL to_copy = array_capacity(array); + if(capacity < to_copy) + to_copy = capacity; + + REGISTER_UNTAGGED(array); + + F_BYTE_ARRAY *new_array = allot_array_internal(untag_header(array->header),capacity); + + UNREGISTER_UNTAGGED(array); + + memcpy(new_array + 1,array + 1,to_copy * CELLS); + memset(AREF(new_array,to_copy),0,capacity - to_copy) ; + + for(i = to_copy; i < capacity; i++) + set_array_nth(new_array,i,fill); + + return new_array; +} + +DEFINE_PRIMITIVE(resize_array) +{ + F_ARRAY* array = untag_array(dpop()); + CELL capacity = unbox_array_size(); + dpush(tag_object(reallot_array(array,capacity,F))); +} + DEFINE_PRIMITIVE(array_to_vector) { F_VECTOR *vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR)); From 9a897f91fff46ea32bedc48d3cfb5dc486184f94 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 28 Jan 2008 19:09:49 -0600 Subject: [PATCH 09/66] Fixing compiler bug with redefining deferred words --- core/compiler/test/redefine.factor | 2 ++ core/generator/generator.factor | 1 - 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 266b331ffc..aa53068e36 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -238,3 +238,5 @@ DEFER: flushable-test-2 [ \ bx forget ] with-compilation-unit [ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test + +[ "one" "two" ] [ "DEFER: redefine-test1 : redefine-test2 redefine-test1 \"two\" ; : redefine-test1 \"one\" ; redefine-test2" eval ] unit-test diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 0e499cf90f..4d985ff164 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -20,7 +20,6 @@ SYMBOL: compiled { { [ dup compiled get key? ] [ drop ] } { [ dup primitive? ] [ drop ] } - { [ dup deferred? ] [ drop ] } { [ t ] [ dup compile-queue get set-at ] } } cond ; From 7b74afd0431cbb962dbfd96333344769f1e1652d Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 29 Jan 2008 12:39:25 -0500 Subject: [PATCH 10/66] Solution to Project Euler problem 35 --- extra/project-euler/035/035.factor | 61 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 6 +-- 2 files changed, 64 insertions(+), 3 deletions(-) create mode 100644 extra/project-euler/035/035.factor diff --git a/extra/project-euler/035/035.factor b/extra/project-euler/035/035.factor new file mode 100644 index 0000000000..867bbc44ac --- /dev/null +++ b/extra/project-euler/035/035.factor @@ -0,0 +1,61 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib kernel math math.combinatorics math.parser math.primes + project-euler.common sequences ; +IN: project-euler.035 + +! http://projecteuler.net/index.php?section=problems&id=35 + +! DESCRIPTION +! ----------- + +! The number, 197, is called a circular prime because all rotations of the +! digits: 197, 971, and 719, are themselves prime. + +! There are thirteen such primes below 100: +! 2, 3, 5, 7, 11, 13, 17, 31, 37, 71, 73, 79, and 97. + +! How many circular primes are there below one million? + + +! SOLUTION +! -------- + +digits ] map ; + +: possible? ( seq -- ? ) + dup length 1 > [ + dup { 0 2 4 5 6 8 } swap seq-diff = + ] [ + drop t + ] if ; + +: rotate ( seq n -- seq ) + cut* swap append ; + +: (circular?) ( seq n -- ? ) + dup 0 > [ + 2dup rotate 10 swap digits>integer + prime? [ 1- (circular?) ] [ 2drop f ] if + ] [ + 2drop t + ] if ; + +: circular? ( seq -- ? ) + dup length 1- (circular?) ; + +PRIVATE> + +: euler035 ( -- answer ) + source-035 [ possible? ] subset [ circular? ] count ; + +! [ euler035 ] 100 ave-time +! 904 ms run / 86 ms GC ave time - 100 trials + +! TODO: try using bit arrays or other methods outlined here: +! http://home.comcast.net/~babdulbaki/Circular_Primes.html + +MAIN: euler035 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 74577debd9..267272e46a 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007, 2008 Aaron Schaefer. +! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. USING: definitions io io.files kernel math.parser sequences vocabs vocabs.loader project-euler.ave-time project-euler.common math @@ -10,8 +10,8 @@ USING: definitions io io.files kernel math.parser sequences vocabs 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.030 project-euler.031 project-euler.032 - project-euler.033 project-euler.034 project-euler.067 project-euler.134 - project-euler.169 project-euler.173 project-euler.175 ; + project-euler.033 project-euler.034 project-euler.035 project-euler.067 + project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler Date: Tue, 29 Jan 2008 11:40:50 -0600 Subject: [PATCH 11/66] fix hardware-info for windows --- extra/hardware-info/backend/backend.factor | 1 - extra/hardware-info/windows/backend/backend.factor | 6 ++++++ extra/hardware-info/windows/nt/nt.factor | 2 +- extra/hardware-info/windows/windows.factor | 4 +--- 4 files changed, 8 insertions(+), 5 deletions(-) create mode 100644 extra/hardware-info/windows/backend/backend.factor diff --git a/extra/hardware-info/backend/backend.factor b/extra/hardware-info/backend/backend.factor index d79678de0c..17794c196d 100644 --- a/extra/hardware-info/backend/backend.factor +++ b/extra/hardware-info/backend/backend.factor @@ -11,4 +11,3 @@ HOOK: available-page-file os ( -- n ) HOOK: total-virtual-mem os ( -- n ) HOOK: available-virtual-mem os ( -- n ) HOOK: available-virtual-extended-mem os ( -- n ) - diff --git a/extra/hardware-info/windows/backend/backend.factor b/extra/hardware-info/windows/backend/backend.factor new file mode 100644 index 0000000000..516603c441 --- /dev/null +++ b/extra/hardware-info/windows/backend/backend.factor @@ -0,0 +1,6 @@ +IN: hardware-info.windows.backend + +TUPLE: wince ; +TUPLE: winnt ; +UNION: windows wince winnt ; + diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor index f412754cdf..8a58e5c168 100644 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -1,4 +1,4 @@ -USING: alien alien.c-types hardware-info hardware-info.windows +USING: alien alien.c-types hardware-info.windows.backend kernel libc math namespaces hardware-info.backend windows windows.advapi32 windows.kernel32 ; IN: hardware-info.windows.nt diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index a49e4f254a..caf859c35e 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -1,11 +1,9 @@ USING: alien alien.c-types kernel libc math namespaces windows windows.kernel32 windows.advapi32 +hardware-info.windows.backend words combinators vocabs.loader hardware-info.backend ; IN: hardware-info.windows -TUPLE: wince ; -TUPLE: winnt ; -UNION: windows wince winnt ; USE: system : system-info ( -- SYSTEM_INFO ) From 8cb274e9f91a32f9ffcda44c6b351bbb08a5e958 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 29 Jan 2008 11:41:12 -0600 Subject: [PATCH 12/66] fix editors for windows --- extra/editors/gvim/windows/windows.factor | 2 +- extra/editors/notepadpp/notepadpp.factor | 4 ++-- extra/editors/scite/scite.factor | 13 +++++++------ extra/editors/ultraedit/ultraedit.factor | 2 +- 4 files changed, 11 insertions(+), 10 deletions(-) diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor index 5a3ea6b67a..5b51738eea 100644 --- a/extra/editors/gvim/windows/windows.factor +++ b/extra/editors/gvim/windows/windows.factor @@ -1,4 +1,4 @@ -USING: editors.gvim io.files io.windows kernel namespaces +USING: editors.gvim.backend io.files io.windows kernel namespaces sequences windows.shell32 ; IN: editors.gvim.windows diff --git a/extra/editors/notepadpp/notepadpp.factor b/extra/editors/notepadpp/notepadpp.factor index f9fa95f175..72ac6c72d7 100755 --- a/extra/editors/notepadpp/notepadpp.factor +++ b/extra/editors/notepadpp/notepadpp.factor @@ -1,5 +1,5 @@ USING: editors io.files io.launcher kernel math.parser -namespaces windows.shell32 ; +namespaces sequences windows.shell32 ; IN: editors.notepadpp : notepadpp-path @@ -11,6 +11,6 @@ IN: editors.notepadpp [ notepadpp-path , "-n" swap number>string append , , - ] "" make run-detached drop ; + ] { } make run-detached drop ; [ notepadpp ] edit-hook set-global diff --git a/extra/editors/scite/scite.factor b/extra/editors/scite/scite.factor index bc9a98a051..ac9a032abc 100755 --- a/extra/editors/scite/scite.factor +++ b/extra/editors/scite/scite.factor @@ -8,18 +8,19 @@ ! variable to point to your executable, ! if not on the path. ! -USING: io.launcher kernel namespaces math math.parser -editors ; +USING: io.files io.launcher kernel namespaces math +math.parser editors sequences windows.shell32 ; IN: editors.scite -SYMBOL: scite-path - -"scite" scite-path set-global +: scite-path ( -- path ) + \ scite-path get-global [ + program-files "wscite\\SciTE.exe" path+ + ] unless* ; : scite-command ( file line -- cmd ) swap [ - scite-path get , + scite-path , , "-goto:" swap number>string append , ] { } make ; diff --git a/extra/editors/ultraedit/ultraedit.factor b/extra/editors/ultraedit/ultraedit.factor index 7da4b807ce..f9d27174b3 100755 --- a/extra/editors/ultraedit/ultraedit.factor +++ b/extra/editors/ultraedit/ultraedit.factor @@ -10,7 +10,7 @@ IN: editors.ultraedit : ultraedit ( file line -- ) [ - ultraedit-path , [ % "/" % # "/1" % ] "" make , + ultraedit-path , [ swap % "/" % # "/1" % ] "" make , ] { } make run-detached drop ; From 5f3c77bb9bd5dfb5e0a477e27454f71d28438bc3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 29 Jan 2008 11:41:50 -0600 Subject: [PATCH 13/66] fix typo --- extra/help/tutorial/tutorial.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/help/tutorial/tutorial.factor b/extra/help/tutorial/tutorial.factor index a4d5e36b06..b3308e83c2 100644 --- a/extra/help/tutorial/tutorial.factor +++ b/extra/help/tutorial/tutorial.factor @@ -23,7 +23,7 @@ $nl $nl "Now, we tell Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:" { $code "IN: palindrome" } -"You are now ready to go onto the nex section." ; +"You are now ready to go on to the next section." ; ARTICLE: "first-program-logic" "Writing some logic in your first program" "Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:" From 44d058c676e768f179f89cfeb66661541202c301 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 29 Jan 2008 12:13:08 -0600 Subject: [PATCH 14/66] fix windows launcher code --- extra/io/windows/launcher/launcher.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 7b793ef74d..8f1d1c6756 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -51,7 +51,7 @@ TUPLE: CreateProcess-args [ [ dup CHAR: " = [ CHAR: \\ , ] when , ] each ] "" make ; : join-arguments ( args -- cmd-line ) - [ "\"" swap escape-argument "\"" 3append ] map " " join ; + " " join ; : app-name/cmd-line ( -- app-name cmd-line ) +command+ get [ From f86f36794f40206eb1944e168cc4ffb7168dd5ec Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 29 Jan 2008 13:31:06 -0500 Subject: [PATCH 15/66] Solution to Project Euler problem 36 --- extra/project-euler/036/036.factor | 42 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 5 +-- 2 files changed, 45 insertions(+), 2 deletions(-) create mode 100644 extra/project-euler/036/036.factor diff --git a/extra/project-euler/036/036.factor b/extra/project-euler/036/036.factor new file mode 100644 index 0000000000..00fc8c2682 --- /dev/null +++ b/extra/project-euler/036/036.factor @@ -0,0 +1,42 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib kernel math.parser math.ranges sequences ; +IN: project-euler.036 + +! http://projecteuler.net/index.php?section=problems&id=36 + +! DESCRIPTION +! ----------- + +! The decimal number, 585 = 1001001001 (binary), is palindromic in both bases. + +! Find the sum of all numbers, less than one million, which are palindromic in +! base 10 and base 2. + +! (Please note that the palindromic number, in either base, may not include +! leading zeros.) + + +! SOLUTION +! -------- + +! Only check odd numbers since the binary number must begin and end with 1 + +string palindrome? ] + [ dup >bin palindrome? ] } && nip ; + +PRIVATE> + +: euler036 ( -- answer ) + 1 1000000 2 [ both-bases? ] subset sum ; + +! [ euler036 ] 100 ave-time +! 3891 ms run / 173 ms GC ave time - 100 trials + +MAIN: euler036 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 267272e46a..feef9dbfa8 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -10,8 +10,9 @@ USING: definitions io io.files kernel math.parser sequences vocabs 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.030 project-euler.031 project-euler.032 - project-euler.033 project-euler.034 project-euler.035 project-euler.067 - project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; + project-euler.033 project-euler.034 project-euler.035 project-euler.036 + project-euler.067 project-euler.134 project-euler.169 project-euler.173 + project-euler.175 ; IN: project-euler Date: Tue, 29 Jan 2008 13:12:04 -0600 Subject: [PATCH 16/66] Unit test for recompiling deferred words --- core/compiler/test/redefine.factor | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index aa53068e36..c1561f38d4 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -239,4 +239,14 @@ DEFER: flushable-test-2 [ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test -[ "one" "two" ] [ "DEFER: redefine-test1 : redefine-test2 redefine-test1 \"two\" ; : redefine-test1 \"one\" ; redefine-test2" eval ] unit-test +DEFER: defer-redefine-test-2 + +[ ] [ "IN: temporary DEFER: defer-redefine-test-1" eval ] unit-test + +[ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test + +[ defer-redefine-test-2 ] unit-test-fails + +[ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test + +[ 1 ] [ defer-redefine-test-2 ] unit-test From edf1f2724728b9088b9a746814c7dc9f912e7cd0 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 29 Jan 2008 13:33:14 -0600 Subject: [PATCH 17/66] Changes to Unicode --- extra/const/const.factor | 8 ++++ extra/unicode/breaks/breaks.factor | 14 +++---- extra/unicode/data/data.factor | 49 +++++++++++------------- extra/unicode/normalize/normalize.factor | 6 +-- extra/unicode/syntax/syntax.factor | 4 +- 5 files changed, 42 insertions(+), 39 deletions(-) diff --git a/extra/const/const.factor b/extra/const/const.factor index 59d65edaae..8efef7e372 100644 --- a/extra/const/const.factor +++ b/extra/const/const.factor @@ -14,3 +14,11 @@ IN: const : ENUM: ";" parse-tokens [ create-in ] map define-enum ; parsing + +: define-value ( word -- ) + { f } clone [ first ] curry define ; + +: VALUE: CREATE define-value ; parsing + +: set-value ( value word -- ) + word-def first set-first ; diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index 9c9242edc3..70a9c781a2 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -1,7 +1,7 @@ USING: unicode.categories kernel math combinators splitting sequences math.parser io.files io assocs arrays namespaces combinators.lib assocs.lib math.ranges unicode.normalize -unicode.syntax unicode.data compiler.units alien.syntax ; +unicode.syntax unicode.data compiler.units alien.syntax const ; IN: unicode.breaks C-ENUM: Any L V T Extend Control CR LF graphemes ; @@ -32,7 +32,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; : other-extend-lines ( -- lines ) "extra/unicode/PropList.txt" resource-path file-lines ; -DEFER: other-extend +VALUE: other-extend CATEGORY: (extend) Me Mn ; : extend? ( ch -- ? ) @@ -77,7 +77,7 @@ SYMBOL: table T T connect graphemes Extend connect-after ; -DEFER: grapheme-table +VALUE: grapheme-table : grapheme-break? ( class1 class2 -- ? ) grapheme-table nth nth not ; @@ -113,10 +113,10 @@ DEFER: grapheme-table [ grapheme-class dup rot grapheme-break? ] find-last-index nip -1 or 1+ ; -<< - other-extend-lines process-other-extend \ other-extend define-value +[ + other-extend-lines process-other-extend \ other-extend set-value init-grapheme-table table [ make-grapheme-table finish-table ] with-variable - \ grapheme-table define-value ->> + \ grapheme-table set-value +] with-compilation-unit diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index e112471c28..c579d1fdfd 100644 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -1,15 +1,12 @@ USING: assocs math kernel sequences io.files hashtables quotations splitting arrays math.parser combinators.lib hash2 -byte-arrays words namespaces words compiler.units ; +byte-arrays words namespaces words compiler.units const ; IN: unicode.data ! Convenience functions : 1+* ( n/f _ -- n+1 ) drop [ 1+ ] [ 0 ] if* ; -: define-value ( value word -- ) - swap 1quotation define ; - : ?between? ( n/f from to -- ? ) pick [ between? ] [ 3drop f ] if ; @@ -107,16 +104,16 @@ C: code-point 4 head [ multihex ] map first4 swap first set ; -DEFER: simple-lower -DEFER: simple-upper -DEFER: simple-title -DEFER: canonical-map -DEFER: combine-map -DEFER: class-map -DEFER: compat-map -DEFER: category-map -DEFER: name-map -DEFER: special-casing +VALUE: simple-lower +VALUE: simple-upper +VALUE: simple-title +VALUE: canonical-map +VALUE: combine-map +VALUE: class-map +VALUE: compat-map +VALUE: category-map +VALUE: name-map +VALUE: special-casing : canonical-entry ( char -- seq ) canonical-map at ; : combine-chars ( a b -- char/f ) combine-map hash2 ; @@ -132,16 +129,14 @@ DEFER: special-casing [ length 5 = ] subset [ [ set-code-point ] each ] H{ } make-assoc ; -[ - load-data - dup process-names \ name-map define-value - 13 over process-data \ simple-lower define-value - 12 over process-data tuck \ simple-upper define-value - 14 over process-data swapd union \ simple-title define-value - dup process-combining \ class-map define-value - dup process-canonical \ canonical-map define-value - \ combine-map define-value - dup process-compat \ compat-map define-value - process-category \ category-map define-value - load-special-casing \ special-casing define-value -] with-compilation-unit +load-data +dup process-names \ name-map set-value +13 over process-data \ simple-lower set-value +12 over process-data tuck \ simple-upper set-value +14 over process-data swapd union \ simple-title set-value +dup process-combining \ class-map set-value +dup process-canonical \ canonical-map set-value + \ combine-map set-value +dup process-compat \ compat-map set-value +process-category \ category-map set-value +load-special-casing \ special-casing set-value diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor index 86a922793f..b018d115f8 100644 --- a/extra/unicode/normalize/normalize.factor +++ b/extra/unicode/normalize/normalize.factor @@ -2,7 +2,7 @@ USING: sequences namespaces unicode.data kernel combinators.lib math arrays ; IN: unicode.normalize -! Utility word +! Utility word--probably unnecessary : make* ( seq quot exemplar -- newseq ) ! quot has access to original seq on stack ! this just makes the new-resizable the same length as seq @@ -89,7 +89,7 @@ IN: unicode.normalize swap [ [ dup hangul? [ hangul>jamo % drop ] [ dup rot call [ % ] [ , ] ?if ] if - ] with each ] "" make* + ] with each ] "" make dup reorder ] if ; inline @@ -167,7 +167,7 @@ SYMBOL: char 0 ind set SBUF" " clone after set pass-combining (compose) - ] "" make* ; + ] "" make ; : nfc ( string -- nfc ) nfd compose ; diff --git a/extra/unicode/syntax/syntax.factor b/extra/unicode/syntax/syntax.factor index 5119663872..6c75a77c76 100644 --- a/extra/unicode/syntax/syntax.factor +++ b/extra/unicode/syntax/syntax.factor @@ -1,5 +1,5 @@ USING: unicode.data kernel math sequences parser bit-arrays namespaces -sequences.private arrays quotations classes.predicate ; +sequences.private arrays quotations classes.predicate assocs ; IN: unicode.syntax ! Character classes (categories) @@ -48,5 +48,5 @@ IN: unicode.syntax categories swap seq-minus define-category ; parsing : UNICHAR: - ! This should be part of CHAR: + ! This should be part of CHAR:. Also, name-map at ==> name>char scan name>char [ parsed ] [ "Invalid character" throw ] if* ; parsing From a263784f94e19781ab8cd021a46a10777374bf8f Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 29 Jan 2008 13:33:33 -0600 Subject: [PATCH 18/66] Fixing opengl's use --- extra/opengl/opengl.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 656c514cd1..ea3577c037 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -4,7 +4,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types continuations kernel libc math macros namespaces math.vectors math.constants math.functions math.parser opengl.gl opengl.glu -combinators arrays sequences splitting words ; +combinators arrays sequences splitting words byte-arrays ; IN: opengl : coordinates [ first2 ] 2apply ; From f2dbf50c6c892d0296ced94cff0419c9fc6d97cd Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 29 Jan 2008 13:53:54 -0600 Subject: [PATCH 19/66] Back out change --- core/generator/generator.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 4d985ff164..0e499cf90f 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -20,6 +20,7 @@ SYMBOL: compiled { { [ dup compiled get key? ] [ drop ] } { [ dup primitive? ] [ drop ] } + { [ dup deferred? ] [ drop ] } { [ t ] [ dup compile-queue get set-at ] } } cond ; From e37ccf190eb2fe52c440a5b684d9832c17274872 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 29 Jan 2008 13:58:37 -0600 Subject: [PATCH 20/66] Add failing unit test --- core/classes/classes-tests.factor | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 5addd273c8..854e6add5a 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -207,3 +207,14 @@ DEFER: mixin-forget-test-g [ { } mixin-forget-test-g ] unit-test-fails [ H{ } ] [ H{ } mixin-forget-test-g ] unit-test + +! Method flattening interfered with mixin update +MIXIN: flat-mx-1 +TUPLE: flat-mx-1-1 ; INSTANCE: flat-mx-1-1 flat-mx-1 +TUPLE: flat-mx-1-2 ; INSTANCE: flat-mx-1-2 flat-mx-1 +TUPLE: flat-mx-1-3 ; INSTANCE: flat-mx-1-3 flat-mx-1 +TUPLE: flat-mx-1-4 ; INSTANCE: flat-mx-1-4 flat-mx-1 +MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1 +TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2 + +[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test From 0cd2f857fe0931213a3bc61fa678a00e97c64b0f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 29 Jan 2008 15:04:26 -0600 Subject: [PATCH 21/66] bit-vectors byte-vectors float-vectors --- core/bit-arrays/bit-arrays-tests.factor | 6 + core/bit-vectors/bit-vectors-docs.factor | 33 ++ core/bit-vectors/bit-vectors-tests.factor | 12 + core/bit-vectors/bit-vectors.factor | 2 +- core/bootstrap/primitives.factor | 33 +- core/byte-arrays/byte-arrays-tests.factor | 8 + core/byte-vectors/byte-vectors-docs.factor | 34 ++ core/byte-vectors/byte-vectors-tests.factor | 12 + core/byte-vectors/byte-vectors.factor | 4 +- core/float-arrays/float-arrays-tests.factor | 6 + core/float-vectors/float-vectors-tests.factor | 12 + core/float-vectors/float-vectors.factor | 4 +- core/syntax/syntax-docs.factor | 40 +- core/vectors/vectors-docs.factor | 2 +- vm/alien.h | 6 +- vm/errors.h | 7 + vm/primitives.c | 3 + vm/types.c | 513 ++++++++++-------- vm/types.h | 33 +- 19 files changed, 500 insertions(+), 270 deletions(-) mode change 100644 => 100755 core/bit-arrays/bit-arrays-tests.factor create mode 100755 core/bit-vectors/bit-vectors-docs.factor create mode 100755 core/bit-vectors/bit-vectors-tests.factor create mode 100755 core/byte-arrays/byte-arrays-tests.factor create mode 100755 core/byte-vectors/byte-vectors-docs.factor create mode 100755 core/byte-vectors/byte-vectors-tests.factor mode change 100644 => 100755 core/float-arrays/float-arrays-tests.factor create mode 100755 core/float-vectors/float-vectors-tests.factor mode change 100644 => 100755 core/vectors/vectors-docs.factor mode change 100644 => 100755 vm/alien.h diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor old mode 100644 new mode 100755 index 48698ad91d..f605eba24c --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -46,3 +46,9 @@ IN: temporary [ ?{ f } ] [ 1 2 { t f t f } >bit-array ] unit-test + +[ ?{ t f t f f f } ] [ 6 ?{ t f t } resize-bit-array ] unit-test + +[ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test + +[ -10 ?{ } resize-bit-array ] unit-test-fails diff --git a/core/bit-vectors/bit-vectors-docs.factor b/core/bit-vectors/bit-vectors-docs.factor new file mode 100755 index 0000000000..b4b6d8e845 --- /dev/null +++ b/core/bit-vectors/bit-vectors-docs.factor @@ -0,0 +1,33 @@ +USING: arrays bit-arrays help.markup help.syntax kernel +bit-vectors.private combinators ; +IN: bit-vectors + +ARTICLE: "bit-vectors" "Bit vectors" +"A bit vector is a resizable mutable sequence of bits. The literal syntax is covered in " { $link "syntax-bit-vectors" } ". Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary." +$nl +"Bit vectors form a class:" +{ $subsection bit-vector } +{ $subsection bit-vector? } +"Creating bit vectors:" +{ $subsection >bit-vector } +{ $subsection } +"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:" +{ $code "?V{ } clone" } ; + +ABOUT: "bit-vectors" + +HELP: bit-vector +{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ; + +HELP: +{ $values { "n" "a positive integer specifying initial capacity" } { "vector" vector } } +{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ; + +HELP: >bit vector +{ $values { "seq" "a sequence" } { "vector" vector } } +{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ; + +HELP: bit-array>vector +{ $values { "bit-array" "an array" } { "capacity" "a non-negative integer" } { "bit-vector" bit-vector } } +{ $description "Creates a new bit vector using the array for underlying storage with the specified initial length." } +{ $warning "This word is in the " { $vocab-link "bit-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >bit-vector } " instead." } ; diff --git a/core/bit-vectors/bit-vectors-tests.factor b/core/bit-vectors/bit-vectors-tests.factor new file mode 100755 index 0000000000..2af9141ace --- /dev/null +++ b/core/bit-vectors/bit-vectors-tests.factor @@ -0,0 +1,12 @@ +IN: temporary +USING: tools.test bit-vectors vectors sequences kernel math ; + +[ 0 ] [ 123 length ] unit-test + +: do-it + 1234 swap [ >r even? r> push ] curry each ; + +[ t ] [ + 3 dup do-it + 3 dup do-it sequence= +] unit-test diff --git a/core/bit-vectors/bit-vectors.factor b/core/bit-vectors/bit-vectors.factor index 713f7b8a93..b22e3c2eef 100755 --- a/core/bit-vectors/bit-vectors.factor +++ b/core/bit-vectors/bit-vectors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences -sequences.private growable ; +sequences.private growable bit-arrays ; IN: bit-vectors r first2 r> make-primitive ] 2each diff --git a/core/byte-arrays/byte-arrays-tests.factor b/core/byte-arrays/byte-arrays-tests.factor new file mode 100755 index 0000000000..b39551eb86 --- /dev/null +++ b/core/byte-arrays/byte-arrays-tests.factor @@ -0,0 +1,8 @@ +IN: temporary +USING: tools.test byte-arrays ; + +[ B{ 1 2 3 0 0 0 } ] [ 6 B{ 1 2 3 } resize-byte-array ] unit-test + +[ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test + +[ -10 B{ } resize-byte-array ] unit-test-fails diff --git a/core/byte-vectors/byte-vectors-docs.factor b/core/byte-vectors/byte-vectors-docs.factor new file mode 100755 index 0000000000..e4bd1bd096 --- /dev/null +++ b/core/byte-vectors/byte-vectors-docs.factor @@ -0,0 +1,34 @@ +USING: arrays byte-arrays help.markup help.syntax kernel +byte-vectors.private combinators ; +IN: byte-vectors + +ARTICLE: "byte-vectors" "Byte vectors" +"A byte vector is a resizable mutable sequence of unsigned bytes. The literal syntax is covered in " { $link "syntax-byte-vectors" } ". Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary." +$nl +"Byte vectors form a class:" +{ $subsection byte-vector } +{ $subsection byte-vector? } +"Creating byte vectors:" +{ $subsection >byte-vector } +{ $subsection } +"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:" +{ $code "BV{ } clone" } ; + +ABOUT: "byte-vectors" + +HELP: byte-vector +{ $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ; + +HELP: +{ $values { "n" "a positive integer specifying initial capacity" } { "vector" vector } } +{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ; + +HELP: >byte vector +{ $values { "seq" "a sequence" } { "vector" vector } } +{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." } +{ $errors "Throws an error if the sequence contains elements other than integers." } ; + +HELP: byte-array>vector +{ $values { "byte-array" "an array" } { "capacity" "a non-negative integer" } { "byte-vector" byte-vector } } +{ $description "Creates a new byte vector using the array for underlying storage with the specified initial length." } +{ $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ; diff --git a/core/byte-vectors/byte-vectors-tests.factor b/core/byte-vectors/byte-vectors-tests.factor new file mode 100755 index 0000000000..888d6957b2 --- /dev/null +++ b/core/byte-vectors/byte-vectors-tests.factor @@ -0,0 +1,12 @@ +IN: temporary +USING: tools.test byte-vectors vectors sequences kernel ; + +[ 0 ] [ 123 length ] unit-test + +: do-it + 123 [ over push ] each ; + +[ t ] [ + 3 do-it + 3 do-it sequence= +] unit-test diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index bf3f01fb72..060ac94472 100755 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences -sequences.private growable ; +sequences.private growable byte-arrays ; IN: byte-vectors vector ( byte-array -- byte-vector ) +: byte-array>vector ( byte-array capacity -- byte-vector ) byte-vector construct-boa ; inline PRIVATE> diff --git a/core/float-arrays/float-arrays-tests.factor b/core/float-arrays/float-arrays-tests.factor old mode 100644 new mode 100755 index 811c380e41..afadaac0db --- a/core/float-arrays/float-arrays-tests.factor +++ b/core/float-arrays/float-arrays-tests.factor @@ -2,3 +2,9 @@ IN: temporary USING: float-arrays tools.test ; [ F{ 1.0 1.0 1.0 } ] [ 3 1.0 ] unit-test + +[ F{ 1 2 3 0 0 0 } ] [ 6 F{ 1 2 3 } resize-float-array ] unit-test + +[ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize-float-array ] unit-test + +[ -10 F{ } resize-float-array ] unit-test-fails diff --git a/core/float-vectors/float-vectors-tests.factor b/core/float-vectors/float-vectors-tests.factor new file mode 100755 index 0000000000..11f87f1f52 --- /dev/null +++ b/core/float-vectors/float-vectors-tests.factor @@ -0,0 +1,12 @@ +IN: temporary +USING: tools.test float-vectors vectors sequences kernel ; + +[ 0 ] [ 123 length ] unit-test + +: do-it + 12345 [ over push ] each ; + +[ t ] [ + 3 do-it + 3 do-it sequence= +] unit-test diff --git a/core/float-vectors/float-vectors.factor b/core/float-vectors/float-vectors.factor index fe623801dd..fa19e3aaf8 100755 --- a/core/float-vectors/float-vectors.factor +++ b/core/float-vectors/float-vectors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences -sequences.private growable ; +sequences.private growable float-arrays ; IN: float-vectors : ( n -- float-vector ) - 0 float-array>vector ; inline + 0.0 0 float-array>vector ; inline : >float-vector ( seq -- float-vector ) V{ } clone-like ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 9cf9647e41..df96743e3d 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -151,6 +151,18 @@ ARTICLE: "syntax-byte-arrays" "Byte array syntax" { $subsection POSTPONE: B{ } "Byte arrays are documented in " { $link "byte-arrays" } "." ; +ARTICLE: "syntax-bit-vectors" "Bit vector syntax" +{ $subsection POSTPONE: ?V{ } +"Bit vectors are documented in " { $link "bit-vectors" } "." ; + +ARTICLE: "syntax-float-vectors" "Float vector syntax" +{ $subsection POSTPONE: FV{ } +"Float vectors are documented in " { $link "float-vectors" } "." ; + +ARTICLE: "syntax-byte-vectors" "Byte vector syntax" +{ $subsection POSTPONE: BV{ } +"Byte vectors are documented in " { $link "byte-vectors" } "." ; + ARTICLE: "syntax-pathnames" "Pathname syntax" { $subsection POSTPONE: P" } "Pathnames are documented in " { $link "file-streams" } "." ; @@ -165,11 +177,15 @@ $nl { $subsection "syntax-words" } { $subsection "syntax-quots" } { $subsection "syntax-arrays" } -{ $subsection "syntax-vectors" } { $subsection "syntax-strings" } -{ $subsection "syntax-sbufs" } -{ $subsection "syntax-byte-arrays" } { $subsection "syntax-bit-arrays" } +{ $subsection "syntax-byte-arrays" } +{ $subsection "syntax-float-arrays" } +{ $subsection "syntax-vectors" } +{ $subsection "syntax-sbufs" } +{ $subsection "syntax-bit-vectors" } +{ $subsection "syntax-byte-vectors" } +{ $subsection "syntax-float-vectors" } { $subsection "syntax-hashtables" } { $subsection "syntax-tuples" } { $subsection "syntax-pathnames" } ; @@ -273,12 +289,30 @@ HELP: B{ { $description "Marks the beginning of a literal byte array. Literal byte arrays are terminated by " { $link POSTPONE: } } "." } { $examples { $code "B{ 1 2 3 }" } } ; +HELP: BV{ +{ $syntax "BV{ elements... }" } +{ $values { "elements" "a list of bytes" } } +{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } +{ $examples { $code "BV{ 1 2 3 12 }" } } ; + HELP: ?{ { $syntax "?{ elements... }" } { $values { "elements" "a list of booleans" } } { $description "Marks the beginning of a literal bit array. Literal bit arrays are terminated by " { $link POSTPONE: } } "." } { $examples { $code "?{ t f t }" } } ; +HELP: ?V{ +{ $syntax "?V{ elements... }" } +{ $values { "elements" "a list of booleans" } } +{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." } +{ $examples { $code "?V{ t f t }" } } ; + +HELP: FV{ +{ $syntax "FV{ elements... }" } +{ $values { "elements" "a list of real numbers" } } +{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." } +{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ; + HELP: F{ { $syntax "F{ elements... }" } { $values { "elements" "a list of real numbers" } } diff --git a/core/vectors/vectors-docs.factor b/core/vectors/vectors-docs.factor old mode 100644 new mode 100755 index 56c59fac46..7093c684a9 --- a/core/vectors/vectors-docs.factor +++ b/core/vectors/vectors-docs.factor @@ -33,7 +33,7 @@ HELP: >vector HELP: array>vector ( array length -- vector ) { $values { "array" "an array" } { "length" "a non-negative integer" } { "vector" vector } } { $description "Creates a new vector using the array for underlying storage with the specified initial length." } -{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >vector } " instead." } ; +{ $warning "This word is in the " { $vocab-link "vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >vector } " instead." } ; HELP: 1vector { $values { "x" object } { "vector" vector } } diff --git a/vm/alien.h b/vm/alien.h old mode 100644 new mode 100755 index a3ca0753a4..3357b0a3c0 --- a/vm/alien.h +++ b/vm/alien.h @@ -41,11 +41,7 @@ DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size); DLLEXPORT void box_value_struct(void *src, CELL size); DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size); -INLINE F_DLL *untag_dll(CELL tagged) -{ - type_check(DLL_TYPE,tagged); - return (F_DLL*)UNTAG(tagged); -} +DEFINE_UNTAG(F_DLL,DLL_TYPE,dll) DECLARE_PRIMITIVE(dlopen); DECLARE_PRIMITIVE(dlsym); diff --git a/vm/errors.h b/vm/errors.h index 5fe5b08e0d..747a3415ba 100755 --- a/vm/errors.h +++ b/vm/errors.h @@ -39,6 +39,13 @@ INLINE void type_check(CELL type, CELL tagged) if(type_of(tagged) != type) type_error(type,tagged); } +#define DEFINE_UNTAG(type,check,name) \ + INLINE type *untag_##name(CELL obj) \ + { \ + type_check(check,obj); \ + return untag_object(obj); \ + } + /* Global variables used to pass fault handler state from signal handler to user-space */ CELL signal_number; diff --git a/vm/primitives.c b/vm/primitives.c index 7151d139bf..78dbc28358 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -192,4 +192,7 @@ void *primitives[] = { primitive_set_innermost_stack_frame_quot, primitive_call_clear, primitive_os_envs, + primitive_resize_byte_array, + primitive_resize_bit_array, + primitive_resize_float_array, }; diff --git a/vm/types.c b/vm/types.c index 063b5e966a..9f5dfb1248 100755 --- a/vm/types.c +++ b/vm/types.c @@ -12,6 +12,105 @@ bool to_boolean(CELL value) return value != F; } +CELL clone(CELL object) +{ + CELL size = object_size(object); + if(size == 0) + return object; + else + { + REGISTER_ROOT(object); + void *new_obj = allot_object(type_of(object),size); + UNREGISTER_ROOT(object); + + CELL tag = TAG(object); + memcpy(new_obj,(void*)UNTAG(object),size); + return RETAG(new_obj,tag); + } +} + +DEFINE_PRIMITIVE(clone) +{ + drepl(clone(dpeek())); +} + +DEFINE_PRIMITIVE(array_to_vector) +{ + F_VECTOR *vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR)); + vector->top = dpop(); + vector->array = dpop(); + dpush(tag_object(vector)); +} + +DEFINE_PRIMITIVE(string_to_sbuf) +{ + F_SBUF *sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF)); + sbuf->top = dpop(); + sbuf->string = dpop(); + dpush(tag_object(sbuf)); +} + +DEFINE_PRIMITIVE(hashtable) +{ + F_HASHTABLE* hash = allot_object(HASHTABLE_TYPE,sizeof(F_HASHTABLE)); + hash->count = F; + hash->deleted = F; + hash->array = F; + dpush(tag_object(hash)); +} + +F_WORD *allot_word(CELL vocab, CELL name) +{ + REGISTER_ROOT(vocab); + REGISTER_ROOT(name); + F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD)); + UNREGISTER_ROOT(name); + UNREGISTER_ROOT(vocab); + + word->hashcode = tag_fixnum(rand()); + word->vocabulary = vocab; + word->name = name; + word->def = userenv[UNDEFINED_ENV]; + word->props = F; + word->counter = tag_fixnum(0); + word->compiledp = F; + word->profiling = NULL; + + REGISTER_UNTAGGED(word); + default_word_code(word,true); + UNREGISTER_UNTAGGED(word); + + REGISTER_UNTAGGED(word); + update_word_xt(word); + UNREGISTER_UNTAGGED(word); + + return word; +} + +/* ( name vocabulary -- word ) */ +DEFINE_PRIMITIVE(word) +{ + CELL vocab = dpop(); + CELL name = dpop(); + dpush(tag_object(allot_word(vocab,name))); +} + +/* word-xt ( word -- xt ) */ +DEFINE_PRIMITIVE(word_xt) +{ + F_WORD *word = untag_word(dpeek()); + drepl(allot_cell((CELL)word->xt)); +} + +DEFINE_PRIMITIVE(wrapper) +{ + F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER)); + wrapper->object = dpeek(); + drepl(tag_object(wrapper)); +} + +/* Arrays */ + /* the array is full of undefined data, and must be correctly filled before the next GC. size is in cells */ F_ARRAY *allot_array_internal(CELL type, CELL capacity) @@ -38,41 +137,6 @@ F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill) return array; } -/* size is in bytes this time */ -F_BYTE_ARRAY *allot_byte_array(CELL size) -{ - F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE, - byte_array_size(size)); - array->capacity = tag_fixnum(size); - memset(array + 1,0,size); - return array; -} - -/* size is in bits */ -F_BIT_ARRAY *allot_bit_array(CELL size) -{ - F_BIT_ARRAY *array = allot_object(BIT_ARRAY_TYPE, - bit_array_size(size)); - array->capacity = tag_fixnum(size); - memset(array + 1,0,(size + 31) / 32 * 4); - return array; -} - -/* size is in 8-byte doubles */ -F_BIT_ARRAY *allot_float_array(CELL size, double initial) -{ - F_FLOAT_ARRAY *array = allot_object(FLOAT_ARRAY_TYPE, - float_array_size(size)); - array->capacity = tag_fixnum(size); - - double *elements = (double *)AREF(array,0); - int i; - for(i = 0; i < size; i++) - elements[i] = initial; - - return array; -} - /* push a new array on the stack */ DEFINE_PRIMITIVE(array) { @@ -81,89 +145,6 @@ DEFINE_PRIMITIVE(array) dpush(tag_object(allot_array(ARRAY_TYPE,size,initial))); } -/* push a new tuple on the stack */ -DEFINE_PRIMITIVE(tuple) -{ - CELL size = unbox_array_size(); - F_ARRAY *array = allot_array(TUPLE_TYPE,size,F); - set_array_nth(array,0,dpop()); - dpush(tag_tuple(array)); -} - -/* push a new tuple on the stack, filling its slots from the stack */ -DEFINE_PRIMITIVE(tuple_boa) -{ - CELL size = unbox_array_size(); - F_ARRAY *array = allot_array(TUPLE_TYPE,size,F); - set_array_nth(array,0,dpop()); - - CELL i; - for(i = size - 1; i >= 2; i--) - set_array_nth(array,i,dpop()); - - dpush(tag_tuple(array)); -} - -/* push a new byte array on the stack */ -DEFINE_PRIMITIVE(byte_array) -{ - CELL size = unbox_array_size(); - dpush(tag_object(allot_byte_array(size))); -} - -/* push a new bit array on the stack */ -DEFINE_PRIMITIVE(bit_array) -{ - CELL size = unbox_array_size(); - dpush(tag_object(allot_bit_array(size))); -} - -/* push a new float array on the stack */ -DEFINE_PRIMITIVE(float_array) -{ - double initial = untag_float(dpop()); - CELL size = unbox_array_size(); - dpush(tag_object(allot_float_array(size,initial))); -} - -CELL clone(CELL object) -{ - CELL size = object_size(object); - if(size == 0) - return object; - else - { - REGISTER_ROOT(object); - void *new_obj = allot_object(type_of(object),size); - UNREGISTER_ROOT(object); - - CELL tag = TAG(object); - memcpy(new_obj,(void*)UNTAG(object),size); - return RETAG(new_obj,tag); - } -} - -DEFINE_PRIMITIVE(clone) -{ - drepl(clone(dpeek())); -} - -DEFINE_PRIMITIVE(tuple_to_array) -{ - CELL object = dpeek(); - type_check(TUPLE_TYPE,object); - object = RETAG(clone(object),OBJECT_TYPE); - set_slot(object,0,tag_header(ARRAY_TYPE)); - drepl(object); -} - -DEFINE_PRIMITIVE(to_tuple) -{ - CELL object = RETAG(clone(dpeek()),TUPLE_TYPE); - set_slot(object,0,tag_header(TUPLE_TYPE)); - drepl(object); -} - CELL allot_array_1(CELL obj) { REGISTER_ROOT(obj); @@ -235,42 +216,6 @@ DEFINE_PRIMITIVE(resize_array) dpush(tag_object(reallot_array(array,capacity,F))); } -F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) -{ - CELL to_copy = array_capacity(array); - if(capacity < to_copy) - to_copy = capacity; - - REGISTER_UNTAGGED(array); - - F_BYTE_ARRAY *new_array = allot_array_internal(untag_header(array->header),capacity); - - UNREGISTER_UNTAGGED(array); - - memcpy(new_array + 1,array + 1,to_copy * CELLS); - memset(AREF(new_array,to_copy),0,capacity - to_copy) ; - - for(i = to_copy; i < capacity; i++) - set_array_nth(new_array,i,fill); - - return new_array; -} - -DEFINE_PRIMITIVE(resize_array) -{ - F_ARRAY* array = untag_array(dpop()); - CELL capacity = unbox_array_size(); - dpush(tag_object(reallot_array(array,capacity,F))); -} - -DEFINE_PRIMITIVE(array_to_vector) -{ - F_VECTOR *vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR)); - vector->top = dpop(); - vector->array = dpop(); - dpush(tag_object(vector)); -} - F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count) { REGISTER_ROOT(elt); @@ -307,6 +252,199 @@ F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count) return result; } +/* Byte arrays */ + +/* must fill out array before next GC */ +F_BYTE_ARRAY *allot_byte_array_internal(CELL size) +{ + F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE, + byte_array_size(size)); + array->capacity = tag_fixnum(size); + return array; +} + +/* size is in bytes this time */ +F_BYTE_ARRAY *allot_byte_array(CELL size) +{ + F_BYTE_ARRAY *array = allot_byte_array_internal(size); + memset(array + 1,0,size); + return array; +} + +/* push a new byte array on the stack */ +DEFINE_PRIMITIVE(byte_array) +{ + CELL size = unbox_array_size(); + dpush(tag_object(allot_byte_array(size))); +} + +F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) +{ + CELL to_copy = array_capacity(array); + if(capacity < to_copy) + to_copy = capacity; + + REGISTER_UNTAGGED(array); + F_BYTE_ARRAY *new_array = allot_byte_array(capacity); + UNREGISTER_UNTAGGED(array); + + memcpy(new_array + 1,array + 1,to_copy); + + return new_array; +} + +DEFINE_PRIMITIVE(resize_byte_array) +{ + F_BYTE_ARRAY* array = untag_byte_array(dpop()); + CELL capacity = unbox_array_size(); + dpush(tag_object(reallot_byte_array(array,capacity))); +} + +/* Bit arrays */ + +/* size is in bits */ + +F_BIT_ARRAY *allot_bit_array_internal(CELL size) +{ + F_BIT_ARRAY *array = allot_object(BIT_ARRAY_TYPE,bit_array_size(size)); + array->capacity = tag_fixnum(size); + return array; +} + +F_BIT_ARRAY *allot_bit_array(CELL size) +{ + F_BIT_ARRAY *array = allot_bit_array_internal(size); + memset(array + 1,0,bit_array_size(size)); + return array; +} + +/* push a new bit array on the stack */ +DEFINE_PRIMITIVE(bit_array) +{ + CELL size = unbox_array_size(); + dpush(tag_object(allot_bit_array(size))); +} + +F_BIT_ARRAY *reallot_bit_array(F_BIT_ARRAY *array, CELL capacity) +{ + CELL to_copy = array_capacity(array); + if(capacity < to_copy) + to_copy = capacity; + + REGISTER_UNTAGGED(array); + F_BIT_ARRAY *new_array = allot_bit_array(capacity); + UNREGISTER_UNTAGGED(array); + + memcpy(new_array + 1,array + 1,bit_array_size(to_copy)); + + return new_array; +} + +DEFINE_PRIMITIVE(resize_bit_array) +{ + F_BYTE_ARRAY* array = untag_bit_array(dpop()); + CELL capacity = unbox_array_size(); + dpush(tag_object(reallot_bit_array(array,capacity))); +} + +/* Float arrays */ + +/* size is in 8-byte doubles */ +F_FLOAT_ARRAY *allot_float_array_internal(CELL size) +{ + F_FLOAT_ARRAY *array = allot_object(FLOAT_ARRAY_TYPE, + float_array_size(size)); + array->capacity = tag_fixnum(size); + return array; +} + +F_FLOAT_ARRAY *allot_float_array(CELL size, double initial) +{ + F_FLOAT_ARRAY *array = allot_float_array_internal(size); + + double *elements = (double *)AREF(array,0); + int i; + for(i = 0; i < size; i++) + elements[i] = initial; + + return array; +} + +/* push a new float array on the stack */ +DEFINE_PRIMITIVE(float_array) +{ + double initial = untag_float(dpop()); + CELL size = unbox_array_size(); + dpush(tag_object(allot_float_array(size,initial))); +} + +F_ARRAY *reallot_float_array(F_FLOAT_ARRAY* array, CELL capacity) +{ + F_FLOAT_ARRAY* new_array; + + CELL to_copy = array_capacity(array); + if(capacity < to_copy) + to_copy = capacity; + + REGISTER_UNTAGGED(array); + new_array = allot_float_array(capacity,0.0); + UNREGISTER_UNTAGGED(array); + + memcpy(new_array + 1,array + 1,to_copy * sizeof(double)); + + return new_array; +} + +DEFINE_PRIMITIVE(resize_float_array) +{ + F_FLOAT_ARRAY* array = untag_float_array(dpop()); + CELL capacity = unbox_array_size(); + dpush(tag_object(reallot_float_array(array,capacity))); +} + +/* Tuples */ + +/* push a new tuple on the stack */ +DEFINE_PRIMITIVE(tuple) +{ + CELL size = unbox_array_size(); + F_ARRAY *array = allot_array(TUPLE_TYPE,size,F); + set_array_nth(array,0,dpop()); + dpush(tag_tuple(array)); +} + +/* push a new tuple on the stack, filling its slots from the stack */ +DEFINE_PRIMITIVE(tuple_boa) +{ + CELL size = unbox_array_size(); + F_ARRAY *array = allot_array(TUPLE_TYPE,size,F); + set_array_nth(array,0,dpop()); + + CELL i; + for(i = size - 1; i >= 2; i--) + set_array_nth(array,i,dpop()); + + dpush(tag_tuple(array)); +} + +DEFINE_PRIMITIVE(tuple_to_array) +{ + CELL object = dpeek(); + type_check(TUPLE_TYPE,object); + object = RETAG(clone(object),OBJECT_TYPE); + set_slot(object,0,tag_header(ARRAY_TYPE)); + drepl(object); +} + +DEFINE_PRIMITIVE(to_tuple) +{ + CELL object = RETAG(clone(dpeek()),TUPLE_TYPE); + set_slot(object,0,tag_header(TUPLE_TYPE)); + drepl(object); +} + +/* Strings */ + /* untagged */ F_STRING* allot_string_internal(CELL capacity) { @@ -497,70 +635,3 @@ DEFINE_PRIMITIVE(set_char_slot) CELL value = untag_fixnum_fast(dpop()); set_string_nth(string,index,value); } - -DEFINE_PRIMITIVE(string_to_sbuf) -{ - F_SBUF *sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF)); - sbuf->top = dpop(); - sbuf->string = dpop(); - dpush(tag_object(sbuf)); -} - -DEFINE_PRIMITIVE(hashtable) -{ - F_HASHTABLE* hash = allot_object(HASHTABLE_TYPE,sizeof(F_HASHTABLE)); - hash->count = F; - hash->deleted = F; - hash->array = F; - dpush(tag_object(hash)); -} - -F_WORD *allot_word(CELL vocab, CELL name) -{ - REGISTER_ROOT(vocab); - REGISTER_ROOT(name); - F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD)); - UNREGISTER_ROOT(name); - UNREGISTER_ROOT(vocab); - - word->hashcode = tag_fixnum(rand()); - word->vocabulary = vocab; - word->name = name; - word->def = userenv[UNDEFINED_ENV]; - word->props = F; - word->counter = tag_fixnum(0); - word->compiledp = F; - word->profiling = NULL; - - REGISTER_UNTAGGED(word); - default_word_code(word,true); - UNREGISTER_UNTAGGED(word); - - REGISTER_UNTAGGED(word); - update_word_xt(word); - UNREGISTER_UNTAGGED(word); - - return word; -} - -/* ( name vocabulary -- word ) */ -DEFINE_PRIMITIVE(word) -{ - CELL vocab = dpop(); - CELL name = dpop(); - dpush(tag_object(allot_word(vocab,name))); -} - -/* word-xt ( word -- xt ) */ -DEFINE_PRIMITIVE(word_xt) -{ - F_WORD *word = untag_word(dpeek()); - drepl(allot_cell((CELL)word->xt)); -} - -DEFINE_PRIMITIVE(wrapper) -{ - F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER)); - wrapper->object = dpeek(); - drepl(tag_object(wrapper)); -} diff --git a/vm/types.h b/vm/types.h index 356b944133..ae27f1130a 100755 --- a/vm/types.h +++ b/vm/types.h @@ -14,6 +14,8 @@ INLINE CELL string_size(CELL size) return sizeof(F_STRING) + (size + 1) * CHARS; } +DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array) + INLINE CELL byte_array_capacity(F_BYTE_ARRAY *array) { return untag_fixnum_fast(array->capacity); @@ -24,6 +26,8 @@ INLINE CELL byte_array_size(CELL size) return sizeof(F_BYTE_ARRAY) + size; } +DEFINE_UNTAG(F_BIT_ARRAY,BIT_ARRAY_TYPE,bit_array) + INLINE CELL bit_array_capacity(F_BIT_ARRAY *array) { return untag_fixnum_fast(array->capacity); @@ -34,6 +38,8 @@ INLINE CELL bit_array_size(CELL size) return sizeof(F_BIT_ARRAY) + (size + 7) / 8; } +DEFINE_UNTAG(F_FLOAT_ARRAY,FLOAT_ARRAY_TYPE,float_array) + INLINE CELL float_array_capacity(F_FLOAT_ARRAY *array) { return untag_fixnum_fast(array->capacity); @@ -49,22 +55,14 @@ INLINE CELL callstack_size(CELL size) return sizeof(F_CALLSTACK) + size; } -INLINE F_CALLSTACK *untag_callstack(CELL obj) -{ - type_check(CALLSTACK_TYPE,obj); - return untag_object(obj); -} +DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack) INLINE CELL tag_boolean(CELL untagged) { return (untagged == false ? F : T); } -INLINE F_ARRAY* untag_array(CELL tagged) -{ - type_check(ARRAY_TYPE,tagged); - return untag_object(tagged); -} +DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array) #define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS) #define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS) @@ -103,17 +101,9 @@ INLINE void set_string_nth(F_STRING* string, CELL index, u16 value) cput(SREF(string,index),value); } -INLINE F_QUOTATION *untag_quotation(CELL tagged) -{ - type_check(QUOTATION_TYPE,tagged); - return untag_object(tagged); -} +DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation) -INLINE F_WORD *untag_word(CELL tagged) -{ - type_check(WORD_TYPE,tagged); - return untag_object(tagged); -} +DEFINE_UNTAG(F_WORD,WORD_TYPE,word) INLINE CELL tag_tuple(F_ARRAY *tuple) { @@ -144,6 +134,9 @@ DECLARE_PRIMITIVE(to_tuple); F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill); DECLARE_PRIMITIVE(resize_array); +DECLARE_PRIMITIVE(resize_byte_array); +DECLARE_PRIMITIVE(resize_bit_array); +DECLARE_PRIMITIVE(resize_float_array); DECLARE_PRIMITIVE(array_to_vector); From e2f81c50c6a8a720c0afcc2221e65570b799d566 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 29 Jan 2008 20:01:57 -0600 Subject: [PATCH 22/66] make misc/factor.sh install gcc, make, and answer yes to apt-get --- misc/factor.sh | 370 +++++++++++++++++++++++++------------------------ 1 file changed, 186 insertions(+), 184 deletions(-) diff --git a/misc/factor.sh b/misc/factor.sh index 8dca786846..39a15f93dc 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -13,289 +13,291 @@ WORD= NO_UI= ensure_program_installed() { - echo -n "Checking for $1..." - result=`type -p $1` - if ! [[ -n $result ]] ; then - echo "not found!" - echo "Install $1 and try again." - exit 1 - fi - echo "found!" + echo -n "Checking for $1..." + result=`type -p $1` + if ! [[ -n $result ]] ; then + echo "not found!" + echo "Install $1 and try again." + exit 1 + fi + echo "found!" } check_ret() { - RET=$? - if [[ $RET -ne 0 ]] ; then - echo $1 failed - exit 2 - fi + RET=$? + if [[ $RET -ne 0 ]] ; then + echo $1 failed + exit 2 + fi } check_gcc_version() { - echo -n "Checking gcc version..." - GCC_VERSION=`gcc --version` - check_ret gcc - if [[ $GCC_VERSION == *3.3.* ]] ; then - echo "bad!" - echo "You have a known buggy version of gcc (3.3)" - echo "Install gcc 3.4 or higher and try again." - exit 3 - fi - echo "ok." + echo -n "Checking gcc version..." + GCC_VERSION=`gcc --version` + check_ret gcc + if [[ $GCC_VERSION == *3.3.* ]] ; then + echo "bad!" + echo "You have a known buggy version of gcc (3.3)" + echo "Install gcc 3.4 or higher and try again." + exit 3 + fi + echo "ok." } check_installed_programs() { - ensure_program_installed chmod - ensure_program_installed uname - ensure_program_installed git - ensure_program_installed wget - ensure_program_installed gcc - ensure_program_installed make - check_gcc_version + ensure_program_installed sudo + ensure_program_installed chmod + ensure_program_installed uname + ensure_program_installed git + ensure_program_installed wget + ensure_program_installed gcc + ensure_program_installed make + check_gcc_version } check_library_exists() { - GCC_TEST=factor-library-test.c - GCC_OUT=factor-library-test.out - echo -n "Checking for library $1..." - echo "int main(){return 0;}" > $GCC_TEST - gcc $GCC_TEST -o $GCC_OUT -l $1 - if [[ $? -ne 0 ]] ; then - echo "not found!" - echo "Warning: library $1 not found." - echo "***Factor will compile NO_UI=1" - NO_UI=1 - fi - rm -f $GCC_TEST - check_ret rm - rm -f $GCC_OUT - check_ret rm - echo "found." + GCC_TEST=factor-library-test.c + GCC_OUT=factor-library-test.out + echo -n "Checking for library $1..." + echo "int main(){return 0;}" > $GCC_TEST + gcc $GCC_TEST -o $GCC_OUT -l $1 + if [[ $? -ne 0 ]] ; then + echo "not found!" + echo "Warning: library $1 not found." + echo "***Factor will compile NO_UI=1" + NO_UI=1 + fi + rm -f $GCC_TEST + check_ret rm + rm -f $GCC_OUT + check_ret rm + echo "found." } check_X11_libraries() { - check_library_exists freetype - check_library_exists GLU - check_library_exists GL - check_library_exists X11 + check_library_exists freetype + check_library_exists GLU + check_library_exists GL + check_library_exists X11 } check_libraries() { - case $OS in - linux) check_X11_libraries;; - esac + case $OS in + linux) check_X11_libraries;; + esac } check_factor_exists() { - if [[ -d "factor" ]] ; then - echo "A directory called 'factor' already exists." - echo "Rename or delete it and try again." - exit 4 - fi + if [[ -d "factor" ]] ; then + echo "A directory called 'factor' already exists." + echo "Rename or delete it and try again." + exit 4 + fi } find_os() { - echo "Finding OS..." - uname_s=`uname -s` - check_ret uname - case $uname_s in - CYGWIN_NT-5.2-WOW64) OS=windows-nt;; - *CYGWIN_NT*) OS=windows-nt;; - *CYGWIN*) OS=windows-nt;; - *darwin*) OS=macosx;; - *Darwin*) OS=macosx;; - *linux*) OS=linux;; - *Linux*) OS=linux;; - esac + echo "Finding OS..." + uname_s=`uname -s` + check_ret uname + case $uname_s in + CYGWIN_NT-5.2-WOW64) OS=windows-nt;; + *CYGWIN_NT*) OS=windows-nt;; + *CYGWIN*) OS=windows-nt;; + *darwin*) OS=macosx;; + *Darwin*) OS=macosx;; + *linux*) OS=linux;; + *Linux*) OS=linux;; + esac } find_architecture() { - echo "Finding ARCH..." - uname_m=`uname -m` - check_ret uname - case $uname_m in - i386) ARCH=x86;; - i686) ARCH=x86;; - *86) ARCH=x86;; - *86_64) ARCH=x86;; - "Power Macintosh") ARCH=ppc;; - esac + echo "Finding ARCH..." + uname_m=`uname -m` + check_ret uname + case $uname_m in + i386) ARCH=x86;; + i686) ARCH=x86;; + *86) ARCH=x86;; + *86_64) ARCH=x86;; + "Power Macintosh") ARCH=ppc;; + esac } write_test_program() { - echo "#include " > $C_WORD.c - echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c + echo "#include " > $C_WORD.c + echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c } find_word_size() { - echo "Finding WORD..." - C_WORD=factor-word-size - write_test_program - gcc -o $C_WORD $C_WORD.c - WORD=$(./$C_WORD) - check_ret $C_WORD - rm -f $C_WORD* + echo "Finding WORD..." + C_WORD=factor-word-size + write_test_program + gcc -o $C_WORD $C_WORD.c + WORD=$(./$C_WORD) + check_ret $C_WORD + rm -f $C_WORD* } set_factor_binary() { - case $OS in - windows-nt) FACTOR_BINARY=factor-nt;; - macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; - *) FACTOR_BINARY=factor;; - esac + case $OS in + windows-nt) FACTOR_BINARY=factor-nt;; + macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; + *) FACTOR_BINARY=factor;; + esac } echo_build_info() { - echo OS=$OS - echo ARCH=$ARCH - echo WORD=$WORD - echo FACTOR_BINARY=$FACTOR_BINARY - echo MAKE_TARGET=$MAKE_TARGET - echo BOOT_IMAGE=$BOOT_IMAGE - echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET + echo OS=$OS + echo ARCH=$ARCH + echo WORD=$WORD + echo FACTOR_BINARY=$FACTOR_BINARY + echo MAKE_TARGET=$MAKE_TARGET + echo BOOT_IMAGE=$BOOT_IMAGE + echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET } set_build_info() { - if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then - echo "OS: $OS" - echo "ARCH: $ARCH" - echo "WORD: $WORD" - echo "OS, ARCH, or WORD is empty. Please report this" - exit 5 - fi + if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then + echo "OS: $OS" + echo "ARCH: $ARCH" + echo "WORD: $WORD" + echo "OS, ARCH, or WORD is empty. Please report this" + exit 5 + fi - MAKE_TARGET=$OS-$ARCH-$WORD - MAKE_IMAGE_TARGET=$ARCH.$WORD - BOOT_IMAGE=boot.$ARCH.$WORD.image - if [[ $OS == macosx && $ARCH == ppc ]] ; then - MAKE_IMAGE_TARGET=$OS-$ARCH - MAKE_TARGET=$OS-$ARCH - BOOT_IMAGE=boot.macosx-ppc.image - fi - if [[ $OS == linux && $ARCH == ppc ]] ; then - MAKE_IMAGE_TARGET=$OS-$ARCH - MAKE_TARGET=$OS-$ARCH - BOOT_IMAGE=boot.linux-ppc.image - fi + MAKE_TARGET=$OS-$ARCH-$WORD + MAKE_IMAGE_TARGET=$ARCH.$WORD + BOOT_IMAGE=boot.$ARCH.$WORD.image + if [[ $OS == macosx && $ARCH == ppc ]] ; then + MAKE_IMAGE_TARGET=$OS-$ARCH + MAKE_TARGET=$OS-$ARCH + BOOT_IMAGE=boot.macosx-ppc.image + fi + if [[ $OS == linux && $ARCH == ppc ]] ; then + MAKE_IMAGE_TARGET=$OS-$ARCH + MAKE_TARGET=$OS-$ARCH + BOOT_IMAGE=boot.linux-ppc.image + fi } find_build_info() { - find_os - find_architecture - find_word_size - set_factor_binary - set_build_info - echo_build_info + find_os + find_architecture + find_word_size + set_factor_binary + set_build_info + echo_build_info } git_clone() { - echo "Downloading the git repository from factorcode.org..." - git clone git://factorcode.org/git/factor.git - check_ret git + echo "Downloading the git repository from factorcode.org..." + git clone git://factorcode.org/git/factor.git + check_ret git } git_pull_factorcode() { - echo "Updating the git repository from factorcode.org..." - git pull git://factorcode.org/git/factor.git - check_ret git + echo "Updating the git repository from factorcode.org..." + git pull git://factorcode.org/git/factor.git + check_ret git } cd_factor() { - cd factor - check_ret cd + cd factor + check_ret cd } make_clean() { - make clean - check_ret make + make clean + check_ret make } make_factor() { - make NO_UI=$NO_UI $MAKE_TARGET -j5 - check_ret make + make NO_UI=$NO_UI $MAKE_TARGET -j5 + check_ret make } delete_boot_images() { - echo "Deleting old images..." - rm $BOOT_IMAGE > /dev/null 2>&1 - rm $BOOT_IMAGE.* > /dev/null 2>&1 + echo "Deleting old images..." + rm $BOOT_IMAGE > /dev/null 2>&1 + rm $BOOT_IMAGE.* > /dev/null 2>&1 } get_boot_image() { - wget http://factorcode.org/images/latest/$BOOT_IMAGE - check_ret wget + wget http://factorcode.org/images/latest/$BOOT_IMAGE + check_ret wget } maybe_download_dlls() { - if [[ $OS == windows-nt ]] ; then - wget http://factorcode.org/dlls/freetype6.dll - check_ret wget - wget http://factorcode.org/dlls/zlib1.dll - check_ret wget - chmod 777 *.dll - check_ret chmod - fi + if [[ $OS == windows-nt ]] ; then + wget http://factorcode.org/dlls/freetype6.dll + check_ret wget + wget http://factorcode.org/dlls/zlib1.dll + check_ret wget + chmod 777 *.dll + check_ret chmod + fi } get_config_info() { - check_installed_programs - find_build_info - check_libraries + check_installed_programs + find_build_info + check_libraries } bootstrap() { - ./$FACTOR_BINARY -i=$BOOT_IMAGE + ./$FACTOR_BINARY -i=$BOOT_IMAGE } install() { - check_factor_exists - get_config_info - git_clone - cd_factor - make_factor - get_boot_image - maybe_download_dlls - bootstrap + check_factor_exists + get_config_info + git_clone + cd_factor + make_factor + get_boot_image + maybe_download_dlls + bootstrap } update() { - get_config_info - git_pull_factorcode - make_clean - make_factor + get_config_info + git_pull_factorcode + make_clean + make_factor } update_bootstrap() { - delete_boot_images - get_boot_image - bootstrap + delete_boot_images + get_boot_image + bootstrap } refresh_image() { - ./$FACTOR_BINARY -script -e="refresh-all save 0 USE: system exit" - check_ret factor + ./$FACTOR_BINARY -script -e="refresh-all save 0 USE: system exit" + check_ret factor } make_boot_image() { - ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit" - check_ret factor + ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit" + check_ret factor } install_libraries() { - sudo apt-get install libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap + yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make + check_ret sudo } usage() { - echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap" + echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap" } case "$1" in - install) install ;; - install-x11) install_libraries; install ;; - self-update) update; make_boot_image; bootstrap;; - quick-update) update; refresh_image ;; - update) update; update_bootstrap ;; - bootstrap) get_config_info; bootstrap ;; - *) usage ;; + install) install ;; + install-x11) install_libraries; install ;; + self-update) update; make_boot_image; bootstrap;; + quick-update) update; refresh_image ;; + update) update; update_bootstrap ;; + bootstrap) get_config_info; bootstrap ;; + *) usage ;; esac From 28ee96af4079445f140b0fc712e7b5efb739138d Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 29 Jan 2008 20:52:58 -0600 Subject: [PATCH 23/66] namespaces.lib: set-assoc-stack --- extra/namespaces/lib/lib.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index 6e66119cb0..528e770558 100644 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -16,4 +16,4 @@ IN: namespaces.lib ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: set* ( val var -- ) namestack* set-hash-stack ; +: set* ( val var -- ) namestack* set-assoc-stack ; From 5f2655747a1471103daccb9c02d84b82d5593a05 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 29 Jan 2008 23:06:27 -0600 Subject: [PATCH 24/66] Pastebin now uses in-memory persistence as store is broken. Will use db soon --- extra/store/authors.txt | 1 - extra/store/blob/authors.txt | 1 - extra/store/blob/blob.factor | 22 ---------------- extra/store/store-tests.factor | 35 -------------------------- extra/store/store.factor | 33 ------------------------ extra/webapps/pastebin/pastebin.factor | 25 ++++++------------ 6 files changed, 8 insertions(+), 109 deletions(-) delete mode 100644 extra/store/authors.txt delete mode 100755 extra/store/blob/authors.txt delete mode 100644 extra/store/blob/blob.factor delete mode 100644 extra/store/store-tests.factor delete mode 100644 extra/store/store.factor diff --git a/extra/store/authors.txt b/extra/store/authors.txt deleted file mode 100644 index 7c1b2f2279..0000000000 --- a/extra/store/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/store/blob/authors.txt b/extra/store/blob/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/extra/store/blob/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/store/blob/blob.factor b/extra/store/blob/blob.factor deleted file mode 100644 index 9cec77c6c2..0000000000 --- a/extra/store/blob/blob.factor +++ /dev/null @@ -1,22 +0,0 @@ -! Copyright (C) 2006 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel io io.files namespaces serialize ; -IN: store.blob - -: (save-blob) serialize ; - -: save-blob ( obj path -- ) - [ (save-blob) ] with-stream ; - -: (load-blob) ( path -- seq/f ) - dup exists? [ - [ - deserialize-sequence - ] with-stream - ] [ - drop f - ] if ; - -: load-blob ( path -- seq/f ) - resource-path (load-blob) ; - diff --git a/extra/store/store-tests.factor b/extra/store/store-tests.factor deleted file mode 100644 index 6f33d66101..0000000000 --- a/extra/store/store-tests.factor +++ /dev/null @@ -1,35 +0,0 @@ -USING: assocs continuations debugger io.files kernel -namespaces store tools.test ; -IN: temporary - -SYMBOL: store -SYMBOL: foo - -: the-store ( -- path ) - "store-test.store" resource-path ; - -: delete-the-store ( -- ) - [ the-store delete-file ] catch drop ; - -: load-the-store ( -- ) - the-store load-store store set-global ; - -: save-the-store ( -- ) - store save-store ; - -delete-the-store -load-the-store - -[ f ] [ foo store get-persistent ] unit-test - -USE: prettyprint -store get-global store-data . - -[ ] [ 100 foo store set-persistent ] unit-test - -[ ] [ save-the-store ] unit-test - -[ 100 ] [ foo store get-persistent ] unit-test - -delete-the-store -f store set-global diff --git a/extra/store/store.factor b/extra/store/store.factor deleted file mode 100644 index 46b1a09568..0000000000 --- a/extra/store/store.factor +++ /dev/null @@ -1,33 +0,0 @@ -! Copyright (C) 2006, 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs io io.files kernel namespaces serialize init ; -IN: store - -TUPLE: store path data ; - -C: store - -: save-store ( store -- ) - get-global dup store-data swap store-path - [ serialize ] with-stream ; - -: load-store ( path -- store ) - dup exists? [ - dup [ deserialize ] with-stream - ] [ - H{ } clone - ] if ; - -: define-store ( path id -- ) - over >r - [ >r resource-path load-store r> set-global ] 2curry - r> add-init-hook ; - -: get-persistent ( key store -- value ) - get-global store-data at ; - -: set-persistent ( value key store -- ) - [ get-global store-data set-at ] keep save-store ; - -: init-persistent ( value key store -- ) - 2dup get-persistent [ 3drop ] [ set-persistent ] if ; diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 9492e9e5a1..5ac322a952 100755 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -1,6 +1,6 @@ USING: calendar furnace furnace.validator io.files kernel -namespaces sequences store http.server.responders html -math.parser rss xml.writer xmode.code2html ; +namespaces sequences http.server.responders html math.parser rss +xml.writer xmode.code2html ; IN: webapps.pastebin TUPLE: pastebin pastes ; @@ -8,11 +8,7 @@ TUPLE: pastebin pastes ; : ( -- pastebin ) V{ } clone pastebin construct-boa ; -! Persistence -SYMBOL: store - -"pastebin.store" store define-store - pastebin store init-persistent + pastebin set-global TUPLE: paste summary author channel mode contents date @@ -25,11 +21,8 @@ TUPLE: annotation summary author mode contents ; C: annotation -: get-pastebin ( -- pastebin ) - pastebin store get-persistent ; - : get-paste ( n -- paste ) - get-pastebin pastebin-pastes nth ; + pastebin get pastebin-pastes nth ; : show-paste ( n -- ) serving-html @@ -49,7 +42,7 @@ C: annotation [ [ show-paste ] "show-paste-quot" set [ new-paste ] "new-paste-quot" set - get-pastebin "paste-list" render-component + pastebin get "paste-list" render-component ] with-html-stream ; \ paste-list { } define-action @@ -61,7 +54,7 @@ C: annotation over length min head ; : paste-feed ( -- entries ) - get-pastebin pastebin-pastes 20 safe-head [ + pastebin get pastebin-pastes 20 safe-head [ { paste-summary paste-link @@ -82,10 +75,8 @@ C: annotation pastebin-pastes 2dup length swap set-paste-n push ; : submit-paste ( summary author channel mode contents -- ) - [ - pastebin store get-persistent add-paste - store save-store - ] keep paste-link permanent-redirect ; + [ pastebin get add-paste ] keep + paste-link permanent-redirect ; \ new-paste \ submit-paste { From fcf5801899f79f9e23e2a97a7b0f5f3b6b300050 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 29 Jan 2008 23:13:47 -0600 Subject: [PATCH 25/66] Data type cleanups --- core/bit-vectors/bit-vectors-docs.factor | 2 +- core/bootstrap/image/image.factor | 23 ++-- core/bootstrap/layouts/layouts.factor | 11 +- core/bootstrap/primitives.factor | 109 +++++++++---------- core/byte-vectors/byte-vectors-docs.factor | 4 +- core/float-vectors/float-vectors-docs.factor | 34 ++++++ core/hashtables/hashtables.factor | 2 +- core/prettyprint/backend/backend.factor | 1 + core/sbufs/sbufs.factor | 11 +- core/vectors/vectors-docs.factor | 2 +- core/vectors/vectors.factor | 13 ++- vm/data_gc.c | 6 - vm/layouts.h | 43 +------- vm/primitives.c | 3 - vm/types.c | 25 ----- vm/types.h | 6 - 16 files changed, 136 insertions(+), 159 deletions(-) mode change 100644 => 100755 core/bootstrap/layouts/layouts.factor create mode 100755 core/float-vectors/float-vectors-docs.factor mode change 100644 => 100755 core/sbufs/sbufs.factor diff --git a/core/bit-vectors/bit-vectors-docs.factor b/core/bit-vectors/bit-vectors-docs.factor index b4b6d8e845..a16f58ec14 100755 --- a/core/bit-vectors/bit-vectors-docs.factor +++ b/core/bit-vectors/bit-vectors-docs.factor @@ -28,6 +28,6 @@ HELP: >bit vector { $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ; HELP: bit-array>vector -{ $values { "bit-array" "an array" } { "capacity" "a non-negative integer" } { "bit-vector" bit-vector } } +{ $values { "bit-array" "an array" } { "length" "a non-negative integer" } { "bit-vector" bit-vector } } { $description "Creates a new bit vector using the array for underlying storage with the specified initial length." } { $warning "This word is in the " { $vocab-link "bit-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >bit-vector } " instead." } ; diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 43a8d9752a..f7e0d483f6 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -320,24 +320,33 @@ M: quotation ' ! Vectors and sbufs M: vector ' - dup underlying ' swap length - vector type-number object tag-number [ - emit-fixnum ! length + dup length swap underlying ' + tuple type-number tuple tag-number [ + 4 emit-fixnum + vector ' emit + f ' emit emit ! array ptr + emit-fixnum ! length ] emit-object ; M: sbuf ' - dup underlying ' swap length - sbuf type-number object tag-number [ - emit-fixnum ! length + dup length swap underlying ' + tuple type-number tuple tag-number [ + 4 emit-fixnum + sbuf ' emit + f ' emit emit ! array ptr + emit-fixnum ! length ] emit-object ; ! Hashes M: hashtable ' [ hash-array ' ] keep - hashtable type-number object tag-number [ + tuple type-number tuple tag-number [ + 5 emit-fixnum + hashtable ' emit + f ' emit dup hash-count emit-fixnum hash-deleted emit-fixnum emit ! array ptr diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor old mode 100644 new mode 100755 index 189233e2d4..9c0d6b9838 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -8,7 +8,7 @@ BIN: 111 tag-mask set 8 num-tags set 3 tag-bits set -23 num-types set +20 num-types set H{ { fixnum BIN: 000 } @@ -24,17 +24,14 @@ H{ tag-numbers get H{ { array 8 } { wrapper 9 } - { hashtable 10 } - { vector 11 } + { float-array 10 } + { callstack 11 } { string 12 } - { sbuf 13 } + { curry 13 } { quotation 14 } { dll 15 } { alien 16 } { word 17 } { byte-array 18 } { bit-array 19 } - { float-array 20 } - { curry 21 } - { callstack 22 } } union type-numbers set diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index e13576992a..4c5246e0eb 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -22,7 +22,9 @@ crossref off { "arm" "arm" } } at "/bootstrap.factor" 3append parse-file -! Now we have ( syntax-quot arch-quot ) on the stack +"resource:core/bootstrap/layouts/layouts.factor" parse-file + +! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack ! Bring up a bare cross-compiling vocabulary. "syntax" vocab vocab-words bootstrap-syntax set @@ -30,6 +32,7 @@ H{ } clone dictionary set H{ } clone changed-words set [ drop ] recompile-hook set +call call call @@ -180,41 +183,6 @@ num-types get f builtins set } } define-builtin -"hashtable" "hashtables" create "hashtable?" "hashtables" create -{ - { - { "array-capacity" "sequences.private" } - "count" - { "hash-count" "hashtables.private" } - { "set-hash-count" "hashtables.private" } - } { - { "array-capacity" "sequences.private" } - "deleted" - { "hash-deleted" "hashtables.private" } - { "set-hash-deleted" "hashtables.private" } - } { - { "array" "arrays" } - "array" - { "hash-array" "hashtables.private" } - { "set-hash-array" "hashtables.private" } - } -} define-builtin - -"vector" "vectors" create "vector?" "vectors" create -{ - { - { "array-capacity" "sequences.private" } - "fill" - { "length" "sequences" } - { "set-fill" "growable" } - } { - { "array" "arrays" } - "underlying" - { "underlying" "growable" } - { "set-underlying" "growable" } - } -} define-builtin - "string" "strings" create "string?" "strings" create { { @@ -225,22 +193,6 @@ num-types get f builtins set } } define-builtin -"sbuf" "sbufs" create "sbuf?" "sbufs" create -{ - { - { "array-capacity" "sequences.private" } - "length" - { "length" "sequences" } - { "set-fill" "growable" } - } - { - { "string" "strings" } - "underlying" - { "underlying" "growable" } - { "set-underlying" "growable" } - } -} define-builtin - "quotation" "quotations" create "quotation?" "quotations" create { { @@ -387,6 +339,56 @@ builtins get num-tags get tail f union-class define-class 2array >tuple 1quotation define-inline ! Some tuple classes +"hashtable" "hashtables" create +{ + { + { "array-capacity" "sequences.private" } + "count" + { "hash-count" "hashtables.private" } + { "set-hash-count" "hashtables.private" } + } { + { "array-capacity" "sequences.private" } + "deleted" + { "hash-deleted" "hashtables.private" } + { "set-hash-deleted" "hashtables.private" } + } { + { "array" "arrays" } + "array" + { "hash-array" "hashtables.private" } + { "set-hash-array" "hashtables.private" } + } +} define-tuple-class + +"sbuf" "sbufs" create +{ + { + { "string" "strings" } + "underlying" + { "underlying" "growable" } + { "set-underlying" "growable" } + } { + { "array-capacity" "sequences.private" } + "length" + { "length" "sequences" } + { "set-fill" "growable" } + } +} define-tuple-class + +"vector" "vectors" create +{ + { + { "array" "arrays" } + "underlying" + { "underlying" "growable" } + { "set-underlying" "growable" } + } { + { "array-capacity" "sequences.private" } + "fill" + { "length" "sequences" } + { "set-fill" "growable" } + } +} define-tuple-class + "byte-vector" "byte-vectors" create { { @@ -440,7 +442,6 @@ builtins get num-tags get tail f union-class define-class { "(execute)" "words.private" } { "(call)" "kernel.private" } { "uncurry" "kernel.private" } - { "string>sbuf" "sbufs.private" } { "bignum>fixnum" "math.private" } { "float>fixnum" "math.private" } { "fixnum>bignum" "math.private" } @@ -593,7 +594,6 @@ builtins get num-tags get tail f union-class define-class { "set-char-slot" "strings.private" } { "resize-array" "arrays" } { "resize-string" "strings" } - { "(hashtable)" "hashtables.private" } { "" "arrays" } { "begin-scan" "memory" } { "next-object" "memory" } @@ -608,7 +608,6 @@ builtins get num-tags get tail f union-class define-class { "fclose" "io.streams.c" } { "" "kernel" } { "(clone)" "kernel" } - { "array>vector" "vectors.private" } { "" "strings" } { "(>tuple)" "tuples.private" } { "array>quotation" "quotations.private" } diff --git a/core/byte-vectors/byte-vectors-docs.factor b/core/byte-vectors/byte-vectors-docs.factor index e4bd1bd096..9d29d31550 100755 --- a/core/byte-vectors/byte-vectors-docs.factor +++ b/core/byte-vectors/byte-vectors-docs.factor @@ -23,12 +23,12 @@ HELP: { $values { "n" "a positive integer specifying initial capacity" } { "vector" vector } } { $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ; -HELP: >byte vector +HELP: >byte-vector { $values { "seq" "a sequence" } { "vector" vector } } { $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." } { $errors "Throws an error if the sequence contains elements other than integers." } ; HELP: byte-array>vector -{ $values { "byte-array" "an array" } { "capacity" "a non-negative integer" } { "byte-vector" byte-vector } } +{ $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } } { $description "Creates a new byte vector using the array for underlying storage with the specified initial length." } { $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ; diff --git a/core/float-vectors/float-vectors-docs.factor b/core/float-vectors/float-vectors-docs.factor new file mode 100755 index 0000000000..4d04101e7b --- /dev/null +++ b/core/float-vectors/float-vectors-docs.factor @@ -0,0 +1,34 @@ +USING: arrays float-arrays help.markup help.syntax kernel +float-vectors.private combinators ; +IN: float-vectors + +ARTICLE: "float-vectors" "Float vectors" +"A float vector is a resizable mutable sequence of unsigned floats. The literal syntax is covered in " { $link "syntax-float-vectors" } ". Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary." +$nl +"Float vectors form a class:" +{ $subsection float-vector } +{ $subsection float-vector? } +"Creating float vectors:" +{ $subsection >float-vector } +{ $subsection } +"If you don't care about initial capacity, a more elegant way to create a new float vector is to write:" +{ $code "BV{ } clone" } ; + +ABOUT: "float-vectors" + +HELP: float-vector +{ $description "The class of resizable float vectors. See " { $link "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general information." } ; + +HELP: +{ $values { "n" "a positive integer specifying initial capacity" } { "vector" vector } } +{ $description "Creates a new float vector that can hold " { $snippet "n" } " floats before resizing." } ; + +HELP: >float-vector +{ $values { "seq" "a sequence" } { "vector" vector } } +{ $description "Outputs a freshly-allocated float vector with the same elements as a given sequence." } +{ $errors "Throws an error if the sequence contains elements other than real numbers." } ; + +HELP: float-array>vector +{ $values { "float-array" "an array" } { "length" "a non-negative integer" } { "float-vector" float-vector } } +{ $description "Creates a new float vector using the array for underlying storage with the specified initial length." } +{ $warning "This word is in the " { $vocab-link "float-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >float-vector } " instead." } ; diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index e477aa59ed..b24928a71e 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -122,7 +122,7 @@ IN: hashtables PRIVATE> : ( n -- hash ) - (hashtable) [ reset-hash ] keep ; + hashtable construct-empty [ reset-hash ] keep ; M: hashtable at* ( key hash -- value ? ) key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ; diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index 8d0140202e..380ab87d40 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -155,6 +155,7 @@ GENERIC: >pprint-sequence ( obj -- seq ) M: object >pprint-sequence ; +M: vector >pprint-sequence ; M: hashtable >pprint-sequence >alist ; M: tuple >pprint-sequence tuple>array ; M: wrapper >pprint-sequence wrapped 1array ; diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor old mode 100644 new mode 100755 index 3753be7729..bcc7536e6f --- a/core/sbufs/sbufs.factor +++ b/core/sbufs/sbufs.factor @@ -1,9 +1,16 @@ ! Copyright (C) 2004, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math strings kernel.private sequences.private -sequences strings growable strings.private sbufs.private ; +USING: kernel math strings sequences.private sequences strings +growable strings.private ; IN: sbufs +sbuf ( string length -- sbuf ) + sbuf construct-boa ; inline + +PRIVATE> + : ( n -- sbuf ) 0 0 string>sbuf ; inline M: sbuf set-nth-unsafe diff --git a/core/vectors/vectors-docs.factor b/core/vectors/vectors-docs.factor index 7093c684a9..b130dc4a71 100755 --- a/core/vectors/vectors-docs.factor +++ b/core/vectors/vectors-docs.factor @@ -30,7 +30,7 @@ HELP: >vector { $values { "seq" "a sequence" } { "vector" vector } } { $description "Outputs a freshly-allocated vector with the same elements as a given sequence." } ; -HELP: array>vector ( array length -- vector ) +HELP: array>vector { $values { "array" "an array" } { "length" "a non-negative integer" } { "vector" vector } } { $description "Creates a new vector using the array for underlying storage with the specified initial length." } { $warning "This word is in the " { $vocab-link "vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >vector } " instead." } ; diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor index 8d52b8fa9c..ed97bcc0c4 100755 --- a/core/vectors/vectors.factor +++ b/core/vectors/vectors.factor @@ -1,10 +1,15 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel kernel.private math -math.private sequences sequences.private vectors.private -growable ; +USING: arrays kernel math sequences sequences.private growable ; IN: vectors +vector ( byte-array capacity -- byte-vector ) + vector construct-boa ; inline + +PRIVATE> + : ( n -- vector ) f 0 array>vector ; inline : >vector ( seq -- vector ) V{ } clone-like ; diff --git a/vm/data_gc.c b/vm/data_gc.c index 4826c1d1ea..3ca41d602c 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -177,12 +177,6 @@ CELL unaligned_object_size(CELL pointer) return sizeof(F_QUOTATION); case WORD_TYPE: return sizeof(F_WORD); - case HASHTABLE_TYPE: - return sizeof(F_HASHTABLE); - case VECTOR_TYPE: - return sizeof(F_VECTOR); - case SBUF_TYPE: - return sizeof(F_SBUF); case RATIO_TYPE: return sizeof(F_RATIO); case FLOAT_TYPE: diff --git a/vm/layouts.h b/vm/layouts.h index 302a4497b4..07e22cfed0 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -52,21 +52,18 @@ typedef signed long long s64; /*** Header types ***/ #define ARRAY_TYPE 8 #define WRAPPER_TYPE 9 -#define HASHTABLE_TYPE 10 -#define VECTOR_TYPE 11 +#define FLOAT_ARRAY_TYPE 10 +#define CALLSTACK_TYPE 11 #define STRING_TYPE 12 -#define SBUF_TYPE 13 +#define CURRY_TYPE 13 #define QUOTATION_TYPE 14 #define DLL_TYPE 15 #define ALIEN_TYPE 16 #define WORD_TYPE 17 #define BYTE_ARRAY_TYPE 18 #define BIT_ARRAY_TYPE 19 -#define FLOAT_ARRAY_TYPE 20 -#define CURRY_TYPE 21 -#define CALLSTACK_TYPE 22 -#define TYPE_COUNT 23 +#define TYPE_COUNT 20 INLINE bool immediate_p(CELL obj) { @@ -103,16 +100,6 @@ typedef F_ARRAY F_BIT_ARRAY; typedef F_ARRAY F_FLOAT_ARRAY; -/* Assembly code makes assumptions about the layout of this struct */ -typedef struct { - /* always tag_header(VECTOR_TYPE) */ - CELL header; - /* tagged */ - CELL top; - /* tagged */ - CELL array; -} F_VECTOR; - /* Assembly code makes assumptions about the layout of this struct */ typedef struct { CELL header; @@ -122,28 +109,6 @@ typedef struct { CELL hashcode; } F_STRING; -/* Assembly code makes assumptions about the layout of this struct */ -typedef struct { - /* always tag_header(SBUF_TYPE) */ - CELL header; - /* tagged */ - CELL top; - /* tagged */ - CELL string; -} F_SBUF; - -/* Assembly code makes assumptions about the layout of this struct */ -typedef struct { - /* always tag_header(HASHTABLE_TYPE) */ - CELL header; - /* tagged */ - CELL count; - /* tagged */ - CELL deleted; - /* tagged */ - CELL array; -} F_HASHTABLE; - /* The compiled code heap is structured into blocks. */ typedef struct { diff --git a/vm/primitives.c b/vm/primitives.c index 78dbc28358..3b986e970a 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -4,7 +4,6 @@ void *primitives[] = { primitive_execute, primitive_call, primitive_uncurry, - primitive_string_to_sbuf, primitive_bignum_to_fixnum, primitive_float_to_fixnum, primitive_fixnum_to_bignum, @@ -157,7 +156,6 @@ void *primitives[] = { primitive_set_char_slot, primitive_resize_array, primitive_resize_string, - primitive_hashtable, primitive_array, primitive_begin_scan, primitive_next_object, @@ -172,7 +170,6 @@ void *primitives[] = { primitive_fclose, primitive_wrapper, primitive_clone, - primitive_array_to_vector, primitive_string, primitive_to_tuple, primitive_array_to_quotation, diff --git a/vm/types.c b/vm/types.c index 9f5dfb1248..27a5b55e2b 100755 --- a/vm/types.c +++ b/vm/types.c @@ -34,31 +34,6 @@ DEFINE_PRIMITIVE(clone) drepl(clone(dpeek())); } -DEFINE_PRIMITIVE(array_to_vector) -{ - F_VECTOR *vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR)); - vector->top = dpop(); - vector->array = dpop(); - dpush(tag_object(vector)); -} - -DEFINE_PRIMITIVE(string_to_sbuf) -{ - F_SBUF *sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF)); - sbuf->top = dpop(); - sbuf->string = dpop(); - dpush(tag_object(sbuf)); -} - -DEFINE_PRIMITIVE(hashtable) -{ - F_HASHTABLE* hash = allot_object(HASHTABLE_TYPE,sizeof(F_HASHTABLE)); - hash->count = F; - hash->deleted = F; - hash->array = F; - dpush(tag_object(hash)); -} - F_WORD *allot_word(CELL vocab, CELL name) { REGISTER_ROOT(vocab); diff --git a/vm/types.h b/vm/types.h index ae27f1130a..dca54e5951 100755 --- a/vm/types.h +++ b/vm/types.h @@ -138,8 +138,6 @@ DECLARE_PRIMITIVE(resize_byte_array); DECLARE_PRIMITIVE(resize_bit_array); DECLARE_PRIMITIVE(resize_float_array); -DECLARE_PRIMITIVE(array_to_vector); - F_STRING* allot_string_internal(CELL capacity); F_STRING* allot_string(CELL capacity, CELL fill); DECLARE_PRIMITIVE(string); @@ -171,10 +169,6 @@ DECLARE_PRIMITIVE(string_to_u16_alien); DECLARE_PRIMITIVE(char_slot); DECLARE_PRIMITIVE(set_char_slot); -DECLARE_PRIMITIVE(string_to_sbuf); - -DECLARE_PRIMITIVE(hashtable); - F_WORD *allot_word(CELL vocab, CELL name); DECLARE_PRIMITIVE(word); DECLARE_PRIMITIVE(word_xt); From d11203cf28580529a6f58bf1beab6e0c3b326f78 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 29 Jan 2008 23:17:22 -0600 Subject: [PATCH 26/66] Documentation update --- extra/help/handbook/handbook.factor | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index fdfc6b6604..3b959ba801 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -110,15 +110,21 @@ USE: io.buffers ARTICLE: "collections" "Collections" { $heading "Sequences" } { $subsection "sequences" } -"Sequence implementations:" +"Fixed-length sequences:" { $subsection "arrays" } -{ $subsection "vectors" } +{ $subsection "quotations" } +"Fixed-length specialized sequences:" +{ $subsection "strings" } { $subsection "bit-arrays" } { $subsection "byte-arrays" } { $subsection "float-arrays" } -{ $subsection "strings" } +"Resizable sequence:" +{ $subsection "vectors" } +"Resizable specialized sequences:" { $subsection "sbufs" } -{ $subsection "quotations" } +{ $subsection "bit-vectors" } +{ $subsection "byte-vectors" } +{ $subsection "float-vectors" } { $heading "Associative mappings" } { $subsection "assocs" } { $subsection "namespaces" } From f73f2b8697c043366e37e058ebf4ab862f9e2b77 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 30 Jan 2008 01:10:58 -0600 Subject: [PATCH 27/66] Assorted fixes --- core/bit-vectors/bit-vectors-docs.factor | 6 +-- core/bit-vectors/bit-vectors-tests.factor | 2 + core/bit-vectors/bit-vectors.factor | 2 +- core/bootstrap/syntax.factor | 3 ++ core/byte-vectors/byte-vectors-docs.factor | 2 +- core/byte-vectors/byte-vectors-tests.factor | 2 + core/cpu/arm/intrinsics/intrinsics.factor | 35 ----------------- core/cpu/ppc/intrinsics/intrinsics.factor | 37 ------------------ core/cpu/x86/intrinsics/intrinsics.factor | 39 ------------------- core/float-vectors/float-vectors-docs.factor | 2 +- core/float-vectors/float-vectors-tests.factor | 2 + core/float-vectors/float-vectors.factor | 4 +- core/hashtables/hashtables-docs.factor | 4 -- core/inference/known-words/known-words.factor | 18 ++++----- core/prettyprint/backend/backend.factor | 17 +++++--- core/syntax/syntax.factor | 17 ++++---- 16 files changed, 48 insertions(+), 144 deletions(-) diff --git a/core/bit-vectors/bit-vectors-docs.factor b/core/bit-vectors/bit-vectors-docs.factor index a16f58ec14..f2f5c4da2c 100755 --- a/core/bit-vectors/bit-vectors-docs.factor +++ b/core/bit-vectors/bit-vectors-docs.factor @@ -20,11 +20,11 @@ HELP: bit-vector { $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ; HELP: -{ $values { "n" "a positive integer specifying initial capacity" } { "vector" vector } } +{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } } { $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ; -HELP: >bit vector -{ $values { "seq" "a sequence" } { "vector" vector } } +HELP: >bit-vector +{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } } { $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ; HELP: bit-array>vector diff --git a/core/bit-vectors/bit-vectors-tests.factor b/core/bit-vectors/bit-vectors-tests.factor index 2af9141ace..5838c1eb8d 100755 --- a/core/bit-vectors/bit-vectors-tests.factor +++ b/core/bit-vectors/bit-vectors-tests.factor @@ -10,3 +10,5 @@ USING: tools.test bit-vectors vectors sequences kernel math ; 3 dup do-it 3 dup do-it sequence= ] unit-test + +[ t ] [ ?V{ } bit-vector? ] unit-test diff --git a/core/bit-vectors/bit-vectors.factor b/core/bit-vectors/bit-vectors.factor index b22e3c2eef..f3259b2389 100755 --- a/core/bit-vectors/bit-vectors.factor +++ b/core/bit-vectors/bit-vectors.factor @@ -6,7 +6,7 @@ IN: bit-vectors vector ( bit-array -- bit-vector ) +: bit-array>vector ( bit-array length -- bit-vector ) bit-vector construct-boa ; inline PRIVATE> diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 2ddceabe44..4df5a68e97 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -16,12 +16,15 @@ f swap set-vocab-source-loaded? ";" " -{ $values { "n" "a positive integer specifying initial capacity" } { "vector" vector } } +{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } } { $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ; HELP: >byte-vector diff --git a/core/byte-vectors/byte-vectors-tests.factor b/core/byte-vectors/byte-vectors-tests.factor index 888d6957b2..2d9ca1f205 100755 --- a/core/byte-vectors/byte-vectors-tests.factor +++ b/core/byte-vectors/byte-vectors-tests.factor @@ -10,3 +10,5 @@ USING: tools.test byte-vectors vectors sequences kernel ; 3 do-it 3 do-it sequence= ] unit-test + +[ t ] [ BV{ } byte-vector? ] unit-test diff --git a/core/cpu/arm/intrinsics/intrinsics.factor b/core/cpu/arm/intrinsics/intrinsics.factor index 81b23ea8b2..29210afaa5 100755 --- a/core/cpu/arm/intrinsics/intrinsics.factor +++ b/core/cpu/arm/intrinsics/intrinsics.factor @@ -383,41 +383,6 @@ IN: cpu.arm.intrinsics { +output+ { "out" } } } define-intrinsic -\ (hashtable) [ - hashtable 4 cells %allot - R12 f v>operand MOV - R12 1 %set-slot - R12 2 %set-slot - R12 3 %set-slot - ! Store tagged ptr in reg - "out" get object %store-tagged -] H{ - { +scratch+ { { f "out" } } } - { +output+ { "out" } } -} define-intrinsic - -\ string>sbuf [ - sbuf 3 cells %allot - "length" operand 1 %set-slot - "string" operand 2 %set-slot - "out" get object %store-tagged -] H{ - { +input+ { { f "string" } { f "length" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } -} define-intrinsic - -\ array>vector [ - vector 3 cells %allot - "length" operand 1 %set-slot - "array" operand 2 %set-slot - "out" get object %store-tagged -] H{ - { +input+ { { f "array" } { f "length" } } } - { +scratch+ { { f "out" } } } - { +output+ { "out" } } -} define-intrinsic - ! Alien intrinsics : %alien-accessor ( quot -- ) "offset" operand dup %untag-fixnum diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 0773dae947..c73cd149a4 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -586,43 +586,6 @@ IN: cpu.ppc.intrinsics { +output+ { "wrapper" } } } define-intrinsic -\ (hashtable) [ - hashtable 4 cells %allot - f v>operand 12 LI - 12 11 1 cells STW - 12 11 2 cells STW - 12 11 3 cells STW - ! Store tagged ptr in reg - "hashtable" get object %store-tagged -] H{ - { +scratch+ { { f "hashtable" } } } - { +output+ { "hashtable" } } -} define-intrinsic - -\ string>sbuf [ - sbuf 3 cells %allot - "length" operand 11 1 cells STW - "string" operand 11 2 cells STW - ! Store tagged ptr in reg - "sbuf" get object %store-tagged -] H{ - { +input+ { { f "string" } { f "length" } } } - { +scratch+ { { f "sbuf" } } } - { +output+ { "sbuf" } } -} define-intrinsic - -\ array>vector [ - vector 3 cells %allot - "length" operand 11 1 cells STW - "array" operand 11 2 cells STW - ! Store tagged ptr in reg - "vector" get object %store-tagged -] H{ - { +input+ { { f "array" } { f "length" } } } - { +scratch+ { { f "vector" } } } - { +output+ { "vector" } } -} define-intrinsic - ! Alien intrinsics : %alien-accessor ( quot -- ) "offset" operand dup %untag-fixnum diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index 0e9d66498d..1fc649e128 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -447,45 +447,6 @@ IN: cpu.x86.intrinsics { +output+ { "wrapper" } } } define-intrinsic -\ (hashtable) [ - hashtable 4 cells [ - 1 object@ f v>operand MOV - 2 object@ f v>operand MOV - 3 object@ f v>operand MOV - ! Store tagged ptr in reg - "hashtable" get object %store-tagged - ] %allot -] H{ - { +scratch+ { { f "hashtable" } } } - { +output+ { "hashtable" } } -} define-intrinsic - -\ string>sbuf [ - sbuf 3 cells [ - 1 object@ "length" operand MOV - 2 object@ "string" operand MOV - ! Store tagged ptr in reg - "sbuf" get object %store-tagged - ] %allot -] H{ - { +input+ { { f "string" } { f "length" } } } - { +scratch+ { { f "sbuf" } } } - { +output+ { "sbuf" } } -} define-intrinsic - -\ array>vector [ - vector 3 cells [ - 1 object@ "length" operand MOV - 2 object@ "array" operand MOV - ! Store tagged ptr in reg - "vector" get object %store-tagged - ] %allot -] H{ - { +input+ { { f "array" } { f "length" } } } - { +scratch+ { { f "vector" } } } - { +output+ { "vector" } } -} define-intrinsic - ! Alien intrinsics : %alien-accessor ( quot -- ) "offset" operand %untag-fixnum diff --git a/core/float-vectors/float-vectors-docs.factor b/core/float-vectors/float-vectors-docs.factor index 4d04101e7b..5be891945a 100755 --- a/core/float-vectors/float-vectors-docs.factor +++ b/core/float-vectors/float-vectors-docs.factor @@ -20,7 +20,7 @@ HELP: float-vector { $description "The class of resizable float vectors. See " { $link "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general information." } ; HELP: -{ $values { "n" "a positive integer specifying initial capacity" } { "vector" vector } } +{ $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } } { $description "Creates a new float vector that can hold " { $snippet "n" } " floats before resizing." } ; HELP: >float-vector diff --git a/core/float-vectors/float-vectors-tests.factor b/core/float-vectors/float-vectors-tests.factor index 11f87f1f52..68b8195eb7 100755 --- a/core/float-vectors/float-vectors-tests.factor +++ b/core/float-vectors/float-vectors-tests.factor @@ -10,3 +10,5 @@ USING: tools.test float-vectors vectors sequences kernel ; 3 do-it 3 do-it sequence= ] unit-test + +[ t ] [ FV{ } float-vector? ] unit-test diff --git a/core/float-vectors/float-vectors.factor b/core/float-vectors/float-vectors.factor index fa19e3aaf8..f666a260f8 100755 --- a/core/float-vectors/float-vectors.factor +++ b/core/float-vectors/float-vectors.factor @@ -6,7 +6,7 @@ IN: float-vectors vector ( float-array -- float-vector ) +: float-array>vector ( float-array length -- float-vector ) float-vector construct-boa ; inline PRIVATE> @@ -23,7 +23,7 @@ M: float-vector like ] unless ; M: float-vector new - drop [ ] keep >fixnum float-array>vector ; + drop [ 0.0 ] keep >fixnum float-array>vector ; M: float-vector equal? over float-vector? [ sequence= ] [ 2drop f ] if ; diff --git a/core/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor index 7b6c2d1dc9..563a59d20f 100755 --- a/core/hashtables/hashtables-docs.factor +++ b/core/hashtables/hashtables-docs.factor @@ -116,10 +116,6 @@ HELP: { $values { "n" "a positive integer specifying hashtable capacity" } { "hash" "a new hashtable" } } { $description "Create a new hashtable capable of storing " { $snippet "n" } " key/value pairs before growing." } ; -HELP: (hashtable) ( -- hash ) -{ $values { "hash" "a new hashtable" } } -{ $description "Allocates a hashtable stub object without an underlying array. User code should call " { $link } " instead." } ; - HELP: associate { $values { "value" "a value" } { "key" "a key" } { "hash" "a new " { $link hashtable } } } { $description "Create a new hashtable holding one key/value pair." } ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 72935f1405..9a826d8e9b 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -167,9 +167,6 @@ t over set-effect-terminated? \ rehash-string { string } { } "inferred-effect" set-word-prop -\ string>sbuf { string integer } { sbuf } "inferred-effect" set-word-prop -\ string>sbuf make-flushable - \ bignum>fixnum { bignum } { fixnum } "inferred-effect" set-word-prop \ bignum>fixnum make-foldable @@ -491,12 +488,18 @@ t over set-effect-terminated? \ resize-array { integer array } { array } "inferred-effect" set-word-prop \ resize-array make-flushable +\ resize-byte-array { integer byte-array } { byte-array } "inferred-effect" set-word-prop +\ resize-byte-array make-flushable + +\ resize-bit-array { integer bit-array } { bit-array } "inferred-effect" set-word-prop +\ resize-bit-array make-flushable + +\ resize-float-array { integer float-array } { float-array } "inferred-effect" set-word-prop +\ resize-float-array make-flushable + \ resize-string { integer string } { string } "inferred-effect" set-word-prop \ resize-string make-flushable -\ (hashtable) { } { hashtable } "inferred-effect" set-word-prop -\ (hashtable) make-flushable - \ { integer object } { array } "inferred-effect" set-word-prop \ make-flushable @@ -532,9 +535,6 @@ t over set-effect-terminated? \ (clone) { object } { object } "inferred-effect" set-word-prop \ (clone) make-flushable -\ array>vector { array integer } { vector } "inferred-effect" set-word-prop -\ array>vector make-flushable - \ { integer integer } { string } "inferred-effect" set-word-prop \ make-flushable diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index 380ab87d40..86ac6cd926 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays byte-arrays bit-arrays generic hashtables io -assocs kernel math namespaces sequences strings sbufs io.styles -vectors words prettyprint.config prettyprint.sections quotations -io io.files math.parser effects tuples classes float-arrays ; +USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors +generic hashtables io assocs kernel math namespaces sequences +strings sbufs io.styles vectors words prettyprint.config +prettyprint.sections quotations io io.files math.parser effects +tuples classes float-arrays float-vectors ; IN: prettyprint.backend GENERIC: pprint* ( obj -- ) @@ -143,8 +144,11 @@ M: quotation pprint-delims drop \ [ \ ] ; M: curry pprint-delims drop \ [ \ ] ; M: array pprint-delims drop \ { \ } ; M: byte-array pprint-delims drop \ B{ \ } ; +M: byte-vector pprint-delims drop \ BV{ \ } ; M: bit-array pprint-delims drop \ ?{ \ } ; +M: bit-vector pprint-delims drop \ ?V{ \ } ; M: float-array pprint-delims drop \ F{ \ } ; +M: float-vector pprint-delims drop \ FV{ \ } ; M: vector pprint-delims drop \ V{ \ } ; M: hashtable pprint-delims drop \ H{ \ } ; M: tuple pprint-delims drop \ T{ \ } ; @@ -156,6 +160,9 @@ GENERIC: >pprint-sequence ( obj -- seq ) M: object >pprint-sequence ; M: vector >pprint-sequence ; +M: bit-vector >pprint-sequence ; +M: byte-vector >pprint-sequence ; +M: float-vector >pprint-sequence ; M: hashtable >pprint-sequence >alist ; M: tuple >pprint-sequence tuple>array ; M: wrapper >pprint-sequence wrapped 1array ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 7616f6e64b..006f1a225f 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays bit-arrays byte-arrays definitions generic -hashtables kernel math namespaces parser sequences strings sbufs -vectors words quotations io assocs splitting tuples -generic.standard generic.math classes io.files vocabs -float-arrays classes.union classes.mixin classes.predicate -compiler.units ; +USING: alien arrays bit-arrays bit-vectors byte-arrays +byte-vectors definitions generic hashtables kernel math +namespaces parser sequences strings sbufs vectors words +quotations io assocs splitting tuples generic.standard +generic.math classes io.files vocabs float-arrays float-vectors +classes.union classes.mixin classes.predicate compiler.units ; IN: bootstrap.syntax ! These words are defined as a top-level form, instead of with @@ -71,8 +71,11 @@ IN: bootstrap.syntax "{" [ \ } [ >array ] parse-literal ] define-syntax "V{" [ \ } [ >vector ] parse-literal ] define-syntax "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax + "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax "?{" [ \ } [ >bit-array ] parse-literal ] define-syntax + "?V{" [ \ } [ >bit-vector ] parse-literal ] define-syntax "F{" [ \ } [ >float-array ] parse-literal ] define-syntax + "FV{" [ \ } [ >float-vector ] parse-literal ] define-syntax "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax "T{" [ \ } [ >tuple ] parse-literal ] define-syntax "W{" [ \ } [ first ] parse-literal ] define-syntax From 14324ae39644c08e8bffd5971d0cb8830a22a7ce Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 30 Jan 2008 01:22:29 -0600 Subject: [PATCH 28/66] Doc fixes --- core/byte-vectors/byte-vectors-docs.factor | 2 +- core/float-vectors/float-vectors-docs.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/core/byte-vectors/byte-vectors-docs.factor b/core/byte-vectors/byte-vectors-docs.factor index 7617b90699..7ea0138760 100755 --- a/core/byte-vectors/byte-vectors-docs.factor +++ b/core/byte-vectors/byte-vectors-docs.factor @@ -24,7 +24,7 @@ HELP: { $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ; HELP: >byte-vector -{ $values { "seq" "a sequence" } { "vector" vector } } +{ $values { "seq" "a sequence" } { "byte-vector" vector } } { $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." } { $errors "Throws an error if the sequence contains elements other than integers." } ; diff --git a/core/float-vectors/float-vectors-docs.factor b/core/float-vectors/float-vectors-docs.factor index 5be891945a..f0901fd46f 100755 --- a/core/float-vectors/float-vectors-docs.factor +++ b/core/float-vectors/float-vectors-docs.factor @@ -24,7 +24,7 @@ HELP: { $description "Creates a new float vector that can hold " { $snippet "n" } " floats before resizing." } ; HELP: >float-vector -{ $values { "seq" "a sequence" } { "vector" vector } } +{ $values { "seq" "a sequence" } { "float-vector" float-vector } } { $description "Outputs a freshly-allocated float vector with the same elements as a given sequence." } { $errors "Throws an error if the sequence contains elements other than real numbers." } ; From adaa615f180acdc3bc782e610e42a9bb2a1bf111 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 30 Jan 2008 01:40:22 -0600 Subject: [PATCH 29/66] More fixes --- core/bit-vectors/bit-vectors.factor | 2 ++ core/byte-vectors/byte-vectors-docs.factor | 2 +- core/byte-vectors/byte-vectors.factor | 2 ++ core/float-arrays/float-arrays.factor | 2 ++ 4 files changed, 7 insertions(+), 1 deletion(-) diff --git a/core/bit-vectors/bit-vectors.factor b/core/bit-vectors/bit-vectors.factor index f3259b2389..37bc551751 100755 --- a/core/bit-vectors/bit-vectors.factor +++ b/core/bit-vectors/bit-vectors.factor @@ -28,4 +28,6 @@ M: bit-vector new M: bit-vector equal? over bit-vector? [ sequence= ] [ 2drop f ] if ; +M: bit-array new-resizable drop ; + INSTANCE: bit-vector growable diff --git a/core/byte-vectors/byte-vectors-docs.factor b/core/byte-vectors/byte-vectors-docs.factor index 7ea0138760..0f1054ee5e 100755 --- a/core/byte-vectors/byte-vectors-docs.factor +++ b/core/byte-vectors/byte-vectors-docs.factor @@ -24,7 +24,7 @@ HELP: { $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ; HELP: >byte-vector -{ $values { "seq" "a sequence" } { "byte-vector" vector } } +{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } } { $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." } { $errors "Throws an error if the sequence contains elements other than integers." } ; diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index 060ac94472..dab54e841c 100755 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -28,4 +28,6 @@ M: byte-vector new M: byte-vector equal? over byte-vector? [ sequence= ] [ 2drop f ] if ; +M: byte-array new-resizable drop ; + INSTANCE: byte-vector growable diff --git a/core/float-arrays/float-arrays.factor b/core/float-arrays/float-arrays.factor index 445edd550a..34c96fd0ed 100755 --- a/core/float-arrays/float-arrays.factor +++ b/core/float-arrays/float-arrays.factor @@ -32,6 +32,8 @@ M: float-array equal? M: float-array resize resize-float-array ; +M: float-array new-resizable drop ; + INSTANCE: float-array sequence INSTANCE: float-array simple-c-ptr INSTANCE: float-array c-ptr From 10015b70c1c6f8848fb7ed05ec7d033a8d385435 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 30 Jan 2008 01:42:51 -0600 Subject: [PATCH 30/66] Implement new-resizable for new sequences --- core/float-arrays/float-arrays.factor | 2 -- core/float-vectors/float-vectors.factor | 2 ++ 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/core/float-arrays/float-arrays.factor b/core/float-arrays/float-arrays.factor index 34c96fd0ed..445edd550a 100755 --- a/core/float-arrays/float-arrays.factor +++ b/core/float-arrays/float-arrays.factor @@ -32,8 +32,6 @@ M: float-array equal? M: float-array resize resize-float-array ; -M: float-array new-resizable drop ; - INSTANCE: float-array sequence INSTANCE: float-array simple-c-ptr INSTANCE: float-array c-ptr diff --git a/core/float-vectors/float-vectors.factor b/core/float-vectors/float-vectors.factor index f666a260f8..66f66856e1 100755 --- a/core/float-vectors/float-vectors.factor +++ b/core/float-vectors/float-vectors.factor @@ -28,4 +28,6 @@ M: float-vector new M: float-vector equal? over float-vector? [ sequence= ] [ 2drop f ] if ; +M: float-array new-resizable drop ; + INSTANCE: float-vector growable From a5bdfc0d0efa11ae04095a574da1ea163dd47698 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 30 Jan 2008 01:54:11 -0600 Subject: [PATCH 31/66] Fix coercer words --- core/bit-vectors/bit-vectors.factor | 2 +- core/byte-vectors/byte-vectors.factor | 2 +- core/float-vectors/float-vectors.factor | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/core/bit-vectors/bit-vectors.factor b/core/bit-vectors/bit-vectors.factor index 37bc551751..c418a24813 100755 --- a/core/bit-vectors/bit-vectors.factor +++ b/core/bit-vectors/bit-vectors.factor @@ -14,7 +14,7 @@ PRIVATE> : ( n -- bit-vector ) 0 bit-array>vector ; inline -: >bit-vector ( seq -- bit-vector ) V{ } clone-like ; +: >bit-vector ( seq -- bit-vector ) ?V{ } clone-like ; M: bit-vector like drop dup bit-vector? [ diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index dab54e841c..0acf06c0c1 100755 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -14,7 +14,7 @@ PRIVATE> : ( n -- byte-vector ) 0 byte-array>vector ; inline -: >byte-vector ( seq -- byte-vector ) V{ } clone-like ; +: >byte-vector ( seq -- byte-vector ) BV{ } clone-like ; M: byte-vector like drop dup byte-vector? [ diff --git a/core/float-vectors/float-vectors.factor b/core/float-vectors/float-vectors.factor index 66f66856e1..2b023985a4 100755 --- a/core/float-vectors/float-vectors.factor +++ b/core/float-vectors/float-vectors.factor @@ -14,7 +14,7 @@ PRIVATE> : ( n -- float-vector ) 0.0 0 float-array>vector ; inline -: >float-vector ( seq -- float-vector ) V{ } clone-like ; +: >float-vector ( seq -- float-vector ) FV{ } clone-like ; M: float-vector like drop dup float-vector? [ From b7191f370687979426e56ea342afcb551a1bb5ba Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 30 Jan 2008 01:59:46 -0600 Subject: [PATCH 32/66] ui.tools.workspace: Add workspace-dim global variable --- extra/ui/tools/workspace/workspace.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/extra/ui/tools/workspace/workspace.factor b/extra/ui/tools/workspace/workspace.factor index b4a6574c83..de21bf3187 100755 --- a/extra/ui/tools/workspace/workspace.factor +++ b/extra/ui/tools/workspace/workspace.factor @@ -69,7 +69,11 @@ M: gadget tool-scroller drop f ; [ find-workspace hide-popup ] "Error" show-titled-popup ; -M: workspace pref-dim* drop { 600 700 } ; +SYMBOL: workspace-dim + +{ 600 700 } workspace-dim set-global + +M: workspace pref-dim* drop workspace-dim get ; M: workspace focusable-child* dup workspace-popup [ ] [ workspace-listener ] ?if ; From a02920a3f7a6307149c77d295eea6290de3071d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 30 Jan 2008 02:44:10 -0600 Subject: [PATCH 33/66] Add 'ignore' restart to load-everything --- core/vocabs/loader/loader.factor | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 20dbe7594f..3dd43fc78c 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -148,8 +148,16 @@ SYMBOL: load-help? dup update-roots dup modified-sources swap modified-docs ; +: require-restart { { "Ignore this vocabulary" t } } ; + : require-all ( seq -- ) - [ [ require ] each ] with-compiler-errors ; + [ + [ + [ require ] + [ require-restart rethrow-restarts drop ] + recover + ] each + ] with-compiler-errors ; : do-refresh ( modified-sources modified-docs -- ) 2dup From 837b89422bc99836a40aa289b24fa6fa64958a1a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 30 Jan 2008 02:44:26 -0600 Subject: [PATCH 34/66] Fix ignore restart --- core/vocabs/loader/loader.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 3dd43fc78c..f2c5b2a012 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -154,7 +154,7 @@ SYMBOL: load-help? [ [ [ require ] - [ require-restart rethrow-restarts drop ] + [ require-restart rethrow-restarts 2drop ] recover ] each ] with-compiler-errors ; From 9f90cf6263690e63f4966bd6c7b98287f998c455 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 30 Jan 2008 02:46:39 -0600 Subject: [PATCH 35/66] Fix circularity in hardware-info --- extra/hardware-info/windows/ce/ce.factor | 8 +++++--- extra/hardware-info/windows/nt/nt.factor | 14 +++++++++++--- extra/hardware-info/windows/windows.factor | 16 ++++------------ 3 files changed, 20 insertions(+), 18 deletions(-) mode change 100644 => 100755 extra/hardware-info/windows/ce/ce.factor mode change 100644 => 100755 extra/hardware-info/windows/nt/nt.factor diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor old mode 100644 new mode 100755 index 9fb15ef823..1592bad14c --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/hardware-info/windows/ce/ce.factor @@ -1,8 +1,8 @@ -USING: alien.c-types hardware-info hardware-info.windows -kernel math namespaces windows windows.kernel32 -hardware-info.backend ; +USING: alien.c-types hardware-info kernel math namespaces +windows windows.kernel32 hardware-info.backend ; IN: hardware-info.windows.ce +TUPLE: wince ; T{ wince } os set-global : memory-status ( -- MEMORYSTATUS ) @@ -10,6 +10,8 @@ T{ wince } os set-global "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength [ GlobalMemoryStatus ] keep ; +M: wince cpus ( -- n ) 1 ; + M: wince memory-load ( -- n ) memory-status MEMORYSTATUS-dwMemoryLoad ; diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor old mode 100644 new mode 100755 index f412754cdf..2003e689a7 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -1,10 +1,18 @@ -USING: alien alien.c-types hardware-info hardware-info.windows -kernel libc math namespaces hardware-info.backend -windows windows.advapi32 windows.kernel32 ; +USING: alien alien.c-types kernel libc math namespaces +hardware-info.backend windows windows.advapi32 windows.kernel32 +; IN: hardware-info.windows.nt +TUPLE: winnt ; + T{ winnt } os set-global +: system-info ( -- SYSTEM_INFO ) + "SYSTEM_INFO" [ GetSystemInfo ] keep ; + +M: winnt cpus ( -- n ) + system-info SYSTEM_INFO-dwNumberOfProcessors ; + : memory-status ( -- MEMORYSTATUSEX ) "MEMORYSTATUSEX" "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index a49e4f254a..7876a890b6 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -1,22 +1,15 @@ USING: alien alien.c-types kernel libc math namespaces windows windows.kernel32 windows.advapi32 -words combinators vocabs.loader hardware-info.backend ; +words combinators vocabs.loader hardware-info.backend +system ; IN: hardware-info.windows -TUPLE: wince ; -TUPLE: winnt ; -UNION: windows wince winnt ; -USE: system - : system-info ( -- SYSTEM_INFO ) "SYSTEM_INFO" [ GetSystemInfo ] keep ; : page-size ( -- n ) system-info SYSTEM_INFO-dwPageSize ; -M: windows cpus ( -- n ) - system-info SYSTEM_INFO-dwNumberOfProcessors ; - ! 386, 486, 586, 2200 (IA64), 8664 (AMD_X8664) : processor-type ( -- n ) system-info SYSTEM_INFO-dwProcessorType ; @@ -70,8 +63,7 @@ M: windows cpus ( -- n ) : system-windows-directory ( -- str ) \ GetSystemWindowsDirectory get-directory ; -<< { +{ { [ wince? ] [ "hardware-info.windows.ce" ] } { [ winnt? ] [ "hardware-info.windows.nt" ] } - { [ t ] [ f ] } -} cond [ require ] when* >> +} cond [ require ] when* From c5bdf78d9a0779d0dd0eef4b6855900714b18b47 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 30 Jan 2008 02:46:52 -0600 Subject: [PATCH 36/66] Fix benchmark.bootstrap2 --- extra/benchmark/bootstrap2/bootstrap2.factor | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) mode change 100644 => 100755 extra/benchmark/bootstrap2/bootstrap2.factor diff --git a/extra/benchmark/bootstrap2/bootstrap2.factor b/extra/benchmark/bootstrap2/bootstrap2.factor old mode 100644 new mode 100755 index b56b36ac41..bde92a2260 --- a/extra/benchmark/bootstrap2/bootstrap2.factor +++ b/extra/benchmark/bootstrap2/bootstrap2.factor @@ -1,9 +1,14 @@ -USING: tools.deploy.private io.files system -tools.deploy.backend ; +USING: io.files io.launcher system tools.deploy.backend +namespaces sequences kernel ; IN: benchmark.bootstrap2 : bootstrap-benchmark "." resource-path cd - vm { "-output-image=foo.image" "-no-user-init" } stage2 ; + [ + vm , + "-i=" boot-image-name append , + "-output-image=foo.image" , + "-no-user-init" , + ] { } make run-process drop ; MAIN: bootstrap-benchmark From c7d9e5afef4c5309242705ec7ac62630853a0897 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 30 Jan 2008 02:47:08 -0600 Subject: [PATCH 37/66] Update boids.ui for assocs.lib change --- extra/boids/ui/ui.factor | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) mode change 100644 => 100755 extra/boids/ui/ui.factor diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor old mode 100644 new mode 100755 index 6d04a4d623..b545f41060 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -145,20 +145,20 @@ VARS: population-label cohesion-label alignment-label separation-label ; slate> over @center grid-add H{ } clone - T{ key-down f f "1" } C[ drop randomize ] put-hash - T{ key-down f f "2" } C[ drop sub-10-boids ] put-hash - T{ key-down f f "3" } C[ drop add-10-boids ] put-hash + T{ key-down f f "1" } C[ drop randomize ] put-at + T{ key-down f f "2" } C[ drop sub-10-boids ] put-at + T{ key-down f f "3" } C[ drop add-10-boids ] put-at - T{ key-down f f "q" } C[ drop inc-cohesion-weight ] put-hash - T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-hash + T{ key-down f f "q" } C[ drop inc-cohesion-weight ] put-at + T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-at - T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-hash - T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-hash + T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-at + T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-at - T{ key-down f f "e" } C[ drop inc-separation-weight ] put-hash - T{ key-down f f "d" } C[ drop dec-separation-weight ] put-hash + T{ key-down f f "e" } C[ drop inc-separation-weight ] put-at + T{ key-down f f "d" } C[ drop dec-separation-weight ] put-at - T{ key-down f f "ESC" } C[ drop toggle-loop ] put-hash + T{ key-down f f "ESC" } C[ drop toggle-loop ] put-at tuck set-gadget-delegate "Boids" open-window ; : boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ; From ac2fb043cf45673036ca5c8961585a5bd9e2e36e Mon Sep 17 00:00:00 2001 From: Daniel Neri Date: Wed, 30 Jan 2008 01:02:42 +0100 Subject: [PATCH 38/66] Add NetBSD support --- Makefile | 8 ++++++++ core/system/system-docs.factor | 1 + core/system/system.factor | 4 ++-- vm/Config.netbsd | 4 ++++ vm/Config.netbsd.x86.32 | 2 ++ vm/Config.netbsd.x86.64 | 2 ++ vm/os-netbsd.c | 6 ++++++ vm/os-netbsd.h | 9 +++++++++ vm/platform.h | 3 +++ 9 files changed, 37 insertions(+), 2 deletions(-) create mode 100644 vm/Config.netbsd create mode 100644 vm/Config.netbsd.x86.32 create mode 100644 vm/Config.netbsd.x86.64 create mode 100644 vm/os-netbsd.c create mode 100644 vm/os-netbsd.h diff --git a/Makefile b/Makefile index e02b6a672b..aad7fe90eb 100755 --- a/Makefile +++ b/Makefile @@ -56,6 +56,8 @@ default: @echo "linux-arm" @echo "openbsd-x86-32" @echo "openbsd-x86-64" + @echo "netbsd-x86-32" + @echo "netbsd-x86-64" @echo "macosx-x86-32" @echo "macosx-x86-64" @echo "macosx-ppc" @@ -83,6 +85,12 @@ freebsd-x86-32: freebsd-x86-64: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.x86.64 +netbsd-x86-32: + $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.netbsd.x86.32 + +netbsd-x86-64: + $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.netbsd.x86.64 + macosx-freetype: ln -sf libfreetype.6.dylib \ Factor.app/Contents/Frameworks/libfreetype.dylib diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index d91a84ec99..d80cfa9ceb 100644 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -49,6 +49,7 @@ HELP: os "linux" "macosx" "openbsd" + "netbsd" "solaris" "windows" } diff --git a/core/system/system.factor b/core/system/system.factor index 845ba8265d..4983260a36 100644 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -39,11 +39,11 @@ splitting assocs ; : unix? ( -- ? ) os { - "freebsd" "openbsd" "linux" "macosx" "solaris" + "freebsd" "openbsd" "netbsd" "linux" "macosx" "solaris" } member? ; : bsd? ( -- ? ) - os { "freebsd" "openbsd" "macosx" } member? ; + os { "freebsd" "openbsd" "netbsd" "macosx" } member? ; : linux? ( -- ? ) os "linux" = ; diff --git a/vm/Config.netbsd b/vm/Config.netbsd new file mode 100644 index 0000000000..9f334e18b4 --- /dev/null +++ b/vm/Config.netbsd @@ -0,0 +1,4 @@ +include vm/Config.unix +PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o +CFLAGS += -export-dynamic +LIBS = -L/usr/local/lib/ -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib -lm $(X11_UI_LIBS) diff --git a/vm/Config.netbsd.x86.32 b/vm/Config.netbsd.x86.32 new file mode 100644 index 0000000000..849bd65732 --- /dev/null +++ b/vm/Config.netbsd.x86.32 @@ -0,0 +1,2 @@ +include vm/Config.netbsd +include vm/Config.x86.32 diff --git a/vm/Config.netbsd.x86.64 b/vm/Config.netbsd.x86.64 new file mode 100644 index 0000000000..24f86d0118 --- /dev/null +++ b/vm/Config.netbsd.x86.64 @@ -0,0 +1,2 @@ +include vm/Config.netbsd +include vm/Config.x86.64 diff --git a/vm/os-netbsd.c b/vm/os-netbsd.c new file mode 100644 index 0000000000..b9238b7877 --- /dev/null +++ b/vm/os-netbsd.c @@ -0,0 +1,6 @@ +#include "master.h" + +const char *vm_executable_path(void) +{ + return NULL; +} diff --git a/vm/os-netbsd.h b/vm/os-netbsd.h new file mode 100644 index 0000000000..e282828577 --- /dev/null +++ b/vm/os-netbsd.h @@ -0,0 +1,9 @@ +#include + +#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap)) +#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap) + +#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN) +#define DIRECTORY_P(file) ((file)->d_type == DT_DIR) + +extern char **environ; diff --git a/vm/platform.h b/vm/platform.h index 40324cc330..b0641176bc 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -58,6 +58,9 @@ #else #error "Unsupported OpenBSD flavor" #endif + #elif defined(__NetBSD__) + #define FACTOR_OS_STRING "netbsd" + #include "os-netbsd.h" #elif defined(linux) #define FACTOR_OS_STRING "linux" #include "os-linux.h" From 118583024e7c56eb48bbd6342984ec9c2a99d575 Mon Sep 17 00:00:00 2001 From: Daniel Neri Date: Wed, 30 Jan 2008 12:10:42 +0100 Subject: [PATCH 39/66] Tweak LIBS and LIBPATH for NetBSD --- vm/Config.netbsd | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/vm/Config.netbsd b/vm/Config.netbsd index 9f334e18b4..5fb5966b1e 100644 --- a/vm/Config.netbsd +++ b/vm/Config.netbsd @@ -1,4 +1,5 @@ include vm/Config.unix PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o CFLAGS += -export-dynamic -LIBS = -L/usr/local/lib/ -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib -lm $(X11_UI_LIBS) +LIBPATH = -L/usr/X11R6/lib -Wl,-rpath,/usr/X11R6/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib +LIBS = -lm $(X11_UI_LIBS) From adc6f4de738a45766c1692484f532aa3461a287e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 30 Jan 2008 12:49:20 -0600 Subject: [PATCH 40/66] fix load error --- extra/io/sockets/headers/headers.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/io/sockets/headers/headers.factor b/extra/io/sockets/headers/headers.factor index c697b60973..2547fee5ae 100755 --- a/extra/io/sockets/headers/headers.factor +++ b/extra/io/sockets/headers/headers.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax byte-arrays io -io.sockets.impl kernel structs math prettyprint ; +io.sockets.impl kernel structs math math.parser +prettyprint sequences ; IN: io.sockets.headers C-STRUCT: etherneth From 3b793b84740c374e85e2072ebaf05ee3dc7928e6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 30 Jan 2008 14:23:21 -0600 Subject: [PATCH 41/66] (hashtable) is gone now --- core/compiler/test/intrinsics.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor index 954e45cb66..075961047f 100755 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -334,10 +334,6 @@ cell 8 = [ [ \ + ] [ \ + [ ] compile-call ] unit-test -[ H{ } ] [ - 100 [ (hashtable) ] compile-call [ reset-hash ] keep -] unit-test - [ B{ 0 0 0 0 0 } ] [ [ 5 ] compile-call ] unit-test From d8d87fe83481c34bc5b017faa68c0aba4840c7d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 30 Jan 2008 14:23:48 -0600 Subject: [PATCH 42/66] Fix littledan bug #1 --- core/generator/generator.factor | 2 +- core/inference/backend/backend.factor | 6 +++++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 0e499cf90f..de80872b73 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -19,8 +19,8 @@ SYMBOL: compiled : queue-compile ( word -- ) { { [ dup compiled get key? ] [ drop ] } + { [ dup inlined-block? ] [ drop ] } { [ dup primitive? ] [ drop ] } - { [ dup deferred? ] [ drop ] } { [ t ] [ dup compile-queue get set-at ] } } cond ; diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index cf2d021430..121c555d29 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -402,10 +402,14 @@ TUPLE: recursive-declare-error word ; dup node-param #return node, dataflow-graph get 1array over set-node-children ; +: inlined-block? "inlined-block" word-prop ; + +: gensym dup t "inlined-block" set-word-prop ; + : inline-block ( word -- node-block data ) [ copy-inference nest-node - dup word-def swap gensym + dup word-def swap [ infer-quot-recursive ] 2keep #label unnest-node ] H{ } make-assoc ; From 99172b6f79132e840719adae02489162228f02c7 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 30 Jan 2008 15:03:02 -0600 Subject: [PATCH 43/66] Changes in XML prettyprinter --- extra/xml/entities/entities.factor | 26 +++++++++++++++++- extra/xml/writer/writer.factor | 42 +++++++----------------------- 2 files changed, 35 insertions(+), 33 deletions(-) diff --git a/extra/xml/entities/entities.factor b/extra/xml/entities/entities.factor index a52f5be3dc..b90613ec79 100644 --- a/extra/xml/entities/entities.factor +++ b/extra/xml/entities/entities.factor @@ -1,8 +1,32 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel ; +USING: namespaces kernel assocs sequences ; IN: xml.entities +: entities-out + H{ + { CHAR: < "<" } + { CHAR: > ">" } + { CHAR: & "&" } + } ; + +: quoted-entities-out + H{ + { CHAR: & "&" } + { CHAR: ' "'" } + { CHAR: " """ } + } ; + +: escape-string-by ( str table -- escaped ) + #! Convert <, >, &, ' and " to HTML entities. + [ [ dupd at [ % ] [ , ] ?if ] curry each ] "" make ; + +: escape-string ( str -- newstr ) + entities-out escape-string-by ; + +: escape-quoted-string ( str -- newstr ) + quoted-entities-out escape-string-by ; + : entities H{ { "lt" CHAR: < } diff --git a/extra/xml/writer/writer.factor b/extra/xml/writer/writer.factor index 7bd1cc3046..f943f24ccd 100644 --- a/extra/xml/writer/writer.factor +++ b/extra/xml/writer/writer.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: hashtables kernel math namespaces sequences strings -io io.streams.string xml.data assocs ; +io io.streams.string xml.data assocs wrap xml.entities ; IN: xml.writer SYMBOL: xml-pprint? @@ -13,10 +13,11 @@ SYMBOL: indenter : sensitive? ( tag -- ? ) sensitive-tags get swap [ names-match? ] curry contains? ; +: indent-string ( -- string ) + indentation get indenter get concat ; + : ?indent ( -- ) - xml-pprint? get [ - nl indentation get indenter get [ write ] each - ] when ; + xml-pprint? get [ nl indent-string write ] when ; : indent ( -- ) xml-pprint? get [ 1 indentation +@ ] when ; @@ -35,30 +36,6 @@ SYMBOL: indenter [ dup empty? swap string? and not ] subset ] when ; -: entities-out - H{ - { CHAR: < "<" } - { CHAR: > ">" } - { CHAR: & "&" } - } ; - -: quoted-entities-out - H{ - { CHAR: & "&" } - { CHAR: ' "'" } - { CHAR: " """ } - } ; - -: escape-string-by ( str table -- escaped ) - #! Convert <, >, &, ' and " to HTML entities. - [ [ dupd at [ % ] [ , ] ?if ] curry each ] "" make ; - -: escape-string ( str -- newstr ) - entities-out escape-string-by ; - -: escape-quoted-string ( str -- newstr ) - quoted-entities-out escape-string-by ; - : print-name ( name -- ) dup name-space f like [ write CHAR: : write1 ] when* @@ -76,10 +53,11 @@ SYMBOL: indenter GENERIC: write-item ( object -- ) M: string write-item - escape-string write ; + escape-string xml-pprint? over empty? not and + [ nl 80 indent-string indented-break ] when write ; : write-tag ( tag -- ) - CHAR: < write1 + ?indent CHAR: < write1 dup print-name tag-attrs print-attrs ; M: contained-tag write-item @@ -87,7 +65,7 @@ M: contained-tag write-item : write-children ( tag -- ) indent tag-children ?filter-children - [ ?indent write-item ] each unindent ; + [ write-item ] each unindent ; : write-end-tag ( tag -- ) ?indent " write1 ; @@ -112,7 +90,7 @@ M: instruction write-item "\n" write ; + "\"?>" write ; : write-chunk ( seq -- ) [ write-item ] each ; From 9d5b944ec1dbbd035ef6ce34060cfa5938a739ff Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 30 Jan 2008 23:16:20 -0600 Subject: [PATCH 44/66] io.launcher: update docs --- extra/io/launcher/launcher-docs.factor | 15 ++++++++++----- extra/io/launcher/launcher.factor | 10 +++++----- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 28063bae0d..072cfcf959 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -93,7 +93,7 @@ HELP: run-process* { $notes "User code should call " { $link run-process } " instead." } ; HELP: >descriptor -{ $values { "obj" object } { "desc" "a launch descriptor" } } +{ $values { "desc" "a launch descriptor" } { "desc" "a launch descriptor" } } { $description "Creates a launch descriptor from an object, which must be one of the following:" { $list { "a string -- this is wrapped in a launch descriptor with a single " { $link +command+ } " key" } @@ -103,12 +103,12 @@ HELP: >descriptor } ; HELP: run-process -{ $values { "obj" object } { "process" process } } +{ $values { "desc" "a launch descriptor" } { "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 } { "process" process } } +{ $values { "desc" "a launch descriptor" } { "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." @@ -127,12 +127,17 @@ 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" } } +{ $values + { "desc" "a launch descriptor" } + { "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." } ; HELP: with-process-stream -{ $values { "obj" object } { "quot" quotation } { "process" process } } +{ $values + { "desc" "a launch descriptor" } + { "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 diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 7cf9d51ed0..9fb24fb51a 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -63,7 +63,7 @@ SYMBOL: append-environment { replace-environment [ ] } } case ; -GENERIC: >descriptor ( obj -- desc ) +GENERIC: >descriptor ( desc -- desc ) M: string >descriptor +command+ associate ; M: sequence >descriptor +arguments+ associate ; @@ -76,24 +76,24 @@ HOOK: run-process* io-backend ( desc -- handle ) dup [ processes get at push stop ] curry callcc0 ] when process-status ; -: run-process ( obj -- process ) +: run-process ( desc -- process ) >descriptor dup run-process* +detached+ rot at [ dup wait-for-process drop ] unless ; -: run-detached ( obj -- process ) +: run-detached ( desc -- process ) >descriptor H{ { +detached+ t } } union run-process ; HOOK: process-stream* io-backend ( desc -- stream process ) TUPLE: process-stream process ; -: ( obj -- stream ) +: ( desc -- stream ) >descriptor process-stream* { set-delegate set-process-stream-process } process-stream construct ; -: with-process-stream ( obj quot -- process ) +: with-process-stream ( desc quot -- process ) swap [ swap with-stream ] keep process-stream-process ; inline From ce260a07aba18370485f2176823015d2e53dc107 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 31 Jan 2008 00:25:06 -0600 Subject: [PATCH 45/66] Add builder vocab --- extra/builder/builder.factor | 113 +++++++++++++++++++++++++++++++++++ 1 file changed, 113 insertions(+) create mode 100644 extra/builder/builder.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor new file mode 100644 index 0000000000..a2b5dffb4d --- /dev/null +++ b/extra/builder/builder.factor @@ -0,0 +1,113 @@ + +USING: kernel io io.files io.launcher + system namespaces sequences splitting math.parser + unix prettyprint tools.time calendar bake vars ; + +IN: builder + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: datestamp ( -- string ) + now `{ ,[ dup timestamp-year ] + ,[ dup timestamp-month ] + ,[ dup timestamp-day ] + ,[ dup timestamp-hour ] + ,[ timestamp-minute ] } + [ number>string 2 CHAR: 0 pad-left ] map "-" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: builder-recipients + +: quote ( str -- str ) "'" swap "'" 3append ; + +: email-file ( subject file -- ) + `{ + "cat" , + "| mutt -s" ,[ quote ] + "-x" %[ builder-recipients get ] + } + " " join system drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: boot-image ( -- filename ) `{ "boot" ,[ cpu ] "image" } "." join ; + +: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: stamp + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: build ( -- ) + +datestamp >stamp + +"/builds/factor" cd +"git pull git://factorcode.org/git/factor.git" system +0 = +[ ] +[ + "builder: git pull" "/dev/null" email-file + "builder: git pull" throw +] +if + +"/builds/" stamp> append make-directory +"/builds/" stamp> append cd +"git clone /builds/factor" system drop + +"factor" cd + +{ "/usr/bin/git" "show" } +[ readln ] with-stream +" " split second +"../git-id" [ print ] with-stream + +"make clean" system drop + +"make " target " > ../compile-log" 3append system +0 = +[ ] +[ + "builder: vm compile" "../compile-log" email-file + "builder: vm compile" throw +] if + +"wget http://factorcode.org/images/latest/" boot-image append system +0 = +[ ] +[ + "builder: image download" "/dev/null" email-file + "builder: image download" throw +] if + +[ "./factor -i=" boot-image " -no-user-init > ../boot-log" 3append system ] +benchmark nip +"../boot-time" [ . ] with-stream +0 = +[ ] +[ + "builder: bootstrap" "../boot-log" email-file + "builder: bootstrap" throw +] if + +[ + "./factor -e='USE: tools.browser load-everything' > ../load-everything-log" + system +] benchmark nip +"../load-everything-time" [ . ] with-stream +0 = +[ ] +[ + "builder: load-everything" "../load-everything-log" email-file + "builder: load-everything" throw +] if + +; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: build \ No newline at end of file From cea24feaa9f01eb86bc198af671d924cfd89a2c3 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 31 Jan 2008 00:47:11 -0600 Subject: [PATCH 46/66] Fixing failing XML unit tests --- extra/xml/test/templating.factor | 7 +++---- extra/xml/test/test.factor | 4 ++-- extra/xml/writer/writer.factor | 6 ++++-- 3 files changed, 9 insertions(+), 8 deletions(-) diff --git a/extra/xml/test/templating.factor b/extra/xml/test/templating.factor index 0ee4ae51b0..2dd69ca99b 100644 --- a/extra/xml/test/templating.factor +++ b/extra/xml/test/templating.factor @@ -1,4 +1,3 @@ -IN: templating USING: kernel xml sequences assocs tools.test io arrays namespaces xml.data xml.utilities xml.writer generic sequences.deep ; @@ -9,10 +8,10 @@ SYMBOL: ref-table GENERIC: (r-ref) ( xml -- ) M: tag (r-ref) - sub-tag over at [ + sub-tag over at* [ ref-table get at swap set-tag-children - ] [ drop ] if* ; + ] [ 2drop ] if ; M: object (r-ref) drop ; : template ( xml -- ) @@ -40,4 +39,4 @@ M: object (r-ref) drop ; sample-doc string>xml dup template xml>string ] with-scope ; -[ "\nfoo
blah

" ] [ test-refs ] unit-test +[ "foo

" ] [ test-refs ] unit-test diff --git a/extra/xml/test/test.factor b/extra/xml/test/test.factor index 80a508787e..ec59d3564e 100644 --- a/extra/xml/test/test.factor +++ b/extra/xml/test/test.factor @@ -26,7 +26,7 @@ SYMBOL: xml-file ] unit-test [ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test [ "that" ] [ xml-file get "this" swap at ] unit-test -[ "\n" ] +[ "" ] [ "" string>xml xml>string ] unit-test [ "abcd" ] [ "

abcd
" string>xml @@ -44,7 +44,7 @@ SYMBOL: xml-file at swap "z" >r tuck r> swap set-at T{ name f "blah" "z" f } swap at ] unit-test [ "foo" ] [ "" string>xml children>string ] unit-test -[ "\nbar baz" ] +[ "bar baz" ] [ "bar" string>xml [ " baz" append ] map xml>string ] unit-test [ "\n\n bar\n" ] [ " bar " string>xml pprint-xml>string ] unit-test diff --git a/extra/xml/writer/writer.factor b/extra/xml/writer/writer.factor index f943f24ccd..95f38f3da9 100644 --- a/extra/xml/writer/writer.factor +++ b/extra/xml/writer/writer.factor @@ -14,7 +14,9 @@ SYMBOL: indenter sensitive-tags get swap [ names-match? ] curry contains? ; : indent-string ( -- string ) - indentation get indenter get concat ; + xml-pprint? get + [ indentation get indenter get concat ] + [ "" ] if ; : ?indent ( -- ) xml-pprint? get [ nl indent-string write ] when ; @@ -53,7 +55,7 @@ SYMBOL: indenter GENERIC: write-item ( object -- ) M: string write-item - escape-string xml-pprint? over empty? not and + escape-string dup empty? not xml-pprint? get and [ nl 80 indent-string indented-break ] when write ; : write-tag ( tag -- ) From 0c078d04555ea1dc1a928dcc0f3b39c72bb0f4a7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 00:48:41 -0600 Subject: [PATCH 47/66] Friendlier bootstrap errors --- core/bootstrap/stage2.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 0163422f47..8fc3435ffa 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -87,5 +87,5 @@ IN: bootstrap.stage2 "output-image" get resource-path save-image-and-exit ] if ] [ - error. :c "listener" vocab-main execute + print-error :c "listener" vocab-main execute ] recover From 60290fbf526b31a5667622ec5480c35b1b0f4ec8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 00:49:18 -0600 Subject: [PATCH 48/66] Fix littledan bug #2 --- core/classes/classes.factor | 14 +++++++++++--- core/classes/union/union.factor | 2 ++ core/generic/generic.factor | 4 ++-- 3 files changed, 15 insertions(+), 5 deletions(-) mode change 100644 => 100755 core/classes/union/union.factor diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 65dc5f5ff7..a6a1db7045 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -255,7 +255,14 @@ PRIVATE> >r dup word-props r> union over set-word-props t "class" set-word-prop ; -GENERIC: update-methods ( class -- ) +GENERIC: update-predicate ( class -- ) + +M: class update-predicate drop ; + +: update-predicates ( assoc -- ) + [ drop update-predicate ] assoc-each ; + +GENERIC: update-methods ( assoc -- ) : define-class ( word members superclass metaclass -- ) #! If it was already a class, update methods after. @@ -264,8 +271,9 @@ GENERIC: update-methods ( class -- ) over class-usages [ uncache-classes dupd (define-class) - ] keep cache-classes - r> [ update-methods ] [ drop ] if ; + ] keep cache-classes r> + [ class-usages dup update-predicates update-methods ] + [ drop ] if ; GENERIC: class ( object -- class ) inline diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor old mode 100644 new mode 100755 index e95c08b507..0adbdc080d --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -20,6 +20,8 @@ PREDICATE: class union-class over members union-predicate-quot define-predicate ; +M: union-class update-predicate define-union-predicate ; + : define-union-class ( class members -- ) dupd f union-class define-class define-union-predicate ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 5ee6b9c87c..bde5fd31af 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -107,5 +107,5 @@ M: class forget* ( class -- ) dup uncache-class forget-word ; -M: class update-methods ( class -- ) - class-usages implementors* [ make-generic ] each ; +M: assoc update-methods ( assoc -- ) + implementors* [ make-generic ] each ; From 926e09a46a6886bd2376d9fa3cdfa1cc18ebd685 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 00:52:06 -0600 Subject: [PATCH 49/66] New dispose word and with-dispose combinator, docs for io.monitor, working on O(1) stream timeouts --- core/continuations/continuations-docs.factor | 9 +++ core/continuations/continuations.factor | 5 ++ core/dlists/dlists-docs.factor | 34 ++++++----- core/dlists/dlists-tests.factor | 16 ++--- core/dlists/dlists.factor | 32 +++++++--- core/inference/inference-tests.factor | 3 +- core/io/files/files-tests.factor | 4 +- core/io/io-docs.factor | 12 +--- core/io/io.factor | 7 +-- core/io/streams/c/c.factor | 8 +-- core/io/streams/duplex/duplex-docs.factor | 4 +- core/io/streams/duplex/duplex-tests.factor | 10 ++-- core/io/streams/duplex/duplex.factor | 6 +- core/io/streams/nested/nested.factor | 8 +-- core/io/streams/string/string.factor | 6 +- extra/cabal/cabal.factor | 2 +- extra/cryptlib/streams/streams.factor | 8 +-- extra/delegate/protocols/protocols.factor | 2 +- extra/help/handbook/handbook.factor | 13 +++-- extra/help/tutorial/tutorial.factor | 6 +- extra/html/html.factor | 4 +- extra/http/client/client.factor | 4 +- extra/io/mmap/mmap-docs.factor | 14 ++--- extra/io/mmap/mmap.factor | 10 ++-- extra/io/monitor/monitor-docs.factor | 61 ++++++++++++++++++++ extra/io/monitor/monitor.factor | 4 +- extra/io/nonblocking/nonblocking-docs.factor | 4 +- extra/io/nonblocking/nonblocking.factor | 55 ++++++++++++++---- extra/io/server/server.factor | 8 +-- extra/io/sockets/sockets-docs.factor | 10 ++-- extra/io/streams/null/null.factor | 2 +- extra/io/unix/mmap/mmap.factor | 2 +- extra/io/unix/sockets/sockets.factor | 3 +- extra/io/unix/unix-tests.factor | 6 +- extra/io/windows/mmap/mmap.factor | 2 +- extra/io/windows/nt/backend/backend.factor | 20 ++----- extra/io/windows/nt/monitor/monitor.factor | 2 - extra/io/windows/windows.factor | 7 ++- extra/irc/irc.factor | 2 +- extra/tar/tar.factor | 4 +- extra/tools/deploy/backend/backend.factor | 9 +-- extra/ui/gadgets/panes/panes.factor | 12 ++-- 42 files changed, 274 insertions(+), 166 deletions(-) mode change 100644 => 100755 core/continuations/continuations-docs.factor mode change 100644 => 100755 core/dlists/dlists-docs.factor mode change 100644 => 100755 core/io/files/files-tests.factor mode change 100644 => 100755 core/io/streams/duplex/duplex-docs.factor mode change 100644 => 100755 core/io/streams/duplex/duplex-tests.factor mode change 100644 => 100755 core/io/streams/duplex/duplex.factor mode change 100644 => 100755 core/io/streams/nested/nested.factor mode change 100644 => 100755 core/io/streams/string/string.factor mode change 100644 => 100755 extra/cabal/cabal.factor mode change 100644 => 100755 extra/cryptlib/streams/streams.factor mode change 100644 => 100755 extra/delegate/protocols/protocols.factor mode change 100644 => 100755 extra/help/tutorial/tutorial.factor mode change 100644 => 100755 extra/http/client/client.factor mode change 100644 => 100755 extra/io/mmap/mmap-docs.factor create mode 100755 extra/io/monitor/monitor-docs.factor mode change 100644 => 100755 extra/io/nonblocking/nonblocking-docs.factor mode change 100644 => 100755 extra/io/sockets/sockets-docs.factor mode change 100644 => 100755 extra/io/streams/null/null.factor mode change 100644 => 100755 extra/io/unix/mmap/mmap.factor mode change 100644 => 100755 extra/io/unix/sockets/sockets.factor mode change 100644 => 100755 extra/io/unix/unix-tests.factor mode change 100644 => 100755 extra/irc/irc.factor mode change 100644 => 100755 extra/tar/tar.factor diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor old mode 100644 new mode 100755 index 2918f3340b..51e461c715 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -68,6 +68,15 @@ $nl ABOUT: "continuations" +HELP: dispose +{ $values { "object" "a disposable object" } } +{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." } +{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ; + +HELP: with-disposal +{ $values { "object" "a disposable object" } { "quot" "a quotation with stack effect " { $snippet "( object -- )" } } } +{ $description "Calls the quotation, disposing the object with " { $link dispose } " after the quotation returns or if it throws an error." } ; + HELP: catchstack* { $values { "catchstack" "a vector of continuations" } } { $description "Outputs the current catchstack." } ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 278264c17d..6e4ce16bea 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -135,6 +135,11 @@ PRIVATE> [ [ , f ] compose [ , drop t ] recover ] curry all? ] { } make peek swap [ rethrow ] when ; inline +GENERIC: dispose ( object -- ) + +: with-disposal ( object quot -- ) + over [ dispose ] curry [ ] cleanup ; inline + TUPLE: condition restarts continuation ; : ( error restarts cc -- condition ) diff --git a/core/dlists/dlists-docs.factor b/core/dlists/dlists-docs.factor old mode 100644 new mode 100755 index 5a808a9a5d..2aeaadad3e --- a/core/dlists/dlists-docs.factor +++ b/core/dlists/dlists-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax kernel ; +USING: help.markup help.syntax kernel quotations ; IN: dlists ARTICLE: "dlists" "Doubly-linked lists" @@ -13,23 +13,31 @@ $nl { $subsection dlist? } "Constructing a dlist:" { $subsection } -"Double-ended queue protocol:" -{ $subsection dlist-empty? } +"Working with the front of the list:" { $subsection push-front } +{ $subsection push-front* } +{ $subsection peek-front } { $subsection pop-front } { $subsection pop-front* } +"Working with the back of the list:" { $subsection push-back } +{ $subsection push-back* } +{ $subsection peek-back } { $subsection pop-back } { $subsection pop-back* } "Finding out the length:" +{ $subsection dlist-empty? } { $subsection dlist-length } "Iterating over elements:" { $subsection dlist-each } { $subsection dlist-find } { $subsection dlist-contains? } -"Deleting a node matching a predicate:" -{ $subsection delete-node* } +"Deleting a node:" { $subsection delete-node } +{ $subsection dlist-delete } +"Deleting a node matching a predicate:" +{ $subsection delete-node-if* } +{ $subsection delete-node-if } "Consuming all nodes:" { $subsection dlist-slurp } ; @@ -77,7 +85,7 @@ HELP: pop-back* { $see-also push-front push-back pop-front pop-front* pop-back } ; HELP: dlist-find -{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } +{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } { $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." } { $notes "Returns a boolean to allow dlists to store " { $link f } "." $nl @@ -85,20 +93,20 @@ HELP: dlist-find } ; HELP: dlist-contains? -{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "?" "a boolean" } } +{ $values { "quot" quotation } { "dlist" { $link dlist } } { "?" "a boolean" } } { $description "Just like " { $link dlist-find } " except it doesn't return the object." } { $notes "This operation is O(n)." } ; -HELP: delete-node* -{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } +HELP: delete-node-if* +{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } { $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any. Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." } { $notes "This operation is O(n)." } ; -HELP: delete-node -{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } } -{ $description "Like " { $link delete-node* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." } +HELP: delete-node-if +{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } } +{ $description "Like " { $link delete-node-if* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." } { $notes "This operation is O(n)." } ; HELP: dlist-each -{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } } +{ $values { "quot" quotation } { "dlist" { $link dlist } } } { $description "Iterate a " { $link dlist } ", calling quot on each element." } ; diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor index ebae68472b..203c975bb2 100755 --- a/core/dlists/dlists-tests.factor +++ b/core/dlists/dlists-tests.factor @@ -49,14 +49,14 @@ IN: temporary [ f ] [ 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test [ t ] [ 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test -[ 1 ] [ 1 over push-back [ 1 = ] swap delete-node ] unit-test -[ t ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test -[ t ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test -[ 0 ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test -[ 1 ] [ 1 over push-back 2 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node drop dlist-length ] unit-test +[ 1 ] [ 1 over push-back [ 1 = ] swap delete-node-if ] unit-test +[ t ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test +[ t ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test +[ 0 ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test +[ 1 ] [ 1 over push-back 2 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node-if drop dlist-length ] unit-test [ 0 ] [ dlist-length ] unit-test [ 1 ] [ 1 over push-front dlist-length ] unit-test diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index 84d68b28aa..ddec312182 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -63,12 +63,22 @@ C: dlist-node >r dlist-front r> (dlist-each-node) ; inline PRIVATE> -: push-front ( obj dlist -- ) - [ dlist-front f swap dup set-next-prev ] keep +: push-front* ( obj dlist -- dlist-node ) + [ dlist-front f swap dup dup set-next-prev ] keep [ set-dlist-front ] keep [ set-back-to-front ] keep inc-length ; +: push-front ( obj dlist -- ) + push-front* drop ; + +: push-back* ( obj dlist -- dlist-node ) + [ dlist-back f ] keep + [ dlist-back set-next-when ] 2keep + [ set-dlist-back ] 2keep + [ set-front-to-back ] keep + inc-length ; + : push-back ( obj dlist -- ) [ dlist-back f ] keep [ dlist-back set-next-when ] 2keep @@ -76,6 +86,9 @@ PRIVATE> [ set-front-to-back ] keep inc-length ; +: peek-front ( dlist -- obj ) + dlist-front dlist-node-obj ; + : pop-front ( dlist -- obj ) dup dlist-front [ dup dlist-node-next @@ -87,6 +100,9 @@ PRIVATE> : pop-front* ( dlist -- ) pop-front drop ; +: peek-back ( dlist -- obj ) + dlist-back dlist-node-obj ; + : pop-back ( dlist -- obj ) dup dlist-back [ dup dlist-node-prev @@ -108,25 +124,25 @@ PRIVATE> dup dlist-node-prev over dlist-node-next set-prev-when dup dlist-node-next swap dlist-node-prev set-next-when ; -: (delete-node) ( dlist dlist-node -- ) +: delete-node ( dlist dlist-node -- ) { { [ over dlist-front over eq? ] [ drop pop-front* ] } { [ over dlist-back over eq? ] [ drop pop-back* ] } { [ t ] [ unlink-node dec-length ] } } cond ; -: delete-node* ( quot dlist -- obj/f ? ) +: delete-node-if* ( quot dlist -- obj/f ? ) tuck dlist-find-node [ - [ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if* + [ delete-node ] keep [ dlist-node-obj t ] [ f f ] if* ] [ 2drop f f ] if ; inline -: delete-node ( quot dlist -- obj/f ) - delete-node* drop ; inline +: delete-node-if ( quot dlist -- obj/f ) + delete-node-if* drop ; inline : dlist-delete ( obj dlist -- obj/f ) - >r [ eq? ] curry r> delete-node ; + >r [ eq? ] curry r> delete-node-if ; : dlist-each ( dlist quot -- ) [ dlist-node-obj ] swap compose dlist-each-node ; inline diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index f5ad256ec5..3e3858d45d 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -421,6 +421,8 @@ DEFER: bar { 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect { 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect +\ dispose must-infer + ! Test stream protocol \ set-timeout must-infer \ stream-read must-infer @@ -430,7 +432,6 @@ DEFER: bar \ stream-write must-infer \ stream-write1 must-infer \ stream-nl must-infer -\ stream-close must-infer \ stream-format must-infer \ stream-write-table must-infer \ stream-flush must-infer diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor old mode 100644 new mode 100755 index 3559a3487b..5d4bb70912 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,5 +1,5 @@ IN: temporary -USING: tools.test io.files io threads kernel ; +USING: tools.test io.files io threads kernel continuations ; [ "passwd" ] [ "/etc/passwd" file-name ] unit-test [ "awk/" ] [ "/usr/libexec/awk/" file-name ] unit-test @@ -41,7 +41,7 @@ USING: tools.test io.files io threads kernel ; [ ] [ "test-blah" resource-path make-directory ] unit-test [ ] [ - "test-blah/fooz" resource-path stream-close + "test-blah/fooz" resource-path dispose ] unit-test [ t ] [ diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index cf867d7945..5333b3c8c5 100755 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -1,12 +1,12 @@ USING: help.markup help.syntax quotations hashtables kernel -classes strings ; +classes strings continuations ; IN: io ARTICLE: "stream-protocol" "Stream protocol" "The stream protocol consists of a large number of generic words, many of which are optional." $nl -"A word required to be implemented for all streams:" -{ $subsection stream-close } +"All streams must implement the " { $link dispose } " word in addition to the stream protocol." +$nl "Three words are required for input streams:" { $subsection stream-read1 } { $subsection stream-read } @@ -73,12 +73,6 @@ ARTICLE: "streams" "Streams" ABOUT: "streams" -HELP: stream-close -{ $values { "stream" "a stream" } } -{ $contract "Closes the stream. This releases any external resources associated with the stream, such as file handles and network connections. No further operations can be performed on the stream after this call." } -{ $notes "You must close streams after you are finished working with them. A convenient way to automate this is by using the " { $link with-stream } " word." } -$io-error ; - HELP: set-timeout { $values { "n" "an integer" } { "stream" "a stream" } } { $contract "Sets a timeout, in milliseconds, for closing the stream if there is no activity. Not all streams support timeouts." } diff --git a/core/io/io.factor b/core/io/io.factor index edd0fa938f..e0c890c0e3 100755 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -4,7 +4,6 @@ USING: hashtables generic kernel math namespaces sequences strings continuations assocs io.styles sbufs ; IN: io -GENERIC: stream-close ( stream -- ) GENERIC: set-timeout ( n stream -- ) GENERIC: stream-readln ( stream -- str ) GENERIC: stream-read1 ( stream -- ch/f ) @@ -29,7 +28,7 @@ GENERIC: stream-write-table ( table-cells style stream -- ) [ over stream-write (stream-copy) ] [ 2drop ] if* ; : stream-copy ( in out -- ) - [ 2dup (stream-copy) ] [ stream-close stream-close ] [ ] + [ 2dup (stream-copy) ] [ dispose dispose ] [ ] cleanup ; ! Default stream @@ -54,9 +53,7 @@ SYMBOL: stderr stdio swap with-variable ; inline : with-stream ( stream quot -- ) - swap [ - [ stdio get stream-close ] [ ] cleanup - ] with-stream* ; inline + [ with-stream* ] curry with-disposal ; inline : tabular-output ( style quot -- ) swap >r { } make r> stdio get stream-write-table ; inline diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index d816e08443..b02c3367d4 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel kernel.private namespaces io strings sequences math generic threads.private classes io.backend io.streams.lines io.streams.plain io.streams.duplex -io.files ; +io.files continuations ; IN: io.streams.c TUPLE: c-writer handle ; @@ -19,7 +19,7 @@ M: c-writer stream-write M: c-writer stream-flush c-writer-handle fflush ; -M: c-writer stream-close +M: c-writer dispose c-writer-handle fclose ; TUPLE: c-reader handle ; @@ -46,7 +46,7 @@ M: c-reader stream-read-until [ swap read-until-loop ] "" make swap over empty? over not and [ 2drop f f ] when ; -M: c-reader stream-close +M: c-reader dispose c-reader-handle fclose ; : ( in out -- stream ) diff --git a/core/io/streams/duplex/duplex-docs.factor b/core/io/streams/duplex/duplex-docs.factor old mode 100644 new mode 100755 index 6293836348..fa82c54163 --- a/core/io/streams/duplex/duplex-docs.factor +++ b/core/io/streams/duplex/duplex-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io ; +USING: help.markup help.syntax io continuations ; IN: io.streams.duplex ARTICLE: "io.streams.duplex" "Duplex streams" @@ -19,4 +19,4 @@ HELP: HELP: check-closed { $values { "stream" "a duplex stream" } } { $description "Throws a " { $link check-closed } " error if the stream has already been closed." } -{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link stream-close } "." } ; +{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ; diff --git a/core/io/streams/duplex/duplex-tests.factor b/core/io/streams/duplex/duplex-tests.factor old mode 100644 new mode 100755 index a4a6433a29..962a46413f --- a/core/io/streams/duplex/duplex-tests.factor +++ b/core/io/streams/duplex/duplex-tests.factor @@ -6,7 +6,7 @@ TUPLE: closing-stream closed? ; : closing-stream construct-empty ; -M: closing-stream stream-close +M: closing-stream dispose dup closing-stream-closed? [ "Closing twice!" throw ] [ @@ -17,24 +17,24 @@ TUPLE: unclosable-stream ; : unclosable-stream construct-empty ; -M: unclosable-stream stream-close +M: unclosable-stream dispose "Can't close me!" throw ; [ ] [ - dup stream-close stream-close + dup dispose dispose ] unit-test [ t ] [ [ - [ dup stream-close ] catch 2drop + [ dup dispose ] catch 2drop ] keep closing-stream-closed? ] unit-test [ t ] [ [ - [ dup stream-close ] catch 2drop + [ dup dispose ] catch 2drop ] keep closing-stream-closed? ] unit-test diff --git a/core/io/streams/duplex/duplex.factor b/core/io/streams/duplex/duplex.factor old mode 100644 new mode 100755 index a46dad71a0..86660b2752 --- a/core/io/streams/duplex/duplex.factor +++ b/core/io/streams/duplex/duplex.factor @@ -65,14 +65,14 @@ M: duplex-stream make-cell-stream M: duplex-stream stream-write-table duplex-stream-out+ stream-write-table ; -M: duplex-stream stream-close +M: duplex-stream dispose #! The output stream is closed first, in case both streams #! are attached to the same file descriptor, the output #! buffer needs to be flushed before we close the fd. dup duplex-stream-closed? [ t over set-duplex-stream-closed? - [ dup duplex-stream-out stream-close ] - [ dup duplex-stream-in stream-close ] [ ] cleanup + [ dup duplex-stream-out dispose ] + [ dup duplex-stream-in dispose ] [ ] cleanup ] unless drop ; M: duplex-stream set-timeout diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor old mode 100644 new mode 100755 index 83a86a9ced..e32c90a2fc --- a/core/io/streams/nested/nested.factor +++ b/core/io/streams/nested/nested.factor @@ -1,14 +1,14 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.nested USING: arrays generic assocs kernel namespaces strings -quotations io ; +quotations io continuations ; TUPLE: ignore-close-stream ; : ignore-close-stream construct-delegate ; -M: ignore-close-stream stream-close drop ; +M: ignore-close-stream dispose drop ; TUPLE: style-stream style ; @@ -44,4 +44,4 @@ TUPLE: block-stream ; : block-stream construct-delegate ; -M: block-stream stream-close drop ; +M: block-stream dispose drop ; diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor old mode 100644 new mode 100755 index 9aaece6e31..3d5a55739b --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -2,11 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.string USING: io kernel math namespaces sequences sbufs strings -generic splitting io.streams.plain io.streams.lines ; +generic splitting io.streams.plain io.streams.lines +continuations ; + +M: sbuf dispose drop ; M: sbuf stream-write1 push ; M: sbuf stream-write push-all ; -M: sbuf stream-close drop ; M: sbuf stream-flush drop ; : ( -- stream ) diff --git a/extra/cabal/cabal.factor b/extra/cabal/cabal.factor old mode 100644 new mode 100755 index cc51bcf308..0ad8465498 --- a/extra/cabal/cabal.factor +++ b/extra/cabal/cabal.factor @@ -41,7 +41,7 @@ VARS: input user ; : ((send-input)) ( other -- ) [ input> print flush ] with-stream* ; : (send-input) ( other -- ) -[ ((send-input)) ] catch [ print dup stream-close users> delete ] when ; +[ ((send-input)) ] catch [ print dup dispose users> delete ] when ; : send-input ( other -- ) dup duplex-stream-closed? [ users> delete ] [ (send-input) ] if ; diff --git a/extra/cryptlib/streams/streams.factor b/extra/cryptlib/streams/streams.factor old mode 100644 new mode 100755 index 77a34e84d1..64b5ee9992 --- a/extra/cryptlib/streams/streams.factor +++ b/extra/cryptlib/streams/streams.factor @@ -84,7 +84,7 @@ M: crypt-stream stream-write1 ( ch stream -- ) : check-close ( err -- ) dup CRYPT_ERROR_PARAM1 = [ drop ] [ check-result ] if ; -M: crypt-stream stream-close ( stream -- ) +M: crypt-stream dispose ( stream -- ) crypt-stream-handle cryptDestroySession check-close ; : create-session ( format -- session ) @@ -115,7 +115,7 @@ M: crypt-stream stream-close ( stream -- ) dup stream-readln print - stream-close + dispose end ; @@ -130,7 +130,7 @@ M: crypt-stream stream-close ( stream -- ) "Thanks!" over stream-print dup stream-flush - stream-close + dispose end ; @@ -152,6 +152,6 @@ M: crypt-stream stream-close ( stream -- ) (rpl) - stream-close + dispose end ; \ No newline at end of file diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor old mode 100644 new mode 100755 index 07f4ce119a..1121883b7c --- a/extra/delegate/protocols/protocols.factor +++ b/extra/delegate/protocols/protocols.factor @@ -15,7 +15,7 @@ PROTOCOL: assoc-protocol ! everything should work, just slower (with >alist) PROTOCOL: stream-protocol - stream-close stream-read1 stream-read stream-read-until + stream-read1 stream-read stream-read-until stream-flush stream-write1 stream-write stream-format stream-nl make-span-stream make-block-stream stream-readln make-cell-stream stream-write-table set-timeout ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 3b959ba801..234e7891d7 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -137,22 +137,25 @@ ARTICLE: "collections" "Collections" { $subsection "graphs" } { $subsection "buffers" } ; -USING: io.sockets io.launcher io.mmap ; +USING: io.sockets io.launcher io.mmap io.monitor ; ARTICLE: "io" "Input and output" { $subsection "streams" } -"Stream implementations:" +"External streams:" { $subsection "file-streams" } +{ $subsection "network-streams" } +"Wrapper streams:" { $subsection "io.streams.duplex" } { $subsection "io.streams.lines" } { $subsection "io.streams.plain" } { $subsection "io.streams.string" } -"Advanced features:" +"Stream utilities:" { $subsection "stream-binary" } { $subsection "styles" } -{ $subsection "network-streams" } +"Advanced features:" { $subsection "io.launcher" } -{ $subsection "io.mmap" } ; +{ $subsection "io.mmap" } +{ $subsection "io.monitor" } ; ARTICLE: "tools" "Developer tools" { $subsection "tools.annotations" } diff --git a/extra/help/tutorial/tutorial.factor b/extra/help/tutorial/tutorial.factor old mode 100644 new mode 100755 index b3308e83c2..f20ca27a5f --- a/extra/help/tutorial/tutorial.factor +++ b/extra/help/tutorial/tutorial.factor @@ -23,7 +23,7 @@ $nl $nl "Now, we tell Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:" { $code "IN: palindrome" } -"You are now ready to go on to the next section." ; +"You are now ready to go on to the next section: " { $link "first-program-logic" } "." ; ARTICLE: "first-program-logic" "Writing some logic in your first program" "Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:" @@ -56,7 +56,7 @@ $nl { $code "\\ = see" } "It's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path." -"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors." ; +"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors. You can now go on and learn about " { $link "first-program-test" } "." ; ARTICLE: "first-program-test" "Testing your first program" "Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:" @@ -92,7 +92,7 @@ $nl } "Now, you can run unit tests:" { $code "\"palindrome\" test" } -"It should report that all tests have passed." ; +"It should report that all tests have passed. Now you can read about " { $link "first-program-extend" } "." ; ARTICLE: "first-program-extend" "Extending your first program" "Our palindrome program works well, however we'd like to extend it to ignore spaces and non-alphabetical characters in the input." diff --git a/extra/html/html.factor b/extra/html/html.factor index f9d5bde5e6..b5d4e63930 100755 --- a/extra/html/html.factor +++ b/extra/html/html.factor @@ -105,7 +105,7 @@ TUPLE: html-sub-stream style stream ; TUPLE: html-span-stream ; -M: html-span-stream stream-close +M: html-span-stream dispose end-sub-stream not-a-div format-html-span ; : border-css, ( border -- ) @@ -138,7 +138,7 @@ M: html-span-stream stream-close TUPLE: html-block-stream ; -M: html-block-stream stream-close ( quot style stream -- ) +M: html-block-stream dispose ( quot style stream -- ) end-sub-stream a-div format-html-div ; : border-spacing-css, diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor old mode 100644 new mode 100755 index 7c385c0bb3..d03ce37c14 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -44,14 +44,14 @@ DEFER: http-get-stream #! Should this support Location: headers that are #! relative URLs? pick 100 /i 3 = [ - stream-close "Location" swap at nip http-get-stream + dispose "Location" swap at nip http-get-stream ] when ; : http-get-stream ( url -- code headers stream ) #! Opens a stream for reading from an HTTP URL. parse-url over parse-host [ [ [ get-request read-response ] with-stream* ] keep - ] [ >r stream-close r> rethrow ] recover do-redirect ; + ] [ ] [ dispose ] cleanup do-redirect ; : http-get ( url -- code headers string ) #! Opens a stream for reading from an HTTP URL. diff --git a/extra/io/mmap/mmap-docs.factor b/extra/io/mmap/mmap-docs.factor old mode 100644 new mode 100755 index 22e403ed31..cb51088e58 --- a/extra/io/mmap/mmap-docs.factor +++ b/extra/io/mmap/mmap-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax alien math ; +USING: help.markup help.syntax alien math continuations ; IN: io.mmap HELP: mapped-file @@ -15,21 +15,17 @@ HELP: { $notes "You must call " { $link close-mapped-file } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." } { $errors "Throws an error if a memory mapping could not be established." } ; -HELP: (close-mapped-file) -{ $values { "mmap" mapped-file } } -{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link close-mapped-file } " instead." } -{ $errors "Throws an error if a memory mapping could not be established." } ; - HELP: close-mapped-file { $values { "mmap" mapped-file } } -{ $description "Releases system resources associated with the mapped file." } +{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." } { $errors "Throws an error if a memory mapping could not be established." } ; ARTICLE: "io.mmap" "Memory-mapped files" "The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files." { $subsection } -{ $subsection close-mapped-file } -"A combinator which wraps the above two words:" +"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "." +$nl +"A utility combinator which wraps the above:" { $subsection with-mapped-file } "Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly:" { $subsection mapped-file-address } diff --git a/extra/io/mmap/mmap.factor b/extra/io/mmap/mmap.factor index 26378a06aa..af020e5a26 100755 --- a/extra/io/mmap/mmap.factor +++ b/extra/io/mmap/mmap.factor @@ -23,14 +23,12 @@ INSTANCE: mapped-file sequence HOOK: io-backend ( path length -- mmap ) -HOOK: (close-mapped-file) io-backend ( mmap -- ) +HOOK: close-mapped-file io-backend ( mmap -- ) -: close-mapped-file ( mmap -- ) +M: mapped-file dispose ( mmap -- ) check-closed t over set-mapped-file-closed? - (close-mapped-file) ; + close-mapped-file ; : with-mapped-file ( path length quot -- ) - >r r> - [ keep ] curry - [ close-mapped-file ] [ ] cleanup ; inline + >r r> with-disposal ; inline diff --git a/extra/io/monitor/monitor-docs.factor b/extra/io/monitor/monitor-docs.factor new file mode 100755 index 0000000000..56fd203bde --- /dev/null +++ b/extra/io/monitor/monitor-docs.factor @@ -0,0 +1,61 @@ +IN: io.monitor +USING: help.markup help.syntax continuations ; + +HELP: +{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } } +{ $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." +$nl +"Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ; + +HELP: next-change +{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a sequence of change descriptors" } } +{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence containing at least one change descriptor; see " { $link "io.monitor.descriptors" } "." } ; + +HELP: with-monitor +{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } } +{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ; + +HELP: +change-file+ +{ $description "Indicates that the contents of the file have changed." } ; + +HELP: +change-name+ +{ $description "Indicates that the file name has changed." } ; + +HELP: +change-size+ +{ $description "Indicates that the file size has changed." } ; + +HELP: +change-attributes+ +{ $description "Indicates that file attributes has changed. Attributes are operating system-specific but may include the creation time and permissions." } ; + +HELP: +change-modified+ +{ $description "Indicates that the last modification time of the file has changed." } ; + +ARTICLE: "io.monitor.descriptors" "File system change descriptors" +"Change descriptors output by " { $link next-change } ":" +{ $subsection +change-file+ } +{ $subsection +change-name+ } +{ $subsection +change-size+ } +{ $subsection +change-attributes+ } +{ $subsection +change-modified+ } ; + +ARTICLE: "io.monitor" "File system change monitors" +"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored." +$nl +"Creating a file system change monitor and listening for changes:" +{ $subsection } +{ $subsection next-change } +{ $subsection "io.monitor.descriptors" } +"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "." +$nl +"A utility combinator which opens a monitor and cleans it up after:" +{ $subsection with-monitor } +"An example which watches the Factor directory for changes:" +{ $code + "USE: io.monitor" + ": watch-loop ( monitor -- )" + " dup next-change . . nl nl flush watch-loop ;" + "" + "\"\" resource-path f [ watch-loop ] with-monitor" +} ; + +ABOUT: "io.monitor" diff --git a/extra/io/monitor/monitor.factor b/extra/io/monitor/monitor.factor index 23b336c929..044fa9572b 100755 --- a/extra/io/monitor/monitor.factor +++ b/extra/io/monitor/monitor.factor @@ -5,8 +5,6 @@ IN: io.monitor HOOK: io-backend ( path recursive? -- monitor ) -HOOK: close-monitor io-backend ( monitor -- ) - HOOK: next-change io-backend ( monitor -- path changes ) SYMBOL: +change-file+ @@ -16,4 +14,4 @@ SYMBOL: +change-attributes+ SYMBOL: +change-modified+ : with-monitor ( path recursive? quot -- ) - >r r> over [ close-monitor ] curry [ ] cleanup ; + >r r> with-disposal ; inline diff --git a/extra/io/nonblocking/nonblocking-docs.factor b/extra/io/nonblocking/nonblocking-docs.factor old mode 100644 new mode 100755 index d6d619229f..af73a47030 --- a/extra/io/nonblocking/nonblocking-docs.factor +++ b/extra/io/nonblocking/nonblocking-docs.factor @@ -1,5 +1,5 @@ USING: io io.buffers io.backend help.markup help.syntax kernel -strings sbufs words ; +strings sbufs words continuations ; IN: io.nonblocking ARTICLE: "io.nonblocking" "Non-blocking I/O implementation" @@ -23,7 +23,7 @@ $nl "Per-port native I/O protocol:" { $subsection init-handle } { $subsection (wait-to-read) } -"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link stream-close } " generic words." +"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link dispose } " generic words." $nl "Dummy ports which should be used to implement networking:" { $subsection server-port } diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 8a7e732281..9d08e87fa3 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -1,16 +1,20 @@ -! Copyright (C) 2005, 2007 Slava Pestov, Doug Coleman +! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. IN: io.nonblocking -USING: math kernel io sequences io.buffers generic sbufs -system io.streams.lines io.streams.plain io.streams.duplex -continuations debugger classes byte-arrays namespaces -splitting ; +USING: math kernel io sequences io.buffers generic sbufs system +io.streams.lines io.streams.plain io.streams.duplex io.backend +continuations debugger classes byte-arrays namespaces splitting +dlists ; SYMBOL: default-buffer-size 64 1024 * default-buffer-size set-global ! Common delegate of native stream readers and writers -TUPLE: port handle error timeout cutoff type eof? ; +TUPLE: port +handle +error +timeout-entry timeout cutoff +type eof? ; SYMBOL: closed @@ -41,19 +45,46 @@ GENERIC: close-handle ( handle -- ) : handle>duplex-stream ( in-handle out-handle -- stream ) - [ >r r> ] [ ] [ stream-close ] + [ >r r> ] [ ] [ dispose ] cleanup ; -: touch-port ( port -- ) - dup port-timeout dup zero? - [ 2drop ] [ millis + swap set-port-cutoff ] if ; - : timeout? ( port -- ? ) port-cutoff dup zero? not swap millis < and ; : pending-error ( port -- ) dup port-error f rot set-port-error [ throw ] when* ; +SYMBOL: timeout-queue + + timeout-queue set-global + +: unqueue-timeout ( port -- ) + port-timeout-entry [ + timeout-queue get-global swap delete-node + ] when* ; + +: queue-timeout ( port -- ) + dup timeout-queue get-global push-front* + swap set-port-timeout-entry ; + +HOOK: expire-port io-backend ( port -- ) + +M: object expire-port drop ; + +: expire-timeouts ( -- ) + timeout-queue get-global dup dlist-empty? [ drop ] [ + dup peek-back timeout? + [ pop-back expire-port expire-timeouts ] [ drop ] if + ] if ; + +: touch-port ( port -- ) + dup port-timeout dup zero? [ + 2drop + ] [ + millis + over set-port-cutoff + dup unqueue-timeout queue-timeout + ] if ; + M: port set-timeout [ set-port-timeout ] keep touch-port ; @@ -157,7 +188,7 @@ GENERIC: port-flush ( port -- ) M: output-port stream-flush ( port -- ) dup port-flush pending-error ; -M: port stream-close +M: port dispose dup port-type closed eq? [ dup port-type >r closed over set-port-type r> output-port eq? [ dup port-flush ] when diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 0141289c38..6e7cd5a940 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -29,8 +29,7 @@ SYMBOL: log-stream : with-log-file ( file quot -- ) >r r> - [ [ with-log-stream ] 2keep ] - [ drop stream-close ] [ ] cleanup ; inline + [ with-log-stream ] with-disposal ; inline : with-log-stdio ( quot -- ) stdio get swap with-log-stream ; @@ -52,7 +51,7 @@ SYMBOL: log-stream [ swap accept with-client ] 2keep accept-loop ; inline : server-loop ( server quot -- ) - [ accept-loop ] [ drop stream-close ] [ ] cleanup ; inline + [ accept-loop ] compose with-disposal ; inline : spawn-server ( addrspec quot -- ) "Waiting for connections on " pick unparse append @@ -87,8 +86,7 @@ SYMBOL: log-stream : spawn-datagrams ( quot addrspec -- ) "Waiting for datagrams on " over unparse append log-message - [ datagram-loop ] [ stream-close ] [ ] cleanup ; - inline + [ datagram-loop ] with-disposal ; inline : with-datagrams ( seq service quot -- ) [ diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor old mode 100644 new mode 100755 index a5c623b6b7..9136c3ca22 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io io.backend threads -strings byte-arrays ; +strings byte-arrays continuations ; IN: io.sockets ARTICLE: "network-addressing" "Address specifiers" @@ -19,7 +19,7 @@ ARTICLE: "network-connection" "Connection-oriented networking" { $subsection accept } "The stream returned by " { $link accept } " holds the address specifier of the remote client:" { $subsection client-stream-addr } -"Server sockets are closed by calling " { $link stream-close } ", but they do not respond to the rest of the stream protocol." +"Server sockets are closed by calling " { $link dispose } "." $nl "Address specifiers have the following interpretation with connection-oriented networking words:" { $list @@ -36,7 +36,7 @@ ARTICLE: "network-packet" "Packet-oriented networking" "Packets can be sent and received with a pair of words:" { $subsection send } { $subsection receive } -"Packet-oriented sockets are closed by calling " { $link stream-close } ", but they do not respond to the rest of the stream protocol." +"Packet-oriented sockets are closed by calling " { $link dispose } "." $nl "Address specifiers have the following interpretation with connection-oriented networking words:" { $list @@ -104,7 +104,7 @@ HELP: { $description "Begins listening for network connections to a local address. Server objects responds to two words:" { $list - { { $link stream-close } " - stops listening on the port and frees all associated resources" } + { { $link dispose } " - stops listening on the port and frees all associated resources" } { { $link accept } " - blocks until there is a connection" } } } @@ -128,7 +128,7 @@ HELP: { $values { "addrspec" "an address specifier" } { "datagram" "a handle" } } { $description "Creates a datagram socket bound to a local address. Datagram socket objects responds to three words:" { $list - { { $link stream-close } " - stops listening on the port and frees all associated resources" } + { { $link dispose } " - stops listening on the port and frees all associated resources" } { { $link receive } " - waits for a packet" } { { $link send } " - sends a packet" } } diff --git a/extra/io/streams/null/null.factor b/extra/io/streams/null/null.factor old mode 100644 new mode 100755 index 12a36091ce..28d1b29be8 --- a/extra/io/streams/null/null.factor +++ b/extra/io/streams/null/null.factor @@ -5,7 +5,7 @@ USING: kernel io ; TUPLE: null-stream ; -M: null-stream stream-close drop ; +M: null-stream dispose drop ; M: null-stream set-timeout 2drop ; M: null-stream stream-readln drop f ; M: null-stream stream-read1 drop f ; diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor old mode 100644 new mode 100755 index 5a72a5426a..71c55f2303 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -15,7 +15,7 @@ M: unix-io ( path length -- obj ) dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor r> mmap-open f mapped-file construct-boa ; -M: unix-io (close-mapped-file) ( mmap -- ) +M: unix-io close-mapped-file ( mmap -- ) [ mapped-file-address ] keep [ mapped-file-length munmap ] keep mapped-file-handle close diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor old mode 100644 new mode 100755 index 35366b1d41..748dbc40a7 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -15,8 +15,7 @@ libc combinators ; #! don't set up error handlers until after #! returns (and if they did before, they wouldn't have #! anything to close!) - dup port-error dup - [ swap stream-close throw ] [ 2drop ] if ; + dup port-error dup [ swap dispose throw ] [ 2drop ] if ; : socket-fd ( domain type -- socket ) 0 socket dup io-error dup init-handle ; diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor old mode 100644 new mode 100755 index e328e7bf5d..ce2f052450 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -63,7 +63,7 @@ yield "d" get send - "d" get stream-close + "d" get dispose "Done" print @@ -104,7 +104,7 @@ client-addr >r >string r> ] unit-test -[ ] [ "d" get stream-close ] unit-test +[ ] [ "d" get dispose ] unit-test ! Test error behavior @@ -120,7 +120,7 @@ client-addr B{ 1 2 3 } "unix-domain-datagram-test-3" "d" get send ] unit-test-fails -[ ] [ "d" get stream-close ] unit-test +[ ] [ "d" get dispose ] unit-test ! See what happens on send/receive after close diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index 27587e8340..d1cafa4c0f 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -81,7 +81,7 @@ M: windows-io ( path length -- mmap ) f \ mapped-file construct-boa ] with-destructors ; -M: windows-io (close-mapped-file) ( mapped-file -- ) +M: windows-io close-mapped-file ( mapped-file -- ) [ dup mapped-file-handle [ close-always ] each mapped-file-address UnmapViewOfFile win32-error=0/f diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 3b10ddd935..940b1b7fee 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -1,8 +1,8 @@ USING: alien alien.c-types arrays assocs combinators continuations destructors io io.backend io.nonblocking -io.windows libc kernel math namespaces sequences threads -tuples.lib windows windows.errors windows.kernel32 strings -splitting io.files qualified ; +io.windows libc kernel math namespaces sequences +threads tuples.lib windows windows.errors windows.kernel32 +strings splitting io.files qualified ; QUALIFIED: windows.winsock IN: io.windows.nt.backend @@ -122,19 +122,11 @@ M: windows-nt-io add-completion ( handle -- ) : drain-overlapped ( timeout -- ) handle-overlapped [ 0 drain-overlapped ] unless ; -: maybe-expire ( io-callbck -- ) - io-callback-port - dup timeout? [ - port-handle win32-file-handle CancelIo drop - ] [ - drop - ] if ; - -: cancel-timeout ( -- ) - io-hash get-global [ nip maybe-expire ] assoc-each ; +M: windows-nt-io expire-port + port-handle win32-file-handle CancelIo drop ; M: windows-nt-io io-multiplex ( ms -- ) - cancel-timeout drain-overlapped ; + expire-timeouts drain-overlapped ; M: windows-nt-io init-io ( -- ) master-completion-port set-global diff --git a/extra/io/windows/nt/monitor/monitor.factor b/extra/io/windows/nt/monitor/monitor.factor index bd3debecad..f296e859f0 100755 --- a/extra/io/windows/nt/monitor/monitor.factor +++ b/extra/io/windows/nt/monitor/monitor.factor @@ -34,8 +34,6 @@ M: windows-nt-io ( path recursive? -- monitor ) : check-closed ( monitor -- ) port-type closed eq? [ "Monitor closed" throw ] when ; -M: windows-nt-io close-monitor ( monitor -- ) stream-close ; - : begin-reading-changes ( monitor -- overlapped ) dup port-handle win32-file-handle over buffer-ptr diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 03cb3be9ae..419864b624 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -1,10 +1,11 @@ -! Copyright (C) 2004, 2007 Mackenzie Straight, Doug Coleman. +! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. 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.types windows.winsock splitting ; +windows.shell32 windows.types windows.winsock splitting +continuations ; IN: io.windows TUPLE: windows-nt-io ; @@ -174,7 +175,7 @@ USE: namespaces : listen-on-socket ( socket -- ) listen-backlog listen winsock-return-check ; -M: win32-socket stream-close ( stream -- ) +M: win32-socket dispose ( stream -- ) win32-file-handle closesocket drop ; M: windows-io addrinfo-error ( n -- ) diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor old mode 100644 new mode 100755 index 6f54768cab..74d8951d10 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -185,7 +185,7 @@ SYMBOL: line dup irc-client-profile profile-server over irc-client-profile profile-port connect* dup irc-client-profile profile-nickname login - [ irc-loop ] [ irc-stream> stream-close ] [ ] cleanup ; + [ irc-loop ] [ irc-stream> dispose ] [ ] cleanup ; : with-infinite-loop ( quot timeout -- quot timeout ) "looping" print flush diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor old mode 100644 new mode 100755 index 4a737f06c2..ee312c1111 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -95,7 +95,7 @@ TUPLE: unimplemented-typeflag header ; ! Normal file : typeflag-0 tar-header-name tar-path+ - [ read-data-blocks ] keep stream-close ; + [ read-data-blocks ] keep dispose ; ! Hard link : typeflag-1 ( header -- ) @@ -221,7 +221,7 @@ TUPLE: unimplemented-typeflag header ; [ throw ] } case ! dup tar-header-size zero? [ - ! out-stream get [ stream-close ] when + ! out-stream get [ dispose ] when ! out-stream off ! drop ! ] [ diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 83e0ea5ec3..f2bd03475f 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -9,15 +9,16 @@ quotations io.launcher words.private tools.deploy.config bootstrap.image ; IN: tools.deploy.backend -: (copy-lines) ( stream -- stream ) - dup stream-readln [ print flush (copy-lines) ] when* ; +: (copy-lines) ( stream -- ) + dup stream-readln dup + [ print flush (copy-lines) ] [ 2drop ] if ; : copy-lines ( stream -- ) - [ (copy-lines) ] [ stream-close ] [ ] cleanup ; + [ (copy-lines) ] with-disposal ; : run-with-output ( descriptor -- ) - dup duplex-stream-out stream-close + dup duplex-stream-out dispose copy-lines ; : boot-image-name ( -- string ) diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 016d02e527..dde312b34d 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -8,7 +8,7 @@ hashtables io kernel namespaces sequences io.styles strings quotations math opengl combinators math.vectors io.streams.duplex sorting splitting io.streams.nested assocs ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids -ui.gadgets.grid-lines tuples models ; +ui.gadgets.grid-lines tuples models continuations ; IN: ui.gadgets.panes TUPLE: pane output current prototype scrolls? @@ -161,7 +161,7 @@ M: pane-stream stream-write M: pane-stream stream-format [ rot string-lines pane-format ] do-pane-stream ; -M: pane-stream stream-close drop ; +M: pane-stream dispose drop ; M: pane-stream stream-flush drop ; @@ -249,7 +249,7 @@ TUPLE: nested-pane-stream style parent ; TUPLE: pane-block-stream ; -M: pane-block-stream stream-close +M: pane-block-stream dispose unnest-pane-stream write-gadget ; M: pane-stream make-block-stream @@ -272,7 +272,7 @@ M: pane-stream make-block-stream TUPLE: pane-cell-stream ; -M: pane-cell-stream stream-close ?nl ; +M: pane-cell-stream dispose ?nl ; M: pane-stream make-cell-stream pane-cell-stream construct-delegate ; @@ -284,9 +284,9 @@ M: pane-stream stream-write-table r> print-gadget ; ! Stream utilities -M: pack stream-close drop ; +M: pack dispose drop ; -M: paragraph stream-close drop ; +M: paragraph dispose drop ; : gadget-write ( string gadget -- ) over empty? [ From b60a4f4ade1abf8756edb817122434f612fcddce Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 00:52:24 -0600 Subject: [PATCH 50/66] Clean up listener --- core/listener/listener.factor | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 8f26ddf9b2..02cd727930 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -18,11 +18,10 @@ GENERIC: stream-read-quot ( stream -- quot/f ) [ parse-lines in get ] with-compilation-unit in set ; : read-quot-step ( lines -- quot/f ) - [ parse-lines-interactive ] catch { - { [ dup delegate unexpected-eof? ] [ 2drop f ] } - { [ dup not ] [ drop ] } - { [ t ] [ rethrow ] } - } cond ; + [ parse-lines-interactive ] [ + dup delegate unexpected-eof? + [ 2drop f ] [ rethrow ] if + ] recover ; : read-quot-loop ( stream accum -- quot/f ) over stream-readln dup [ From 14481db63f1ef04af43972009aa78cff1d7c85e2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 01:15:28 -0600 Subject: [PATCH 51/66] Smarter download word, old download word renamed to download-to for Ed --- extra/http/client/client-tests.factor | 5 +++++ extra/http/client/client.factor | 18 ++++++++++++++++-- 2 files changed, 21 insertions(+), 2 deletions(-) mode change 100644 => 100755 extra/http/client/client-tests.factor diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor old mode 100644 new mode 100755 index 5c570993e6..d2fb719acd --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -7,3 +7,8 @@ USING: http.client tools.test ; [ 404 ] [ "404 File not found" parse-response ] unit-test [ 200 ] [ "HTTP/1.0 200" parse-response ] unit-test [ 200 ] [ "HTTP/1.0 200 Success" parse-response ] unit-test + +[ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test +[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test +[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test +[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index d03ce37c14..dde2c7d205 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -59,9 +59,23 @@ DEFER: http-get-stream http-get-stream [ stdio get contents ] with-stream ] with-scope ; -: download ( url file -- ) +: download-name ( url -- name ) + file-name "?" split1 drop "/" ?tail drop ; + +: default-timeout 60 1000 * over set-timeout ; + +: success? ( code -- ? ) 200 = ; + +: download-to ( url file -- ) #! Downloads the contents of a URL to a file. - >r http-get 2nip r> [ write ] with-stream ; + >r http-get-stream nip default-timeout swap success? [ + r> stream-copy + ] [ + r> drop dispose "HTTP download failed" throw + ] if ; + +: download ( url -- ) + dup download-name download-to ; : post-request ( content-type content host resource -- ) #! Note: It is up to the caller to url encode the content if From 0a5f90d5daebfbf97e6d199d4a4210f72b6ed9a1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 01:15:41 -0600 Subject: [PATCH 52/66] Clarify docs --- core/io/io-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 5333b3c8c5..208e2a2ba7 100755 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -75,8 +75,8 @@ ABOUT: "streams" HELP: set-timeout { $values { "n" "an integer" } { "stream" "a stream" } } -{ $contract "Sets a timeout, in milliseconds, for closing the stream if there is no activity. Not all streams support timeouts." } -$io-error ; +{ $contract "Sets a timeout, in milliseconds, for input and output operations on the stream. If a read or a write is initiated and no activity is seen before the timeout expires, an error will be thrown to the caller of the operation being performed." } +{ $notes "Whether or not the stream is closed when the error is thrown is implementation-specific, and user code should take care to close the stream on all error conditions in any case." } ; HELP: stream-readln { $values { "stream" "an input stream" } { "str" string } } From d08919199c748eb20e0013b72dd68a2d6ed8a631 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 01:16:02 -0600 Subject: [PATCH 53/66] Update bunny --- extra/bunny/bunny.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 extra/bunny/bunny.factor diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor old mode 100644 new mode 100755 index 3042b87ad6..550eb50e0a --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -53,7 +53,7 @@ IN: bunny model-path resource-path dup exists? [ "Downloading bunny from " write model-url dup print flush - over download + over download-to ] unless ; : draw-triangle ( ns vs triple -- ) From 5478f225247a2c0c429d01a985c625dd4ca48432 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 01:16:10 -0600 Subject: [PATCH 54/66] Don't blow away timeouts on reload --- extra/io/nonblocking/nonblocking.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 9d08e87fa3..ca50d7063a 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -4,7 +4,7 @@ IN: io.nonblocking USING: math kernel io sequences io.buffers generic sbufs system io.streams.lines io.streams.plain io.streams.duplex io.backend continuations debugger classes byte-arrays namespaces splitting -dlists ; +dlists assocs ; SYMBOL: default-buffer-size 64 1024 * default-buffer-size set-global @@ -56,7 +56,7 @@ GENERIC: close-handle ( handle -- ) SYMBOL: timeout-queue - timeout-queue set-global +timeout-queue global [ [ ] unless* ] change-at : unqueue-timeout ( port -- ) port-timeout-entry [ From 91213541169fff492932649140dadd68ae796f00 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 31 Jan 2008 11:51:38 -0600 Subject: [PATCH 55/66] Adding word wrap vocab --- extra/wrap/wrap.factor | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) create mode 100644 extra/wrap/wrap.factor diff --git a/extra/wrap/wrap.factor b/extra/wrap/wrap.factor new file mode 100644 index 0000000000..4392ac81a6 --- /dev/null +++ b/extra/wrap/wrap.factor @@ -0,0 +1,30 @@ +USING: sequences kernel namespaces splitting math ; +IN: wrap + +! Very stupid word wrapping/line breaking +! This will be replaced by a Unicode-aware method, +! which works with variable-width fonts + +SYMBOL: width + +: line-chunks ( string -- words-lines ) + "\n" split [ " \t" split [ empty? not ] subset ] map ; + +: (split-chunk) ( words -- ) + -1 over [ length + 1+ dup width get > ] find drop nip + [ cut-slice swap , (split-chunk) ] [ , ] if* ; + +: split-chunk ( words -- lines ) + [ (split-chunk) ] { } make ; + +: broken-lines ( string width -- lines ) + width [ + line-chunks + [ split-chunk [ " " join ] map ] map concat + ] with-variable ; + +: line-break ( string width -- newstring ) + broken-lines "\n" join ; + +: indented-break ( string width indent -- newstring ) + [ length - broken-lines ] keep [ swap append ] curry map "\n" join ; From 92ebcc36199eba0f51fe08445110a72d7812b5fe Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 12:27:37 -0600 Subject: [PATCH 56/66] New timeout implementation --- extra/io/nonblocking/nonblocking.factor | 11 +++++++--- extra/io/unix/backend/backend.factor | 14 +++++++----- extra/io/unix/sockets/sockets.factor | 9 ++++---- extra/io/windows/ce/sockets/sockets.factor | 25 +++++++++++----------- extra/io/windows/nt/files/files.factor | 11 +++------- extra/io/windows/nt/monitor/monitor.factor | 7 ++++-- extra/io/windows/nt/sockets/sockets.factor | 19 ++++++++-------- 7 files changed, 53 insertions(+), 43 deletions(-) diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index ca50d7063a..3588ea5d14 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -77,7 +77,7 @@ M: object expire-port drop ; [ pop-back expire-port expire-timeouts ] [ drop ] if ] if ; -: touch-port ( port -- ) +: begin-timeout ( port -- ) dup port-timeout dup zero? [ 2drop ] [ @@ -85,8 +85,13 @@ M: object expire-port drop ; dup unqueue-timeout queue-timeout ] if ; -M: port set-timeout - [ set-port-timeout ] keep touch-port ; +: end-timeout ( port -- ) + unqueue-timeout ; + +: with-port-timeout ( port quot -- ) + over begin-timeout keep end-timeout ; inline + +M: port set-timeout set-port-timeout ; GENERIC: (wait-to-read) ( port -- ) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 6da26b5b67..141b115ebe 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -57,7 +57,11 @@ GENERIC: wait-for-events ( ms mx -- ) M: mx register-io-task ( task mx -- ) 2dup check-io-task fd/container set-at ; -: add-io-task ( task -- ) mx get-global register-io-task ; +: add-io-task ( task -- ) + mx get-global register-io-task stop ; + +: with-port-continuation ( port quot -- port ) + [ callcc0 ] curry with-port-timeout ; inline M: mx unregister-io-task ( task mx -- ) fd/container delete-at drop ; @@ -98,7 +102,6 @@ M: integer close-handle ( fd -- ) io-task-callbacks [ schedule-thread ] each ; : handle-io-task ( mx task -- ) - dup io-task-port touch-port dup do-io-task [ pop-callbacks ] [ 2drop ] if ; : handle-timeout ( mx task -- ) @@ -133,7 +136,8 @@ M: read-task do-io-task [ [ reader-eof ] [ drop ] if ] keep ; M: input-port (wait-to-read) - [ add-io-task stop ] callcc0 pending-error ; + [ add-io-task ] with-port-continuation + pending-error ; ! Writers : write-step ( port -- ? ) @@ -151,11 +155,11 @@ M: write-task do-io-task : add-write-io-task ( port continuation -- ) over port-handle mx get-global mx-writes at* - [ io-task-callbacks push drop ] + [ io-task-callbacks push stop ] [ drop add-io-task ] if ; : (wait-to-write) ( port -- ) - [ add-write-io-task stop ] callcc0 drop ; + [ add-write-io-task ] with-port-continuation drop ; M: port port-flush ( port -- ) dup buffer-empty? [ drop ] [ (wait-to-write) ] if ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 748dbc40a7..59a9a8ac2e 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -40,7 +40,7 @@ M: connect-task do-io-task 0 < [ defer-error ] [ drop t ] if ; : wait-to-connect ( port -- ) - [ add-io-task stop ] callcc0 drop ; + [ add-io-task ] with-port-continuation drop ; M: unix-io (client) ( addrspec -- stream ) dup make-sockaddr/size >r >r @@ -82,7 +82,7 @@ M: accept-task do-io-task over 0 >= [ do-accept t ] [ 2drop defer-error ] if ; : wait-to-accept ( server -- ) - [ add-io-task stop ] callcc0 drop ; + [ add-io-task ] with-port-continuation drop ; USE: io.sockets @@ -147,7 +147,7 @@ M: receive-task do-io-task ] if ; : wait-receive ( stream -- ) - [ add-io-task stop ] callcc0 drop ; + [ add-io-task ] with-port-continuation drop ; M: unix-io receive ( datagram -- packet addrspec ) dup check-datagram-port @@ -178,7 +178,8 @@ M: send-task do-io-task swap 0 < [ io-task-port defer-error ] [ drop t ] if ; : wait-send ( packet sockaddr len stream -- ) - [ add-io-task stop ] callcc0 2drop 2drop ; + [ add-io-task ] with-port-continuation + 2drop 2drop ; M: unix-io send ( packet addrspec datagram -- ) 3dup check-datagram-send diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor index 5f87088804..9114dceb75 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -42,19 +42,20 @@ M: windows-ce-io ( addrspec -- duplex-stream ) ] keep ; M: windows-ce-io accept ( server -- client ) - dup check-server-port [ - dup touch-port - dup port-handle win32-file-handle - swap server-port-addr sockaddr-type heap-size - dup [ - swap f 0 - windows.winsock:WSAAccept - dup windows.winsock:INVALID_SOCKET = - [ windows.winsock:winsock-error ] when - ] keep - ] keep server-port-addr parse-sockaddr swap - dup handle>duplex-stream ; + dup check-server-port + [ + dup port-handle win32-file-handle + swap server-port-addr sockaddr-type heap-size + dup [ + swap f 0 + windows.winsock:WSAAccept + dup windows.winsock:INVALID_SOCKET = + [ windows.winsock:winsock-error ] when + ] keep + ] keep server-port-addr parse-sockaddr swap + dup handle>duplex-stream + ] with-port-timeout ; M: windows-ce-io ( addrspec -- datagram ) [ diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 06edd8b3ee..4a304e5ac9 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -24,7 +24,6 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped ) swap buffer-consume ; : (flush-output) ( port -- ) - dup touch-port dup make-FileArgs tuck setup-write WriteFile dupd overlapped-error? [ @@ -37,7 +36,7 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped ) ] if ; : flush-output ( port -- ) - [ (flush-output) ] with-destructors ; + [ [ (flush-output) ] with-port-timeout ] with-destructors ; M: port port-flush dup buffer-empty? [ dup flush-output ] unless drop ; @@ -52,17 +51,13 @@ M: port port-flush ] if ; : ((wait-to-read)) ( port -- ) - dup touch-port dup make-FileArgs tuck setup-read ReadFile dupd overlapped-error? [ >r FileArgs-lpOverlapped r> [ save-callback ] 2keep finish-read - ] [ - 2drop - ] if ; + ] [ 2drop ] if ; M: input-port (wait-to-read) ( port -- ) - [ ((wait-to-read)) ] with-destructors ; - + [ [ ((wait-to-read)) ] with-port-timeout ] with-destructors ; diff --git a/extra/io/windows/nt/monitor/monitor.factor b/extra/io/windows/nt/monitor/monitor.factor index f296e859f0..a7c065b878 100755 --- a/extra/io/windows/nt/monitor/monitor.factor +++ b/extra/io/windows/nt/monitor/monitor.factor @@ -46,8 +46,11 @@ M: windows-nt-io ( path recursive? -- monitor ) : read-changes ( monitor -- bytes ) [ - dup begin-reading-changes swap [ save-callback ] 2keep - get-overlapped-result + [ + dup begin-reading-changes + swap [ save-callback ] 2keep + get-overlapped-result + ] with-port-timeout ] with-destructors ; : parse-action-flag ( action mask symbol -- action ) diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 6c7db33ee3..b9ce5aad4c 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -129,15 +129,16 @@ TUPLE: AcceptEx-args port M: windows-nt-io accept ( server -- client ) [ - dup check-server-port - dup touch-port - \ AcceptEx-args construct-empty - [ init-accept ] keep - [ (accept) ] keep - [ accept-continuation ] keep - AcceptEx-args-port pending-error - dup duplex-stream-in pending-error - dup duplex-stream-out pending-error + [ + dup check-server-port + \ AcceptEx-args construct-empty + [ init-accept ] keep + [ (accept) ] keep + [ accept-continuation ] keep + AcceptEx-args-port pending-error + dup duplex-stream-in pending-error + dup duplex-stream-out pending-error + ] with-port-timeout ] with-destructors ; M: windows-nt-io ( addrspec -- server ) From 6530057512f2b7306fb8dc38d1e84e8f4ea35f29 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 20:11:46 -0600 Subject: [PATCH 57/66] Starting work on record1 strings --- core/alien/alien.factor | 15 ++---- core/bit-arrays/bit-arrays.factor | 4 +- core/bootstrap/image/image.factor | 1 + core/bootstrap/primitives.factor | 58 +++++++++++++----------- core/byte-arrays/byte-arrays.factor | 6 +-- core/compiler/constants/constants.factor | 2 +- core/float-arrays/float-arrays.factor | 4 +- core/strings/strings.factor | 14 ++++-- vm/debug.c | 2 +- vm/layouts.h | 2 + vm/types.c | 9 ++-- 11 files changed, 61 insertions(+), 56 deletions(-) diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 1c8163e2fa..317dac803e 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel math namespaces sequences system -kernel.private tuples ; +kernel.private tuples bit-arrays byte-arrays float-arrays ; IN: alien ! Some predicate classes used by the compiler for optimization @@ -9,16 +9,11 @@ IN: alien PREDICATE: alien simple-alien underlying-alien not ; -! These mixins are not intended to be extended by user code. -! They are not unions, because if they were we'd have a circular -! dependency between alien and {byte,bit,float}-arrays. -MIXIN: simple-c-ptr -INSTANCE: simple-alien simple-c-ptr -INSTANCE: f simple-c-ptr +UNION: simple-c-ptr +simple-alien POSTPONE: f byte-array bit-array float-array ; -MIXIN: c-ptr -INSTANCE: alien c-ptr -INSTANCE: f c-ptr +UNION: c-ptr +alien POSTPONE: f byte-array bit-array float-array ; DEFER: pinned-c-ptr? diff --git a/core/bit-arrays/bit-arrays.factor b/core/bit-arrays/bit-arrays.factor index 4c68d94aad..ee485d399e 100755 --- a/core/bit-arrays/bit-arrays.factor +++ b/core/bit-arrays/bit-arrays.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math alien kernel kernel.private sequences +USING: math alien.accessors kernel kernel.private sequences sequences.private ; IN: bit-arrays @@ -52,5 +52,3 @@ M: bit-array resize resize-bit-array ; INSTANCE: bit-array sequence -INSTANCE: bit-array simple-c-ptr -INSTANCE: bit-array c-ptr diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index f7e0d483f6..c3bf18cffc 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -259,6 +259,7 @@ M: wrapper ' string type-number object tag-number [ dup length emit-fixnum f ' emit + f ' emit pack-string emit-chars ] emit-object ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 4c5246e0eb..defbac6720 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -40,6 +40,7 @@ call ! classes will go { "alien" + "alien.accessors" "arrays" "bit-arrays" "bit-vectors" @@ -190,6 +191,11 @@ num-types get f builtins set "length" { "length" "sequences" } f + } { + { "object" "kernel" } + "aux" + { "string-aux" "strings.private" } + { "set-string-aux" "strings.private" } } } define-builtin @@ -556,32 +562,32 @@ builtins get num-tags get tail f union-class define-class { "" "byte-arrays" } { "" "bit-arrays" } { "" "alien" } - { "alien-signed-cell" "alien" } - { "set-alien-signed-cell" "alien" } - { "alien-unsigned-cell" "alien" } - { "set-alien-unsigned-cell" "alien" } - { "alien-signed-8" "alien" } - { "set-alien-signed-8" "alien" } - { "alien-unsigned-8" "alien" } - { "set-alien-unsigned-8" "alien" } - { "alien-signed-4" "alien" } - { "set-alien-signed-4" "alien" } - { "alien-unsigned-4" "alien" } - { "set-alien-unsigned-4" "alien" } - { "alien-signed-2" "alien" } - { "set-alien-signed-2" "alien" } - { "alien-unsigned-2" "alien" } - { "set-alien-unsigned-2" "alien" } - { "alien-signed-1" "alien" } - { "set-alien-signed-1" "alien" } - { "alien-unsigned-1" "alien" } - { "set-alien-unsigned-1" "alien" } - { "alien-float" "alien" } - { "set-alien-float" "alien" } - { "alien-double" "alien" } - { "set-alien-double" "alien" } - { "alien-cell" "alien" } - { "set-alien-cell" "alien" } + { "alien-signed-cell" "alien.accessors" } + { "set-alien-signed-cell" "alien.accessors" } + { "alien-unsigned-cell" "alien.accessors" } + { "set-alien-unsigned-cell" "alien.accessors" } + { "alien-signed-8" "alien.accessors" } + { "set-alien-signed-8" "alien.accessors" } + { "alien-unsigned-8" "alien.accessors" } + { "set-alien-unsigned-8" "alien.accessors" } + { "alien-signed-4" "alien.accessors" } + { "set-alien-signed-4" "alien.accessors" } + { "alien-unsigned-4" "alien.accessors" } + { "set-alien-unsigned-4" "alien.accessors" } + { "alien-signed-2" "alien.accessors" } + { "set-alien-signed-2" "alien.accessors" } + { "alien-unsigned-2" "alien.accessors" } + { "set-alien-unsigned-2" "alien.accessors" } + { "alien-signed-1" "alien.accessors" } + { "set-alien-signed-1" "alien.accessors" } + { "alien-unsigned-1" "alien.accessors" } + { "set-alien-unsigned-1" "alien.accessors" } + { "alien-float" "alien.accessors" } + { "set-alien-float" "alien.accessors" } + { "alien-double" "alien.accessors" } + { "set-alien-double" "alien.accessors" } + { "alien-cell" "alien.accessors" } + { "set-alien-cell" "alien.accessors" } { "alien>char-string" "alien" } { "string>char-alien" "alien" } { "alien>u16-string" "alien" } diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index 401b151ad0..548c293e7c 100755 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private alien sequences sequences.private -math ; +USING: kernel kernel.private alien.accessors sequences +sequences.private math ; IN: byte-arrays M: byte-array clone (clone) ; @@ -19,5 +19,3 @@ M: byte-array resize resize-byte-array ; INSTANCE: byte-array sequence -INSTANCE: byte-array simple-c-ptr -INSTANCE: byte-array c-ptr diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor index 66fc8d5789..277a64225a 100755 --- a/core/compiler/constants/constants.factor +++ b/core/compiler/constants/constants.factor @@ -10,7 +10,7 @@ IN: compiler.constants ! These constants must match vm/layouts.h : header-offset object tag-number neg ; : float-offset 8 float tag-number - ; -: string-offset 3 bootstrap-cells object tag-number - ; +: string-offset 4 bootstrap-cells object tag-number - ; : profile-count-offset 7 bootstrap-cells object tag-number - ; : byte-array-offset 2 bootstrap-cells object tag-number - ; : alien-offset 3 bootstrap-cells object tag-number - ; diff --git a/core/float-arrays/float-arrays.factor b/core/float-arrays/float-arrays.factor index 445edd550a..33302572de 100755 --- a/core/float-arrays/float-arrays.factor +++ b/core/float-arrays/float-arrays.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private alien sequences +USING: kernel kernel.private alien.accessors sequences sequences.private math math.private ; IN: float-arrays @@ -33,8 +33,6 @@ M: float-array resize resize-float-array ; INSTANCE: float-array sequence -INSTANCE: float-array simple-c-ptr -INSTANCE: float-array c-ptr : 1float-array ( x -- array ) 1 swap ; flushable diff --git a/core/strings/strings.factor b/core/strings/strings.factor index 10f38f8298..33efed11e8 100755 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -1,14 +1,20 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math.private sequences kernel.private -math sequences.private slots.private ; +math sequences.private slots.private byte-arrays +alien.accessors ; IN: strings dup rot set-string-aux ] ?if + { byte-array } declare ; inline -: set-string-hashcode 2 set-slot ; inline +: string-hashcode 3 slot ; inline + +: set-string-hashcode 3 set-slot ; inline : reset-string-hashcode f swap set-string-hashcode ; inline diff --git a/vm/debug.c b/vm/debug.c index 2692bdf59c..5b4320b5e9 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -4,7 +4,7 @@ void print_chars(F_STRING* str) { CELL i; for(i = 0; i < string_capacity(str); i++) - putchar(cget(SREF(str,i))); + putchar(string_nth(str,i)); } void print_word(F_WORD* word, CELL nesting) diff --git a/vm/layouts.h b/vm/layouts.h index 07e22cfed0..2b8957ee66 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -106,6 +106,8 @@ typedef struct { /* tagged num of chars */ CELL length; /* tagged */ + CELL aux; + /* tagged */ CELL hashcode; } F_STRING; diff --git a/vm/types.c b/vm/types.c index 27a5b55e2b..d5e8d76abb 100755 --- a/vm/types.c +++ b/vm/types.c @@ -429,10 +429,11 @@ F_STRING* allot_string_internal(CELL capacity) /* strings are null-terminated in memory, even though they also have a length field. The null termination allows us to add the sizeof(F_STRING) to a Factor string to get a C-style - UCS-2 string for C library calls. */ - cput(SREF(string,capacity),(u16)'\0'); + char* string for C library calls. */ + set_string_nth(string,capacity,0); string->length = tag_fixnum(capacity); string->hashcode = F; + string->aux = F; return string; } @@ -446,7 +447,7 @@ void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) CELL i; for(i = start; i < capacity; i++) - cput(SREF(string,i),fill); + set_string_nth(string,i,fill); } } @@ -499,7 +500,7 @@ DEFINE_PRIMITIVE(resize_string) CELL i; \ for(i = 0; i < length; i++) \ { \ - cput(SREF(s,i),(utype)*string); \ + set_string_nth(s,i,(utype)*string); \ string++; \ } \ return s; \ From 9d339e467748b5012366ee5920b505be1bd29315 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 31 Jan 2008 22:41:06 -0600 Subject: [PATCH 58/66] concurrency-docs fix --- extra/concurrency/concurrency-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor index e1377f5265..f481647e1e 100644 --- a/extra/concurrency/concurrency-docs.factor +++ b/extra/concurrency/concurrency-docs.factor @@ -150,7 +150,7 @@ ARTICLE: { "concurrency" "exceptions" } "Exceptions" "Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ; ARTICLE: { "concurrency" "futures" } "Futures" -"A future is a placeholder for the result of a computation that is being calculated in a process. When the process has completed the computation the future can be queried to find out the result. If the computation has not completed when the future is queried them the process will block until the result is completed.

A future is created using " { $link future } ".\n\nThe quotation will be run in a spawned process, and a future object is immediately returned. This future object can be resolved using " { $link ?future } ".\n\nFutures are useful for starting calculations that take a long time to run but aren't needed until later in the process. When the process needs the value it can use '?future' to get the result or block until the result is available. For example:" +"A future is a placeholder for the result of a computation that is being calculated in a process. When the process has completed the computation the future can be queried to find out the result. If the computation has not completed when the future is queried them the process will block until the result is completed. A future is created using " { $link future } ".\n\nThe quotation will be run in a spawned process, and a future object is immediately returned. This future object can be resolved using " { $link ?future } ".\n\nFutures are useful for starting calculations that take a long time to run but aren't needed until later in the process. When the process needs the value it can use '?future' to get the result or block until the result is available. For example:" { $code "[ 30 fib ] future\n...do stuff...\n?future" } ; ARTICLE: { "concurrency" "promises" } "Promises" From ee533db516ad79b85706f587847f561a7ae14662 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 31 Jan 2008 22:43:26 -0600 Subject: [PATCH 59/66] concurrency-docs fix 2 --- extra/concurrency/concurrency-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor index f481647e1e..7e76ff242a 100644 --- a/extra/concurrency/concurrency-docs.factor +++ b/extra/concurrency/concurrency-docs.factor @@ -127,7 +127,7 @@ ARTICLE: { "concurrency" "processes" } "Processes" { $code ": odd? ( n -- ? ) 2 mod 1 = ;\n1 self send 2 self send 3 self send\n\nreceive .\n => 1\n\n[ odd? ] receive-if .\n => 3\n\nreceive .\n => 2" } ; ARTICLE: { "concurrency" "self" } "Self" -"A process can get access to its own process object using " { $link self } " so it can pass it to other processes. This allows the other processes to send messages back. A simple example of using this gets the current processes 'self' and spawns a process which sends a message to it. We then receive the message from the original process:" +"A process can get access to its own process object using " { $link self } " so it can pass it to other processes. This allows the other processes to send messages back. A simple example of using this gets the current process' 'self' and spawns a process which sends a message to it. We then receive the message from the original process:" { $code "self [ \"Hello!\" swap send ] spawn 2drop receive .\n => \"Hello!\"" } ; ARTICLE: { "concurrency" "servers" } "Servers" From 2ef76798b07e595ac05d281c6592575c0570068d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 23:00:08 -0600 Subject: [PATCH 60/66] record1 strings --- core/alien/alien-docs.factor | 3 +- core/alien/alien-tests.factor | 6 +- core/alien/c-types/c-types.factor | 2 +- core/ascii/ascii-docs.factor | 51 ++++++++++++ core/ascii/ascii.factor | 27 +++++++ core/ascii/authors.txt | 1 + core/ascii/summary.txt | 1 + core/ascii/tags.txt | 1 + core/bootstrap/image/image.factor | 11 +-- core/bootstrap/primitives.factor | 4 +- core/bootstrap/stage2.factor | 2 +- core/compiler/test/intrinsics.factor | 26 +++--- core/compiler/test/redefine.factor | 2 +- core/compiler/test/templates.factor | 4 +- core/cpu/ppc/intrinsics/intrinsics.factor | 24 ------ core/cpu/x86/intrinsics/intrinsics.factor | 37 ++------- core/cpu/x86/sse2/sse2.factor | 10 +-- core/growable/growable-docs.factor | 4 +- core/inference/known-words/known-words.factor | 29 +++---- core/math/parser/parser.factor | 34 ++++++-- core/optimizer/math/math.factor | 10 +-- core/parser/parser.factor | 3 +- core/prettyprint/backend/backend.factor | 2 +- core/sbufs/sbufs.factor | 2 +- core/sbufs/tags.txt | 1 + core/strings/strings-docs.factor | 79 ++++--------------- core/strings/strings-tests.factor | 26 +++++- core/strings/strings.factor | 39 +-------- core/strings/tags.txt | 1 + core/syntax/tags.txt | 0 extra/io/buffers/buffers.factor | 4 +- extra/io/mmap/mmap.factor | 4 +- extra/io/windows/nt/sockets/sockets.factor | 9 ++- extra/ui/freetype/freetype.factor | 4 +- 34 files changed, 227 insertions(+), 236 deletions(-) mode change 100644 => 100755 core/alien/alien-tests.factor create mode 100755 core/ascii/ascii-docs.factor create mode 100755 core/ascii/ascii.factor create mode 100755 core/ascii/authors.txt create mode 100755 core/ascii/summary.txt create mode 100755 core/ascii/tags.txt mode change 100644 => 100755 core/cpu/x86/sse2/sse2.factor mode change 100644 => 100755 core/growable/growable-docs.factor mode change 100644 => 100755 core/math/parser/parser.factor mode change 100644 => 100755 core/parser/parser.factor mode change 100644 => 100755 core/strings/strings-tests.factor create mode 100755 core/syntax/tags.txt diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 8fee0e8c3e..19ee52b039 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -1,6 +1,7 @@ USING: byte-arrays arrays help.syntax help.markup alien.syntax compiler definitions math libc -debugger parser io io.backend system bit-arrays float-arrays ; +debugger parser io io.backend system bit-arrays float-arrays +alien.accessors ; IN: alien HELP: alien diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor old mode 100644 new mode 100755 index aedad25906..d5133753c1 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -1,7 +1,7 @@ IN: temporary -USING: alien byte-arrays -arrays kernel kernel.private namespaces tools.test sequences -libc math system prettyprint ; +USING: alien alien.accessors byte-arrays arrays kernel +kernel.private namespaces tools.test sequences libc math system +prettyprint ; [ t ] [ -1 alien-address 0 > ] unit-test diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 1ecfa37ee6..88df823e5b 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -3,7 +3,7 @@ USING: byte-arrays arrays generator.registers assocs kernel kernel.private libc math namespaces parser sequences strings words assocs splitting math.parser cpu.architecture -alien quotations system compiler.units ; +alien alien.accessors quotations system compiler.units ; IN: alien.c-types TUPLE: c-type diff --git a/core/ascii/ascii-docs.factor b/core/ascii/ascii-docs.factor new file mode 100755 index 0000000000..1f7a56bed9 --- /dev/null +++ b/core/ascii/ascii-docs.factor @@ -0,0 +1,51 @@ +USING: help.markup help.syntax ; +IN: ascii + +HELP: blank? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for an ASCII whitespace character." } ; + +HELP: letter? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for a lowercase alphabet ASCII character." } ; + +HELP: LETTER? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for a uppercase alphabet ASCII character." } ; + +HELP: digit? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for an ASCII decimal digit character." } ; + +HELP: Letter? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for an ASCII alphabet character, both upper and lower case." } ; + +HELP: alpha? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for an alphanumeric ASCII character." } ; + +HELP: printable? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for a printable ASCII character." } ; + +HELP: control? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for an ASCII control character." } ; + +HELP: quotable? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ; + +ARTICLE: "ascii" "ASCII character classes" +"Traditional ASCII character classes:" +{ $subsection blank? } +{ $subsection letter? } +{ $subsection LETTER? } +{ $subsection digit? } +{ $subsection printable? } +{ $subsection control? } +{ $subsection quotable? } +"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode" } ")." ; + +ABOUT: "ascii" diff --git a/core/ascii/ascii.factor b/core/ascii/ascii.factor new file mode 100755 index 0000000000..eeb6b2d480 --- /dev/null +++ b/core/ascii/ascii.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2005, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: sequences math kernel ; +IN: ascii + +: blank? ( ch -- ? ) " \t\n\r" member? ; inline + +: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline + +: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline + +: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline + +: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline + +: control? ( ch -- ? ) "\0\e\r\n\t\u0008\u007f" member? ; inline + +: quotable? ( ch -- ? ) + dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline + +: Letter? ( ch -- ? ) + dup letter? [ drop t ] [ LETTER? ] if ; inline + +: alpha? ( ch -- ? ) + dup Letter? [ drop t ] [ digit? ] if ; inline + + diff --git a/core/ascii/authors.txt b/core/ascii/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/ascii/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/ascii/summary.txt b/core/ascii/summary.txt new file mode 100755 index 0000000000..ae2ea69b8b --- /dev/null +++ b/core/ascii/summary.txt @@ -0,0 +1 @@ +ASCII character classes diff --git a/core/ascii/tags.txt b/core/ascii/tags.txt new file mode 100755 index 0000000000..8e27be7d61 --- /dev/null +++ b/core/ascii/tags.txt @@ -0,0 +1 @@ +text diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index c3bf18cffc..e9ee569fd6 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -17,8 +17,6 @@ IN: bootstrap.image : image-magic HEX: 0f0e0d0c ; inline : image-version 4 ; inline -: char bootstrap-cell 2/ ; inline - : data-base 1024 ; inline : userenv-size 40 ; inline @@ -244,16 +242,13 @@ M: wrapper ' [ emit ] emit-object ; ! Strings -: 16be> 0 [ swap 16 shift bitor ] reduce ; -: 16le> 16be> ; - : emit-chars ( seq -- ) - char - big-endian get [ [ 16be> ] map ] [ [ 16le> ] map ] if + bootstrap-cell + big-endian get [ [ be> ] map ] [ [ le> ] map ] if emit-seq ; : pack-string ( string -- newstr ) - dup length 1+ char align 0 pad-right ; + dup length 1+ bootstrap-cell align 0 pad-right ; : emit-string ( string -- ptr ) string type-number object tag-number [ diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index defbac6720..fef93e163f 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -596,8 +596,8 @@ builtins get num-tags get tail f union-class define-class { "alien-address" "alien" } { "slot" "slots.private" } { "set-slot" "slots.private" } - { "char-slot" "strings.private" } - { "set-char-slot" "strings.private" } + { "string-nth" "strings.private" } + { "set-string-nth" "strings.private" } { "resize-array" "arrays" } { "resize-string" "strings" } { "" "arrays" } diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 8fc3435ffa..5a5a8d1c67 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -12,7 +12,7 @@ IN: bootstrap.stage2 ! you can see what went wrong, instead of dealing with a ! fep [ - vm file-name windows? [ >lower ".exe" ?tail drop ] when + vm file-name windows? [ "." split1 drop ] when ".image" append "output-image" set-global "math tools help compiler ui ui.tools io" "include" set-global diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor index 075961047f..1d0ad141c2 100755 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -1,10 +1,10 @@ IN: temporary -USING: arrays compiler kernel kernel.private math -math.constants math.private sequences strings tools.test words -continuations sequences.private hashtables.private byte-arrays -strings.private system random layouts vectors.private -sbufs.private strings.private slots.private alien alien.c-types -alien.syntax namespaces libc combinators.private ; +USING: arrays compiler kernel kernel.private math math.constants +math.private sequences strings tools.test words continuations +sequences.private hashtables.private byte-arrays strings.private +system random layouts vectors.private sbufs.private +strings.private slots.private alien alien.accessors +alien.c-types alien.syntax namespaces libc combinators.private ; ! Make sure that intrinsic ops compile to correct code. [ ] [ 1 [ drop ] compile-call ] unit-test @@ -36,13 +36,13 @@ alien.syntax namespaces libc combinators.private ; ! Write barrier hits on the wrong value were causing segfaults [ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test -[ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test -[ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test -[ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test - -[ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test -[ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test -[ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test +! [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test +! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test +! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test +! +! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test +! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test +! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test [ ] [ [ 0 getenv ] compile-call drop ] unit-test [ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index c1561f38d4..01dd27f8be 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -249,4 +249,4 @@ DEFER: defer-redefine-test-2 [ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test -[ 1 ] [ defer-redefine-test-2 ] unit-test +[ 2 1 ] [ defer-redefine-test-2 ] unit-test diff --git a/core/compiler/test/templates.factor b/core/compiler/test/templates.factor index 78f57efb43..08e1c98729 100755 --- a/core/compiler/test/templates.factor +++ b/core/compiler/test/templates.factor @@ -2,8 +2,8 @@ USING: arrays compiler kernel kernel.private math hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private -combinators.private byte-arrays alien layouts words definitions -compiler.units ; +combinators.private byte-arrays alien alien.accessors layouts +words definitions compiler.units ; IN: temporary ! Oops! diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index c73cd149a4..693bcdb5e4 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -93,30 +93,6 @@ IN: cpu.ppc.intrinsics } } define-intrinsics -: (%char-slot) - "offset" operand "n" operand 2 SRAWI - "offset" operand dup "obj" operand ADD ; - -\ char-slot [ - (%char-slot) - "out" operand "offset" operand string-offset LHZ - "out" operand dup %tag-fixnum -] H{ - { +input+ { { f "n" } { f "obj" } } } - { +scratch+ { { f "out" } { f "offset" } } } - { +output+ { "out" } } -} define-intrinsic - -\ set-char-slot [ - (%char-slot) - "val" operand dup %untag-fixnum - "val" operand "offset" operand string-offset STH -] H{ - { +input+ { { f "val" } { f "n" } { f "obj" } } } - { +scratch+ { { f "offset" } } } - { +clobber+ { "val" } } -} define-intrinsic - : fixnum-register-op ( op -- pair ) [ "out" operand "y" operand "x" operand ] swap add H{ { +input+ { { f "x" } { f "y" } } } diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index 1fc649e128..99a89eab05 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -1,12 +1,13 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays cpu.x86.assembler cpu.x86.allot -cpu.x86.architecture cpu.architecture kernel kernel.private math -math.private namespaces quotations sequences +USING: alien alien.accessors arrays cpu.x86.assembler +cpu.x86.allot cpu.x86.architecture cpu.architecture kernel +kernel.private math math.private namespaces quotations sequences words generic byte-arrays hashtables hashtables.private generator generator.registers generator.fixup sequences.private sbufs sbufs.private vectors vectors.private layouts system -tuples.private strings.private slots.private compiler.constants ; +tuples.private strings.private slots.private compiler.constants +; IN: cpu.x86.intrinsics ! Type checks @@ -153,34 +154,6 @@ IN: cpu.x86.intrinsics : small-reg-16 BX ; inline : small-reg-32 EBX ; inline -\ char-slot [ - small-reg PUSH - "n" operand 2 SHR - small-reg dup XOR - "obj" operand "n" operand ADD - small-reg-16 "obj" operand string-offset [+] MOV - small-reg %tag-fixnum - "obj" operand small-reg MOV - small-reg POP -] H{ - { +input+ { { f "n" } { f "obj" } } } - { +output+ { "obj" } } - { +clobber+ { "obj" "n" } } -} define-intrinsic - -\ set-char-slot [ - small-reg PUSH - "val" operand %untag-fixnum - "slot" operand 2 SHR - "obj" operand "slot" operand ADD - small-reg "val" operand MOV - "obj" operand string-offset [+] small-reg-16 MOV - small-reg POP -] H{ - { +input+ { { f "val" } { f "slot" } { f "obj" } } } - { +clobber+ { "val" "slot" "obj" } } -} define-intrinsic - ! Fixnums : fixnum-op ( op hash -- pair ) >r [ "x" operand "y" operand ] swap add r> 2array ; diff --git a/core/cpu/x86/sse2/sse2.factor b/core/cpu/x86/sse2/sse2.factor old mode 100644 new mode 100755 index cb8c87ed8d..98e42fa7fe --- a/core/cpu/x86/sse2/sse2.factor +++ b/core/cpu/x86/sse2/sse2.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays cpu.x86.assembler cpu.x86.architecture -cpu.x86.intrinsics generic kernel kernel.private math -math.private memory namespaces sequences words generator -generator.registers cpu.architecture math.floats.private layouts -quotations ; +USING: alien alien.accessors arrays cpu.x86.assembler +cpu.x86.architecture cpu.x86.intrinsics generic kernel +kernel.private math math.private memory namespaces sequences +words generator generator.registers cpu.architecture +math.floats.private layouts quotations ; IN: cpu.x86.sse2 : define-float-op ( word op -- ) diff --git a/core/growable/growable-docs.factor b/core/growable/growable-docs.factor old mode 100644 new mode 100755 index 0311397a43..02f6292001 --- a/core/growable/growable-docs.factor +++ b/core/growable/growable-docs.factor @@ -21,7 +21,7 @@ HELP: set-fill { $values { "n" "a new fill pointer" } { "seq" "a resizable sequence" } } { $contract "Sets the fill pointer (number of occupied elements in the underlying storage) of a resizable sequence." } { $side-effects "seq" } -{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ; +{ $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ; HELP: underlying { $values { "seq" "a resizable sequence" } { "underlying" "the underlying sequence" } } @@ -30,7 +30,7 @@ HELP: underlying HELP: set-underlying { $values { "underlying" "a sequence" } { "seq" "a resizable sequence" } } { $contract "Modifies the underlying storage of a resizable sequence." } -{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ; +{ $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ; HELP: capacity { $values { "seq" "a vector or string buffer" } { "n" "the capacity of the sequence" } } diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 9a826d8e9b..6be3899acd 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -1,15 +1,16 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays bit-arrays byte-arrays classes -combinators.private continuations.private effects float-arrays -generic hashtables hashtables.private inference.state -inference.backend inference.dataflow io io.backend io.files -io.files.private io.streams.c kernel kernel.private math -math.private memory namespaces namespaces.private parser -prettyprint quotations quotations.private sbufs sbufs.private -sequences sequences.private slots.private strings -strings.private system threads.private tuples tuples.private -vectors vectors.private words words.private assocs inspector ; +USING: alien alien.accessors arrays bit-arrays byte-arrays +classes combinators.private continuations.private effects +float-arrays generic hashtables hashtables.private +inference.state inference.backend inference.dataflow io +io.backend io.files io.files.private io.streams.c kernel +kernel.private math math.private memory namespaces +namespaces.private parser prettyprint quotations +quotations.private sbufs sbufs.private sequences +sequences.private slots.private strings strings.private system +threads.private tuples tuples.private vectors vectors.private +words words.private assocs inspector ; IN: inference.known-words ! Shuffle words @@ -480,10 +481,10 @@ t over set-effect-terminated? \ set-slot { object object fixnum } { } "inferred-effect" set-word-prop -\ char-slot { fixnum object } { fixnum } "inferred-effect" set-word-prop -\ char-slot make-flushable +\ string-nth { fixnum string } { fixnum } "inferred-effect" set-word-prop +\ string-nth make-flushable -\ set-char-slot { fixnum fixnum object } { } "inferred-effect" set-word-prop +\ set-string-nth { fixnum fixnum string } { } "inferred-effect" set-word-prop \ resize-array { integer array } { array } "inferred-effect" set-word-prop \ resize-array make-flushable diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor old mode 100644 new mode 100755 index 28cecc033f..7f0404812d --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math.private namespaces sequences strings arrays -combinators splitting math ; +combinators splitting math assocs ; IN: math.parser DEFER: base> @@ -11,12 +11,30 @@ DEFER: base> 2dup and [ / ] [ 2drop f ] if ; : digit> ( ch -- n ) - { - { [ dup digit? ] [ CHAR: 0 - ] } - { [ dup letter? ] [ CHAR: a - 10 + ] } - { [ dup LETTER? ] [ CHAR: A - 10 + ] } - { [ t ] [ drop f ] } - } cond ; + H{ + { CHAR: 0 0 } + { CHAR: 1 1 } + { CHAR: 2 2 } + { CHAR: 3 3 } + { CHAR: 4 4 } + { CHAR: 5 5 } + { CHAR: 6 6 } + { CHAR: 7 7 } + { CHAR: 8 8 } + { CHAR: 9 9 } + { CHAR: A 10 } + { CHAR: B 11 } + { CHAR: C 12 } + { CHAR: D 13 } + { CHAR: E 14 } + { CHAR: F 15 } + { CHAR: a 10 } + { CHAR: b 11 } + { CHAR: c 12 } + { CHAR: d 13 } + { CHAR: e 14 } + { CHAR: f 15 } + } at ; : digits>integer ( radix seq -- n ) 0 rot [ swapd * + ] curry reduce ; diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index ec3c9c15da..e048e29f48 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: optimizer.math -USING: alien arrays generic hashtables kernel assocs math -math.private kernel.private sequences words parser +USING: alien alien.accessors arrays generic hashtables kernel +assocs math math.private kernel.private sequences words parser inference.class inference.dataflow vectors strings sbufs io namespaces assocs quotations math.intervals sequences.private -combinators splitting layouts math.parser classes -generic.math optimizer.pattern-match optimizer.backend -optimizer.def-use generic.standard system ; +combinators splitting layouts math.parser classes generic.math +optimizer.pattern-match optimizer.backend optimizer.def-use +generic.standard system ; { + bignum+ float+ fixnum+fast } { { { number 0 } [ drop ] } diff --git a/core/parser/parser.factor b/core/parser/parser.factor old mode 100644 new mode 100755 index 31a3ceac03..1a61573bd4 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -5,7 +5,8 @@ namespaces prettyprint sequences strings vectors words quotations inspector io.styles io combinators sorting splitting math.parser effects continuations debugger io.files io.streams.string io.streams.lines vocabs -source-files classes hashtables compiler.errors compiler.units ; +source-files classes hashtables compiler.errors compiler.units +ascii ; IN: parser TUPLE: lexer text line column ; diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index 86ac6cd926..f88ab4ca2a 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -4,7 +4,7 @@ USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors generic hashtables io assocs kernel math namespaces sequences strings sbufs io.styles vectors words prettyprint.config prettyprint.sections quotations io io.files math.parser effects -tuples classes float-arrays float-vectors ; +tuples classes float-arrays float-vectors ascii ; IN: prettyprint.backend GENERIC: pprint* ( obj -- ) diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor index bcc7536e6f..9de57c0801 100755 --- a/core/sbufs/sbufs.factor +++ b/core/sbufs/sbufs.factor @@ -14,7 +14,7 @@ PRIVATE> : ( n -- sbuf ) 0 0 string>sbuf ; inline M: sbuf set-nth-unsafe - underlying >r >r >fixnum r> >fixnum r> set-char-slot ; + underlying >r >r >fixnum r> >fixnum r> set-string-nth ; M: sbuf new drop [ 0 ] keep >fixnum string>sbuf ; diff --git a/core/sbufs/tags.txt b/core/sbufs/tags.txt index 42d711b32b..de2741b09f 100644 --- a/core/sbufs/tags.txt +++ b/core/sbufs/tags.txt @@ -1 +1,2 @@ +text collections diff --git a/core/strings/strings-docs.factor b/core/strings/strings-docs.factor index d42e8cc601..e09c6da0eb 100755 --- a/core/strings/strings-docs.factor +++ b/core/strings/strings-docs.factor @@ -4,7 +4,11 @@ sbufs math ; IN: strings ARTICLE: "strings" "Strings" -"A string is a fixed-size mutable sequence of characters. The literal syntax is covered in " { $link "syntax-strings" } "." +"A string is a fixed-size mutable sequence of Unicode 5.0 code points." +$nl +"Characters are not a first-class type; they are simply represented as integers between 0 and 16777216 (2^24). Only characters up to 2097152 (2^21) have a defined meaning in Unicode." +$nl +"String literal syntax is covered in " { $link "syntax-strings" } "." $nl "String words are found in the " { $vocab-link "strings" } " vocabulary." $nl @@ -16,28 +20,25 @@ $nl { $subsection } "Creating a string from a single character:" { $subsection 1string } -"Characters are not a first-class type; they are simply represented as integers between 0 and 65535. A few words operate on characters:" -{ $subsection blank? } -{ $subsection letter? } -{ $subsection LETTER? } -{ $subsection digit? } -{ $subsection printable? } -{ $subsection control? } -{ $subsection quotable? } -{ $subsection ch>lower } -{ $subsection ch>upper } ; +"Since strings are sequences, basic string manipulation can be performed using sequence operations (" { $link "sequences" } "). More advanced functionality can be found in other vocabularies, including but not limited to:" +{ $list + { { $vocab-link "ascii" } " - traditional ASCII character classes" } + { { $vocab-link "unicode" } " - Unicode 5.0-aware character classes, case conversion, word breaks, ..." } + { { $vocab-link "regexp" } " - regular expressions" } + { { $vocab-link "peg" } " - parser expression grammars" } +} ; ABOUT: "strings" HELP: string { $description "The class of fixed-length character strings. See " { $link "syntax-strings" } " for syntax and " { $link "strings" } " for general information." } ; -HELP: char-slot ( n string -- ch ) +HELP: string-nth ( n string -- ch ) { $values { "n" fixnum } { "string" string } { "ch" "the character at the " { $snippet "n" } "th index" } } { $description "Unsafe string accessor, used to define " { $link nth } " on strings." } { $warning "This word is in the " { $vocab-link "strings.private" } " vocabulary because it does not perform type or bounds checking. User code should call " { $link nth } " instead." } ; -HELP: set-char-slot ( ch n string -- ) +HELP: set-string-nth ( ch n string -- ) { $values { "ch" "a character" } { "n" fixnum } { "string" string } } { $description "Unsafe string mutator, used to define " { $link set-nth } " on strings." } { $warning "This word is in the " { $vocab-link "strings.private" } " vocabulary because it does not perform type or bounds checking. User code should call " { $link set-nth } " instead." } ; @@ -46,58 +47,6 @@ HELP: ( n ch -- string ) { $values { "n" "a positive integer specifying string length" } { "ch" "an initial character" } { "string" string } } { $description "Creates a new string with the given length and all characters initially set to " { $snippet "ch" } "." } ; -HELP: blank? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for an ASCII whitespace character." } ; - -HELP: letter? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for a lowercase alphabet ASCII character." } ; - -HELP: LETTER? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for a uppercase alphabet ASCII character." } ; - -HELP: digit? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for an ASCII decimal digit character." } ; - -HELP: Letter? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for an ASCII alphabet character, both upper and lower case." } ; - -HELP: alpha? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for an alphanumeric ASCII character." } ; - -HELP: printable? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for a printable ASCII character." } ; - -HELP: control? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for an ASCII control character." } ; - -HELP: quotable? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ; - -HELP: ch>lower -{ $values { "ch" "a character" } { "lower" "a character" } } -{ $description "Converts a character to lowercase." } ; - -HELP: ch>upper -{ $values { "ch" "a character" } { "upper" "a character" } } -{ $description "Converts a character to uppercase." } ; - -HELP: >lower -{ $values { "str" string } { "lower" string } } -{ $description "Converts a string to lowercase." } ; - -HELP: >upper -{ $values { "str" string } { "upper" string } } -{ $description "Converts a string to uppercase." } ; - HELP: 1string { $values { "ch" "a character"} { "str" string } } { $description "Outputs a string of one character." } ; diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor old mode 100644 new mode 100755 index 88f6f3e9ca..a3c49a08ba --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -1,5 +1,5 @@ USING: continuations kernel math namespaces strings sbufs -tools.test sequences vectors ; +tools.test sequences vectors arrays ; IN: temporary [ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test @@ -66,3 +66,27 @@ unit-test ! Random tester found this [ { "kernel-error" 3 12 -7 } ] [ [ 2 -7 resize-string ] catch ] unit-test + +"hello world" "s" set + +[ ] [ HEX: 1234 1 "s" get set-nth ] unit-test +[ ] [ HEX: 4321 3 "s" get set-nth ] unit-test +[ ] [ HEX: 654321 5 "s" get set-nth ] unit-test + +[ + { + CHAR: h + HEX: 1234 + CHAR: l + HEX: 4321 + CHAR: o + HEX: 654321 + CHAR: w + CHAR: o + CHAR: r + CHAR: l + CHAR: d + } +] [ + "s" get >array +] unit-test diff --git a/core/strings/strings.factor b/core/strings/strings.factor index 33efed11e8..dc1d12cec9 100755 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -7,11 +7,6 @@ IN: strings dup rot set-string-aux ] ?if - { byte-array } declare ; inline - : string-hashcode 3 slot ; inline : set-string-hashcode 3 set-slot ; inline @@ -35,43 +30,17 @@ M: string hashcode* nip dup string-hashcode [ ] [ dup rehash-string string-hashcode ] ?if ; -M: string nth-unsafe >r >fixnum r> char-slot ; +M: string nth-unsafe + >r >fixnum r> string-nth ; -M: string set-nth-unsafe +M: string set-nth-unsafe dup reset-string-hashcode - >r >fixnum >r >fixnum r> r> set-char-slot ; + >r >fixnum >r >fixnum r> r> set-string-nth ; M: string clone (clone) ; M: string resize resize-string ; -! Characters -: blank? ( ch -- ? ) " \t\n\r" member? ; inline -: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline -: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline -: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline -: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline -: control? ( ch -- ? ) "\0\e\r\n\t\u0008\u007f" member? ; inline - -: quotable? ( ch -- ? ) - dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline - -: Letter? ( ch -- ? ) - dup letter? [ drop t ] [ LETTER? ] if ; inline - -: alpha? ( ch -- ? ) - dup Letter? [ drop t ] [ digit? ] if ; inline - -: ch>lower ( ch -- lower ) - dup LETTER? [ HEX: 20 + ] when ; inline - -: ch>upper ( ch -- upper ) - dup letter? [ HEX: 20 - ] when ; inline - -: >lower ( str -- lower ) [ ch>lower ] map ; - -: >upper ( str -- upper ) [ ch>upper ] map ; - : 1string ( ch -- str ) 1 swap ; : >string ( seq -- str ) "" clone-like ; diff --git a/core/strings/tags.txt b/core/strings/tags.txt index 42d711b32b..de2741b09f 100644 --- a/core/strings/tags.txt +++ b/core/strings/tags.txt @@ -1 +1,2 @@ +text collections diff --git a/core/syntax/tags.txt b/core/syntax/tags.txt new file mode 100755 index 0000000000..e69de29bb2 diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index 54198a7dcc..f26fe50d79 100755 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -2,8 +2,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.buffers -USING: alien alien.c-types alien.syntax kernel kernel.private -libc math sequences strings hints ; +USING: alien alien.accessors alien.c-types alien.syntax kernel +kernel.private libc math sequences strings hints ; TUPLE: buffer size ptr fill pos ; diff --git a/extra/io/mmap/mmap.factor b/extra/io/mmap/mmap.factor index af020e5a26..59246115cf 100755 --- a/extra/io/mmap/mmap.factor +++ b/extra/io/mmap/mmap.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2007 Doug Coleman. +! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: continuations io.backend kernel quotations sequences -system alien sequences.private ; +system alien alien.accessors sequences.private ; IN: io.mmap TUPLE: mapped-file length address handle closed? ; diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index b9ce5aad4c..77249df9f1 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -1,7 +1,8 @@ -USING: alien alien.c-types byte-arrays continuations destructors -io.nonblocking io io.sockets io.sockets.impl namespaces -io.streams.duplex io.windows io.windows.nt.backend -windows.winsock kernel libc math sequences threads tuples.lib ; +USING: alien alien.accessors alien.c-types byte-arrays +continuations destructors io.nonblocking io io.sockets +io.sockets.impl namespaces io.streams.duplex io.windows +io.windows.nt.backend windows.winsock kernel libc math sequences +threads tuples.lib ; IN: io.windows.nt.sockets : malloc-int ( object -- object ) diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 8fc320e34c..0d7522332f 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays io kernel libc math -math.vectors namespaces opengl opengl.gl prettyprint assocs +USING: alien alien.accessors alien.c-types arrays io kernel libc +math math.vectors namespaces opengl opengl.gl prettyprint assocs sequences io.files io.styles continuations freetype ui.gadgets.worlds ui.render ui.backend byte-arrays ; IN: ui.freetype From d9f7acae0f1f682fe295a483953b9b7b491aa19e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 23:03:10 -0600 Subject: [PATCH 61/66] VM changes for record1 strings --- vm/alien.c | 0 vm/code_heap.c | 2 +- vm/layouts.h | 3 --- vm/primitives.c | 4 ++-- vm/run.h | 18 ++++++++++++---- vm/types.c | 55 +++++++++++++++++++++++++++++++++++++------------ vm/types.h | 25 +++++++++------------- 7 files changed, 69 insertions(+), 38 deletions(-) mode change 100644 => 100755 vm/alien.c diff --git a/vm/alien.c b/vm/alien.c old mode 100644 new mode 100755 diff --git a/vm/code_heap.c b/vm/code_heap.c index 5771725f9d..f449445eb9 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -176,7 +176,7 @@ void deposit_integers(CELL here, F_ARRAY *array, CELL format) { F_FIXNUM value = to_fixnum(array_nth(array,i)); if(format == 1) - cput(here + i,value); + bput(here + i,value); else if(format == sizeof(unsigned int)) *(unsigned int *)(here + format * i) = value; else if(format == CELLS) diff --git a/vm/layouts.h b/vm/layouts.h index 2b8957ee66..ef6fb3d4ac 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -19,9 +19,6 @@ typedef signed long long s64; #define CELLS ((signed)sizeof(CELL)) -/* must always be 16 bits */ -#define CHARS ((signed)sizeof(u16)) - #define WORD_SIZE (CELLS*8) #define HALF_WORD_SIZE (CELLS*4) #define HALF_WORD_MASK (((unsigned long)1<aux == F) + return ch; + else + { + F_BYTE_ARRAY *aux = untag_object(string->aux); + return (cget(BREF(aux,index * sizeof(u16))) << 8) | ch; + } +} + +void set_string_nth(F_STRING* string, CELL index, CELL value) +{ + bput(SREF(string,index),value & 0xff); + + if(string->aux == F) + { + if(value <= 0xff) + return; + else + { + string->aux = tag_object(allot_byte_array( + untag_fixnum_fast(string->length) + * sizeof(u16))); + } + } + + F_BYTE_ARRAY *aux = untag_object(string->aux); + cput(BREF(aux,index * sizeof(u16)),value >> 8); +} /* untagged */ F_STRING* allot_string_internal(CELL capacity) { - F_STRING* string = allot_object(STRING_TYPE, - sizeof(F_STRING) + (capacity + 1) * CHARS); + F_STRING *string = allot_object(STRING_TYPE,string_size(capacity)); /* strings are null-terminated in memory, even though they also have a length field. The null termination allows us to add the sizeof(F_STRING) to a Factor string to get a C-style char* string for C library calls. */ - set_string_nth(string,capacity,0); string->length = tag_fixnum(capacity); string->hashcode = F; string->aux = F; + set_string_nth(string,capacity,0); return string; } void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) { if(fill == 0) - memset((void*)SREF(string,start),'\0', - (capacity - start) * CHARS); + memset((void*)SREF(string,start),'\0',capacity - start); else { CELL i; @@ -466,7 +495,7 @@ DEFINE_PRIMITIVE(string) dpush(tag_object(allot_string(length,initial))); } -F_STRING* reallot_string(F_STRING* string, CELL capacity, u16 fill) +F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill) { CELL to_copy = string_capacity(string); if(capacity < to_copy) @@ -476,7 +505,7 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, u16 fill) F_STRING *new_string = allot_string_internal(capacity); UNREGISTER_UNTAGGED(string); - memcpy(new_string + 1,string + 1,to_copy * CHARS); + memcpy(new_string + 1,string + 1,to_copy); fill_string(new_string,to_copy,capacity,fill); return new_string; @@ -530,7 +559,7 @@ bool check_string(F_STRING *s, CELL max) CELL i; for(i = 0; i < capacity; i++) { - u16 ch = string_nth(s,i); + CELL ch = string_nth(s,i); if(ch == '\0' || ch >= (1 << (max * 8))) return false; } @@ -572,7 +601,7 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) } \ type *to_##type##_string(F_STRING *s, bool check) \ { \ - if(sizeof(type) == sizeof(u16)) \ + if(sizeof(type) == sizeof(char)) \ { \ if(check && !check_string(s,sizeof(type))) \ general_error(ERROR_C_STRING,tag_object(s),F,NULL); \ @@ -597,16 +626,16 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) STRING_TO_MEMORY(char); STRING_TO_MEMORY(u16); -DEFINE_PRIMITIVE(char_slot) +DEFINE_PRIMITIVE(string_nth) { - F_STRING* string = untag_object(dpop()); + F_STRING *string = untag_object(dpop()); CELL index = untag_fixnum_fast(dpop()); dpush(tag_fixnum(string_nth(string,index))); } -DEFINE_PRIMITIVE(set_char_slot) +DEFINE_PRIMITIVE(set_string_nth) { - F_STRING* string = untag_object(dpop()); + F_STRING *string = untag_object(dpop()); CELL index = untag_fixnum_fast(dpop()); CELL value = untag_fixnum_fast(dpop()); set_string_nth(string,index,value); diff --git a/vm/types.h b/vm/types.h index dca54e5951..6f4234af34 100755 --- a/vm/types.h +++ b/vm/types.h @@ -11,7 +11,7 @@ INLINE CELL string_capacity(F_STRING* str) INLINE CELL string_size(CELL size) { - return sizeof(F_STRING) + (size + 1) * CHARS; + return sizeof(F_STRING) + size + 1; } DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array) @@ -83,7 +83,8 @@ INLINE CELL array_capacity(F_ARRAY* array) return array->capacity >> TAG_BITS; } -#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + index * CHARS) +#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + index) +#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + index) INLINE F_STRING* untag_string(CELL tagged) { @@ -91,16 +92,6 @@ INLINE F_STRING* untag_string(CELL tagged) return untag_object(tagged); } -INLINE CELL string_nth(F_STRING* string, CELL index) -{ - return cget(SREF(string,index)); -} - -INLINE void set_string_nth(F_STRING* string, CELL index, u16 value) -{ - cput(SREF(string,index),value); -} - DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation) DEFINE_UNTAG(F_WORD,WORD_TYPE,word) @@ -141,7 +132,7 @@ DECLARE_PRIMITIVE(resize_float_array); F_STRING* allot_string_internal(CELL capacity); F_STRING* allot_string(CELL capacity, CELL fill); DECLARE_PRIMITIVE(string); -F_STRING *reallot_string(F_STRING *string, CELL capacity, u16 fill); +F_STRING *reallot_string(F_STRING *string, CELL capacity, CELL fill); DECLARE_PRIMITIVE(resize_string); F_STRING *memory_to_char_string(const char *string, CELL length); @@ -166,8 +157,12 @@ u16* to_u16_string(F_STRING *s, bool check); DLLEXPORT u16 *unbox_u16_string(void); DECLARE_PRIMITIVE(string_to_u16_alien); -DECLARE_PRIMITIVE(char_slot); -DECLARE_PRIMITIVE(set_char_slot); +/* String getters and setters */ +CELL string_nth(F_STRING* string, CELL index); +void set_string_nth(F_STRING* string, CELL index, CELL value); + +DECLARE_PRIMITIVE(string_nth); +DECLARE_PRIMITIVE(set_string_nth); F_WORD *allot_word(CELL vocab, CELL name); DECLARE_PRIMITIVE(word); From 5dfe21d818c7e6406e511a6520c483b309bdec38 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 23:03:54 -0600 Subject: [PATCH 62/66] Better error reporting in planet --- extra/webapps/planet/planet.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 extra/webapps/planet/planet.factor diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor old mode 100644 new mode 100755 index da6cf6dfcc..3e09b57dd1 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -89,7 +89,7 @@ SYMBOL: last-update [ set-entry-title ] keep ; : ?fetch-feed ( triple -- feed/f ) - [ fetch-feed ] [ error. drop f ] recover ; + [ fetch-feed ] [ swap . error. f ] recover ; : fetch-blogroll ( blogroll -- entries ) dup 0 From af13a47485f6f23a727e8ac0a15c64e74e165231 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 23:04:11 -0600 Subject: [PATCH 63/66] Adding tags --- extra/multiline/tags.txt | 1 + extra/opengl/tags.txt | 3 +++ extra/parser-combinators/simple/tags.txt | 1 + extra/parser-combinators/tags.txt | 1 + extra/peg/tags.txt | 1 + extra/prolog/tags.txt | 2 +- extra/regexp/tags.txt | 2 ++ extra/space-invaders/resources/invaders.rom | Bin 0 -> 8192 bytes extra/tuple-syntax/tags.txt | 2 +- extra/unicode/breaks/tags.txt | 1 + extra/unicode/case/tags.txt | 1 + extra/unicode/categories/tags.txt | 1 + extra/unicode/data/tags.txt | 1 + extra/unicode/normalize/tags.txt | 1 + extra/unicode/syntax/tags.txt | 1 + extra/unicode/tags.txt | 1 + 16 files changed, 18 insertions(+), 2 deletions(-) create mode 100755 extra/multiline/tags.txt create mode 100755 extra/parser-combinators/simple/tags.txt create mode 100755 extra/parser-combinators/tags.txt create mode 100755 extra/regexp/tags.txt create mode 100644 extra/space-invaders/resources/invaders.rom create mode 100755 extra/unicode/breaks/tags.txt create mode 100755 extra/unicode/case/tags.txt create mode 100755 extra/unicode/categories/tags.txt create mode 100755 extra/unicode/data/tags.txt create mode 100755 extra/unicode/normalize/tags.txt create mode 100755 extra/unicode/syntax/tags.txt create mode 100755 extra/unicode/tags.txt diff --git a/extra/multiline/tags.txt b/extra/multiline/tags.txt new file mode 100755 index 0000000000..abf53a421b --- /dev/null +++ b/extra/multiline/tags.txt @@ -0,0 +1 @@ +reflection diff --git a/extra/opengl/tags.txt b/extra/opengl/tags.txt index bb863cf9a0..5e477dbcb3 100644 --- a/extra/opengl/tags.txt +++ b/extra/opengl/tags.txt @@ -1 +1,4 @@ +opengl.glu +opengl.gl +opengl bindings diff --git a/extra/parser-combinators/simple/tags.txt b/extra/parser-combinators/simple/tags.txt new file mode 100755 index 0000000000..9da56880c0 --- /dev/null +++ b/extra/parser-combinators/simple/tags.txt @@ -0,0 +1 @@ +parsing diff --git a/extra/parser-combinators/tags.txt b/extra/parser-combinators/tags.txt new file mode 100755 index 0000000000..9da56880c0 --- /dev/null +++ b/extra/parser-combinators/tags.txt @@ -0,0 +1 @@ +parsing diff --git a/extra/peg/tags.txt b/extra/peg/tags.txt index 9da56880c0..5af5dba748 100644 --- a/extra/peg/tags.txt +++ b/extra/peg/tags.txt @@ -1 +1,2 @@ +text parsing diff --git a/extra/prolog/tags.txt b/extra/prolog/tags.txt index 458345b533..eab42feac7 100644 --- a/extra/prolog/tags.txt +++ b/extra/prolog/tags.txt @@ -1 +1 @@ -prolog +languages diff --git a/extra/regexp/tags.txt b/extra/regexp/tags.txt new file mode 100755 index 0000000000..65bc471f6b --- /dev/null +++ b/extra/regexp/tags.txt @@ -0,0 +1,2 @@ +parsing +text diff --git a/extra/space-invaders/resources/invaders.rom b/extra/space-invaders/resources/invaders.rom new file mode 100644 index 0000000000000000000000000000000000000000..606ec01945d665881793becbde201b7292947a9e GIT binary patch literal 8192 zcmeG>|9=}*a&K3w)k?A@tu5KoN{Zh~w(Qu!m?gH8#THIV{3Xy3X!zD^FA3prC^1d~ z7u&&>orFLR3WN`EB+&B7^$uL1t;4mSkWY`MvbOel6&`V75`w~qVv5BgcP4)oT+xC zeuW2<%aM8(8~c+{G|H4KXEAB<4Jlt?^-CDriPZCWFwsd#1`~gc$bZ^2=zAWJok;tE zCCUJ$b|WH9#j1jp0Zb4>T3J$PMU%&er!VUWo+0?`A9H&Rsl(WLVkeR@CO5NW83R1Y z>{ zQ!0-;)ppz-8=OqmG2w75+?+Nn7R%ZqB%^@uZ1>=Q-N01ZG4CQ1o*@NcU9LgCv%0zw z500q_560#*-wB%;P!~UR8(4M~rO7v4%9$H6*v= z`*n~_=IcRTb7F+iC-o@9e=4)3+I#MBbGYa6u5kC`T{<5ZkzYnwQzUu0tX*Q{%pEx7aIo6?qS2<58pX;c1rGK|L5eFlVTq7 zX*aWGF44y}nm1Q=FgPjZmljIGiaBaM0NZE*$2XM4T`5W9_XAajUUNKcl zRR5)J_?qbQLsOA>L_YSZ9aR6|fn(R9(#zySAE~wuCOeAA7v9)la*;`WAAA%*JHF^l zDJJ4zNw@HDcxzSFW<)+`rkzolM<)tQJdTExc1#Z0h7=KZPna8&eVClGl7311)k$ADi0;mO0*^9{y z5^0ghQg;+71z7JkK1z0)8WcYU(r%*$kj5MWR#rS1T+kwK4(#p>c_~F=B`618TC+*4 z#Dte7$3cWKgGtVq3^r-w!muAIx!PnM7c-pkDN@6c+uf7l#o=&mE&SGo>jdc2kh`G^ zBpwwM;F87ReR669h=(VStBdgNPGun`&$-q0pjCy%x?vvE>NvR^Yp{SUSGf#}Wq#fQ zR;YX$FX}Tkr2c}dUK4s6S3Zjug`UOgV_=q8nqd~QiHA7mQ$v0dZwZGt>yxVDR}@^i z1o!=0;z_P5v;^y7EslOmR-4sktZc^Womkm|$p*99jR)mgocNwutnte=V1IDqN%bLW z@BwTvad8EXeog1qeRtkAY`9WiaB8bx*@m-RR%E#}`Q;|+MT(^E#El8T4BPP`T)7Qv zF@93K14qyNK?q=(69SldQj5*%-B+01k!7~pFR#uq0|ueHv99!E`C-i4K}c~90v<~b zB!Jl!O2CFM-3U594nb$AM4}mV0q+ZB=b;lvnz&wuv8%YcSM9 zonL#-J=eJ19csnk3t&bzF7JXsoOGJO@Pi4bnZ}N{c(9Nmq@3nDhBR2jC$lS+chiV{ ziU(hcg~N|4(A!|42*lTKd1La#x4h095EQ~7R7vt?i{VY?Sq9_$d3hg>9q3Bq2{Y_o zvfM(By5Xz5jjXlshW4=!9AO%RCpSAdd38{{B`6(ER#?J?`H7$Si{;*6=n1TW%)9*H3BdSyoQ+I9K8PlAVU2j9#KDmZ z0vwl(va7=3PTVDk$0X=E!=$-nzlGmFq`Z$|cwp|Rl@SVE!l7AA%6z2C2Qf}&m|o>P z4t;?`Q<&W8Bj*`%ks-$gB_k`D5cv=eR6|yb5Q#H{^U2*yLbGycHUt3=A{lvF08xNs z7?WcRnAMruDv&}J5b`!6$9-^c&3K8oh}eAOf`{y}f-we@=dHw1OlqyzI za$qT#6FSeZY161lr=DXSk6u<{;K&gD<3PY;?Wo&fl1`G0a2%|9LC{6CU@C$-!K%Kq zle{p&gF#g*HoC_vpQEv9p;bmam~R)Z3O$E)A{JF=Vmfj8s;VIB@*en_kZiR=I7wQ= zvBRg~+*usEC^KcHrHzTZpo8xP zh7}Hh3rn{M`EJ$%{^S(oQmBozA|G>!XsE z$!bi#gip(}a5Z5|;lj|DE-?bBUs**S`Ff3})JImGG{DLBB|XwWZx`v&2ge=N{#3OQ zOIsScY*6al_^$VLbwbAQLy#+MxDu+{h-Zm#v zA_ZLu%;&)-9GWmqn8{AxW%9O7JqL$MagBpZ{K_uQ1jzF?aVSWR*a%unV72gWNDmA+uwzKxKuMi1^jtJ{; z!sfgBT-Cr;4P4d0RSjI#z*PEi3jH{5V_T92o%NC$oYaiwp5=03MRG}1LE(0guOEyGZ-fV@&& zh>g=NCu%$@3)kyz9JqUh?;z;5>(6WFxuPqgG;?>W1#aQ8T@h?eIW0TH}F| z+gcl~*i3k$F2w}*RTGSAD?PFa*TyUFqq%>nJIX=l5EM!H-$5FQ9O&H-_IlnOA9dwv zf9ZiQ{eZ0TEHi)N>eN*mhW00}cBr>0yRo*y(+%~Vfq{V?joIp>o;T{6+3V5Oe7JwU z-++zmxe)qxcYT<}ZF=m44a4ry>DAd}EO&j6)2d#$`CuHhnX9iQZ!c1> z0nu8EpsJO2je%TcSh)r=BZ|gp3#vkOOy$=&+-Jm68;YtQ34M)YN)YSy`cN(l0;NK> zBwobQ5r37Ge5&Zgz9Q|}q9XvPL&OTmYG1Zurx(el3h{Nx;fA|wSsCxoCVTG`@quo* z4Aa|kw!WtqXkikI_@D*J9 zUPm#l0w+6)-$Ih!qa6j#NvsSbF^E5KkMPS;GBb@fG{ezRB>B~hkTs3Rwy zf$wO$izVeHOsA)7T4HIZ#c(BlRvcvxb`2>nVtGIC=Fihl&s8#j6E&9eL=wvM`WY5} z)7+T)GS~_h3=2JFH77m>2FlAA)_PfdHy{^5(nD4BHso3_V<<~#pybDB>BVA!noFE# zXkzNB5PuqQcpw9b+LTS0ITD1lBUSGuH+i)RFHB~R(Vo+giD;^K1UA7^_pm;qZo;<$ z^I_d)Wa`H{O}2KEZLP_6muZk@VT;47pnlz=Ch_6qKChaC6-5M zA?2(#;el8JLLUWRT8+hcuFeY;{Q(TQa}0wnhp~DGPBY2F-YiVSy);9LAn*$9kc}=L zku(D}k*ENM)4sBSn&dCAb3Cl`EGWD&>q4_@MFvo-pY$3TYYxzM;M30V=9e$jBW5 zc|oc8xujhXAg$J}^Fd+_Z>VO^r{fNb%+!i+lmG=3YGkHC`?*#AEhQptOILl>U{7I6s^HWQ{Jb18kB{=*N^xdg}{ymQ*{CCvw!kIJ!sph zt?>qB0j5o3aa{ISi@&owtUy;WpT~(#hlmOVM}7tH{}Ss%+Jq0m3J=V!kSR~j_@EZS zyKV(j^)x2V`M_vL-MvO_V#cS-TXD0L9{9(2y{=T128zUdn_%J1oQY)?SC@wZUQeOR zk)LO`TFe;j{)a z7=&E(gKYPb?j`6FLIda-He=3P7r-?x7=-5+Cgj>1sHkB$l*s_)HZI%E{W^e<37Urh zXHby)Y!2Va1I`Dzaf)Y99Dqw^Pz@>oVk+AF8vJFmh@mVIzArew(95m~A_39aO~4Rk zmyb+bx4Te~8aK|)Zful*mN~rdfZvrt2mF9g=^eD3iI8PHF!l<_LnqkbKO!?T9jY%o zl6?U~=8+Ou9(@AW!e2T3Ek$T)&-RDT&CHy8XnPM}@N@@{Y-(s|*mNY=oyF02nJwAg z-$Cg+`nNC1jyt?ZIvN`qJC1lAIr={m7CM|I@bqW;DS&bV#}t|@|LVNfbZr}Ff|Uy9 zpV~~{bC#FeZ*F=_Y<2E$h&8?&?cHDQmm*GwkY89(kuw=Gc~CyfMG6sP=PFnit|=7k z;QwtQ_m1Ug`3`re4ff4VZ@TuZ3Ax_9DYRzKO3#rSzhB19a;{kyp2Y*R1IR$7MghEA zjlE!rg`g7)!!Vqk;Y|!Ybz2N(rN`6IcXejbHaw6#&b%a^s?b3ed5cWFP>{?^-W zyKNP~1q<8SngKSow60zUux?Hd*R{2+Yyf<2Ik3)@~ literal 0 HcmV?d00001 diff --git a/extra/tuple-syntax/tags.txt b/extra/tuple-syntax/tags.txt index 71c0ff7282..abf53a421b 100644 --- a/extra/tuple-syntax/tags.txt +++ b/extra/tuple-syntax/tags.txt @@ -1 +1 @@ -syntax +reflection diff --git a/extra/unicode/breaks/tags.txt b/extra/unicode/breaks/tags.txt new file mode 100755 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/unicode/breaks/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/unicode/case/tags.txt b/extra/unicode/case/tags.txt new file mode 100755 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/unicode/case/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/unicode/categories/tags.txt b/extra/unicode/categories/tags.txt new file mode 100755 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/unicode/categories/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/unicode/data/tags.txt b/extra/unicode/data/tags.txt new file mode 100755 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/unicode/data/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/unicode/normalize/tags.txt b/extra/unicode/normalize/tags.txt new file mode 100755 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/unicode/normalize/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/unicode/syntax/tags.txt b/extra/unicode/syntax/tags.txt new file mode 100755 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/unicode/syntax/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/unicode/tags.txt b/extra/unicode/tags.txt new file mode 100755 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/unicode/tags.txt @@ -0,0 +1 @@ +text From d7c1349c8daf61875326bf3c572dcb1296e517a9 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 31 Jan 2008 23:21:06 -0600 Subject: [PATCH 64/66] Fix a bunch of load-everything hiccups --- extra/cryptlib/streams/streams.factor | 2 +- extra/html/elements/elements.factor | 2 +- extra/html/html.factor | 4 ++-- extra/io/streams/null/null.factor | 2 +- extra/tar/tar.factor | 5 ++--- extra/webapps/pastebin/pastebin.factor | 4 ++-- 6 files changed, 9 insertions(+), 10 deletions(-) diff --git a/extra/cryptlib/streams/streams.factor b/extra/cryptlib/streams/streams.factor index 64b5ee9992..828476d2e2 100755 --- a/extra/cryptlib/streams/streams.factor +++ b/extra/cryptlib/streams/streams.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Matthew Willis ! See http://factorcode.org/license.txt for BSD license. -USING: cryptlib cryptlib.libcl kernel alien sequences +USING: cryptlib cryptlib.libcl kernel alien sequences continuations byte-arrays namespaces io.buffers math generic io strings io.streams.lines io.streams.plain io.streams.duplex combinators alien.c-types ; diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index ff3e7b1283..0f76c2e91e 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -4,7 +4,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io kernel namespaces prettyprint quotations -sequences strings words xml.writer compiler.units effects ; +sequences strings words xml.writer xml.entities compiler.units effects ; IN: html.elements diff --git a/extra/html/html.factor b/extra/html/html.factor index b5d4e63930..b5b0a5e2a9 100755 --- a/extra/html/html.factor +++ b/extra/html/html.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2004, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: generic assocs help http io io.styles io.files +USING: generic assocs help http io io.styles io.files continuations io.streams.string kernel math math.parser namespaces quotations assocs sequences strings words html.elements -xml.writer sbufs ; +xml.writer xml.entities sbufs ; IN: html GENERIC: browser-link-href ( presented -- href ) diff --git a/extra/io/streams/null/null.factor b/extra/io/streams/null/null.factor index 28d1b29be8..f76b0cbce3 100755 --- a/extra/io/streams/null/null.factor +++ b/extra/io/streams/null/null.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.null -USING: kernel io ; +USING: kernel io continuations ; TUPLE: null-stream ; diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index ee312c1111..d3412568fe 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -1,7 +1,6 @@ -USING: combinators io io.files io.streams.duplex +USING: combinators io io.files io.streams.duplex continuations io.streams.string kernel math math.parser -namespaces pack prettyprint sequences strings system ; -USING: hexdump tools.interpreter ; +namespaces pack prettyprint sequences strings system hexdump ; IN: tar : zero-checksum 256 ; diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 5ac322a952..e02e5c01f2 100755 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -1,5 +1,5 @@ USING: calendar furnace furnace.validator io.files kernel -namespaces sequences http.server.responders html math.parser rss +namespaces sequences http.server.responders html math math.parser rss xml.writer xmode.code2html ; IN: webapps.pastebin @@ -94,7 +94,7 @@ C: annotation : annotate-paste ( n summary author mode contents -- ) swap get-paste - [ paste-annotations push store save-store ] keep + [ paste-annotations push ] keep paste-link permanent-redirect ; [ "n" show-paste ] From da1d8967c4745f91eeca43944de73710dabac9b9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 23:48:51 -0600 Subject: [PATCH 65/66] Load fixes --- extra/documents/documents.factor | 2 +- extra/help/tutorial/tutorial.factor | 5 +++-- extra/io/windows/nt/backend/backend.factor | 2 +- extra/tools/completion/completion.factor | 5 +++-- extra/ui/commands/commands.factor | 4 ++-- extra/ui/tools/search/search.factor | 2 +- extra/ui/windows/windows.factor | 7 +++++-- 7 files changed, 16 insertions(+), 11 deletions(-) mode change 100644 => 100755 extra/ui/commands/commands.factor diff --git a/extra/documents/documents.factor b/extra/documents/documents.factor index 19fca8b24c..a9b696179e 100755 --- a/extra/documents/documents.factor +++ b/extra/documents/documents.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays io kernel math models namespaces sequences strings -splitting io.streams.lines combinators ; +splitting io.streams.lines combinators unicode.categories ; IN: documents : +col ( loc n -- newloc ) >r first2 r> + 2array ; diff --git a/extra/help/tutorial/tutorial.factor b/extra/help/tutorial/tutorial.factor index f20ca27a5f..f6b1faf385 100755 --- a/extra/help/tutorial/tutorial.factor +++ b/extra/help/tutorial/tutorial.factor @@ -1,6 +1,7 @@ USING: help.markup help.syntax ui.commands ui.operations ui.tools.search ui.tools.workspace editors vocabs.loader -kernel sequences prettyprint tools.test strings ; +kernel sequences prettyprint tools.test strings +unicode.categories unicode.case ; IN: help.tutorial ARTICLE: "first-program-start" "Creating a vocabulary for your first program" @@ -134,7 +135,7 @@ $nl { $code "[ Letter? ] subset >lower" } "This code starts with a string on the stack, removes non-alphabetical characters, and converts the result to lower case, leaving a new string on the stack. We put this code in a new word, and add the new word to " { $snippet "palindrome.factor" } ":" { $code ": normalize ( str -- newstr ) [ Letter? ] subset >lower ;" } -"You will need to add " { $vocab-link "strings" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file." +"You will need to add " { $vocab-link "unicode.categories" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file." $nl "We modify " { $snippet "palindrome?" } " to first apply " { $snippet "normalize" } " to its input:" { $code ": palindrome? ( str -- ? ) normalize dup reverse = ;" } diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 940b1b7fee..67f2a9861c 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -2,7 +2,7 @@ USING: alien alien.c-types arrays assocs combinators continuations destructors io io.backend io.nonblocking io.windows libc kernel math namespaces sequences threads tuples.lib windows windows.errors windows.kernel32 -strings splitting io.files qualified ; +strings splitting io.files qualified ascii ; QUALIFIED: windows.winsock IN: io.windows.nt.backend diff --git a/extra/tools/completion/completion.factor b/extra/tools/completion/completion.factor index 539b348706..e44c3c401e 100755 --- a/extra/tools/completion/completion.factor +++ b/extra/tools/completion/completion.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: tools.completion USING: kernel arrays sequences math namespaces strings io -vectors words assocs combinators sorting ; +vectors words assocs combinators sorting unicode.case +unicode.categories ; : (fuzzy) ( accum ch i full -- accum i ? ) index* diff --git a/extra/ui/commands/commands.factor b/extra/ui/commands/commands.factor old mode 100644 new mode 100755 index e0d991e1b2..04f655853a --- a/extra/ui/commands/commands.factor +++ b/extra/ui/commands/commands.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions kernel sequences strings math assocs words generic namespaces assocs quotations splitting -ui.gestures ; +ui.gestures unicode.case unicode.categories ; IN: ui.commands SYMBOL: +nullary+ @@ -51,7 +51,7 @@ GENERIC: command-word ( command -- word ) update-gestures ; : (command-name) ( string -- newstring ) - "-" split " " join unclip ch>upper add* ; + "-" split " " join >title ; M: word command-name ( word -- str ) word-name diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor index ea3fcb02eb..27ca4a165d 100755 --- a/extra/ui/tools/search/search.factor +++ b/extra/ui/tools/search/search.factor @@ -7,7 +7,7 @@ source-files strings tools.completion tools.crossref tuples ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations vocabs words vocabs.loader -tools.browser ; +tools.browser unicode.case ; IN: ui.tools.search TUPLE: live-search field list ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 9311a1b2a6..c3ef328b29 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -6,7 +6,7 @@ math math.vectors namespaces prettyprint sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads timers libc combinators continuations -command-line shuffle opengl ui.render ; +command-line shuffle opengl ui.render unicode.case ascii ; IN: ui.windows TUPLE: windows-ui-backend ; @@ -140,7 +140,10 @@ SYMBOL: mouse-captured : ctrl? ( -- ? ) left-ctrl? right-ctrl? or ; : alt? ( -- ? ) left-alt? right-alt? or ; : caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ; -: switch-case ( seq -- seq ) dup first CHAR: a >= [ >upper ] [ >lower ] if ; + +: switch-case ( seq -- seq ) + dup first CHAR: a >= [ >upper ] [ >lower ] if ; + : switch-case? ( -- ? ) shift? caps-lock? xor not ; : key-modifiers ( -- seq ) From 71bac0da210be60088eca406785cd7c5ffed610e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 31 Jan 2008 23:59:29 -0600 Subject: [PATCH 66/66] Load fixes --- extra/io/unix/unix-tests.factor | 2 +- extra/parser-combinators/parser-combinators.factor | 3 ++- extra/xml/writer/writer.factor | 3 ++- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index ce2f052450..e49364fad3 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -1,6 +1,6 @@ USING: io.files io.sockets io kernel threads namespaces tools.test continuations strings byte-arrays sequences -prettyprint system ; +prettyprint system unicode.case ; IN: temporary ! Unix domain stream sockets diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 4376aed95a..b7b62b3c2e 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: lazy-lists promises kernel sequences strings math -arrays splitting quotations combinators namespaces ; +arrays splitting quotations combinators namespaces +unicode.case unicode.categories ; IN: parser-combinators ! Parser combinator protocol diff --git a/extra/xml/writer/writer.factor b/extra/xml/writer/writer.factor index 95f38f3da9..8c7b51d756 100644 --- a/extra/xml/writer/writer.factor +++ b/extra/xml/writer/writer.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: hashtables kernel math namespaces sequences strings -io io.streams.string xml.data assocs wrap xml.entities ; +io io.streams.string xml.data assocs wrap xml.entities +unicode.categories ; IN: xml.writer SYMBOL: xml-pprint?