From 14ef1649d423a8e6b18f8c50b3f9c8d8ae2fc55b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 17:59:40 -0500 Subject: [PATCH 01/11] add if-zero/when-zero/unless-zero to core/ and update usages --- core/arrays/arrays.factor | 2 +- core/io/encodings/utf8/utf8.factor | 4 ++-- core/math/integers/integers.factor | 6 +++--- core/math/parser/parser.factor | 2 +- core/sequences/sequences-docs.factor | 2 +- core/sequences/sequences.factor | 16 +++++++++++++++- core/splitting/splitting.factor | 2 +- 7 files changed, 24 insertions(+), 10 deletions(-) diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor index 4a998a1ebb..dd70e45b6b 100644 --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -14,7 +14,7 @@ M: array resize resize-array ; M: object new-sequence drop 0 ; -M: f new-sequence drop dup zero? [ drop f ] [ 0 ] if ; +M: f new-sequence drop [ f ] [ 0 ] if-zero ; M: array equal? over array? [ sequence= ] [ 2drop f ] if ; diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index 4846b06f32..a722655cad 100755 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -73,14 +73,14 @@ M: utf8 encode-char PRIVATE> : code-point-length ( n -- x ) - dup zero? [ drop 1 ] [ + [ 1 ] [ log2 { { [ dup 0 6 between? ] [ 1 ] } { [ dup 7 10 between? ] [ 2 ] } { [ dup 11 15 between? ] [ 3 ] } { [ dup 16 20 between? ] [ 4 ] } } cond nip - ] if ; + ] if-zero ; : code-point-offsets ( string -- indices ) 0 [ code-point-length + ] accumulate swap suffix ; diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index bb7fc107b2..2b35ef76fd 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -121,14 +121,14 @@ M: bignum (log2) bignum-log2 ; over zero? [ 2drop 0.0 ] [ - dup zero? [ - 2drop 1/0. + [ + drop 1/0. ] [ pre-scale /f-loop over odd? [ zero? [ 1 + ] unless ] [ drop ] if post-scale - ] if + ] if-zero ] if ; inline M: bignum /f ( m n -- f ) diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 437308d53f..ef8f350e27 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -131,7 +131,7 @@ M: ratio >base [ dup 0 < negative? set abs 1 /mod - [ dup zero? [ drop "" ] [ (>base) sign append ] if ] + [ [ "" ] [ (>base) sign append ] if-zero ] [ [ numerator (>base) ] [ denominator (>base) ] bi diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 71d42705a2..d7db7f5242 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1214,7 +1214,7 @@ HELP: follow { $examples "Get random numbers until zero is reached:" { $unchecked-example "USING: random sequences prettyprint math ;" - "100 [ random dup zero? [ drop f ] when ] follow ." + "100 [ random [ f ] when-zero ] follow ." "{ 100 86 34 32 24 11 7 2 }" } } ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index f0dc6d36c7..2e41d9d2e1 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -29,13 +29,27 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; : empty? ( seq -- ? ) length 0 = ; inline + + : if-empty ( seq quot1 quot2 -- ) - [ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline + [ dup empty? ] (if-empty) ; inline : when-empty ( seq quot -- ) [ ] if-empty ; inline : unless-empty ( seq quot -- ) [ ] swap if-empty ; inline +: if-zero ( n quot1 quot2 -- ) + [ dup zero? ] (if-empty) ; inline + +: when-zero ( seq quot -- ) [ ] if-zero ; inline + +: unless-zero ( seq quot -- ) [ ] swap if-zero ; inline + : delete-all ( seq -- ) 0 swap set-length ; : first ( seq -- first ) 0 swap nth ; inline diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 5ec396e5ba..7aae30f20b 100644 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -58,7 +58,7 @@ PRIVATE> : (split) ( separators n seq -- ) 3dup rot [ member? ] curry find-from drop [ [ swap subseq , ] 2keep 1 + swap (split) ] - [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive + [ swap [ tail ] unless-zero , drop ] if* ; inline recursive : split, ( seq separators -- ) 0 rot (split) ; From 4fef246ca4aa4d43c345fe8a98e54f9f982b40cf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 18:00:24 -0500 Subject: [PATCH 02/11] add 10^ to math.functions and update usages --- basis/calendar/format/format.factor | 2 +- basis/formatting/formatting.factor | 2 +- basis/io/files/info/windows/windows.factor | 6 +++--- basis/math/functions/functions.factor | 6 +++++- extra/math/analysis/analysis.factor | 4 ++-- extra/math/text/english/english.factor | 2 +- extra/math/text/french/french.factor | 2 +- extra/math/text/utils/utils-docs.factor | 6 +++--- extra/math/text/utils/utils-tests.factor | 2 +- extra/math/text/utils/utils.factor | 6 +++--- extra/money/money.factor | 2 +- extra/project-euler/048/048.factor | 5 +++-- extra/project-euler/ave-time/ave-time.factor | 6 +++--- extra/svg/svg.factor | 2 +- 14 files changed, 29 insertions(+), 24 deletions(-) mode change 100644 => 100755 extra/math/text/utils/utils-docs.factor mode change 100644 => 100755 extra/math/text/utils/utils-tests.factor mode change 100644 => 100755 extra/math/text/utils/utils.factor diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index ad43cc2f1d..a187f0c9af 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -162,7 +162,7 @@ M: timestamp year. ( timestamp -- ) : read-rfc3339-seconds ( s -- s' ch ) "+-Z" read-until [ - [ string>number ] [ length 10 swap ^ ] bi / + + [ string>number ] [ length 10^ ] bi / + ] dip ; : (rfc3339>timestamp) ( -- timestamp ) diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index f8b9ba501b..55ebdf1442 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -32,7 +32,7 @@ IN: formatting [ "." split1 ] dip [ CHAR: 0 pad-tail ] [ head-slice ] bi "." glue ; : max-digits ( n digits -- n' ) - 10 swap ^ [ * round ] keep / ; inline + 10^ [ * round ] keep / ; inline : >exp ( x -- exp base ) [ diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index 81e43f8dd9..88e1547b7b 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -9,11 +9,11 @@ calendar ascii combinators.short-circuit locals ; IN: io.files.info.windows :: round-up-to ( n multiple -- n' ) - n multiple rem dup 0 = [ - drop n + n multiple rem [ + n ] [ multiple swap - n + - ] if ; + ] if-zero ; TUPLE: windows-file-info < file-info attributes ; diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 314062591d..3cbe8e19d4 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -104,10 +104,12 @@ PRIVATE> : divisor? ( m n -- ? ) mod 0 = ; +ERROR: non-trivial-divisor n ; + : mod-inv ( x n -- y ) [ nip ] [ gcd 1 = ] 2bi [ dup 0 < [ + ] [ nip ] if ] - [ "Non-trivial divisor found" throw ] if ; foldable + [ non-trivial-divisor ] if ; foldable : ^mod ( x y n -- z ) over 0 < [ @@ -116,6 +118,8 @@ PRIVATE> -rot (^mod) ] if ; foldable +: 10^ ( n -- n' ) 10 swap ^ ; inline + GENERIC: absq ( x -- y ) foldable M: real absq sq ; diff --git a/extra/math/analysis/analysis.factor b/extra/math/analysis/analysis.factor index a1fc0bd07b..16a45fc691 100755 --- a/extra/math/analysis/analysis.factor +++ b/extra/math/analysis/analysis.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman, Slava Pestov, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.short-circuit kernel math math.constants math.functions - math.vectors sequences ; +USING: combinators.short-circuit kernel math math.constants +math.functions math.vectors sequences ; IN: math.analysis text) ( n -- str ) - [ negative-text ] [ abs 3digit-groups recombine ] bi append ; + [ negative-text ] [ abs 3 digit-groups recombine ] bi append ; PRIVATE> diff --git a/extra/math/text/french/french.factor b/extra/math/text/french/french.factor index f8b97103eb..46e326b7e7 100644 --- a/extra/math/text/french/french.factor +++ b/extra/math/text/french/french.factor @@ -73,7 +73,7 @@ MEMO: units ( -- seq ) ! up to 10^99 } cond ; : over-1000000 ( n -- str ) - 3digit-groups [ 1+ units nth n-units ] map-index sift + 3 digit-groups [ 1+ units nth n-units ] map-index sift reverse " " join ; : decompose ( n -- str ) 1000000 /mod [ over-1000000 ] dip complete ; diff --git a/extra/math/text/utils/utils-docs.factor b/extra/math/text/utils/utils-docs.factor old mode 100644 new mode 100755 index e1d1a005d3..2352ab9488 --- a/extra/math/text/utils/utils-docs.factor +++ b/extra/math/text/utils/utils-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax ; IN: math.text.utils -HELP: 3digit-groups -{ $values { "n" "a positive integer" } { "seq" "a sequence" } } -{ $description "Decompose a number into 3 digits groups and return them in a sequence, starting with the units, then the tenths, etc." } ; +HELP: digit-groups +{ $values { "n" "a positive integer" } { "k" "a positive integer" } { "seq" "a sequence" } } +{ $description "Decompose a number into groups of " { $snippet "k" } " digits and return them in a sequence starting with the least significant grouped digits first." } ; diff --git a/extra/math/text/utils/utils-tests.factor b/extra/math/text/utils/utils-tests.factor old mode 100644 new mode 100755 index d14bb06a2a..04fbcdc1a7 --- a/extra/math/text/utils/utils-tests.factor +++ b/extra/math/text/utils/utils-tests.factor @@ -1,3 +1,3 @@ USING: math.text.utils tools.test ; -[ { 1 999 2 } ] [ 2999001 3digit-groups ] unit-test +[ { 1 999 2 } ] [ 2999001 3 digit-groups ] unit-test diff --git a/extra/math/text/utils/utils.factor b/extra/math/text/utils/utils.factor old mode 100644 new mode 100755 index 422a79a1f3..13551f19e4 --- a/extra/math/text/utils/utils.factor +++ b/extra/math/text/utils/utils.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007, 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences ; +USING: kernel fry math.functions math sequences ; IN: math.text.utils -: 3digit-groups ( n -- seq ) - [ dup 0 > ] [ 1000 /mod ] produce nip ; +: digit-groups ( n k -- seq ) + [ dup 0 > ] swap '[ _ 10^ /mod ] produce nip ; diff --git a/extra/money/money.factor b/extra/money/money.factor index 994d214335..36dedb2a65 100644 --- a/extra/money/money.factor +++ b/extra/money/money.factor @@ -28,6 +28,6 @@ ERROR: not-an-integer x ; [ [ dup string>number [ nip ] [ not-an-integer ] if* ] bi@ ] keep length - 10 swap ^ / + swap [ neg ] when ; + 10^ / + swap [ neg ] when ; SYNTAX: DECIMAL: scan parse-decimal parsed ; diff --git a/extra/project-euler/048/048.factor b/extra/project-euler/048/048.factor index 640a3a68f6..fde3fa6026 100644 --- a/extra/project-euler/048/048.factor +++ b/extra/project-euler/048/048.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions math.ranges project-euler.common sequences ; +USING: kernel math math.functions math.ranges +project-euler.common sequences ; IN: project-euler.048 ! http://projecteuler.net/index.php?section=problems&id=48 @@ -17,7 +18,7 @@ IN: project-euler.048 ! -------- : euler048 ( -- answer ) - 1000 [1,b] [ dup ^ ] sigma 10 10 ^ mod ; + 1000 [1,b] [ dup ^ ] sigma 10 10^ mod ; ! [ euler048 ] 100 ave-time ! 276 ms run / 1 ms GC ave time - 100 trials diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor index a7762836f1..6c555f92b5 100644 --- a/extra/project-euler/ave-time/ave-time.factor +++ b/extra/project-euler/ave-time/ave-time.factor @@ -1,11 +1,11 @@ ! 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 ; +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 ; + 10^ [ * round >integer ] keep /f ; : collect-benchmarks ( quot n -- seq ) [ diff --git a/extra/svg/svg.factor b/extra/svg/svg.factor index 2ed5d21707..2d2d38314a 100644 --- a/extra/svg/svg.factor +++ b/extra/svg/svg.factor @@ -11,7 +11,7 @@ XML-NS: inkscape-name http://www.inkscape.org/namespaces/inkscape : svg-string>number ( string -- number ) { { CHAR: E CHAR: e } } substitute "e" split1 - [ string>number ] [ [ string>number 10 swap ^ ] [ 1 ] if* ] bi* * + [ string>number ] [ [ string>number 10^ ] [ 1 ] if* ] bi* * >float ; : degrees ( deg -- rad ) pi * 180.0 / ; From 15ae8fb673e4b4fbfa9732bcf8a9fabbef414909 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 18:15:24 -0500 Subject: [PATCH 03/11] fix sgn docs --- core/math/math-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 55a50cd5d7..c4a1bb4f34 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -213,9 +213,9 @@ HELP: sgn { $description "Outputs one of the following:" { $list - "-1 if " { $snippet "x" } " is negative" - "0 if " { $snippet "x" } " is equal to 0" - "1 if " { $snippet "x" } " is positive" + { "-1 if " { $snippet "x" } " is negative" } + { "0 if " { $snippet "x" } " is equal to 0" } + { "1 if " { $snippet "x" } " is positive" } } } ; From 4a3d63e00ae0a5e27d65a0fee0c55c98a49f627b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 18:15:53 -0500 Subject: [PATCH 04/11] use if-zero in a few more places --- basis/calendar/calendar.factor | 4 ++-- basis/io/sockets/unix/unix.factor | 2 +- basis/math/bits/bits.factor | 2 +- basis/math/functions/functions.factor | 8 ++++---- basis/math/primes/erato/erato.factor | 4 ++-- basis/math/ratios/ratios.factor | 14 ++++++++++---- basis/serialize/serialize.factor | 12 ++++++------ basis/windows/errors/errors.factor | 6 +----- extra/benchmark/fasta/fasta.factor | 2 +- extra/game-loop/game-loop.factor | 7 ++++--- 10 files changed, 32 insertions(+), 29 deletions(-) diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 4b58b1b496..e9028b7841 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -45,11 +45,11 @@ M: not-a-month summary PRIVATE> -: month-names ( -- array ) +CONSTANT: month-names { "January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December" - } ; + } : month-name ( n -- string ) check-month 1- month-names nth ; diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index fe136cd887..ec8b4206e3 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -19,7 +19,7 @@ IN: io.sockets.unix [ handle-fd ] 2dip 1 "int" heap-size setsockopt io-error ; M: unix addrinfo-error ( n -- ) - dup zero? [ drop ] [ gai_strerror throw ] if ; + [ gai_strerror throw ] unless-zero ; ! Client sockets - TCP and Unix domain M: object (get-local-address) ( handle remote -- sockaddr ) diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor index 0fbfdf0bd9..27a9a23ca3 100644 --- a/basis/math/bits/bits.factor +++ b/basis/math/bits/bits.factor @@ -7,7 +7,7 @@ TUPLE: bits { number read-only } { length read-only } ; C: bits : make-bits ( number -- bits ) - dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + ] if ; inline + [ T{ bits f 0 0 } ] [ dup abs log2 1 + ] if-zero ; inline M: bits length length>> ; diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 3cbe8e19d4..8a0d39063b 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -71,7 +71,7 @@ PRIVATE> 2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline : 0^ ( x -- z ) - dup zero? [ drop 0/0. ] [ 0 < 1/0. 0 ? ] if ; inline + [ 0/0. ] [ 0 < 1/0. 0 ? ] if-zero ; inline : (^mod) ( n x y -- z ) make-bits 1 [ @@ -263,13 +263,13 @@ M: real atan fatan ; : round ( x -- y ) dup sgn 2 / + truncate ; inline : floor ( x -- y ) - dup 1 mod dup zero? - [ drop ] [ dup 0 < [ - 1 - ] [ - ] if ] if ; foldable + dup 1 mod + [ ] [ dup 0 < [ - 1 - ] [ - ] if ] if-zero ; foldable : ceiling ( x -- y ) neg floor neg ; foldable : floor-to ( x step -- y ) - dup zero? [ drop ] [ [ / floor ] [ * ] bi ] if ; + [ [ / floor ] [ * ] bi ] unless-zero ; : lerp ( a b t -- a_t ) [ over - ] dip * + ; inline diff --git a/basis/math/primes/erato/erato.factor b/basis/math/primes/erato/erato.factor index 673f9c97cd..fdc2f9fc3b 100644 --- a/basis/math/primes/erato/erato.factor +++ b/basis/math/primes/erato/erato.factor @@ -9,7 +9,7 @@ IN: math.primes.erato CONSTANT: masks B{ 0 128 0 0 0 0 0 64 0 0 0 32 0 16 0 0 0 8 0 4 0 0 0 2 0 0 0 0 0 1 } : bit-pos ( n -- byte/f mask/f ) - 30 /mod masks nth-unsafe dup zero? [ 2drop f f ] when ; + 30 /mod masks nth-unsafe [ drop f f ] when-zero ; : marked-unsafe? ( n arr -- ? ) [ bit-pos ] dip swap [ [ nth-unsafe ] [ bitand zero? not ] bi* ] [ 2drop f ] if* ; @@ -38,4 +38,4 @@ PRIVATE> : marked-prime? ( n arr -- ? ) 2dup upper-bound 2 swap between? [ bounds-error ] unless - over { 2 3 5 } member? [ 2drop t ] [ marked-unsafe? ] if ; \ No newline at end of file + over { 2 3 5 } member? [ 2drop t ] [ marked-unsafe? ] if ; diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index d4f457180e..10ba14d13c 100644 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel kernel.private math math.functions math.private ; +USING: accessors kernel kernel.private math math.functions +math.private sequences summary ; IN: math.ratios : 2>fraction ( a/b c/d -- a c b d ) @@ -19,13 +20,18 @@ IN: math.ratios PRIVATE> +ERROR: division-by-zero ; + +M: division-by-zero summary + drop "Division by zero" ; + M: integer / - dup zero? [ - "Division by zero" throw + [ + division-by-zero ] [ dup 0 < [ [ neg ] bi@ ] when 2dup gcd nip [ /i ] curry bi@ fraction> - ] if ; + ] if-zero ; M: ratio hashcode* nip >fraction [ hashcode ] bi@ bitxor ; diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor index b7e395fa35..da154444c1 100644 --- a/basis/serialize/serialize.factor +++ b/basis/serialize/serialize.factor @@ -47,7 +47,7 @@ M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ; ! The last case is needed because a very large number would ! otherwise be confused with a small number. : serialize-cell ( n -- ) - dup zero? [ drop 0 write1 ] [ + [ 0 write1 ] [ dup HEX: 7e <= [ HEX: 80 bitor write1 ] [ @@ -60,7 +60,7 @@ M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ; ] if >be write ] if - ] if ; + ] if-zero ; : deserialize-cell ( -- n ) read1 { @@ -79,12 +79,12 @@ M: f (serialize) ( obj -- ) drop CHAR: n write1 ; M: integer (serialize) ( obj -- ) - dup zero? [ - drop CHAR: z write1 + [ + CHAR: z write1 ] [ dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1 serialize-cell - ] if ; + ] if-zero ; M: float (serialize) ( obj -- ) CHAR: F write1 @@ -295,4 +295,4 @@ PRIVATE> binary [ deserialize ] with-byte-reader ; : object>bytes ( obj -- bytes ) - binary [ serialize ] with-byte-writer ; \ No newline at end of file + binary [ serialize ] with-byte-writer ; diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index d180cb20e7..8bdbb9f1e9 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -713,11 +713,7 @@ ERROR: error-message-failed id ; GetLastError n>win32-error-string ; : (win32-error) ( n -- ) - dup zero? [ - drop - ] [ - win32-error-string throw - ] if ; + [ win32-error-string throw ] unless-zero ; : win32-error ( -- ) GetLastError (win32-error) ; diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index f457b90c30..c1d554a5a3 100755 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -63,7 +63,7 @@ CONSTANT: homo-sapiens :: split-lines ( n quot -- ) n line-length /mod [ [ line-length quot call ] times ] dip - dup zero? [ drop ] quot if ; inline + quot unless-zero ; inline : write-random-fasta ( seed n chars floats desc id -- seed ) write-description diff --git a/extra/game-loop/game-loop.factor b/extra/game-loop/game-loop.factor index 982319541b..5fe3d85e02 100644 --- a/extra/game-loop/game-loop.factor +++ b/extra/game-loop/game-loop.factor @@ -1,5 +1,6 @@ USING: accessors calendar continuations destructors kernel math -math.order namespaces system threads ui ui.gadgets.worlds ; +math.order namespaces system threads ui ui.gadgets.worlds +sequences ; IN: game-loop TUPLE: game-loop @@ -52,11 +53,11 @@ TUPLE: game-loop-error game-loop error ; drop ; : ?tick ( loop count -- ) - dup zero? [ drop millis >>last-tick drop ] [ + [ millis >>last-tick drop ] [ over [ since-last-tick ] [ tick-length>> ] bi >= [ [ drop increment-tick ] [ drop tick ] [ 1- ?tick ] 2tri ] [ 2drop ] if - ] if ; + ] if-zero ; : (run-loop) ( loop -- ) dup running?>> From eccc919c1891f6f1992dfe0b545a4b0f2603cb1d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 18:22:44 -0500 Subject: [PATCH 05/11] fix project euler 151 and add a unit test --- extra/project-euler/151/151-tests.factor | 4 ++++ extra/project-euler/151/151.factor | 10 ++++------ 2 files changed, 8 insertions(+), 6 deletions(-) create mode 100644 extra/project-euler/151/151-tests.factor diff --git a/extra/project-euler/151/151-tests.factor b/extra/project-euler/151/151-tests.factor new file mode 100644 index 0000000000..beea8e3645 --- /dev/null +++ b/extra/project-euler/151/151-tests.factor @@ -0,0 +1,4 @@ +USING: project-euler.151 tools.test ; +IN: project-euler.151.tests + +[ 12138569781349/26138246400000 ] [ euler151 ] unit-test diff --git a/extra/project-euler/151/151.factor b/extra/project-euler/151/151.factor index 66c5a6301e..708fe9849e 100644 --- a/extra/project-euler/151/151.factor +++ b/extra/project-euler/151/151.factor @@ -39,11 +39,11 @@ SYMBOL: table : (pick-sheet) ( seq i -- newseq ) [ - <=> sgn + <=> { - { -1 [ ] } - { 0 [ 1- ] } - { 1 [ 1+ ] } + { +lt+ [ ] } + { +eq+ [ 1- ] } + { +gt+ [ 1+ ] } } case ] curry map-index ; @@ -71,8 +71,6 @@ DEFER: (euler151) { 1 1 1 1 } (euler151) ] with-scope ; -! TODO: doesn't work currently, problem in area of 'with map' in (euler151) - ! [ euler151 ] 100 ave-time ! ? ms run time - 100 trials From 02becc26fcd376fbba198673906bec02f8926ba4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 18:45:01 -0500 Subject: [PATCH 06/11] add docs for if-zero etc, add docs for 10^ --- basis/math/functions/functions-docs.factor | 10 ++++ basis/math/functions/functions.factor | 6 ++- core/sequences/sequences-docs.factor | 57 +++++++++++++++++++++- core/sequences/sequences.factor | 4 +- extra/project-euler/common/common.factor | 3 -- 5 files changed, 72 insertions(+), 8 deletions(-) diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index 41800e46da..0fe77fa4ae 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -50,8 +50,10 @@ ARTICLE: "power-functions" "Powers and logarithms" { $subsection exp } { $subsection cis } { $subsection log } +{ $subsection log10 } "Raising a number to a power:" { $subsection ^ } +{ $subsection 10^ } "Converting between rectangular and polar form:" { $subsection abs } { $subsection absq } @@ -122,6 +124,10 @@ HELP: log { $values { "x" number } { "y" number } } { $description "Natural logarithm function. Outputs negative infinity if " { $snippet "x" } " is 0." } ; +HELP: log10 +{ $values { "x" number } { "y" number } } +{ $description "Logarithm function base 10. Outputs negative infinity if " { $snippet "x" } " is 0." } ; + HELP: sqrt { $values { "x" number } { "y" number } } { $description "Square root function." } ; @@ -261,6 +267,10 @@ HELP: ^ { $description "Raises " { $snippet "x" } " to the power of " { $snippet "y" } ". If " { $snippet "y" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." } { $errors "Throws an error if " { $snippet "x" } " and " { $snippet "y" } " are both integer 0." } ; +HELP: 10^ +{ $values { "x" number } { "y" number } } +{ $description "Raises " { $snippet "x" } " to the power of 10. If " { $snippet "x" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." } ; + HELP: gcd { $values { "x" integer } { "y" integer } { "a" integer } { "d" integer } } { $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*y = d mod x" } } diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 8a0d39063b..801522b376 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -118,8 +118,6 @@ ERROR: non-trivial-divisor n ; -rot (^mod) ] if ; foldable -: 10^ ( n -- n' ) 10 swap ^ ; inline - GENERIC: absq ( x -- y ) foldable M: real absq sq ; @@ -160,6 +158,10 @@ M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; M: complex log >polar swap flog swap rect> ; +: 10^ ( x -- y ) 10 swap ^ ; inline + +: log10 ( x -- y ) log 10 log / ; inline + GENERIC: cos ( x -- y ) foldable M: complex cos diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index d7db7f5242..fbdd8268da 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -123,7 +123,48 @@ HELP: unless-empty } } ; -{ if-empty when-empty unless-empty } related-words +HELP: if-zero +{ $values { "n" number } { "quot1" quotation } { "quot2" quotation } } +{ $description "Makes an implicit check if the number is zero. A zero is dropped and " { $snippet "quot1" } " is called. Otherwise, if the number is not zero, " { $snippet "quot2" } " is called on it." } +{ $example + "USING: kernel math prettyprint sequences ;" + "3 [ \"zero\" ] [ sq ] if-zero ." + "9" +} ; + +HELP: when-zero +{ $values + { "n" number } { "quot" "the first quotation of an " { $link if-zero } } } +{ $description "Makes an implicit check if the sequence is empty. A zero is dropped and the " { $snippet "quot" } " is called." } +{ $examples "This word is equivalent to " { $link if-zero } " with an empty second quotation:" + { $example + "USING: sequences prettyprint ;" + "0 [ 4 ] [ ] if-zero ." + "4" + } + { $example + "USING: sequences prettyprint ;" + "0 [ 4 ] when-zero ." + "4" + } +} ; + +HELP: unless-zero +{ $values + { "n" number } { "quot" "the second quotation of an " { $link if-empty } } } +{ $description "Makes an implicit check if the number is zero. A zero is dropped. Otherwise, the " { $snippet "quot" } " is called on the number." } +{ $examples "This word is equivalent to " { $link if-zero } " with an empty first quotation:" + { $example + "USING: sequences math prettyprint ;" + "3 [ ] [ sq ] if-empty ." + "9" + } + { $example + "USING: sequences math prettyprint ;" + "3 [ sq ] unless-zero ." + "9" + } +} ; HELP: delete-all { $values { "seq" "a resizable sequence" } } @@ -1393,6 +1434,18 @@ $nl $nl "More elaborate counted loops can be performed with " { $link "math.ranges" } "." ; +ARTICLE: "sequences-if" "Control flow with sequences" +"To reduce the boilerplate of checking if a sequence is empty or a number is zero, several combinators are provided." +$nl +"Checking if a sequence is empty:" +{ $subsection if-empty } +{ $subsection when-empty } +{ $subsection unless-empty } +"Checking if a number is zero:" +{ $subsection if-zero } +{ $subsection when-zero } +{ $subsection unless-zero } ; + ARTICLE: "sequences-access" "Accessing sequence elements" { $subsection ?nth } "Concise way of extracting one of the first four elements:" @@ -1658,6 +1711,8 @@ $nl "Using sequences for looping:" { $subsection "sequences-integers" } { $subsection "math.ranges" } +"Using sequences for control flow:" +{ $subsection "sequences-if" } "For inner loops:" { $subsection "sequences-unsafe" } ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 2e41d9d2e1..39c38d8688 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -46,9 +46,9 @@ PRIVATE> : if-zero ( n quot1 quot2 -- ) [ dup zero? ] (if-empty) ; inline -: when-zero ( seq quot -- ) [ ] if-zero ; inline +: when-zero ( n quot -- ) [ ] if-zero ; inline -: unless-zero ( seq quot -- ) [ ] swap if-zero ; inline +: unless-zero ( n quot -- ) [ ] swap if-zero ; inline : delete-all ( seq -- ) 0 swap set-length ; diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 497fc31de7..c97c6f1a95 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -62,9 +62,6 @@ PRIVATE> : cartesian-product ( seq1 seq2 -- seq1xseq2 ) [ [ 2array ] with map ] curry map concat ; -: log10 ( m -- n ) - log 10 log / ; - : mediant ( a/c b/d -- (a+b)/(c+d) ) 2>fraction [ + ] 2bi@ / ; From 415d89e82141ef85a3224eaead798e2c65b263cc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 21:18:43 -0500 Subject: [PATCH 07/11] use unless-empty --- basis/fry/fry.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor index d50fd9442b..ecb5cbf856 100644 --- a/basis/fry/fry.factor +++ b/basis/fry/fry.factor @@ -26,7 +26,7 @@ M: >r/r>-in-fry-error summary : check-fry ( quot -- quot ) dup { load-local load-locals get-local drop-locals } intersect - empty? [ >r/r>-in-fry-error ] unless ; + [ >r/r>-in-fry-error ] unless-empty ; PREDICATE: fry-specifier < word { _ @ } memq? ; From 14e8abd563153eaa345024b03498ca81a879690b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 22:30:16 -0500 Subject: [PATCH 08/11] even better error handling for division by zero --- basis/math/ratios/ratios.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index 10ba14d13c..7da92cd154 100644 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -20,7 +20,7 @@ IN: math.ratios PRIVATE> -ERROR: division-by-zero ; +ERROR: division-by-zero x ; M: division-by-zero summary drop "Division by zero" ; From 379c17a284cfd276323c9875f3c55e6db6a305a0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 22:40:29 -0500 Subject: [PATCH 09/11] Throw typed errors instead of strings for calling/executing non-callables --- basis/stack-checker/backend/backend.factor | 10 ++++++---- basis/stack-checker/known-words/known-words.factor | 8 ++++++-- 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 338b052316..5411c885ad 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -5,7 +5,7 @@ parser sequences strings vectors words quotations effects classes continuations assocs combinators compiler.errors accessors math.order definitions sets hints macros stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values -stack-checker.recursive-state ; +stack-checker.recursive-state summary ; IN: stack-checker.backend : push-d ( obj -- ) meta-d push ; @@ -98,8 +98,10 @@ M: object apply-object push-literal ; : time-bomb ( error -- ) '[ _ throw ] infer-quot-here ; -: bad-call ( -- ) - "call must be given a callable" time-bomb ; +ERROR: bad-call obj ; + +M: bad-call summary + drop "call must be given a callable" ; : infer-literal-quot ( literal -- ) dup recursive-quotation? [ @@ -110,7 +112,7 @@ M: object apply-object push-literal ; [ [ recursion>> ] keep add-local-quotation ] bi infer-quot ] [ - drop bad-call + value>> \ bad-call boa time-bomb ] if ] if ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 6959e32452..59aeb97d82 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -134,13 +134,17 @@ M: object infer-call* \ compose [ infer-compose ] "special" set-word-prop +ERROR: bad-executable obj ; + +M: bad-executable summary + drop "execute must be given a word" ; + : infer-execute ( -- ) pop-literal nip dup word? [ apply-object ] [ - drop - "execute must be given a word" time-bomb + \ bad-executable boa time-bomb ] if ; \ execute [ infer-execute ] "special" set-word-prop From aabfc614a1c971ac5a03257e64746387c9e7baee Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 23:07:13 -0500 Subject: [PATCH 10/11] fix build errors --- basis/calendar/calendar-docs.factor | 2 +- extra/descriptive/descriptive-tests.factor | 26 ++++++++++++++++++---- 2 files changed, 23 insertions(+), 5 deletions(-) diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index b39a7c7464..71e052bb6c 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -27,7 +27,7 @@ HELP: } ; HELP: month-names -{ $values { "array" array } } +{ $values { "value" object } } { $description "Returns an array with the English names of all the months." } { $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ; diff --git a/extra/descriptive/descriptive-tests.factor b/extra/descriptive/descriptive-tests.factor index 755c57ceda..6630d2addb 100755 --- a/extra/descriptive/descriptive-tests.factor +++ b/extra/descriptive/descriptive-tests.factor @@ -1,16 +1,34 @@ -USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see ; +USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see +math.ratios ; IN: descriptive.tests DESCRIPTIVE: divide ( num denom -- fraction ) / ; [ 3 ] [ 9 3 divide ] unit-test -[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide } ] [ [ 3 0 divide ] [ ] recover ] unit-test -[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] [ \ divide [ see ] with-string-writer ] unit-test +[ + T{ descriptive-error f + { { "num" 3 } { "denom" 0 } } + T{ division-by-zero f 3 } + divide + } +] [ + [ 3 0 divide ] [ ] recover +] unit-test + +[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] +[ \ divide [ see ] with-string-writer ] unit-test DESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ; [ 3 ] [ 9 3 divide* ] unit-test -[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide* } ] [ [ 3 0 divide* ] [ ] recover ] unit-test + +[ + T{ descriptive-error f + { { "num" 3 } { "denom" 0 } } + T{ division-by-zero f 3 } + divide* + } +] [ [ 3 0 divide* ] [ ] recover ] unit-test [ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\n" ] [ \ divide* [ see ] with-string-writer ] unit-test From 686b3e348e8ab69cc14dc14e900633b3a5edfead Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 11 Aug 2009 23:09:02 -0500 Subject: [PATCH 11/11] use ERROR: in several places instead of throwing strings --- core/classes/algebra/algebra.factor | 4 +++- core/effects/parser/parser.factor | 4 +++- core/generic/single/single.factor | 4 +++- core/math/math.factor | 4 +++- core/sequences/sequences.factor | 4 +++- 5 files changed, 15 insertions(+), 5 deletions(-) diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 6bfc94d79a..df4f8f2563 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -202,9 +202,11 @@ M: anonymous-complement (classes-intersect?) : class= ( first second -- ? ) [ class<= ] [ swap class<= ] 2bi and ; +ERROR: topological-sort-failed ; + : largest-class ( seq -- n elt ) dup [ [ class< ] with any? not ] curry find-last - [ "Topological sort failed" throw ] unless* ; + [ topological-sort-failed ] unless* ; : sort-classes ( seq -- newseq ) [ name>> ] sort-with >vector diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index c8ed6da2aa..66179c5e52 100644 --- a/core/effects/parser/parser.factor +++ b/core/effects/parser/parser.factor @@ -24,9 +24,11 @@ ERROR: bad-effect ; : parse-effect-tokens ( end -- tokens ) [ parse-effect-token dup ] curry [ ] produce nip ; +ERROR: stack-effect-omits-dashes effect ; + : parse-effect ( end -- effect ) parse-effect-tokens { "--" } split1 dup - [ ] [ "Stack effect declaration must contain --" throw ] if ; + [ ] [ drop stack-effect-omits-dashes ] if ; : complete-effect ( -- effect ) "(" expect ")" parse-effect ; diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 88387abd5c..8a53368062 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -208,9 +208,11 @@ SYMBOL: predicate-engines : keep-going? ( assoc -- ? ) assumed get swap second first class<= ; +ERROR: unreachable ; + : prune-redundant-predicates ( assoc -- default assoc' ) { - { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } + { [ dup empty? ] [ drop [ unreachable ] { } ] } { [ dup length 1 = ] [ first second { } ] } { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] } [ [ first second ] [ rest-slice ] bi ] diff --git a/core/math/math.factor b/core/math/math.factor index 28efbaa26e..8fa56e6e24 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -48,9 +48,11 @@ GENERIC: (log2) ( x -- n ) foldable PRIVATE> +ERROR: log2-expects-positive x ; + : log2 ( x -- n ) dup 0 <= [ - "log2 expects positive inputs" throw + log2-expects-positive ] [ (log2) ] if ; inline diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 39c38d8688..aecc9e33d8 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -281,9 +281,11 @@ INSTANCE: repetition immutable-sequence