"." write flush
{
- + 1+ 1- 2/ < <= > >= shift
+ + 2/ < <= > >= shift
} compile-unoptimized
"." write flush
[ 3 ] [ t bad-kill-2 ] unit-test
! regression
-: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline recursive
+: (the-test) ( x -- y ) dup 0 > [ 1 - (the-test) ] when ; inline recursive
: the-test ( -- x y ) 2 dup (the-test) ;
[ 2 0 ] [ the-test ] unit-test
[ { fixnum } declare [ ] times ] \ >= inlined?
] unit-test
-[ t ] [
- [ { fixnum } declare [ ] times ] \ 1+ inlined?
-] unit-test
-
[ t ] [
[ { fixnum } declare [ ] times ] \ + inlined?
] unit-test
[ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
] unit-test
-[ t ] [
- [ 5000 [ 5000 [ ] times ] times ] \ 1+ inlined?
-] unit-test
-
-[ t ] [
- [ 5000 [ [ ] times ] each ] \ 1+ inlined?
-] unit-test
-
-[ t ] [
- [ 5000 0 [ dup 2 - swap [ 2drop ] curry each ] reduce ]
- \ 1+ inlined?
-] unit-test
-
GENERIC: annotate-entry-test-1 ( x -- )
M: fixnum annotate-entry-test-1 drop ;
2dup >= [
2drop
] [
- [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
+ [ dup annotate-entry-test-1 1 + ] dip (annotate-entry-test-2)
] if ; inline recursive
: annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
] \ + inlined?
] unit-test
-[ t ] [
- [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
-] unit-test
-
: rec ( a -- b )
dup 0 > [ 1 - rec ] when ; inline recursive
: buffalo-wings ( i seq -- )
2dup < [
2dup chicken-fingers
- [ 1+ ] dip buffalo-wings
+ [ 1 + ] dip buffalo-wings
] [
2drop
] if ; inline recursive
: ribs ( i seq -- )
2dup < [
steak
- [ 1+ ] dip ribs
+ [ 1 + ] dip ribs
] [
2drop
] if ; inline recursive
: body-length-bias ( word -- n )
[ flat-length ] [ inlining-count get at 0 or ] bi
- over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
+ over 2 <= [ drop ] [ 2/ 1 + * ] if 24 swap [-] 4 /i ;
: inlining-rank ( #call word -- n )
[
] unit-test
: loop-test-2 ( a b -- a' )
- dup [ 1+ loop-test-2 1 - ] [ drop ] if ; inline recursive
+ dup [ 1 + loop-test-2 1 - ] [ drop ] if ; inline recursive
[ t ] [
[ loop-test-2 ] build-tree analyze-recursive
dup init-result-set ;
M: postgresql-result-set advance-row ( result-set -- )
- [ 1+ ] change-n drop ;
+ [ 1 + ] change-n drop ;
M: postgresql-result-set more-rows? ( result-set -- ? )
[ n>> ] [ max>> ] bi < ;
: (week-of-year) ( timestamp day -- n )
[ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
- [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ;
+ [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1 + >fixnum ] if ;
: week-of-year-sunday ( timestamp -- n ) 0 (week-of-year) ; inline
[ 256 ] [ 1 { 8 } bitfield ] unit-test
[ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test
[ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test
-[ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test
+: test-1+ ( x -- y ) 1 + ;
+[ 512 ] [ 1 { { test-1+ 8 } } bitfield ] unit-test
CONSTANT: a 1
CONSTANT: b 2
"Computing additive and multiplicative inverses:"
{ $subsection neg }
{ $subsection recip }
-"Incrementing, decrementing:"
-{ $subsection 1+ }
-{ $subsection 1- }
"Minimum, maximum, clamping:"
{ $subsection min }
{ $subsection max }
"Tests:"
{ $subsection zero? }
{ $subsection between? }
+"Control flow:"
+{ $subsection if-zero }
+{ $subsection when-zero }
+{ $subsection unless-zero }
"Sign:"
{ $subsection sgn }
"Rounding:"
{ bitnot interval-bitnot }
{ abs interval-abs }
{ 2/ interval-2/ }
- { 1+ interval-1+ }
- { 1- interval-1- }
{ neg interval-neg }
}
"math.ratios.private" vocab [
GENERIC: end/start ( string regexp -- end start )
M: regexp end/start drop length 0 ;
-M: reverse-regexp end/start drop length 1- -1 swap ;
+M: reverse-regexp end/start drop length 1 - -1 swap ;
PRIVATE>
drop
seen-whitespace-end? get [
- position get 1+ whitespace-end set
+ position get 1 + whitespace-end set
] unless
(check-word-break)
{ $description "Computes the bitwise complement of the input; that is, each bit in the input number is flipped." }
{ $notes "This word implements bitwise not, so applying it to booleans will throw an error. Boolean not is the " { $link not } " word."
$nl
-"Due to the two's complement representation of signed integers, the following two lines are equivalent:" { $code "bitnot" "neg 1-" } } ;
+"Due to the two's complement representation of signed integers, the following two lines are equivalent:" { $code "bitnot" "neg 1 -" } } ;
HELP: bit?
{ $values { "x" integer } { "n" integer } { "?" "a boolean" } }
{ $description "Outputs the largest integer " { $snippet "n" } " such that " { $snippet "2^n" } " is less than or equal to " { $snippet "x" } "." }
{ $errors "Throws an error if " { $snippet "x" } " is zero or negative." } ;
-HELP: 1+
-{ $values { "x" number } { "y" number } }
-{ $description
- "Increments a number by 1. The following two lines are equivalent:"
- { $code "1+" "1 +" }
- "There is no difference in behavior or efficiency."
-} ;
-
-HELP: 1-
-{ $values { "x" number } { "y" number } }
-{ $description
- "Decrements a number by 1. The following two lines are equivalent:"
- { $code "1-" "1 -" }
- "There is no difference in behavior or efficiency."
-} ;
-
HELP: ?1+
{ $values { "x" { $maybe number } } { "y" number } }
{ $description "If the input is not " { $link f } ", adds one. Otherwise, outputs a " { $snippet "0" } "." } ;
{ $values { "x" number } { "?" "a boolean" } }
{ $description "Tests if the number is equal to zero." } ;
+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: math prettyprint ;"
+ "0 [ 4 ] [ ] if-zero ."
+ "4"
+ }
+ { $example
+ "USING: math 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: times
{ $values { "n" integer } { "quot" quotation } }
{ $description "Calls the quotation " { $snippet "n" } " times." }
] if ; inline
: zero? ( x -- ? ) 0 number= ; inline
-: 1+ ( x -- y ) 1 + ; inline
-: 1- ( x -- y ) 1 - ; inline
: 2/ ( x -- y ) -1 shift ; inline
: sq ( x -- y ) dup * ; inline
: neg ( x -- -x ) -1 * ; inline
: even? ( n -- ? ) 1 bitand zero? ;
: odd? ( n -- ? ) 1 bitand 1 number= ;
+: if-zero ( n quot1 quot2 -- )
+ [ dup zero? ] [ [ drop ] prepose ] [ ] tri* if ; inline
+
+: when-zero ( n quot -- ) [ ] if-zero ; inline
+
+: unless-zero ( n quot -- ) [ ] swap if-zero ; inline
+
UNION: integer fixnum bignum ;
TUPLE: ratio { numerator integer read-only } { denominator integer read-only } ;
}
} ;
-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" } }
{ $description "Resizes the sequence to zero length, removing all elements. Not all sequences are resizable." }
"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 } ;
+{ $subsection unless-empty } ;
ARTICLE: "sequences-access" "Accessing sequence elements"
{ $subsection ?nth }
: empty? ( seq -- ? ) length 0 = ; inline
-<PRIVATE
-
-: (if-empty) ( seq quot1 quot2 quot3 -- )
- [ [ drop ] prepose ] [ ] tri* if ; inline
-
-PRIVATE>
-
: if-empty ( seq quot1 quot2 -- )
- [ dup empty? ] (if-empty) ; inline
+ [ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; 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 ( n quot -- ) [ ] if-zero ; inline
-
-: unless-zero ( n quot -- ) [ ] swap if-zero ; inline
-
: delete-all ( seq -- ) 0 swap set-length ;
: first ( seq -- first ) 0 swap nth ; inline
: (lychrel?) ( n iteration -- ? )
dup 50 < [
[ add-reverse ] dip over palindrome?
- [ 2drop f ] [ 1+ (lychrel?) ] if
+ [ 2drop f ] [ 1 + (lychrel?) ] if
] [
2drop t
] if ;
syn keyword factorKeyword or tuck 2bi 2tri while wrapper nip 4dip wrapper? bi* callstack>array both? hashcode die dupd callstack callstack? 3dup tri@ pick curry build ?execute 3bi prepose >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep clear 2dup when not tuple? dup 2bi* 2tri* call tri-curry object bi@ do unless* if* loop bi-curry* drop when* assert= retainstack assert? -rot execute 2bi@ 2tri@ boa with either? 3drop bi curry? datastack until 3dip over 3curry roll tri-curry* swap tri-curry@ 2nip and throw set-retainstack bi-curry (clone) hashcode* compose spin 2dip if 3tri unless compose? tuple keep 2curry equal? set-datastack assert tri 2drop most <wrapper> boolean? identity-tuple? null new set-callstack dip bi-curry@ rot -roll xor identity-tuple boolean
syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect assoc-refine update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map <enum> assoc assoc-map enum value-at* remove-all assoc-map-as >alist assoc-filter-as substitute-here clear-assoc assoc-stack maybe-set-at substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? unzip
syn keyword factorKeyword case execute-effect no-cond no-case? 3cleave>quot 2cleave cond>quot wrong-values? no-cond? cleave>quot no-case case>quot 3cleave wrong-values to-fixed-point alist>quot case-find cond cleave call-effect 2cleave>quot recursive-hashcode linear-case-quot spread spread>quot
-syn keyword factorKeyword byte-array>bignum sgn >bignum next-float number= each-integer next-power-of-2 ?1+ fp-special? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum fp-snan? fp-infinity? denominator (all-integers?) times find-last-integer (each-integer) bit? * + fp-bitwise= - fp-qnan? / power-of-2? >= bitand find-integer complex <fp-nan> < log2 > integer? real number bits>double double>bits bitor 2/ zero? rem fp-nan-payload all-integers? (find-integer) real-part prev-float align bits>float float? shift float 1+ 1- fp-nan? abs bitxor ratio? even? <= /mod odd? >integer ratio rational? bitnot real? >fixnum complex? /i numerator /f
+syn keyword factorKeyword byte-array>bignum sgn >bignum next-float number= each-integer next-power-of-2 ?1+ fp-special? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum fp-snan? fp-infinity? denominator (all-integers?) times find-last-integer (each-integer) bit? * + fp-bitwise= - fp-qnan? / power-of-2? >= bitand find-integer complex <fp-nan> < log2 > integer? real number bits>double double>bits bitor 2/ zero? rem fp-nan-payload all-integers? (find-integer) real-part prev-float align bits>float float? shift float fp-nan? abs bitxor ratio? even? <= /mod odd? >integer ratio rational? bitnot real? >fixnum complex? /i numerator /f
syn keyword factorKeyword append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as filter-here last-index-from reversed index-from cut* pad-tail (indices) concat-as remq but-last snip trim-tail nths nth 2pusher sequence slice? <slice> partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length delq drop-prefix unclip iota unclip-last-slice bounds-error? sequence-hashcode-step map start midpoint@ rest-slice prepend fourth sift delete sigma new-sequence follow like delete-nth first4 1sequence reverse slice unless-empty padding virtual@ repetition? set-last index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? 2sequence map-integers delete-all start* indices snip-slice check-slice sequence? head map-find reduce append-as reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check harvest immutable find produce remove pad-head last replicate set-fourth shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulate each pusher cut-slice new-resizable each-index head-slice* 2reverse-each sequence-hashcode memq? pop set-nth ?nth <flat-slice> second change-each join when-empty accumulator immutable-sequence? <reversed> all? 3append-as virtual-sequence subseq? push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? <repetition> trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum glue slice-error subseq replace-slice push repetition map-index trim-head unclip-last mismatch trim
syn keyword factorKeyword global +@ change set-namestack change-global init-namespaces on off set-global namespace set with-scope bind with-variable inc dec counter initialize namestack get get-global make-assoc
syn keyword factorKeyword <array> 2array 3array pair >array 1array 4array pair? array resize-array array?
projects / factor.git / commitdiff