From f59071189c478a2d211f3bbf083fd45ab8b5cbe1 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 18 Nov 2008 10:19:29 -0500 Subject: [PATCH 01/37] Moved math.polynomials to extra --- {extra => basis}/math/polynomials/authors.txt | 0 {extra => basis}/math/polynomials/polynomials-docs.factor | 0 {extra => basis}/math/polynomials/polynomials-tests.factor | 0 {extra => basis}/math/polynomials/polynomials.factor | 0 {extra => basis}/math/polynomials/summary.txt | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/math/polynomials/authors.txt (100%) rename {extra => basis}/math/polynomials/polynomials-docs.factor (100%) rename {extra => basis}/math/polynomials/polynomials-tests.factor (100%) rename {extra => basis}/math/polynomials/polynomials.factor (100%) rename {extra => basis}/math/polynomials/summary.txt (100%) diff --git a/extra/math/polynomials/authors.txt b/basis/math/polynomials/authors.txt similarity index 100% rename from extra/math/polynomials/authors.txt rename to basis/math/polynomials/authors.txt diff --git a/extra/math/polynomials/polynomials-docs.factor b/basis/math/polynomials/polynomials-docs.factor similarity index 100% rename from extra/math/polynomials/polynomials-docs.factor rename to basis/math/polynomials/polynomials-docs.factor diff --git a/extra/math/polynomials/polynomials-tests.factor b/basis/math/polynomials/polynomials-tests.factor similarity index 100% rename from extra/math/polynomials/polynomials-tests.factor rename to basis/math/polynomials/polynomials-tests.factor diff --git a/extra/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor similarity index 100% rename from extra/math/polynomials/polynomials.factor rename to basis/math/polynomials/polynomials.factor diff --git a/extra/math/polynomials/summary.txt b/basis/math/polynomials/summary.txt similarity index 100% rename from extra/math/polynomials/summary.txt rename to basis/math/polynomials/summary.txt From 5869a1aab48fa5cb6afef8000658aba963587f63 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 18 Nov 2008 10:20:44 -0500 Subject: [PATCH 02/37] Move math.combinatorics to basis --- {extra => basis}/math/combinatorics/authors.txt | 0 {extra => basis}/math/combinatorics/combinatorics-docs.factor | 0 {extra => basis}/math/combinatorics/combinatorics-tests.factor | 0 {extra => basis}/math/combinatorics/combinatorics.factor | 0 {extra => basis}/math/combinatorics/summary.txt | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/math/combinatorics/authors.txt (100%) rename {extra => basis}/math/combinatorics/combinatorics-docs.factor (100%) rename {extra => basis}/math/combinatorics/combinatorics-tests.factor (100%) rename {extra => basis}/math/combinatorics/combinatorics.factor (100%) rename {extra => basis}/math/combinatorics/summary.txt (100%) diff --git a/extra/math/combinatorics/authors.txt b/basis/math/combinatorics/authors.txt similarity index 100% rename from extra/math/combinatorics/authors.txt rename to basis/math/combinatorics/authors.txt diff --git a/extra/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor similarity index 100% rename from extra/math/combinatorics/combinatorics-docs.factor rename to basis/math/combinatorics/combinatorics-docs.factor diff --git a/extra/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor similarity index 100% rename from extra/math/combinatorics/combinatorics-tests.factor rename to basis/math/combinatorics/combinatorics-tests.factor diff --git a/extra/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor similarity index 100% rename from extra/math/combinatorics/combinatorics.factor rename to basis/math/combinatorics/combinatorics.factor diff --git a/extra/math/combinatorics/summary.txt b/basis/math/combinatorics/summary.txt similarity index 100% rename from extra/math/combinatorics/summary.txt rename to basis/math/combinatorics/summary.txt From 1ffc6051cdad982b99bfbdda312beb5251a5732b Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 18 Nov 2008 10:22:16 -0500 Subject: [PATCH 03/37] Move math.blas to basis --- {extra => basis}/math/blas/cblas/authors.txt | 0 {extra => basis}/math/blas/cblas/cblas.factor | 0 {extra => basis}/math/blas/cblas/summary.txt | 0 {extra => basis}/math/blas/cblas/tags.txt | 0 {extra => basis}/math/blas/matrices/authors.txt | 0 {extra => basis}/math/blas/matrices/matrices-docs.factor | 0 {extra => basis}/math/blas/matrices/matrices-tests.factor | 0 {extra => basis}/math/blas/matrices/matrices.factor | 0 {extra => basis}/math/blas/matrices/summary.txt | 0 {extra => basis}/math/blas/matrices/tags.txt | 0 {extra => basis}/math/blas/syntax/authors.txt | 0 {extra => basis}/math/blas/syntax/summary.txt | 0 {extra => basis}/math/blas/syntax/syntax-docs.factor | 0 {extra => basis}/math/blas/syntax/syntax.factor | 0 {extra => basis}/math/blas/syntax/tags.txt | 0 {extra => basis}/math/blas/vectors/authors.txt | 0 {extra => basis}/math/blas/vectors/summary.txt | 0 {extra => basis}/math/blas/vectors/tags.txt | 0 {extra => basis}/math/blas/vectors/vectors-docs.factor | 0 {extra => basis}/math/blas/vectors/vectors-tests.factor | 0 {extra => basis}/math/blas/vectors/vectors.factor | 0 21 files changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/math/blas/cblas/authors.txt (100%) rename {extra => basis}/math/blas/cblas/cblas.factor (100%) rename {extra => basis}/math/blas/cblas/summary.txt (100%) rename {extra => basis}/math/blas/cblas/tags.txt (100%) rename {extra => basis}/math/blas/matrices/authors.txt (100%) rename {extra => basis}/math/blas/matrices/matrices-docs.factor (100%) rename {extra => basis}/math/blas/matrices/matrices-tests.factor (100%) rename {extra => basis}/math/blas/matrices/matrices.factor (100%) rename {extra => basis}/math/blas/matrices/summary.txt (100%) rename {extra => basis}/math/blas/matrices/tags.txt (100%) rename {extra => basis}/math/blas/syntax/authors.txt (100%) rename {extra => basis}/math/blas/syntax/summary.txt (100%) rename {extra => basis}/math/blas/syntax/syntax-docs.factor (100%) rename {extra => basis}/math/blas/syntax/syntax.factor (100%) rename {extra => basis}/math/blas/syntax/tags.txt (100%) rename {extra => basis}/math/blas/vectors/authors.txt (100%) rename {extra => basis}/math/blas/vectors/summary.txt (100%) rename {extra => basis}/math/blas/vectors/tags.txt (100%) rename {extra => basis}/math/blas/vectors/vectors-docs.factor (100%) rename {extra => basis}/math/blas/vectors/vectors-tests.factor (100%) rename {extra => basis}/math/blas/vectors/vectors.factor (100%) diff --git a/extra/math/blas/cblas/authors.txt b/basis/math/blas/cblas/authors.txt similarity index 100% rename from extra/math/blas/cblas/authors.txt rename to basis/math/blas/cblas/authors.txt diff --git a/extra/math/blas/cblas/cblas.factor b/basis/math/blas/cblas/cblas.factor similarity index 100% rename from extra/math/blas/cblas/cblas.factor rename to basis/math/blas/cblas/cblas.factor diff --git a/extra/math/blas/cblas/summary.txt b/basis/math/blas/cblas/summary.txt similarity index 100% rename from extra/math/blas/cblas/summary.txt rename to basis/math/blas/cblas/summary.txt diff --git a/extra/math/blas/cblas/tags.txt b/basis/math/blas/cblas/tags.txt similarity index 100% rename from extra/math/blas/cblas/tags.txt rename to basis/math/blas/cblas/tags.txt diff --git a/extra/math/blas/matrices/authors.txt b/basis/math/blas/matrices/authors.txt similarity index 100% rename from extra/math/blas/matrices/authors.txt rename to basis/math/blas/matrices/authors.txt diff --git a/extra/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor similarity index 100% rename from extra/math/blas/matrices/matrices-docs.factor rename to basis/math/blas/matrices/matrices-docs.factor diff --git a/extra/math/blas/matrices/matrices-tests.factor b/basis/math/blas/matrices/matrices-tests.factor similarity index 100% rename from extra/math/blas/matrices/matrices-tests.factor rename to basis/math/blas/matrices/matrices-tests.factor diff --git a/extra/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor similarity index 100% rename from extra/math/blas/matrices/matrices.factor rename to basis/math/blas/matrices/matrices.factor diff --git a/extra/math/blas/matrices/summary.txt b/basis/math/blas/matrices/summary.txt similarity index 100% rename from extra/math/blas/matrices/summary.txt rename to basis/math/blas/matrices/summary.txt diff --git a/extra/math/blas/matrices/tags.txt b/basis/math/blas/matrices/tags.txt similarity index 100% rename from extra/math/blas/matrices/tags.txt rename to basis/math/blas/matrices/tags.txt diff --git a/extra/math/blas/syntax/authors.txt b/basis/math/blas/syntax/authors.txt similarity index 100% rename from extra/math/blas/syntax/authors.txt rename to basis/math/blas/syntax/authors.txt diff --git a/extra/math/blas/syntax/summary.txt b/basis/math/blas/syntax/summary.txt similarity index 100% rename from extra/math/blas/syntax/summary.txt rename to basis/math/blas/syntax/summary.txt diff --git a/extra/math/blas/syntax/syntax-docs.factor b/basis/math/blas/syntax/syntax-docs.factor similarity index 100% rename from extra/math/blas/syntax/syntax-docs.factor rename to basis/math/blas/syntax/syntax-docs.factor diff --git a/extra/math/blas/syntax/syntax.factor b/basis/math/blas/syntax/syntax.factor similarity index 100% rename from extra/math/blas/syntax/syntax.factor rename to basis/math/blas/syntax/syntax.factor diff --git a/extra/math/blas/syntax/tags.txt b/basis/math/blas/syntax/tags.txt similarity index 100% rename from extra/math/blas/syntax/tags.txt rename to basis/math/blas/syntax/tags.txt diff --git a/extra/math/blas/vectors/authors.txt b/basis/math/blas/vectors/authors.txt similarity index 100% rename from extra/math/blas/vectors/authors.txt rename to basis/math/blas/vectors/authors.txt diff --git a/extra/math/blas/vectors/summary.txt b/basis/math/blas/vectors/summary.txt similarity index 100% rename from extra/math/blas/vectors/summary.txt rename to basis/math/blas/vectors/summary.txt diff --git a/extra/math/blas/vectors/tags.txt b/basis/math/blas/vectors/tags.txt similarity index 100% rename from extra/math/blas/vectors/tags.txt rename to basis/math/blas/vectors/tags.txt diff --git a/extra/math/blas/vectors/vectors-docs.factor b/basis/math/blas/vectors/vectors-docs.factor similarity index 100% rename from extra/math/blas/vectors/vectors-docs.factor rename to basis/math/blas/vectors/vectors-docs.factor diff --git a/extra/math/blas/vectors/vectors-tests.factor b/basis/math/blas/vectors/vectors-tests.factor similarity index 100% rename from extra/math/blas/vectors/vectors-tests.factor rename to basis/math/blas/vectors/vectors-tests.factor diff --git a/extra/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor similarity index 100% rename from extra/math/blas/vectors/vectors.factor rename to basis/math/blas/vectors/vectors.factor From c3f05eaaa141440c3f0cd77b787ced32108df924 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 18 Nov 2008 10:22:48 -0500 Subject: [PATCH 04/37] Move math.quaternions to extra --- {extra => basis}/math/quaternions/authors.txt | 0 {extra => basis}/math/quaternions/quaternions-docs.factor | 0 {extra => basis}/math/quaternions/quaternions-tests.factor | 0 {extra => basis}/math/quaternions/quaternions.factor | 0 {extra => basis}/math/quaternions/summary.txt | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/math/quaternions/authors.txt (100%) rename {extra => basis}/math/quaternions/quaternions-docs.factor (100%) rename {extra => basis}/math/quaternions/quaternions-tests.factor (100%) rename {extra => basis}/math/quaternions/quaternions.factor (100%) rename {extra => basis}/math/quaternions/summary.txt (100%) diff --git a/extra/math/quaternions/authors.txt b/basis/math/quaternions/authors.txt similarity index 100% rename from extra/math/quaternions/authors.txt rename to basis/math/quaternions/authors.txt diff --git a/extra/math/quaternions/quaternions-docs.factor b/basis/math/quaternions/quaternions-docs.factor similarity index 100% rename from extra/math/quaternions/quaternions-docs.factor rename to basis/math/quaternions/quaternions-docs.factor diff --git a/extra/math/quaternions/quaternions-tests.factor b/basis/math/quaternions/quaternions-tests.factor similarity index 100% rename from extra/math/quaternions/quaternions-tests.factor rename to basis/math/quaternions/quaternions-tests.factor diff --git a/extra/math/quaternions/quaternions.factor b/basis/math/quaternions/quaternions.factor similarity index 100% rename from extra/math/quaternions/quaternions.factor rename to basis/math/quaternions/quaternions.factor diff --git a/extra/math/quaternions/summary.txt b/basis/math/quaternions/summary.txt similarity index 100% rename from extra/math/quaternions/summary.txt rename to basis/math/quaternions/summary.txt From 47d268d8947f27011dc3b52e4a153a17191f7d55 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 18 Nov 2008 10:30:11 -0500 Subject: [PATCH 05/37] Remove documentation duplication in math.statistics --- extra/math/statistics/statistics-docs.factor | 11 ++++++----- extra/math/statistics/statistics.factor | 10 +--------- 2 files changed, 7 insertions(+), 14 deletions(-) diff --git a/extra/math/statistics/statistics-docs.factor b/extra/math/statistics/statistics-docs.factor index 695834b554..7a7eb70dd2 100644 --- a/extra/math/statistics/statistics-docs.factor +++ b/extra/math/statistics/statistics-docs.factor @@ -3,13 +3,14 @@ IN: math.statistics HELP: geometric-mean { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } -{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." } +{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } } { $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ; HELP: harmonic-mean { $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } -{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." } +{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." } +{ $notes "Positive reals only." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; @@ -36,21 +37,21 @@ HELP: range HELP: std { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } -{ $description "Computes the standard deviation of " { $snippet "seq" } " by squaring the variance of the sequence. It measures how widely spread the values in a sequence are about the mean." } +{ $description "Computes the standard deviation of " { $snippet "seq" } ", which is the square root of the variance. It measures how widely spread the values in a sequence are about the mean." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } std ." "1.0" } { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } std ." "1.290994448735806" } } ; HELP: ste { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } - { $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." } + { $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." } { $examples { $example "USING: math.statistics prettyprint ;" "{ -2 2 } ste ." "2.0" } { $example "USING: math.statistics prettyprint ;" "{ -2 2 2 } ste ." "1.333333333333333" } } ; HELP: var { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } -{ $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." } +{ $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." } { $notes "If the number of elements in " { $snippet "seq" } " is 1 or less, it outputs 0." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 } var ." "0" } diff --git a/extra/math/statistics/statistics.factor b/extra/math/statistics/statistics.factor index 7568af5294..d2494ee32a 100644 --- a/extra/math/statistics/statistics.factor +++ b/extra/math/statistics/statistics.factor @@ -5,20 +5,15 @@ USING: arrays combinators kernel math math.analysis math.functions sequences IN: math.statistics : mean ( seq -- n ) - #! arithmetic mean, sum divided by length [ sum ] [ length ] bi / ; : geometric-mean ( seq -- n ) - #! geometric mean, nth root of product [ length ] [ product ] bi nth-root ; : harmonic-mean ( seq -- n ) - #! harmonic mean, reciprocal of sum of reciprocals. - #! positive reals only [ recip ] sigma recip ; : median ( seq -- n ) - #! middle number if odd, avg of two middle numbers if even natural-sort dup length even? [ [ midpoint@ dup 1- 2array ] keep nths mean ] [ @@ -26,11 +21,10 @@ IN: math.statistics ] if ; : range ( seq -- n ) - #! max - min minmax swap - ; : var ( seq -- x ) - #! variance, normalize by N-1 + #! normalize by N-1 dup length 1 <= [ drop 0 ] [ @@ -39,11 +33,9 @@ IN: math.statistics ] if ; : std ( seq -- x ) - #! standard deviation, sqrt of variance var sqrt ; : ste ( seq -- x ) - #! standard error, standard deviation / sqrt ( length of sequence ) [ std ] [ length ] bi sqrt / ; : ((r)) ( mean(x) mean(y) {x} {y} -- (r) ) From 197bb708934f6ab2b4c4f3960d9e284e73832bf4 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 18 Nov 2008 10:31:07 -0500 Subject: [PATCH 06/37] Move math.statistics to extra --- {extra => basis}/math/statistics/authors.txt | 0 {extra => basis}/math/statistics/statistics-docs.factor | 0 {extra => basis}/math/statistics/statistics-tests.factor | 0 {extra => basis}/math/statistics/statistics.factor | 0 {extra => basis}/math/statistics/summary.txt | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/math/statistics/authors.txt (100%) rename {extra => basis}/math/statistics/statistics-docs.factor (100%) rename {extra => basis}/math/statistics/statistics-tests.factor (100%) rename {extra => basis}/math/statistics/statistics.factor (100%) rename {extra => basis}/math/statistics/summary.txt (100%) diff --git a/extra/math/statistics/authors.txt b/basis/math/statistics/authors.txt similarity index 100% rename from extra/math/statistics/authors.txt rename to basis/math/statistics/authors.txt diff --git a/extra/math/statistics/statistics-docs.factor b/basis/math/statistics/statistics-docs.factor similarity index 100% rename from extra/math/statistics/statistics-docs.factor rename to basis/math/statistics/statistics-docs.factor diff --git a/extra/math/statistics/statistics-tests.factor b/basis/math/statistics/statistics-tests.factor similarity index 100% rename from extra/math/statistics/statistics-tests.factor rename to basis/math/statistics/statistics-tests.factor diff --git a/extra/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor similarity index 100% rename from extra/math/statistics/statistics.factor rename to basis/math/statistics/statistics.factor diff --git a/extra/math/statistics/summary.txt b/basis/math/statistics/summary.txt similarity index 100% rename from extra/math/statistics/summary.txt rename to basis/math/statistics/summary.txt From 9a870b7760e0d8e042a0aba678844fe0abdcf75a Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 20 Nov 2008 01:48:43 -0500 Subject: [PATCH 07/37] Solution to Project Euler problem 50 --- extra/project-euler/050/050-tests.factor | 6 ++ extra/project-euler/050/050.factor | 90 ++++++++++++++++++++++++ 2 files changed, 96 insertions(+) create mode 100644 extra/project-euler/050/050-tests.factor create mode 100644 extra/project-euler/050/050.factor diff --git a/extra/project-euler/050/050-tests.factor b/extra/project-euler/050/050-tests.factor new file mode 100644 index 0000000000..2bd5482f7e --- /dev/null +++ b/extra/project-euler/050/050-tests.factor @@ -0,0 +1,6 @@ +USING: project-euler.050 project-euler.050.private tools.test ; +IN: project-euler.050.tests + +[ 41 ] [ 100 solve ] unit-test +[ 953 ] [ 1000 solve ] unit-test +[ 997651 ] [ euler050 ] unit-test diff --git a/extra/project-euler/050/050.factor b/extra/project-euler/050/050.factor new file mode 100644 index 0000000000..f8ce68d173 --- /dev/null +++ b/extra/project-euler/050/050.factor @@ -0,0 +1,90 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel locals math math.primes sequences ; +IN: project-euler.050 + +! http://projecteuler.net/index.php?section=problems&id=50 + +! DESCRIPTION +! ----------- + +! The prime 41, can be written as the sum of six consecutive primes: + +! 41 = 2 + 3 + 5 + 7 + 11 + 13 + +! This is the longest sum of consecutive primes that adds to a prime below +! one-hundred. + +! The longest sum of consecutive primes below one-thousand that adds to a +! prime, contains 21 terms, and is equal to 953. + +! Which prime, below one-million, can be written as the sum of the most +! consecutive primes? + + +! SOLUTION +! -------- + +! 1) Create an sequence of all primes under 1000000. +! 2) Start summing elements in the sequence until the next number would put you +! over 1000000. +! 3) Check if that sum is prime, if not, subtract the last number added. +! 4) Repeat step 3 until you get a prime number, and store it along with the +! how many consecutive numbers from the original sequence it took to get there. +! 5) Drop the first number from the sequence of primes, and do steps 2-4 again +! 6) Compare the longest chain from the first run with the second run, and store +! the longer of the two. +! 7) If the sequence of primes is still longer than the longest chain, then +! repeat steps 5-7...otherwise, you've found the longest sum of consecutive +! primes! + + ] find + [ swapd - ] [ drop seq length swap ] if* ; + +: pop-until-prime ( seq sum -- seq prime ) + over length 0 > [ + [ unclip-last-slice ] dip swap - + dup prime? [ pop-until-prime ] unless + ] [ + 2drop { } 0 + ] if ; + +! a pair is { length of chain, prime the chain sums to } + +: longest-prime ( seq limit -- pair ) + dupd sum-upto dup prime? [ + 2array nip + ] [ + [ head-slice ] dip pop-until-prime + [ length ] dip 2array + ] if ; + +: longest ( pair pair -- longest ) + 2dup [ first ] bi@ > [ drop ] [ nip ] if ; + +: continue? ( pair seq -- ? ) + [ first ] [ length 1- ] bi* < ; + +: (find-longest) ( best seq limit -- best ) + [ longest-prime longest ] 2keep 2over continue? [ + [ rest-slice ] dip (find-longest) + ] [ 2drop ] if ; + +: find-longest ( seq limit -- best ) + { 1 2 } -rot (find-longest) ; + +: solve ( n -- answer ) + [ primes-upto ] keep find-longest second ; + +PRIVATE> + +: euler050 ( -- answer ) + 1000000 solve ; + +! [ euler050 ] 100 ave-time +! 291 ms run / 20.6 ms GC ave time - 100 trials + +MAIN: euler050 From 6333710f7df99fdce78ec6854a6ccc94b6d96388 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Mon, 24 Nov 2008 22:05:43 -0500 Subject: [PATCH 08/37] Fix ave-time considering switch to micro seconds --- extra/project-euler/ave-time/ave-time.factor | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor index f176bbc7d2..a7762836f1 100644 --- a/extra/project-euler/ave-time/ave-time.factor +++ b/extra/project-euler/ave-time/ave-time.factor @@ -1,21 +1,24 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2007, 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: continuations fry io kernel make math math.functions math.parser math.statistics memory tools.time ; IN: project-euler.ave-time +: nth-place ( x n -- y ) + 10 swap ^ [ * round >integer ] keep /f ; + : collect-benchmarks ( quot n -- seq ) [ [ datastack ] - [ '[ _ gc benchmark , ] tuck '[ _ _ with-datastack drop ] ] + [ + '[ _ gc benchmark 1000 / , ] tuck + '[ _ _ with-datastack drop ] + ] [ 1- ] tri* swap times call ] { } make ; inline -: nth-place ( x n -- y ) - 10 swap ^ [ * round ] keep / ; - : ave-time ( quot n -- ) [ collect-benchmarks ] keep swap - [ std 2 nth-place ] [ mean round ] bi [ + [ std 2 nth-place ] [ mean round >integer ] bi [ # " ms ave run time - " % # " SD (" % # " trials)" % ] "" make print flush ; inline From 46911bc79744e5ddca070a86335af956f915dad2 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 2 Dec 2008 00:46:38 -0500 Subject: [PATCH 09/37] Add alternate solution to Project Euler problem #2 --- extra/project-euler/002/002-tests.factor | 1 + extra/project-euler/002/002.factor | 31 ++++++++++++++++++++++-- 2 files changed, 30 insertions(+), 2 deletions(-) diff --git a/extra/project-euler/002/002-tests.factor b/extra/project-euler/002/002-tests.factor index bb02518580..46015bee3e 100644 --- a/extra/project-euler/002/002-tests.factor +++ b/extra/project-euler/002/002-tests.factor @@ -3,3 +3,4 @@ IN: project-euler.002.tests [ 4613732 ] [ euler002 ] unit-test [ 4613732 ] [ euler002a ] unit-test +[ 4613732 ] [ euler002b ] unit-test diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index fae535cba9..da20c874b5 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007 Aaron Schaefer, Alexander Solovyov. +! Copyright (c) 2007, 2008 Aaron Schaefer, Alexander Solovyov, Vishal Talwar. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math sequences shuffle ; IN: project-euler.002 @@ -50,4 +50,31 @@ PRIVATE> ! [ euler002a ] 100 ave-time ! 0 ms ave run time - 0.2 SD (100 trials) -MAIN: euler002a + + [ + 3drop + ] [ + [ ?retotal next-fibs ] dip (sum-even-fibs-below) + ] if ; + +PRIVATE> + +: sum-even-fibs-below ( max -- sum ) + [ 0 0 1 ] dip (sum-even-fibs-below) ; + +: euler002b ( -- answer ) + 4000000 sum-even-fibs-below ; + +! [ euler002b ] 100 ave-time +! 0 ms ave run time - 0.0 SD (100 trials) + +MAIN: euler002b From 3d171759263b279fe2b40adca03c6ec6e584a4c8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Dec 2008 05:24:47 -0600 Subject: [PATCH 10/37] move io.files.unique to basis --- {extra => basis}/io/files/unique/backend/backend.factor | 0 {extra => basis}/io/files/unique/unique-docs.factor | 0 {extra => basis}/io/files/unique/unique-tests.factor | 0 {extra => basis}/io/files/unique/unique.factor | 4 ++-- 4 files changed, 2 insertions(+), 2 deletions(-) rename {extra => basis}/io/files/unique/backend/backend.factor (100%) rename {extra => basis}/io/files/unique/unique-docs.factor (100%) rename {extra => basis}/io/files/unique/unique-tests.factor (100%) rename {extra => basis}/io/files/unique/unique.factor (91%) diff --git a/extra/io/files/unique/backend/backend.factor b/basis/io/files/unique/backend/backend.factor similarity index 100% rename from extra/io/files/unique/backend/backend.factor rename to basis/io/files/unique/backend/backend.factor diff --git a/extra/io/files/unique/unique-docs.factor b/basis/io/files/unique/unique-docs.factor similarity index 100% rename from extra/io/files/unique/unique-docs.factor rename to basis/io/files/unique/unique-docs.factor diff --git a/extra/io/files/unique/unique-tests.factor b/basis/io/files/unique/unique-tests.factor similarity index 100% rename from extra/io/files/unique/unique-tests.factor rename to basis/io/files/unique/unique-tests.factor diff --git a/extra/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor similarity index 91% rename from extra/io/files/unique/unique.factor rename to basis/io/files/unique/unique.factor index 3a6c556846..74100c7dc7 100644 --- a/extra/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.bitwise combinators.lib math.parser -random sequences sequences.lib continuations namespaces +USING: kernel math math.bitwise math.parser +random sequences continuations namespaces io.files io arrays io.files.unique.backend system combinators vocabs.loader fry ; IN: io.files.unique From a329960d7eaa186c3c663ab65070cd53b5447a9a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Dec 2008 08:32:12 -0600 Subject: [PATCH 11/37] move retry word to continuations --- core/continuations/continuations-docs.factor | 15 +++++++++++++++ core/continuations/continuations.factor | 2 ++ 2 files changed, 17 insertions(+) diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 7a22306c50..f57be71ca8 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -79,6 +79,7 @@ $nl { $subsection continue-with } "Continuations as control-flow:" { $subsection attempt-all } +{ $subsection retry } { $subsection with-return } "Reflecting the datastack:" { $subsection with-datastack } @@ -237,6 +238,20 @@ HELP: attempt-all } } ; +HELP: retry +{ $values + { "quot" quotation } { "n" null } +} +{ $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." } +{ $examples + { $unchecked-example "USING: continuations math prettyprint ;" + "[ 5 random 0 = ] retry t" + "t" + } +} ; + +{ attempt-all retry } related-words + HELP: return { $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index af8cda37c6..0f55009608 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -154,6 +154,8 @@ ERROR: attempt-all-error ; ] { } make peek swap [ rethrow ] when ] if ; inline +: retry ( quot: ( -- ? ) n -- ) swap [ drop ] prepose attempt-all ; inline + TUPLE: condition error restarts continuation ; C: condition ( error restarts cc -- condition ) From fd270d8ef2b806f809944bc5f63a1a73d6bb3799 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Dec 2008 08:32:54 -0600 Subject: [PATCH 12/37] add surround and glue to sequences --- core/sequences/sequences-docs.factor | 22 ++++++++++++++++++++++ core/sequences/sequences-tests.factor | 3 +++ core/sequences/sequences.factor | 4 ++++ 3 files changed, 29 insertions(+) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index cc8daba8c0..08831579bb 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -714,6 +714,26 @@ HELP: 3append } } ; +HELP: surround +{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "newseq" sequence } } +{ $description "Outputs a new sequence with " { $snippet "seq1" } " inserted between " { $snippet "seq2" } " and " { $snippet "seq3" } "." } +{ $examples + { $example "USING: sequences prettyprint ;" + "\"sssssh\" \"(\" \")\" surround ." + "\"(sssssh)\"" + } +} ; + +HELP: glue +{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "newseq" sequence } } +{ $description "Outputs a new sequence with " { $snippet "seq3" } " inserted between " { $snippet "seq1" } " and " { $snippet "seq2" } "." } +{ $examples + { $example "USING: sequences prettyprint ;" + "\"a\" \"b\" \",\" glue ." + "\"a,b\"" + } +} ; + HELP: subseq { $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "subseq" "a new sequence" } } { $description "Outputs a new sequence consisting of all elements starting from and including " { $snippet "from" } ", and up to but not including " { $snippet "to" } "." } @@ -1348,6 +1368,8 @@ ARTICLE: "sequences-appending" "Appending sequences" { $subsection append } { $subsection prepend } { $subsection 3append } +{ $subsection surround } +{ $subsection glue } { $subsection concat } { $subsection join } "A pair of words useful for aligning strings:" diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index e27f2410b3..0d795d453a 100644 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -268,3 +268,6 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ; [ { 1 3 "X" 5 7 } ] [ "X" 2 { 1 3 5 7 } insert-nth ] unit-test [ V{ 0 2 } ] [ "a" { "a" "b" "a" } indices ] unit-test + +[ "a,b" ] [ "a" "b" "," glue ] unit-test +[ "(abc)" ] [ "abc" "(" ")" surround ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 118969bd3c..3461266081 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -317,6 +317,10 @@ PRIVATE> : 3append ( seq1 seq2 seq3 -- newseq ) pick 3append-as ; +: surround ( seq1 seq2 seq3 -- newseq ) swapd 3append ; inline + +: glue ( seq1 seq2 seq3 -- newseq ) swap 3append ; inline + : change-nth ( i seq quot -- ) [ [ nth ] dip call ] 3keep drop set-nth ; inline From 3c96f9be20bb412b41bd7256a7ef8597742cca03 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Dec 2008 08:33:18 -0600 Subject: [PATCH 13/37] remove try from combinators.lib --- extra/combinators/lib/lib.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 0ae86c48c4..ac8c3d11d8 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -135,9 +135,6 @@ MACRO: multikeep ( word out-indexes -- ... ) r> [ drop \ r> , ] each ] [ ] make ; -: retry ( quot n -- ) - [ drop ] rot compose attempt-all ; inline - : do-while ( pred body tail -- ) [ tuck 2slip ] dip while ; inline From 98246ac53ac84831f21e63942cf134343847d305 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Dec 2008 08:34:14 -0600 Subject: [PATCH 14/37] make ftp not depend on lib --- extra/ftp/server/server.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor index 342c6a3c95..b0ec340202 100644 --- a/extra/ftp/server/server.factor +++ b/extra/ftp/server/server.factor @@ -7,8 +7,7 @@ namespaces make sequences ftp io.unix.launcher.parser unicode.case splitting assocs classes io.servers.connection destructors calendar io.timeouts io.streams.duplex threads continuations math concurrency.promises byte-arrays -io.backend sequences.lib tools.hexdump tools.files -io.streams.string ; +io.backend tools.hexdump tools.files io.streams.string ; IN: ftp.server TUPLE: ftp-client url mode state command-promise user password ; @@ -231,7 +230,7 @@ M: ftp-put service-command ( stream obj -- ) expect-connection [ "Entering Passive Mode (127,0,0,1," % - port>bytes [ number>string ] bi@ "," splice % + port>bytes [ number>string ] bi@ "," glue % ")" % ] "" make 227 swap server-response ; From e6b585c376c2537b0221c3c1b5fcb59e655db5dc Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 3 Dec 2008 13:26:31 -0500 Subject: [PATCH 15/37] Fix example in spread combinator article --- core/kernel/kernel-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 3fc3d175a0..ca18476ce5 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -770,7 +770,7 @@ $nl "Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:" { $code "! First alternative; uses dip" - "[ [ 1 + ] dip 1 - dip ] 2 *" + "[ [ 1 + ] dip 1 - ] dip 2 *" "! Second alternative: uses tri*" "[ 1 + ] [ 1 - ] [ 2 * ] tri*" } From 3a2b0cc1fbd342fc4682a2d231446403dd10d197 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Dec 2008 18:15:14 -0600 Subject: [PATCH 16/37] rice mersenne-twister - replace mod with a subtraction --- basis/random/mersenne-twister/mersenne-twister.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index 3097eafd15..357ab87966 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -15,11 +15,14 @@ TUPLE: mersenne-twister { seq uint-array } { i fixnum } ; : mt-m 397 ; inline : mt-a HEX: 9908b0df ; inline +: mersenne-wrap ( n -- n' ) + dup mt-n > [ mt-n - ] when ; inline + : wrap-nth ( n seq -- obj ) - [ length mod ] keep nth-unsafe ; inline + [ mersenne-wrap ] dip nth-unsafe ; inline : set-wrap-nth ( obj n seq -- ) - [ length mod ] keep set-nth-unsafe ; inline + [ mersenne-wrap ] dip set-nth-unsafe ; inline : calculate-y ( n seq -- y ) [ wrap-nth 31 mask-bit ] @@ -50,7 +53,7 @@ TUPLE: mersenne-twister { seq uint-array } { i fixnum } ; : init-mt-seq ( seed -- seq ) 32 bits mt-n - [ set-first ] [ init-mt-rest ] [ ] tri ; + [ set-first ] [ init-mt-rest ] [ ] tri ; inline : mt-temper ( y -- yt ) dup -11 shift bitxor From 1b0b74bfe15454d695480c60510b57ff457d366a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Dec 2008 18:16:17 -0600 Subject: [PATCH 17/37] call utf8 alien>string instead of alien>native-string --- basis/io/unix/files/netbsd/netbsd.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/io/unix/files/netbsd/netbsd.factor b/basis/io/unix/files/netbsd/netbsd.factor index c200331db5..23717b41a4 100644 --- a/basis/io/unix/files/netbsd/netbsd.factor +++ b/basis/io/unix/files/netbsd/netbsd.factor @@ -4,7 +4,7 @@ USING: alien.syntax kernel unix.stat math unix combinators system io.backend accessors alien.c-types io.encodings.utf8 alien.strings unix.types io.unix.files io.files unix.statvfs.netbsd unix.getfsstat.netbsd -grouping sequences ; +grouping sequences io.encodings.utf8 ; IN: io.unix.files.netbsd TUPLE: netbsd-file-system-info < unix-file-system-info @@ -40,13 +40,13 @@ M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-inf [ statvfs-f_namemax >>name-max ] [ statvfs-f_owner >>owner ] ! [ statvfs-f_spare >>spare ] - [ statvfs-f_fstypename alien>native-string >>type ] - [ statvfs-f_mntonname alien>native-string >>mount-point ] - [ statvfs-f_mntfromname alien>native-string >>device-name ] + [ statvfs-f_fstypename utf8 alien>string >>type ] + [ statvfs-f_mntonname utf8 alien>string >>mount-point ] + [ statvfs-f_mntfromname utf8 alien>string >>device-name ] } cleave ; M: netbsd file-systems ( -- array ) f 0 0 getvfsstat dup io-error "statvfs" dup dup length 0 getvfsstat io-error "statvfs" heap-size group - [ statvfs-f_mntonname alien>native-string file-system-info ] map ; + [ statvfs-f_mntonname utf8 alien>string file-system-info ] map ; From f6a205cc3a99cb1dec4c904e5e38486281fd1130 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Dec 2008 18:19:06 -0600 Subject: [PATCH 18/37] move ftp to basis --- {extra => basis}/ftp/client/authors.txt | 0 {extra => basis}/ftp/client/client.factor | 0 {extra => basis}/ftp/client/listing-parser/authors.txt | 0 {extra => basis}/ftp/client/listing-parser/listing-parser.factor | 0 {extra => basis}/ftp/client/tags.txt | 0 {extra => basis}/ftp/ftp.factor | 0 {extra => basis}/ftp/server/server.factor | 0 {extra => basis}/ftp/server/tags.txt | 0 {extra => basis}/ftp/tags.txt | 0 9 files changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/ftp/client/authors.txt (100%) rename {extra => basis}/ftp/client/client.factor (100%) rename {extra => basis}/ftp/client/listing-parser/authors.txt (100%) rename {extra => basis}/ftp/client/listing-parser/listing-parser.factor (100%) rename {extra => basis}/ftp/client/tags.txt (100%) rename {extra => basis}/ftp/ftp.factor (100%) rename {extra => basis}/ftp/server/server.factor (100%) rename {extra => basis}/ftp/server/tags.txt (100%) rename {extra => basis}/ftp/tags.txt (100%) diff --git a/extra/ftp/client/authors.txt b/basis/ftp/client/authors.txt similarity index 100% rename from extra/ftp/client/authors.txt rename to basis/ftp/client/authors.txt diff --git a/extra/ftp/client/client.factor b/basis/ftp/client/client.factor similarity index 100% rename from extra/ftp/client/client.factor rename to basis/ftp/client/client.factor diff --git a/extra/ftp/client/listing-parser/authors.txt b/basis/ftp/client/listing-parser/authors.txt similarity index 100% rename from extra/ftp/client/listing-parser/authors.txt rename to basis/ftp/client/listing-parser/authors.txt diff --git a/extra/ftp/client/listing-parser/listing-parser.factor b/basis/ftp/client/listing-parser/listing-parser.factor similarity index 100% rename from extra/ftp/client/listing-parser/listing-parser.factor rename to basis/ftp/client/listing-parser/listing-parser.factor diff --git a/extra/ftp/client/tags.txt b/basis/ftp/client/tags.txt similarity index 100% rename from extra/ftp/client/tags.txt rename to basis/ftp/client/tags.txt diff --git a/extra/ftp/ftp.factor b/basis/ftp/ftp.factor similarity index 100% rename from extra/ftp/ftp.factor rename to basis/ftp/ftp.factor diff --git a/extra/ftp/server/server.factor b/basis/ftp/server/server.factor similarity index 100% rename from extra/ftp/server/server.factor rename to basis/ftp/server/server.factor diff --git a/extra/ftp/server/tags.txt b/basis/ftp/server/tags.txt similarity index 100% rename from extra/ftp/server/tags.txt rename to basis/ftp/server/tags.txt diff --git a/extra/ftp/tags.txt b/basis/ftp/tags.txt similarity index 100% rename from extra/ftp/tags.txt rename to basis/ftp/tags.txt From db30415dcb2a8864451f87233ab210783a40bfa5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Dec 2008 19:10:41 -0600 Subject: [PATCH 19/37] basis: swap 3append -> glue --- basis/alien/structs/fields/fields.factor | 2 +- basis/db/queries/queries.factor | 11 ++++------- basis/db/types/types.factor | 10 ++-------- basis/environment/environment.factor | 2 +- basis/furnace/utilities/utilities.factor | 2 +- basis/io/files/unique/unique.factor | 2 +- basis/io/servers/connection/connection.factor | 2 +- basis/io/sockets/sockets.factor | 2 +- basis/io/unix/launcher/launcher.factor | 2 +- basis/prettyprint/prettyprint.factor | 2 +- basis/tools/memory/memory.factor | 2 +- basis/tools/vocabs/vocabs.factor | 2 +- basis/tools/walker/walker.factor | 2 +- basis/urls/encoding/encoding.factor | 2 +- 14 files changed, 18 insertions(+), 27 deletions(-) diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor index 17294aed87..abce91f56f 100644 --- a/basis/alien/structs/fields/fields.factor +++ b/basis/alien/structs/fields/fields.factor @@ -29,7 +29,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; writer>> swap "writing" set-word-prop ; : reader-word ( class name vocab -- word ) - [ "-" swap 3append ] dip create ; + [ "-" glue ] dip create ; : writer-word ( class name vocab -- word ) [ [ swap "set-" % % "-" % % ] "" make ] dip create ; diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index b181aab23b..a96398ff2c 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -162,22 +162,19 @@ M: db ( tuple class -- statement ) where-clause ] query-make ; -: splice ( string1 string2 string3 -- string ) - swap 3append ; - : do-group ( tuple groups -- ) dup string? [ 1array ] when - [ ", " join " group by " splice ] curry change-sql drop ; + [ ", " join " group by " glue ] curry change-sql drop ; : do-order ( tuple order -- ) dup string? [ 1array ] when - [ ", " join " order by " splice ] curry change-sql drop ; + [ ", " join " order by " glue ] curry change-sql drop ; : do-offset ( tuple n -- ) - [ number>string " offset " splice ] curry change-sql drop ; + [ number>string " offset " glue ] curry change-sql drop ; : do-limit ( tuple n -- ) - [ number>string " limit " splice ] curry change-sql drop ; + [ number>string " limit " glue ] curry change-sql drop ; : make-query* ( tuple query -- tuple' ) dupd diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index 6a889689ce..da9fe39b80 100644 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -158,12 +158,6 @@ ERROR: no-sql-type type ; modifiers>> [ lookup-modifier ] map " " join [ "" ] [ " " prepend ] if-empty ; -: join-space ( string1 string2 -- new-string ) - " " swap 3append ; - -: paren ( string -- new-string ) - "(" swap ")" 3append ; - HOOK: bind% db ( spec -- ) HOOK: bind# db ( spec obj -- ) @@ -171,7 +165,7 @@ ERROR: no-column column ; : >reference-string ( string pair -- string ) first2 - [ [ unparse join-space ] [ db-columns ] bi ] dip + [ [ unparse " " glue ] [ db-columns ] bi ] dip swap [ column-name>> = ] with find nip [ no-column ] unless* - column-name>> paren append ; + column-name>> "(" ")" surround append ; diff --git a/basis/environment/environment.factor b/basis/environment/environment.factor index d6ce34dbcf..e60a52c995 100644 --- a/basis/environment/environment.factor +++ b/basis/environment/environment.factor @@ -18,7 +18,7 @@ HOOK: (set-os-envs) os ( seq -- ) (os-envs) [ "=" split1 ] H{ } map>assoc ; : set-os-envs ( assoc -- ) - [ "=" swap 3append ] { } assoc>map (set-os-envs) ; + [ "=" glue ] { } assoc>map (set-os-envs) ; { { [ os unix? ] [ "environment.unix" require ] } diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index f2b71fb89f..7f71a131ed 100644 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -7,7 +7,7 @@ http.server.redirection http.server.remapping ; IN: furnace.utilities : word>string ( word -- string ) - [ vocabulary>> ] [ name>> ] bi ":" swap 3append ; + [ vocabulary>> ] [ name>> ] bi ":" glue ; : words>strings ( seq -- seq' ) [ word>string ] map ; diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor index 74100c7dc7..ec89517bbc 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -29,7 +29,7 @@ PRIVATE> : make-unique-file ( prefix suffix -- path ) temporary-path -rot [ - unique-length get random-name swap 3append append-path + unique-length get random-name glue append-path dup (make-unique-file) ] 3curry unique-retries get retry ; diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index 6c7ff7e0f1..2d990e6483 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -79,7 +79,7 @@ M: threaded-server handle-client* handler>> call ; \ handle-client ERROR add-error-logging : thread-name ( server-name addrspec -- string ) - unparse-short " connection from " swap 3append ; + unparse-short " connection from " glue ; : accept-connection ( threaded-server -- ) [ accept ] [ addr>> ] bi diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index ce7c4f6ddd..fbfae333c0 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -115,7 +115,7 @@ M: invalid-inet6 summary drop "Invalid IPv6 address" ; : pad-inet6 ( string1 string2 -- seq ) 2dup [ length ] bi@ + 8 swap - dup 0 < [ "More than 8 components" throw ] when - swap 3append ; + glue ; : inet6-bytes ( seq -- bytes ) [ 2 >be ] { } map-as concat >byte-array ; diff --git a/basis/io/unix/launcher/launcher.factor b/basis/io/unix/launcher/launcher.factor index 7a1cac3ff1..c81da60e12 100644 --- a/basis/io/unix/launcher/launcher.factor +++ b/basis/io/unix/launcher/launcher.factor @@ -16,7 +16,7 @@ USE: unix command>> dup string? [ tokenize-command ] when ; : assoc>env ( assoc -- env ) - [ "=" swap 3append ] { } assoc>map ; + [ "=" glue ] { } assoc>map ; : setup-priority ( process -- process ) dup priority>> [ diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 82acef9b72..7c4de1e973 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -129,7 +129,7 @@ SYMBOL: -> : remove-breakpoints ( quot pos -- quot' ) over quotation? [ 1+ cut [ (remove-breakpoints) ] bi@ - [ -> ] swap 3append + [ -> ] glue ] [ drop ] if ; diff --git a/basis/tools/memory/memory.factor b/basis/tools/memory/memory.factor index 70f9a10a51..8c35ae25a8 100644 --- a/basis/tools/memory/memory.factor +++ b/basis/tools/memory/memory.factor @@ -10,7 +10,7 @@ IN: tools.memory : write-size ( n -- ) number>string - dup length 4 > [ 3 cut* "," swap 3append ] when + dup length 4 > [ 3 cut* "," glue ] when " KB" append write-cell ; : write-total/used/free ( free total str -- ) diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index ef0c74d7c8..ab2d089d94 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -238,7 +238,7 @@ M: vocab-link summary vocab-summary ; vocab-dir append-path dup exists? [ subdirs ] [ drop { } ] if ] keep [ - swap [ "." swap 3append ] with map + swap [ "." glue ] with map ] unless-empty ; : vocabs-in-dir ( root name -- ) diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index f1a1e3c873..953291cc59 100644 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -126,7 +126,7 @@ SYMBOL: +stopped+ [ 2dup length = [ nip [ break ] append ] [ 2dup nth \ break = [ nip ] [ - swap 1+ cut [ break ] swap 3append + swap 1+ cut [ break ] glue ] if ] if ] change-frame ; diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor index fa882609a5..f621384ede 100644 --- a/basis/urls/encoding/encoding.factor +++ b/basis/urls/encoding/encoding.factor @@ -91,6 +91,6 @@ PRIVATE> [ [ [ url-encode ] dip - [ url-encode "=" swap 3append , ] with each + [ url-encode "=" glue , ] with each ] assoc-each ] { } make "&" join ; From 3ab0d03a1901bb2874ad7a3173dd39f1ba49e237 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Dec 2008 19:11:55 -0600 Subject: [PATCH 20/37] extra: swap 3append -> glue, remove some >r r> --- .../benchmark/knucleotide/knucleotide.factor | 2 +- extra/bitfields/bitfields.factor | 2 +- extra/dns/dns.factor | 2 +- extra/irc/gitbot/gitbot.factor | 2 +- extra/math/text/english/english.factor | 2 +- extra/money/money.factor | 2 +- extra/printf/printf.factor | 2 +- extra/sequences/lib/lib.factor | 26 ++++++++----------- extra/webapps/blogs/blogs.factor | 2 +- 9 files changed, 19 insertions(+), 23 deletions(-) diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index 6bd2d69cfa..7b8e2d34c9 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -9,7 +9,7 @@ IN: benchmark.knucleotide "." split1 rot over length over < [ CHAR: 0 pad-right ] - [ head ] if "." swap 3append ; + [ head ] if "." glue ; : discard-lines ( -- ) readln diff --git a/extra/bitfields/bitfields.factor b/extra/bitfields/bitfields.factor index 5eb41cd943..90e588be48 100755 --- a/extra/bitfields/bitfields.factor +++ b/extra/bitfields/bitfields.factor @@ -80,7 +80,7 @@ M: check< summary drop "Number exceeds upper bound" ; [ ":" split1 string>number [ dup length ] unless* ] { } map>assoc ; : define-slots ( prefix names quots -- ) - >r [ "-" swap 3append create-in ] with map r> + >r [ "-" glue create-in ] with map r> [ define ] 2each ; : define-accessors ( classname slots -- ) diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index 214b45ce0c..be3ba40ac0 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -285,7 +285,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ get-label ] [ skip-label get-name ] 2bi - "." swap 3append + "." glue ] } } diff --git a/extra/irc/gitbot/gitbot.factor b/extra/irc/gitbot/gitbot.factor index 93ccb2b407..3b7694a347 100644 --- a/extra/irc/gitbot/gitbot.factor +++ b/extra/irc/gitbot/gitbot.factor @@ -31,7 +31,7 @@ M: object handle-message drop ; "git-log" , "--no-merges" , "--pretty=format:%h %an: %s" , - ".." swap 3append , + ".." glue , ] { } make latin1 [ input-stream get lines ] with-process-reader ; diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor index 58dab74cdb..41f19b9b07 100755 --- a/extra/math/text/english/english.factor +++ b/extra/math/text/english/english.factor @@ -56,7 +56,7 @@ SYMBOL: and-needed? : text-with-scale ( index seq -- str ) [ nth 3digits>text ] [ drop scale-numbers ] 2bi - [ " " swap 3append ] unless-empty ; + [ " " glue ] unless-empty ; : append-with-conjunction ( str1 str2 -- newstr ) over length zero? [ diff --git a/extra/money/money.factor b/extra/money/money.factor index b7da97ca06..553c473cce 100644 --- a/extra/money/money.factor +++ b/extra/money/money.factor @@ -12,7 +12,7 @@ CHAR: $ \ currency-token set-global : (money>string) ( dollars cents -- string ) [ number>string ] bi@ [ 3 group "," join ] - [ 2 CHAR: 0 pad-left ] bi* "." swap 3append ; + [ 2 CHAR: 0 pad-left ] bi* "." glue ; : money>string ( object -- string ) dollars/cents (money>string) currency-token get prefix ; diff --git a/extra/printf/printf.factor b/extra/printf/printf.factor index 0120891e12..ac02efba69 100644 --- a/extra/printf/printf.factor +++ b/extra/printf/printf.factor @@ -28,7 +28,7 @@ IN: printf [ 0 ] [ string>number ] if-empty ; : pad-digits ( string digits -- string' ) - [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." swap 3append ; + [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ; : max-digits ( n digits -- n' ) 10 swap ^ [ * round ] keep / ; diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 0674b8d9d2..72944c09b4 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -23,11 +23,11 @@ IN: sequences.lib ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : each-percent ( seq quot -- ) - >r - dup length - dup [ / ] curry - [ 1+ ] prepose - r> compose + [ + dup length + dup [ / ] curry + [ 1+ ] prepose + ] dip compose 2each ; inline ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -68,7 +68,7 @@ IN: sequences.lib : minmax ( seq -- min max ) #! find the min and max of a seq in one pass - 1/0. -1/0. rot [ tuck max >r min r> ] each ; + 1/0. -1/0. rot [ tuck max [ min ] dip ] each ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -78,7 +78,7 @@ IN: sequences.lib : (monotonic-split) ( seq quot -- newseq ) [ - >r dup unclip suffix r> + [ dup unclip suffix ] dip v, [ pick ,, call [ v, ] unless ] curry 2each ,v ] { } make ; @@ -88,7 +88,7 @@ IN: sequences.lib ERROR: element-not-found ; : split-around ( seq quot -- before elem after ) dupd find over [ element-not-found ] unless - >r cut rest r> swap ; inline + [ cut rest ] dip swap ; inline : map-until ( seq quot pred -- newseq ) '[ [ @ dup @ [ drop t ] [ , f ] if ] find 2drop ] { } make ; @@ -115,14 +115,14 @@ ERROR: element-not-found ; PRIVATE> : exact-strings ( alphabet length -- seqs ) - >r dup length r> exact-number-strings map-alphabet ; + [ dup length ] dip exact-number-strings map-alphabet ; : strings ( alphabet length -- seqs ) - >r dup length r> number-strings map-alphabet ; + [ dup length ] dip number-strings map-alphabet ; : switches ( seq1 seq -- subseq ) ! seq1 is a sequence of ones and zeroes - >r [ length ] keep [ nth 1 = ] curry filter r> + [ [ length ] keep [ nth 1 = ] curry filter ] dip [ nth ] curry { } map-as ; : power-set ( seq -- subsets ) @@ -147,7 +147,3 @@ PRIVATE> dup length 1 (a,b] [ dup random pick exchange ] each ; : enumerate ( seq -- seq' ) >alist ; - -: splice ( left-seq right-seq seq -- newseq ) swap 3append ; - -: surround ( seq left-seq right-seq -- newseq ) swapd 3append ; diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index e035090fb0..c16450bb25 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/extra/webapps/blogs/blogs.factor @@ -50,7 +50,7 @@ M: entity feed-entry-date date>> ; TUPLE: post < entity title comments ; M: post feed-entry-title - [ author>> ] [ title>> ] bi ": " swap 3append ; + [ author>> ] [ title>> ] bi ": " glue ; M: post entity-url id>> view-post-url ; From 0e14f767ee3ea2d67e9f0c93b372848ad5624735 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Dec 2008 19:12:48 -0600 Subject: [PATCH 21/37] core: swap 3append -> glue --- core/effects/effects.factor | 2 +- core/generic/generic.factor | 2 +- core/math/parser/parser.factor | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 0c082477c7..db6b2461b5 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -26,7 +26,7 @@ GENERIC: effect>string ( obj -- str ) M: string effect>string ; M: word effect>string name>> ; M: integer effect>string number>string ; -M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ; +M: pair effect>string first2 [ effect>string ] bi@ ": " glue ; : stack-picture ( seq -- string ) dup integer? [ "object" ] when diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 0cd5a35623..4eb39291a0 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -77,7 +77,7 @@ TUPLE: check-method class generic ; 3tri ; inline : method-word-name ( class word -- string ) - [ name>> ] bi@ "=>" swap 3append ; + [ name>> ] bi@ "=>" glue ; PREDICATE: method-body < word "method-generic" word-prop >boolean ; diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 8fc6e6dd9e..ac6c5e9790 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -128,7 +128,7 @@ M: ratio >base [ [ numerator (>base) ] [ denominator (>base) ] bi - "/" swap 3append + "/" glue ] bi* append negative? get [ CHAR: - prefix ] when ] with-radix ; From 7d2ca36fad5a362891bc6ecfa32a15cb329ca9b0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Dec 2008 19:13:18 -0600 Subject: [PATCH 22/37] swap 3append -> glue --- basis/http/http.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/http/http.factor b/basis/http/http.factor index c90a1872ce..d006c86462 100644 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -111,7 +111,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s { [ dup real? ] [ number>string ] } [ ] } cond - [ check-cookie-string ] bi@ "=" swap 3append , + [ check-cookie-string ] bi@ "=" glue , ] } case ; From b11caac25fe126bce41d463951cd5cee9edd7e0e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Dec 2008 19:15:58 -0600 Subject: [PATCH 23/37] add infinity? and nan? to math.floating-point --- .../floating-point/floating-point-tests.factor | 12 +++++++++++- extra/math/floating-point/floating-point.factor | 16 +++++++++++++++- 2 files changed, 26 insertions(+), 2 deletions(-) diff --git a/extra/math/floating-point/floating-point-tests.factor b/extra/math/floating-point/floating-point-tests.factor index 7f3a87f9a5..129956331b 100644 --- a/extra/math/floating-point/floating-point-tests.factor +++ b/extra/math/floating-point/floating-point-tests.factor @@ -1,7 +1,17 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test math.floating-point math.constants kernel ; +USING: tools.test math.floating-point math.constants kernel +math.constants fry sequences kernel math ; IN: math.floating-point.tests [ t ] [ pi >double< >double pi = ] unit-test [ t ] [ -1.0 >double< >double -1.0 = ] unit-test + +[ t ] [ 1/0. infinity? ] unit-test +[ t ] [ -1/0. infinity? ] unit-test +[ f ] [ 0/0. infinity? ] unit-test +[ f ] [ 10. infinity? ] unit-test +[ f ] [ -10. infinity? ] unit-test +[ f ] [ 0. infinity? ] unit-test + +[ t ] [ 0/0. nan? ] unit-test diff --git a/extra/math/floating-point/floating-point.factor b/extra/math/floating-point/floating-point.factor index 0d224bfc9d..02fcd01e11 100644 --- a/extra/math/floating-point/floating-point.factor +++ b/extra/math/floating-point/floating-point.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math sequences prettyprint math.parser io -math.functions math.bitwise ; +math.functions math.bitwise combinators.short-circuit ; IN: math.floating-point : (double-sign) ( bits -- n ) -63 shift ; inline @@ -37,3 +37,17 @@ IN: math.floating-point (double-mantissa-bits) >bin 52 CHAR: 0 pad-left 11 [ bl ] times print ] tri ; + +: nan? ( double -- ? ) + double>bits + { + [ (double-exponent-bits) 11 on-bits = ] + [ (double-mantissa-bits) 0 > ] + } 1&& ; + +: infinity? ( double -- ? ) + double>bits + { + [ (double-exponent-bits) 11 on-bits = ] + [ (double-mantissa-bits) 0 = ] + } 1&& ; From b27941dd01d19683f8d53f53b7d2eaee170e5a44 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Dec 2008 20:35:03 -0600 Subject: [PATCH 24/37] clean up windows hardware-info for file-systems code --- extra/hardware-info/windows/ce/ce.factor | 2 +- extra/hardware-info/windows/nt/nt.factor | 26 ++++++---------------- extra/hardware-info/windows/windows.factor | 8 +++---- 3 files changed, 12 insertions(+), 24 deletions(-) diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor index c61a3c8b8a..6537661b3e 100755 --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/hardware-info/windows/ce/ce.factor @@ -5,7 +5,7 @@ IN: hardware-info.windows.ce : memory-status ( -- MEMORYSTATUS ) "MEMORYSTATUS" "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength - [ GlobalMemoryStatus ] keep ; + dup GlobalMemoryStatus ; M: wince cpus ( -- n ) 1 ; diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor index 51af5c5949..6215566f11 100755 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -3,16 +3,13 @@ kernel libc math namespaces hardware-info.backend windows windows.advapi32 windows.kernel32 system ; IN: hardware-info.windows.nt -: 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 - [ GlobalMemoryStatusEx ] keep swap zero? [ win32-error ] when ; + dup GlobalMemoryStatusEx win32-error=0/f ; M: winnt memory-load ( -- n ) memory-status MEMORYSTATUSEX-dwMemoryLoad ; @@ -35,21 +32,12 @@ M: winnt total-virtual-mem ( -- n ) M: winnt available-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailVirtual ; -: pull-win32-string ( alien -- string ) - [ utf16n alien>string ] keep free ; - : computer-name ( -- string ) - MAX_COMPUTERNAME_LENGTH 1+ [ malloc ] keep - dupd GetComputerName zero? [ - free win32-error f - ] [ - pull-win32-string - ] if ; + MAX_COMPUTERNAME_LENGTH 1+ + [ dup ] keep + GetComputerName win32-error=0/f alien>native-string ; : username ( -- string ) - UNLEN 1+ [ malloc ] keep - dupd GetUserName zero? [ - free win32-error f - ] [ - pull-win32-string - ] if ; + UNLEN 1+ + [ dup ] keep + GetUserName win32-error=0/f alien>native-string ; diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index 3aa6824ff6..d3ebe87501 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -21,7 +21,7 @@ IN: hardware-info.windows : os-version ( -- os-version ) "OSVERSIONINFO" "OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize - [ GetVersionEx ] keep swap zero? [ win32-error ] when ; + dup GetVersionEx win32-error=0/f ; : windows-major ( -- n ) os-version OSVERSIONINFO-dwMajorVersion ; @@ -36,7 +36,7 @@ IN: hardware-info.windows os-version OSVERSIONINFO-dwPlatformId ; : windows-service-pack ( -- string ) - os-version OSVERSIONINFO-szCSDVersion utf16n alien>string ; + os-version OSVERSIONINFO-szCSDVersion alien>native-string ; : feature-present? ( n -- ? ) IsProcessorFeaturePresent zero? not ; @@ -51,8 +51,8 @@ IN: hardware-info.windows "ushort" ; : get-directory ( word -- str ) - >r MAX_UNICODE_PATH [ ] keep dupd r> - execute win32-error=0/f utf16n alien>string ; inline + [ MAX_UNICODE_PATH [ ] keep dupd ] dip + execute win32-error=0/f alien>native-string ; inline : windows-directory ( -- str ) \ GetWindowsDirectory get-directory ; From 9f19062892ec2ce164bfc1f01ef991a545586273 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Dec 2008 22:03:10 -0600 Subject: [PATCH 25/37] remove redundant nan? word --- extra/math/floating-point/floating-point-tests.factor | 2 -- extra/math/floating-point/floating-point.factor | 7 ------- 2 files changed, 9 deletions(-) diff --git a/extra/math/floating-point/floating-point-tests.factor b/extra/math/floating-point/floating-point-tests.factor index 129956331b..9e5b5c67aa 100644 --- a/extra/math/floating-point/floating-point-tests.factor +++ b/extra/math/floating-point/floating-point-tests.factor @@ -13,5 +13,3 @@ IN: math.floating-point.tests [ f ] [ 10. infinity? ] unit-test [ f ] [ -10. infinity? ] unit-test [ f ] [ 0. infinity? ] unit-test - -[ t ] [ 0/0. nan? ] unit-test diff --git a/extra/math/floating-point/floating-point.factor b/extra/math/floating-point/floating-point.factor index 02fcd01e11..522f149bc1 100644 --- a/extra/math/floating-point/floating-point.factor +++ b/extra/math/floating-point/floating-point.factor @@ -38,13 +38,6 @@ IN: math.floating-point 11 [ bl ] times print ] tri ; -: nan? ( double -- ? ) - double>bits - { - [ (double-exponent-bits) 11 on-bits = ] - [ (double-mantissa-bits) 0 > ] - } 1&& ; - : infinity? ( double -- ? ) double>bits { From ded6b1963f4b0cd6b160bedf811713543f2ec0b2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 3 Dec 2008 22:05:52 -0600 Subject: [PATCH 26/37] fix docs for db --- basis/db/types/types-docs.factor | 6 ------ 1 file changed, 6 deletions(-) diff --git a/basis/db/types/types-docs.factor b/basis/db/types/types-docs.factor index f1a6ba6c6c..bd0b443fbe 100644 --- a/basis/db/types/types-docs.factor +++ b/basis/db/types/types-docs.factor @@ -147,12 +147,6 @@ HELP: get-slot-named { "value" "the value stored in the slot" } } { $description "Returns the value stored in a tuple slot, where the tuple slot is a string." } ; -HELP: join-space -{ $values - { "string1" string } { "string2" string } - { "new-string" null } } -{ $description "" } ; - HELP: literal-bind { $description "" } ; From ca73c06194a9bf5c631bd86c28083f4eba56b9f1 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 4 Dec 2008 00:36:11 -0500 Subject: [PATCH 27/37] Fix documentation example for floats --- core/math/floats/floats-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/math/floats/floats-docs.factor b/core/math/floats/floats-docs.factor index a1ba16c68a..5549ef79e9 100644 --- a/core/math/floats/floats-docs.factor +++ b/core/math/floats/floats-docs.factor @@ -6,7 +6,7 @@ ARTICLE: "floats" "Floats" "Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximation" } ". While rationals can grow to any required precision, floating point numbers are fixed-width, and manipulating them is usually faster than manipulating ratios or bignums (but slower than manipulating fixnums). Floating point numbers are often used to represent irrational numbers, which have no exact representation as a ratio of two integers." $nl "Introducing a floating point number in a computation forces the result to be expressed in floating point." -{ $example "5/4 1/2 + ." "7/4" } +{ $example "5/4 1/2 + ." "1+3/4" } { $example "5/4 0.5 + ." "1.75" } "Integers and rationals can be converted to floats:" { $subsection >float } From 869fbf27a1e3a816847e3fbd5edbe3304f1e1baf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 4 Dec 2008 00:06:02 -0600 Subject: [PATCH 28/37] remove join-space from db --- basis/db/postgresql/postgresql.factor | 2 +- basis/db/sqlite/sqlite.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index 57a16fc8ef..82d96c4af1 100644 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -266,7 +266,7 @@ M: postgresql-db persistent-table ( -- hashtable ) ERROR: no-compound-found string object ; M: postgresql-db compound ( string object -- string' ) over { - { "default" [ first number>string join-space ] } + { "default" [ first number>string " " glue ] } { "varchar" [ first number>string paren append ] } { "references" [ >reference-string ] } [ drop no-compound-found ] diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index c22bb3a2d8..4e96fb5a4d 100644 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -308,7 +308,7 @@ M: sqlite-db persistent-table ( -- assoc ) M: sqlite-db compound ( string seq -- new-string ) over { - { "default" [ first number>string join-space ] } + { "default" [ first number>string " " glue ] } { "references" [ [ >reference-string ] keep first2 [ "foreign-table" set ] From d698e3e5781bef089f1e8787e6a178da761dd502 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 4 Dec 2008 00:08:20 -0600 Subject: [PATCH 29/37] add using --- extra/webapps/wee-url/wee-url.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor index af7c8b61ce..bc429a0af6 100644 --- a/extra/webapps/wee-url/wee-url.factor +++ b/extra/webapps/wee-url/wee-url.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2007 Doug Coleman. ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math.ranges sequences random accessors combinators.lib +USING: math.ranges sequences random accessors kernel namespaces fry db.types db.tuples urls validators html.components html.forms http http.server.dispatchers furnace furnace.actions furnace.boilerplate furnace.redirection -furnace.utilities ; +furnace.utilities continuations ; IN: webapps.wee-url TUPLE: wee-url < dispatcher ; From 1247ebbac9a74eed55c294848a82872e8001e4e0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 4 Dec 2008 00:28:16 -0600 Subject: [PATCH 30/37] Fix typo --- core/kernel/kernel-docs.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 91b18d834b..5ee12ddedc 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -758,12 +758,10 @@ $nl "Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:" { $code "! First alternative; uses dip" - "[ [ 1 + ] dip 1 - dip ] 2 *" + "[ [ 1 + ] dip 1 - ] dip 2 *" "! Second alternative: uses tri*" "[ 1 + ] [ 1 - ] [ 2 * ] tri*" } - -$nl "A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." { $subsection "spread-shuffle-equivalence" } ; From 1296e3c7920915c0b916b8115733bac019b08b2e Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 4 Dec 2008 01:35:53 -0500 Subject: [PATCH 31/37] Move math.blas back to extra due to multimethods usage --- {basis => extra}/math/blas/cblas/authors.txt | 0 {basis => extra}/math/blas/cblas/cblas.factor | 0 {basis => extra}/math/blas/cblas/summary.txt | 0 {basis => extra}/math/blas/cblas/tags.txt | 0 {basis => extra}/math/blas/matrices/authors.txt | 0 {basis => extra}/math/blas/matrices/matrices-docs.factor | 0 {basis => extra}/math/blas/matrices/matrices-tests.factor | 0 {basis => extra}/math/blas/matrices/matrices.factor | 0 {basis => extra}/math/blas/matrices/summary.txt | 0 {basis => extra}/math/blas/matrices/tags.txt | 0 {basis => extra}/math/blas/syntax/authors.txt | 0 {basis => extra}/math/blas/syntax/summary.txt | 0 {basis => extra}/math/blas/syntax/syntax-docs.factor | 0 {basis => extra}/math/blas/syntax/syntax.factor | 0 {basis => extra}/math/blas/syntax/tags.txt | 0 {basis => extra}/math/blas/vectors/authors.txt | 0 {basis => extra}/math/blas/vectors/summary.txt | 0 {basis => extra}/math/blas/vectors/tags.txt | 0 {basis => extra}/math/blas/vectors/vectors-docs.factor | 0 {basis => extra}/math/blas/vectors/vectors-tests.factor | 0 {basis => extra}/math/blas/vectors/vectors.factor | 0 21 files changed, 0 insertions(+), 0 deletions(-) rename {basis => extra}/math/blas/cblas/authors.txt (100%) rename {basis => extra}/math/blas/cblas/cblas.factor (100%) rename {basis => extra}/math/blas/cblas/summary.txt (100%) rename {basis => extra}/math/blas/cblas/tags.txt (100%) rename {basis => extra}/math/blas/matrices/authors.txt (100%) rename {basis => extra}/math/blas/matrices/matrices-docs.factor (100%) rename {basis => extra}/math/blas/matrices/matrices-tests.factor (100%) rename {basis => extra}/math/blas/matrices/matrices.factor (100%) rename {basis => extra}/math/blas/matrices/summary.txt (100%) rename {basis => extra}/math/blas/matrices/tags.txt (100%) rename {basis => extra}/math/blas/syntax/authors.txt (100%) rename {basis => extra}/math/blas/syntax/summary.txt (100%) rename {basis => extra}/math/blas/syntax/syntax-docs.factor (100%) rename {basis => extra}/math/blas/syntax/syntax.factor (100%) rename {basis => extra}/math/blas/syntax/tags.txt (100%) rename {basis => extra}/math/blas/vectors/authors.txt (100%) rename {basis => extra}/math/blas/vectors/summary.txt (100%) rename {basis => extra}/math/blas/vectors/tags.txt (100%) rename {basis => extra}/math/blas/vectors/vectors-docs.factor (100%) rename {basis => extra}/math/blas/vectors/vectors-tests.factor (100%) rename {basis => extra}/math/blas/vectors/vectors.factor (100%) diff --git a/basis/math/blas/cblas/authors.txt b/extra/math/blas/cblas/authors.txt similarity index 100% rename from basis/math/blas/cblas/authors.txt rename to extra/math/blas/cblas/authors.txt diff --git a/basis/math/blas/cblas/cblas.factor b/extra/math/blas/cblas/cblas.factor similarity index 100% rename from basis/math/blas/cblas/cblas.factor rename to extra/math/blas/cblas/cblas.factor diff --git a/basis/math/blas/cblas/summary.txt b/extra/math/blas/cblas/summary.txt similarity index 100% rename from basis/math/blas/cblas/summary.txt rename to extra/math/blas/cblas/summary.txt diff --git a/basis/math/blas/cblas/tags.txt b/extra/math/blas/cblas/tags.txt similarity index 100% rename from basis/math/blas/cblas/tags.txt rename to extra/math/blas/cblas/tags.txt diff --git a/basis/math/blas/matrices/authors.txt b/extra/math/blas/matrices/authors.txt similarity index 100% rename from basis/math/blas/matrices/authors.txt rename to extra/math/blas/matrices/authors.txt diff --git a/basis/math/blas/matrices/matrices-docs.factor b/extra/math/blas/matrices/matrices-docs.factor similarity index 100% rename from basis/math/blas/matrices/matrices-docs.factor rename to extra/math/blas/matrices/matrices-docs.factor diff --git a/basis/math/blas/matrices/matrices-tests.factor b/extra/math/blas/matrices/matrices-tests.factor similarity index 100% rename from basis/math/blas/matrices/matrices-tests.factor rename to extra/math/blas/matrices/matrices-tests.factor diff --git a/basis/math/blas/matrices/matrices.factor b/extra/math/blas/matrices/matrices.factor similarity index 100% rename from basis/math/blas/matrices/matrices.factor rename to extra/math/blas/matrices/matrices.factor diff --git a/basis/math/blas/matrices/summary.txt b/extra/math/blas/matrices/summary.txt similarity index 100% rename from basis/math/blas/matrices/summary.txt rename to extra/math/blas/matrices/summary.txt diff --git a/basis/math/blas/matrices/tags.txt b/extra/math/blas/matrices/tags.txt similarity index 100% rename from basis/math/blas/matrices/tags.txt rename to extra/math/blas/matrices/tags.txt diff --git a/basis/math/blas/syntax/authors.txt b/extra/math/blas/syntax/authors.txt similarity index 100% rename from basis/math/blas/syntax/authors.txt rename to extra/math/blas/syntax/authors.txt diff --git a/basis/math/blas/syntax/summary.txt b/extra/math/blas/syntax/summary.txt similarity index 100% rename from basis/math/blas/syntax/summary.txt rename to extra/math/blas/syntax/summary.txt diff --git a/basis/math/blas/syntax/syntax-docs.factor b/extra/math/blas/syntax/syntax-docs.factor similarity index 100% rename from basis/math/blas/syntax/syntax-docs.factor rename to extra/math/blas/syntax/syntax-docs.factor diff --git a/basis/math/blas/syntax/syntax.factor b/extra/math/blas/syntax/syntax.factor similarity index 100% rename from basis/math/blas/syntax/syntax.factor rename to extra/math/blas/syntax/syntax.factor diff --git a/basis/math/blas/syntax/tags.txt b/extra/math/blas/syntax/tags.txt similarity index 100% rename from basis/math/blas/syntax/tags.txt rename to extra/math/blas/syntax/tags.txt diff --git a/basis/math/blas/vectors/authors.txt b/extra/math/blas/vectors/authors.txt similarity index 100% rename from basis/math/blas/vectors/authors.txt rename to extra/math/blas/vectors/authors.txt diff --git a/basis/math/blas/vectors/summary.txt b/extra/math/blas/vectors/summary.txt similarity index 100% rename from basis/math/blas/vectors/summary.txt rename to extra/math/blas/vectors/summary.txt diff --git a/basis/math/blas/vectors/tags.txt b/extra/math/blas/vectors/tags.txt similarity index 100% rename from basis/math/blas/vectors/tags.txt rename to extra/math/blas/vectors/tags.txt diff --git a/basis/math/blas/vectors/vectors-docs.factor b/extra/math/blas/vectors/vectors-docs.factor similarity index 100% rename from basis/math/blas/vectors/vectors-docs.factor rename to extra/math/blas/vectors/vectors-docs.factor diff --git a/basis/math/blas/vectors/vectors-tests.factor b/extra/math/blas/vectors/vectors-tests.factor similarity index 100% rename from basis/math/blas/vectors/vectors-tests.factor rename to extra/math/blas/vectors/vectors-tests.factor diff --git a/basis/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor similarity index 100% rename from basis/math/blas/vectors/vectors.factor rename to extra/math/blas/vectors/vectors.factor From ffecedf9dece8ee5b0df558a20e06b834ba727c4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 4 Dec 2008 02:21:36 -0600 Subject: [PATCH 32/37] Fix db.postgresql load error --- basis/db/postgresql/postgresql.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index 82d96c4af1..90a875b8ff 100644 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -267,7 +267,7 @@ ERROR: no-compound-found string object ; M: postgresql-db compound ( string object -- string' ) over { { "default" [ first number>string " " glue ] } - { "varchar" [ first number>string paren append ] } + { "varchar" [ first number>string "(" ")" surround append ] } { "references" [ >reference-string ] } [ drop no-compound-found ] } case ; From d70c8eff1c3decbb5e03e55413353a91ab67b912 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 4 Dec 2008 02:26:34 -0600 Subject: [PATCH 33/37] Rewrite interpolate without using PEGs for mad lulz --- basis/interpolate/interpolate-tests.factor | 20 +++++++++- basis/interpolate/interpolate.factor | 43 ++++++++++++++++------ 2 files changed, 50 insertions(+), 13 deletions(-) diff --git a/basis/interpolate/interpolate-tests.factor b/basis/interpolate/interpolate-tests.factor index 005ae87746..c15debd9b5 100644 --- a/basis/interpolate/interpolate-tests.factor +++ b/basis/interpolate/interpolate-tests.factor @@ -1,4 +1,22 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test interpolate ; +USING: interpolate io.streams.string namespaces tools.test locals ; IN: interpolate.tests + +[ "Hello, Jane." ] [ + "Jane" "name" set + [ "Hello, ${name}." interpolate ] with-string-writer +] unit-test + +[ "Sup Dawg, we heard you liked rims, so we put rims on your rims so you can roll while you roll." ] [ + "Dawg" "name" set + "rims" "noun" set + "roll" "verb" set + [ "Sup ${name}, we heard you liked ${noun}, so we put ${noun} on your ${noun} so you can ${verb} while you ${verb}." interpolate ] with-string-writer +] unit-test + +[ "Oops, I accidentally the whole economy..." ] [ + [let | noun [ "economy" ] | + [ I[ Oops, I accidentally the whole ${noun}...]I ] with-string-writer + ] +] unit-test diff --git a/basis/interpolate/interpolate.factor b/basis/interpolate/interpolate.factor index 27f0756f1f..5e4805a8ac 100644 --- a/basis/interpolate/interpolate.factor +++ b/basis/interpolate/interpolate.factor @@ -1,21 +1,40 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io kernel macros make multiline namespaces parser -peg.ebnf present sequences strings ; +present sequences strings splitting fry accessors ; IN: interpolate -MACRO: interpolate ( string -- ) -[EBNF -var = "${" [^}]+ "}" => [[ second >string [ get present write ] curry ]] -text = [^$]+ => [[ >string [ write ] curry ]] -interpolate = (var|text)* => [[ [ ] join ]] -EBNF] ; +TUPLE: interpolate-var name ; -EBNF: interpolate-locals -var = "${" [^}]+ "}" => [[ [ second >string search , [ present write ] % ] [ ] make ]] -text = [^$]+ => [[ [ >string , [ write ] % ] [ ] make ]] -interpolate = (var|text)* => [[ [ ] join ]] -;EBNF +: (parse-interpolate) ( string -- ) + [ + "${" split1-slice [ >string , ] [ + [ + "}" split1-slice + [ >string interpolate-var boa , ] + [ (parse-interpolate) ] bi* + ] when* + ] bi* + ] unless-empty ; + +: parse-interpolate ( string -- seq ) + [ (parse-interpolate) ] { } make ; + +MACRO: interpolate ( string -- ) + parse-interpolate [ + dup interpolate-var? + [ name>> '[ _ get present write ] ] + [ '[ _ write ] ] + if + ] map [ ] join ; + +: interpolate-locals ( string -- quot ) + parse-interpolate [ + dup interpolate-var? + [ name>> search '[ _ present write ] ] + [ '[ _ write ] ] + if + ] map [ ] join ; : I[ "]I" parse-multiline-string interpolate-locals parsed \ call parsed ; parsing From e304d3c9f8a31f0808ef6c7ef503f55329166dc0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 4 Dec 2008 06:02:49 -0600 Subject: [PATCH 34/37] Local DCE --- basis/compiler/tree/builder/builder.factor | 2 +- .../backend/backend-tests.factor | 11 ++-- basis/stack-checker/backend/backend.factor | 66 +++++++++++-------- basis/stack-checker/branches/branches.factor | 41 +++++++----- basis/stack-checker/inlining/inlining.factor | 17 +++-- .../known-words/known-words.factor | 52 +++++++++++---- basis/stack-checker/state/state.factor | 31 +++++++-- .../transforms/transforms.factor | 7 +- core/kernel/kernel.factor | 10 +-- 9 files changed, 149 insertions(+), 88 deletions(-) diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 4e79c4cd2d..b715223445 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -21,7 +21,7 @@ IN: compiler.tree.builder : build-tree-with ( in-stack quot -- nodes out-stack ) #! Not safe to call from inference transforms. [ - [ >vector meta-d set ] + [ >vector \ meta-d set ] [ f initial-recursive-state infer-quot ] bi* ] with-tree-builder nip unclip-last in-d>> ; diff --git a/basis/stack-checker/backend/backend-tests.factor b/basis/stack-checker/backend/backend-tests.factor index 3bbba0fcb8..48cd10a7ee 100644 --- a/basis/stack-checker/backend/backend-tests.factor +++ b/basis/stack-checker/backend/backend-tests.factor @@ -3,20 +3,21 @@ stack-checker.state sequences ; IN: stack-checker.backend.tests [ ] [ - V{ } clone meta-d set - V{ } clone meta-r set + V{ } clone \ meta-d set + V{ } clone \ meta-r set + V{ } clone \ literals set 0 d-in set ] unit-test [ 0 ] [ 0 ensure-d length ] unit-test [ 2 ] [ 2 ensure-d length ] unit-test -[ 2 ] [ meta-d get length ] unit-test +[ 2 ] [ meta-d length ] unit-test [ 3 ] [ 3 ensure-d length ] unit-test -[ 3 ] [ meta-d get length ] unit-test +[ 3 ] [ meta-d length ] unit-test [ 1 ] [ 1 ensure-d length ] unit-test -[ 3 ] [ meta-d get length ] unit-test +[ 3 ] [ meta-d length ] unit-test [ ] [ 1 consume-d drop ] unit-test diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 8bb19b82f7..56777cc8a7 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -9,10 +9,10 @@ stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state ; IN: stack-checker.backend -: push-d ( obj -- ) meta-d get push ; +: push-d ( obj -- ) meta-d push ; : pop-d ( -- obj ) - meta-d get [ + meta-d [ dup 1array #introduce, d-in inc ] [ pop ] if-empty ; @@ -22,46 +22,52 @@ IN: stack-checker.backend [ ] replicate ; : ensure-d ( n -- values ) - meta-d get 2dup length > [ + meta-d 2dup length > [ 2dup [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri - [ length d-in +@ ] [ #introduce, ] [ meta-d get push-all ] tri - meta-d get push-all + [ length d-in +@ ] [ #introduce, ] [ meta-d push-all ] tri + meta-d push-all ] when swap tail* ; : shorten-by ( n seq -- ) [ length swap - ] keep shorten ; inline : consume-d ( n -- seq ) - [ ensure-d ] [ meta-d get shorten-by ] bi ; + [ ensure-d ] [ meta-d shorten-by ] bi ; -: output-d ( values -- ) meta-d get push-all ; +: output-d ( values -- ) meta-d push-all ; : produce-d ( n -- values ) - make-values dup meta-d get push-all ; + make-values dup meta-d push-all ; -: push-r ( obj -- ) meta-r get push ; +: push-r ( obj -- ) meta-r push ; -: pop-r ( -- obj ) - meta-r get dup empty? +: pop-r ( -- obj ) + meta-r dup empty? [ too-many-r> inference-error ] [ pop ] if ; : consume-r ( n -- seq ) - meta-r get 2dup length > + meta-r 2dup length > [ too-many-r> inference-error ] when [ swap tail* ] [ shorten-by ] 2bi ; -: output-r ( seq -- ) meta-r get push-all ; - -: pop-literal ( -- rstate obj ) - pop-d - [ 1array #drop, ] - [ literal [ recursion>> ] [ value>> ] bi ] bi ; - -GENERIC: apply-object ( obj -- ) +: output-r ( seq -- ) meta-r push-all ; : push-literal ( obj -- ) - dup make-known [ nip push-d ] [ #push, ] 2bi ; + literals get push ; + +: pop-literal ( -- rstate obj ) + literals get [ + pop-d + [ 1array #drop, ] + [ literal [ recursion>> ] [ value>> ] bi ] bi + ] [ pop recursive-state get swap ] if-empty ; + +: literals-available? ( n -- literals ? ) + literals get 2dup length <= + [ [ swap tail* ] [ shorten-by ] 2bi t ] [ 2drop f f ] if ; + +GENERIC: apply-object ( obj -- ) M: wrapper apply-object wrapped>> @@ -72,10 +78,17 @@ M: wrapper apply-object M: object apply-object push-literal ; : terminate ( -- ) - terminated? on meta-d get clone meta-r get clone #terminate, ; + terminated? on meta-d clone meta-r clone #terminate, ; + +: check->r ( -- ) + meta-r empty? [ \ too-many->r inference-error ] unless ; : infer-quot-here ( quot -- ) - [ apply-object terminated? get not ] all? drop ; + meta-r [ + V{ } clone \ meta-r set + [ apply-object terminated? get not ] all? + [ commit-literals check->r ] [ literals get delete-all ] if + ] dip \ meta-r set ; : infer-quot ( quot rstate -- ) recursive-state get [ @@ -127,13 +140,8 @@ M: object apply-object push-literal ; : infer-word-def ( word -- ) [ specialized-def ] [ add-recursive-state ] bi infer-quot ; -: check->r ( -- ) - meta-r get empty? terminated? get or - [ \ too-many->r inference-error ] unless ; - : end-infer ( -- ) - check->r - meta-d get clone #return, ; + meta-d clone #return, ; : effect-required? ( word -- ? ) { diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index 7b461d0028..e4c11960de 100644 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -57,9 +57,9 @@ SYMBOL: quotations branch-variable ; : datastack-phi ( seq -- phi-in phi-out ) - [ d-in branch-variable ] [ meta-d active-variable ] bi + [ d-in branch-variable ] [ \ meta-d active-variable ] bi unify-branches - [ d-in set ] [ ] [ dup >vector meta-d set ] tri* ; + [ d-in set ] [ ] [ dup >vector \ meta-d set ] tri* ; : terminated-phi ( seq -- terminated ) terminated? branch-variable ; @@ -74,17 +74,25 @@ SYMBOL: quotations tri ; : copy-inference ( -- ) - meta-d [ clone ] change - V{ } clone meta-r set + \ meta-d [ clone ] change + literals [ clone ] change d-in [ ] change ; -: infer-branch ( literal -- namespace ) +GENERIC: infer-branch ( literal -- namespace ) + +M: literal infer-branch [ copy-inference nest-visitor [ value>> quotation set ] [ infer-literal-quot ] bi - check->r - ] H{ } make-assoc ; inline + ] H{ } make-assoc ; + +M: callable infer-branch + [ + copy-inference + nest-visitor + [ quotation set ] [ infer-quot-here ] bi + ] H{ } make-assoc ; : infer-branches ( branches -- input children data ) [ pop-d ] dip @@ -96,16 +104,19 @@ SYMBOL: quotations [ first2 #if, ] dip compute-phi-function ; : infer-if ( -- ) - 2 consume-d - dup [ known [ curried? ] [ composed? ] bi or ] contains? [ - output-d - [ rot [ drop call ] [ nip call ] if ] - infer-quot-here + 2 literals-available? [ + (infer-if) ] [ - [ #drop, ] [ [ literal ] map (infer-if) ] bi + drop 2 consume-d + dup [ known [ curried? ] [ composed? ] bi or ] contains? [ + output-d + [ rot [ drop call ] [ nip call ] if ] + infer-quot-here + ] [ + [ #drop, ] [ [ literal ] map (infer-if) ] bi + ] if ] if ; : infer-dispatch ( -- ) - pop-literal nip [ ] map - infer-branches + pop-literal nip infer-branches [ #dispatch, ] dip compute-phi-function ; diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index df0145b73e..23283fb6e3 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -51,14 +51,14 @@ SYMBOL: enter-out : prepare-stack ( word -- ) required-stack-effect in>> [ length ensure-d drop ] [ - meta-d get clone enter-in set - meta-d get swap make-copies enter-out set + meta-d clone enter-in set + meta-d swap make-copies enter-out set ] bi ; : emit-enter-recursive ( label -- ) enter-out get >>enter-out enter-in get enter-out get #enter-recursive, - enter-out get >vector meta-d set ; + enter-out get >vector \ meta-d set ; : entry-stack-height ( label -- stack ) enter-out>> length ; @@ -77,7 +77,7 @@ SYMBOL: enter-out : end-recursive-word ( word label -- ) [ check-return ] - [ meta-d get dup copy-values dup meta-d set #return-recursive, ] + [ meta-d dup copy-values dup \ meta-d set #return-recursive, ] bi ; : recursive-word-inputs ( label -- n ) @@ -95,10 +95,8 @@ SYMBOL: enter-out [ nip ] 2tri - check->r - dup recursive-word-inputs - meta-d get + meta-d stack-visitor get terminated? get ] with-scope ; @@ -116,7 +114,7 @@ SYMBOL: enter-out swap word>> required-stack-effect in>> length tail* ; : call-site-stack ( label -- stack ) - meta-d get trim-stack ; + meta-d trim-stack ; : trimmed-enter-out ( label -- stack ) dup enter-out>> trim-stack ; @@ -131,7 +129,7 @@ SYMBOL: enter-out : adjust-stack-effect ( effect -- effect' ) [ in>> ] [ out>> ] bi - meta-d get length pick length [-] + meta-d length pick length [-] object '[ _ prepend ] bi@ ; @@ -142,6 +140,7 @@ SYMBOL: enter-out ] [ drop undeclared-recursion-error inference-error ] if ; : inline-word ( word -- ) + commit-literals [ inlined-dependency depends-on ] [ dup inline-recursive-label [ diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 12eb637964..26e1b81c93 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -63,7 +63,9 @@ IN: stack-checker.known-words GENERIC: infer-call* ( value known -- ) -: infer-call ( value -- ) dup known infer-call* ; +: (infer-call) ( value -- ) dup known infer-call* ; + +: infer-call ( -- ) pop-d (infer-call) ; M: literal infer-call* [ 1array #drop, ] [ infer-literal-quot ] bi* ; @@ -73,7 +75,7 @@ M: curried infer-call* [ uncurry ] infer-quot-here [ quot>> known pop-d [ set-known ] keep ] [ obj>> known pop-d [ set-known ] keep ] bi - push-d infer-call ; + push-d (infer-call) ; M: composed infer-call* swap push-d @@ -81,20 +83,41 @@ M: composed infer-call* [ quot2>> known pop-d [ set-known ] keep ] [ quot1>> known pop-d [ set-known ] keep ] bi push-d push-d - 1 infer->r pop-d infer-call - terminated? get [ 1 infer-r> pop-d infer-call ] unless ; + 1 infer->r infer-call + terminated? get [ 1 infer-r> infer-call ] unless ; M: object infer-call* \ literal-expected inference-warning ; : infer-slip ( -- ) - 1 infer->r pop-d infer-call 1 infer-r> ; + 1 infer->r infer-call 1 infer-r> ; : infer-2slip ( -- ) - 2 infer->r pop-d infer-call 2 infer-r> ; + 2 infer->r infer-call 2 infer-r> ; : infer-3slip ( -- ) - 3 infer->r pop-d infer-call 3 infer-r> ; + 3 infer->r infer-call 3 infer-r> ; + +: infer-dip ( -- ) + commit-literals + literals get + [ \ dip def>> infer-quot-here ] + [ pop 1 infer->r infer-quot-here 1 infer-r> ] + if-empty ; + +: infer-2dip ( -- ) + commit-literals + literals get + [ \ 2dip def>> infer-quot-here ] + [ pop 2 infer->r infer-quot-here 2 infer-r> ] + if-empty ; + +: infer-3dip ( -- ) + commit-literals + literals get + [ \ 3dip def>> infer-quot-here ] + [ pop 3 infer->r infer-quot-here 3 infer-r> ] + if-empty ; : infer-curry ( -- ) 2 consume-d @@ -157,11 +180,14 @@ M: object infer-call* { \ >r [ 1 infer->r ] } { \ r> [ 1 infer-r> ] } { \ declare [ infer-declare ] } - { \ call [ pop-d infer-call ] } - { \ (call) [ pop-d infer-call ] } + { \ call [ infer-call ] } + { \ (call) [ infer-call ] } { \ slip [ infer-slip ] } { \ 2slip [ infer-2slip ] } { \ 3slip [ infer-3slip ] } + { \ dip [ infer-dip ] } + { \ 2dip [ infer-2dip ] } + { \ 3dip [ infer-3dip ] } { \ curry [ infer-curry ] } { \ compose [ infer-compose ] } { \ execute [ infer-execute ] } @@ -190,10 +216,10 @@ M: object infer-call* "local-word-def" word-prop infer-quot-here ; { - >r r> declare call (call) slip 2slip 3slip curry compose - execute (execute) if dispatch (throw) - load-locals get-local drop-locals do-primitive alien-invoke - alien-indirect alien-callback + >r r> declare call (call) slip 2slip 3slip dip 2dip 3dip + curry compose execute (execute) if dispatch + (throw) load-locals get-local drop-locals do-primitive + alien-invoke alien-indirect alien-callback } [ t "special" set-word-prop ] each { call execute dispatch load-locals get-local drop-locals } diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 2706ec60ef..130147f798 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs arrays namespaces sequences kernel definitions math effects accessors words fry classes.algebra -compiler.units ; +compiler.units stack-checker.values stack-checker.visitor ; IN: stack-checker.state ! Did the current control-flow path throw an error? @@ -11,23 +11,40 @@ SYMBOL: terminated? ! Number of inputs current word expects from the stack SYMBOL: d-in +DEFER: commit-literals + ! Compile-time data stack -SYMBOL: meta-d +: meta-d ( -- stack ) commit-literals \ meta-d get ; ! Compile-time retain stack -SYMBOL: meta-r +: meta-r ( -- stack ) \ meta-r get ; -: current-stack-height ( -- n ) meta-d get length d-in get - ; +! Uncommitted literals. This is a form of local dead-code +! elimination; the goal is to reduce the number of IR nodes +! which get constructed. Technically it is redundant since +! we do global DCE later, but it speeds up compile time. +SYMBOL: literals + +: (push-literal) ( obj -- ) + dup make-known + [ nip \ meta-d get push ] [ #push, ] 2bi ; + +: commit-literals ( -- ) + literals get [ + [ [ (push-literal) ] each ] [ delete-all ] bi + ] unless-empty ; + +: current-stack-height ( -- n ) meta-d length d-in get - ; : current-effect ( -- effect ) d-in get - meta-d get length + meta-d length terminated? get >>terminated? ; : init-inference ( -- ) terminated? off - V{ } clone meta-d set - V{ } clone meta-r set + V{ } clone \ meta-d set + V{ } clone literals set 0 d-in set ; ! Words that the current quotation depends on diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 7eec29f94b..299dc1b551 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -19,11 +19,8 @@ IN: stack-checker.transforms rot with-datastack first2 dup [ [ - [ drop ] [ - [ length meta-d get '[ _ pop* ] times ] - [ #drop, ] - bi - ] bi* + [ drop ] + [ [ length meta-d shorten-by ] [ #drop, ] bi ] bi* ] 2dip swap infer-quot ] [ diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index bbe2d348d8..98dc0e50fa 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -52,7 +52,9 @@ DEFER: if : ?if ( default cond true false -- ) pick [ roll 2drop call ] [ 2nip call ] if ; inline -! Slippers +! Slippers and dippers. +! Not declared inline because the compiler special-cases them + : slip ( quot x -- x ) #! 'slip' and 'dip' can be defined in terms of each other #! because the JIT special-cases a 'dip' preceeded by @@ -71,11 +73,11 @@ DEFER: if #! a literal quotation. [ call ] 3dip ; -: dip ( x quot -- x ) swap slip ; inline +: dip ( x quot -- x ) swap slip ; -: 2dip ( x y quot -- x y ) -rot 2slip ; inline +: 2dip ( x y quot -- x y ) -rot 2slip ; -: 3dip ( x y z quot -- x y z ) -roll 3slip ; inline +: 3dip ( x y z quot -- x y z ) -roll 3slip ; ! Keepers : keep ( x quot -- x ) over slip ; inline From 0e060c5cfdaa09d679b3b6546e8193b9c181ee1d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 4 Dec 2008 06:28:49 -0600 Subject: [PATCH 35/37] fix db load error --- basis/db/postgresql/postgresql.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index 82d96c4af1..90a875b8ff 100644 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -267,7 +267,7 @@ ERROR: no-compound-found string object ; M: postgresql-db compound ( string object -- string' ) over { { "default" [ first number>string " " glue ] } - { "varchar" [ first number>string paren append ] } + { "varchar" [ first number>string "(" ")" surround append ] } { "references" [ >reference-string ] } [ drop no-compound-found ] } case ; From 041d2f328623da3d14ec5477cd186f8f97e1140d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 4 Dec 2008 06:31:08 -0600 Subject: [PATCH 36/37] fix load error --- extra/hardware-info/windows/nt/nt.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor index 6215566f11..dafa90bcec 100755 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -1,6 +1,7 @@ USING: alien alien.c-types alien.strings kernel libc math namespaces hardware-info.backend -windows windows.advapi32 windows.kernel32 system ; +hardware-info.windows windows windows.advapi32 +windows.kernel32 system ; IN: hardware-info.windows.nt M: winnt cpus ( -- n ) From fa6a2047f04885e276d6e060c9c38922430608cc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 4 Dec 2008 07:05:59 -0600 Subject: [PATCH 37/37] New inlining heuristic: number of usages within this word. Speeds up bootstrap by 10% --- .../tree/propagation/inlining/inlining.factor | 26 ++++++++++++++----- .../tree/propagation/nodes/nodes.factor | 2 ++ .../tree/propagation/propagation.factor | 1 + .../propagation/recursive/recursive.factor | 4 +++ 4 files changed, 26 insertions(+), 7 deletions(-) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 83a4a7aef7..3a94029756 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -20,6 +20,10 @@ SYMBOL: node-count : count-nodes ( nodes -- ) 0 swap [ drop 1+ ] each-node node-count set ; +! We try not to inline the same word too many times, to avoid +! combinatorial explosion +SYMBOL: inlining-count + ! Splicing nodes GENERIC: splicing-nodes ( #call word/quot/f -- nodes ) @@ -120,17 +124,25 @@ DEFER: (flat-length) bi and ] contains? ; +: node-count-bias ( -- n ) + 45 node-count get [-] 8 /i ; + +: body-length-bias ( word -- n ) + [ flat-length ] [ inlining-count get at 0 or 2/ 1+ ] bi * + 24 swap [-] 4 /i ; + : inlining-rank ( #call word -- n ) [ classes-known? 2 0 ? ] [ { - [ drop node-count get 45 swap [-] 8 /i ] - [ flat-length 24 swap [-] 4 /i ] + [ body-length-bias ] [ "default" word-prop -4 0 ? ] [ "specializer" word-prop 1 0 ? ] [ method-body? 1 0 ? ] } cleave - ] bi* + + + + + ; + node-count-bias + loop-nesting get 0 or 2 * + ] bi* + + + + + + ; : should-inline? ( #call word -- ? ) dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ; @@ -138,12 +150,12 @@ DEFER: (flat-length) SYMBOL: history : remember-inlining ( word -- ) - history [ swap suffix ] change ; + [ [ 1 ] dip inlining-count get at+ ] + [ history [ swap suffix ] change ] + bi ; : inline-word-def ( #call word quot -- ? ) - over history get memq? [ - 3drop f - ] [ + over history get memq? [ 3drop f ] [ [ swap remember-inlining dupd splicing-nodes >>body diff --git a/basis/compiler/tree/propagation/nodes/nodes.factor b/basis/compiler/tree/propagation/nodes/nodes.factor index 9e4d99e462..d676102bde 100644 --- a/basis/compiler/tree/propagation/nodes/nodes.factor +++ b/basis/compiler/tree/propagation/nodes/nodes.factor @@ -6,6 +6,8 @@ compiler.tree.propagation.copy compiler.tree.propagation.info ; IN: compiler.tree.propagation.nodes +SYMBOL: loop-nesting + GENERIC: propagate-before ( node -- ) GENERIC: propagate-after ( node -- ) diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor index b9822d2c6b..2a9825e3f1 100644 --- a/basis/compiler/tree/propagation/propagation.factor +++ b/basis/compiler/tree/propagation/propagation.factor @@ -19,5 +19,6 @@ IN: compiler.tree.propagation H{ } clone copies set H{ } clone 1array value-infos set H{ } clone 1array constraints set + H{ } clone inlining-count set dup count-nodes dup (propagate) ; diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor index 7f10f87016..ff9f262d28 100644 --- a/basis/compiler/tree/propagation/recursive/recursive.factor +++ b/basis/compiler/tree/propagation/recursive/recursive.factor @@ -55,6 +55,8 @@ IN: compiler.tree.propagation.recursive M: #recursive propagate-around ( #recursive -- ) constraints [ H{ } clone suffix ] change [ + loop-nesting inc + constraints [ but-last H{ } clone suffix ] change child>> @@ -62,6 +64,8 @@ M: #recursive propagate-around ( #recursive -- ) [ first propagate-recursive-phi ] [ (propagate) ] tri + + loop-nesting dec ] until-fixed-point ; : recursive-phi-infos ( node -- infos )