From 68d7137a16dbf3ee2f9543582e771d67cb06b1a0 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 24 Apr 2009 02:16:05 -0400 Subject: [PATCH 001/210] Fix minor inconsistency in reference to var name --- extra/benchmark/pidigits/pidigits.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/benchmark/pidigits/pidigits.factor b/extra/benchmark/pidigits/pidigits.factor index 5de5cc5e99..0f8a98e6f9 100644 --- a/extra/benchmark/pidigits/pidigits.factor +++ b/extra/benchmark/pidigits/pidigits.factor @@ -18,7 +18,7 @@ IN: benchmark.pidigits : >matrix ( q s r t -- z ) 4array 2 group ; -: produce ( z n -- z' ) +: produce ( z y -- z' ) [ 10 ] dip -10 * 0 1 >matrix swap m. ; : gen-x ( x -- matrix ) From 4c175bf676119b4947ef309caf086b20a8f0a047 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 1 May 2009 20:46:25 -0400 Subject: [PATCH 002/210] Use iota in Project Euler solutions --- extra/project-euler/001/001.factor | 6 +++--- extra/project-euler/005/005.factor | 6 +++--- extra/project-euler/030/030.factor | 2 +- extra/project-euler/048/048.factor | 4 ++-- extra/project-euler/055/055.factor | 2 +- extra/project-euler/057/057.factor | 16 ++++++++-------- 6 files changed, 18 insertions(+), 18 deletions(-) diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor index 0d4f5fb1bd..e4c8a20cb3 100644 --- a/extra/project-euler/001/001.factor +++ b/extra/project-euler/001/001.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov. +! Copyright (c) 2007-2009 Aaron Schaefer, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.functions math.ranges project-euler.common sequences sets ; @@ -47,14 +47,14 @@ PRIVATE> : euler001b ( -- answer ) - 1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ; + 1000 iota [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ; ! [ euler001b ] 100 ave-time ! 0 ms ave run time - 0.06 SD (100 trials) : euler001c ( -- answer ) - 1000 [ { 3 5 } [ divisor? ] with any? ] filter sum ; + 1000 iota [ { 3 5 } [ divisor? ] with any? ] filter sum ; ! [ euler001c ] 100 ave-time ! 0 ms ave run time - 0.06 SD (100 trials) diff --git a/extra/project-euler/005/005.factor b/extra/project-euler/005/005.factor index 7fef29a6b9..8512bc97fa 100644 --- a/extra/project-euler/005/005.factor +++ b/extra/project-euler/005/005.factor @@ -1,6 +1,6 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2007, 2009 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: math math.functions sequences project-euler.common ; +USING: math math.functions math.ranges project-euler.common sequences ; IN: project-euler.005 ! http://projecteuler.net/index.php?section=problems&id=5 @@ -18,7 +18,7 @@ IN: project-euler.005 ! -------- : euler005 ( -- answer ) - 20 1 [ 1+ lcm ] reduce ; + 20 [1,b] 1 [ lcm ] reduce ; ! [ euler005 ] 100 ave-time ! 0 ms ave run time - 0.14 SD (100 trials) diff --git a/extra/project-euler/030/030.factor b/extra/project-euler/030/030.factor index 54d48660d5..7c8334cfd4 100644 --- a/extra/project-euler/030/030.factor +++ b/extra/project-euler/030/030.factor @@ -38,7 +38,7 @@ IN: project-euler.030 PRIVATE> : euler030 ( -- answer ) - 325537 [ dup sum-fifth-powers = ] filter sum 1- ; + 325537 iota [ dup sum-fifth-powers = ] filter sum 1- ; ! [ euler030 ] 100 ave-time ! 1700 ms ave run time - 64.84 SD (100 trials) diff --git a/extra/project-euler/048/048.factor b/extra/project-euler/048/048.factor index e56b9e9548..640a3a68f6 100644 --- a/extra/project-euler/048/048.factor +++ b/extra/project-euler/048/048.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions sequences project-euler.common ; +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 +17,7 @@ IN: project-euler.048 ! -------- : euler048 ( -- answer ) - 1000 [ 1+ 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/055/055.factor b/extra/project-euler/055/055.factor index 43f380b3ba..6154e29717 100644 --- a/extra/project-euler/055/055.factor +++ b/extra/project-euler/055/055.factor @@ -61,7 +61,7 @@ IN: project-euler.055 PRIVATE> : euler055 ( -- answer ) - 10000 [ lychrel? ] count ; + 10000 iota [ lychrel? ] count ; ! [ euler055 ] 100 ave-time ! 478 ms ave run time - 30.63 SD (100 trials) diff --git a/extra/project-euler/057/057.factor b/extra/project-euler/057/057.factor index 681a17dd9e..0c434f4506 100644 --- a/extra/project-euler/057/057.factor +++ b/extra/project-euler/057/057.factor @@ -11,14 +11,14 @@ IN: project-euler.057 ! It is possible to show that the square root of two can be expressed ! as an infinite continued fraction. -! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213... +! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213... ! By expanding this for the first four iterations, we get: -! 1 + 1/2 = 3/2 = 1.5 -! 1 + 1/(2 + 1/2) = 7/5 = 1.4 -! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666... -! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379... +! 1 + 1/2 = 3/2 = 1.5 +! 1 + 1/(2 + 1/2) = 7/5 = 1.4 +! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666... +! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379... ! The next three expansions are 99/70, 239/169, and 577/408, but the ! eighth expansion, 1393/985, is the first example where the number of @@ -35,9 +35,9 @@ IN: project-euler.057 >fraction [ number>string length ] bi@ > ; inline : euler057 ( -- answer ) - 0 1000 [ drop 2 + recip dup 1+ longer-numerator? ] count nip ; + 0 1000 iota [ drop 2 + recip dup 1+ longer-numerator? ] count nip ; -! [ euler057 ] time -! 3.375118 seconds +! [ euler057 ] 100 ave-time +! 1728 ms ave run time - 80.81 SD (100 trials) SOLUTION: euler057 From 2d31e951a04c6243e97daf32cf16a483fdd12f32 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 1 May 2009 22:26:49 -0400 Subject: [PATCH 003/210] Use [0,b) and iota where appropriate --- extra/project-euler/001/001.factor | 4 ++-- extra/project-euler/018/018.factor | 4 ++-- extra/project-euler/027/027.factor | 5 ++--- extra/project-euler/030/030.factor | 4 ++-- extra/project-euler/032/032.factor | 2 +- extra/project-euler/055/055.factor | 4 ++-- extra/project-euler/057/057.factor | 5 +++-- extra/project-euler/150/150.factor | 7 ++++--- 8 files changed, 18 insertions(+), 17 deletions(-) diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor index e4c8a20cb3..204527418b 100644 --- a/extra/project-euler/001/001.factor +++ b/extra/project-euler/001/001.factor @@ -47,14 +47,14 @@ PRIVATE> : euler001b ( -- answer ) - 1000 iota [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ; + 1000 [0,b) [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ; ! [ euler001b ] 100 ave-time ! 0 ms ave run time - 0.06 SD (100 trials) : euler001c ( -- answer ) - 1000 iota [ { 3 5 } [ divisor? ] with any? ] filter sum ; + 1000 [0,b) [ { 3 5 } [ divisor? ] with any? ] filter sum ; ! [ euler001c ] 100 ave-time ! 0 ms ave run time - 0.06 SD (100 trials) diff --git a/extra/project-euler/018/018.factor b/extra/project-euler/018/018.factor index 9c7c4fee74..9189323121 100644 --- a/extra/project-euler/018/018.factor +++ b/extra/project-euler/018/018.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math project-euler.common sequences ; +USING: kernel math math.ranges project-euler.common sequences ; IN: project-euler.018 ! http://projecteuler.net/index.php?section=problems&id=18 @@ -66,7 +66,7 @@ IN: project-euler.018 91 71 52 38 17 14 91 43 58 50 27 29 48 63 66 04 68 89 53 67 30 73 16 69 87 40 31 04 62 98 27 23 09 70 98 73 93 38 53 60 04 23 - } 15 iota [ 1+ cut swap ] map nip ; + } 15 [1,b] [ cut swap ] map nip ; PRIVATE> diff --git a/extra/project-euler/027/027.factor b/extra/project-euler/027/027.factor index 4bcfb66a94..f7bffbf665 100644 --- a/extra/project-euler/027/027.factor +++ b/extra/project-euler/027/027.factor @@ -1,7 +1,6 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.primes project-euler.common sequences -project-euler.common ; +USING: kernel math math.primes math.ranges project-euler.common sequences ; IN: project-euler.027 ! http://projecteuler.net/index.php?section=problems&id=27 @@ -47,7 +46,7 @@ IN: project-euler.027 : euler030 ( -- answer ) - 325537 iota [ dup sum-fifth-powers = ] filter sum 1- ; + 325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1- ; ! [ euler030 ] 100 ave-time ! 1700 ms ave run time - 64.84 SD (100 trials) diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor index 64c9ec445e..814f8a5a63 100755 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -28,7 +28,7 @@ IN: project-euler.032 : source-032 ( -- seq ) 9 factorial iota [ - 9 permutation [ 1+ ] map 10 digits>integer + 9 permutation [ 1 + ] map 10 digits>integer ] map ; : 1and4 ( n -- ? ) diff --git a/extra/project-euler/055/055.factor b/extra/project-euler/055/055.factor index 6154e29717..07525fe6a4 100644 --- a/extra/project-euler/055/055.factor +++ b/extra/project-euler/055/055.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.parser project-euler.common sequences ; +USING: kernel math math.parser math.ranges project-euler.common sequences ; IN: project-euler.055 ! http://projecteuler.net/index.php?section=problems&id=55 @@ -61,7 +61,7 @@ IN: project-euler.055 PRIVATE> : euler055 ( -- answer ) - 10000 iota [ lychrel? ] count ; + 10000 [0,b) [ lychrel? ] count ; ! [ euler055 ] 100 ave-time ! 478 ms ave run time - 30.63 SD (100 trials) diff --git a/extra/project-euler/057/057.factor b/extra/project-euler/057/057.factor index 0c434f4506..97789944fe 100644 --- a/extra/project-euler/057/057.factor +++ b/extra/project-euler/057/057.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2008 Samuel Tardieu ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions math.parser sequences project-euler.common ; +USING: kernel math math.functions math.parser math.ranges project-euler.common + sequences ; IN: project-euler.057 ! http://projecteuler.net/index.php?section=problems&id=57 @@ -35,7 +36,7 @@ IN: project-euler.057 >fraction [ number>string length ] bi@ > ; inline : euler057 ( -- answer ) - 0 1000 iota [ drop 2 + recip dup 1+ longer-numerator? ] count nip ; + 0 1000 [0,b) [ drop 2 + recip dup 1 + longer-numerator? ] count nip ; ! [ euler057 ] 100 ave-time ! 1728 ms ave run time - 80.81 SD (100 trials) diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor index 314698534f..eeb4b0c315 100644 --- a/extra/project-euler/150/150.factor +++ b/extra/project-euler/150/150.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2008 Eric Mertens. ! See http://factorcode.org/license.txt for BSD license. -USING: hints kernel locals math math.order sequences sequences.private project-euler.common ; +USING: hints kernel locals math math.order math.ranges project-euler.common + sequences sequences.private ; IN: project-euler.150 ! http://projecteuler.net/index.php?section=problems&id=150 @@ -50,13 +51,13 @@ IN: project-euler.150 615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline : sums-triangle ( -- seq ) - 0 1000 iota [ 1+ [ next ] replicate partial-sums ] map nip ; + 0 1000 [1,b] [ [ next ] replicate partial-sums ] map nip ; :: (euler150) ( m -- n ) [let | table [ sums-triangle ] | m [| x | x 1+ [| y | - m x - iota [| z | + m x - [0,b) [| z | x z + table nth-unsafe [ y z + 1+ swap nth-unsafe ] [ y swap nth-unsafe ] bi - From e925b058197610dfd976e2a7dc9ca16a7e2e9317 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 2 May 2009 02:06:52 -0400 Subject: [PATCH 004/210] Add deck generation and shuffling to poker vocab --- extra/poker/poker-tests.factor | 2 +- extra/poker/poker.factor | 31 ++++++++++++++++++++++--------- 2 files changed, 23 insertions(+), 10 deletions(-) diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor index ad371a6bff..e2d89620e6 100644 --- a/extra/poker/poker-tests.factor +++ b/extra/poker/poker-tests.factor @@ -1,4 +1,4 @@ -USING: accessors poker poker.private tools.test math.order kernel ; +USING: accessors kernel math.order poker poker.private tools.test ; IN: poker.tests [ 134236965 ] [ "KD" >ckf ] unit-test diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index e8e9fa23c5..15e9a96d42 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -1,7 +1,9 @@ -! Copyright (c) 2009 Aaron Schaefer. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors ascii binary-search combinators kernel locals math - math.bitwise math.order poker.arrays sequences splitting ; +! Copyright (c) 2009 Aaron Schaefer. All rights reserved. +! The contents of this file are licensed under the Simplified BSD License +! A copy of the license is available at http://factorcode.org/license.txt +USING: accessors arrays ascii binary-search combinators kernel locals math + math.bitwise math.order poker.arrays random sequences sequences.product + splitting ; IN: poker ! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with @@ -57,6 +59,8 @@ CONSTANT: TWO_PAIR 7 CONSTANT: ONE_PAIR 8 CONSTANT: HIGH_CARD 9 +CONSTANT: SUIT_STR { "C" "D" "H" "S" } + CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" } CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" @@ -108,6 +112,9 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" #! Cactus Kev Format >upper 1 cut (>ckf) ; +: parse-cards ( str -- seq ) + " " split [ >ckf ] map ; + : flush? ( cards -- ? ) HEX: F000 [ bitand ] reduce 0 = not ; @@ -165,6 +172,9 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" [ drop STRAIGHT_FLUSH ] ! 10 straight-flushes } cond ; +: card>string ( card -- str ) + [ >card-rank ] [ >card-suit ] bi append ; + PRIVATE> TUPLE: hand @@ -176,13 +186,16 @@ M: hand equal? over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ; : ( str -- hand ) - " " split [ >ckf ] map - dup hand-value hand boa ; + parse-cards dup hand-value hand boa ; : >cards ( hand -- str ) - cards>> [ - [ >card-rank ] [ >card-suit ] bi append - ] map " " join ; + cards>> [ card>string ] map " " join ; : >value ( hand -- str ) hand-rank VALUE_STR nth ; + +: ( -- deck ) + RANK_STR SUIT_STR 2array [ concat >ckf ] product-map ; + +ALIAS: shuffle randomize + From ef5226b31f43409e273dba0f069281a687b8c969 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 May 2009 21:27:14 -0500 Subject: [PATCH 005/210] remove >bignum in crc32 -- 2x faster on both 32 and 64bit --- core/checksums/crc32/crc32.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/checksums/crc32/crc32.factor b/core/checksums/crc32/crc32.factor index 7655ec8482..209de83763 100644 --- a/core/checksums/crc32/crc32.factor +++ b/core/checksums/crc32/crc32.factor @@ -12,12 +12,12 @@ CONSTANT: crc32-table V{ } 256 iota [ 8 [ [ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless - ] times >bignum + ] times ] map 0 crc32-table copy : (crc32) ( crc ch -- crc ) - >bignum dupd bitxor - mask-byte crc32-table nth-unsafe >bignum + dupd bitxor + mask-byte crc32-table nth-unsafe swap -8 shift bitxor ; inline SINGLETON: crc32 From 1e2561f8631f778cf651eaac632c80534f0d12f7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 09:12:32 -0500 Subject: [PATCH 006/210] Make walker work better with call( and breakpoints which are nested inside combinators --- basis/compiler/compiler.factor | 17 +++++----- basis/compiler/tree/builder/builder.factor | 2 -- .../tree/propagation/inlining/inlining.factor | 6 +--- .../known-words/known-words.factor | 2 +- .../tools/continuations/continuations.factor | 32 ++++++++----------- basis/tools/walker/walker-tests.factor | 18 +++++++++-- core/bootstrap/primitives.factor | 2 +- vm/callstack.cpp | 4 +-- vm/callstack.hpp | 2 +- vm/primitives.cpp | 2 +- 10 files changed, 44 insertions(+), 43 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index e418f0ef60..01e58461ff 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -112,19 +112,18 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ; } cond ; : optimize? ( word -- ? ) - { - [ predicate-engine-word? ] - [ contains-breakpoints? ] - [ single-generic? ] - } 1|| not ; + { [ predicate-engine-word? ] [ single-generic? ] } 1|| not ; + +: contains-breakpoints? ( -- ? ) + dependencies get keys [ "break?" word-prop ] any? ; : frontend ( word -- nodes ) #! If the word contains breakpoints, don't optimize it, since #! the walker does not support this. - dup optimize? - [ [ build-tree ] [ deoptimize ] recover optimize-tree ] - [ dup def>> deoptimize-with ] - if ; + dup optimize? [ + [ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep + contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if + ] [ dup def>> deoptimize-with ] if ; : compile-dependency ( word -- ) #! If a word calls an unoptimized word, try to compile the callee. diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 37cc1f05da..00325f5a72 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -65,5 +65,3 @@ PRIVATE> ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ] with-variable ; -: contains-breakpoints? ( word -- ? ) - def>> [ word? ] filter [ "break?" word-prop ] any? ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 2a7d431314..ee9abf00ec 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -157,11 +157,7 @@ DEFER: (flat-length) ] sum-outputs ; : should-inline? ( #call word -- ? ) - { - { [ dup contains-breakpoints? ] [ 2drop f ] } - { [ dup "inline" word-prop ] [ 2drop t ] } - [ inlining-rank 5 >= ] - } cond ; + dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ; SYMBOL: history diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index f6f94bf20d..7603324200 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -651,7 +651,7 @@ M: object infer-call* \ become { array array } { } define-primitive -\ innermost-frame-quot { callstack } { quotation } define-primitive +\ innermost-frame-executing { callstack } { object } define-primitive \ innermost-frame-scan { callstack } { fixnum } define-primitive diff --git a/basis/tools/continuations/continuations.factor b/basis/tools/continuations/continuations.factor index 8c572f4ae3..15fdb9f9b5 100644 --- a/basis/tools/continuations/continuations.factor +++ b/basis/tools/continuations/continuations.factor @@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words sequences.private assocs models models.arrow arrays accessors -generic generic.single definitions make sbufs tools.crossref ; +generic generic.single definitions make sbufs tools.crossref fry ; IN: tools.continuations > +: >innermost-frame< ( callstack -- n quot ) + [ innermost-frame-scan 1 + ] [ innermost-frame-executing ] bi ; + +: (change-frame) ( callstack quot -- callstack' ) + [ dup innermost-frame-executing quotation? ] dip '[ + clone [ >innermost-frame< @ ] [ set-innermost-frame-quot ] [ ] tri + ] when ; inline + : change-frame ( continuation quot -- continuation' ) #! Applies quot to innermost call frame of the #! continuation. - [ clone ] dip [ - [ clone ] dip - [ - [ - [ innermost-frame-scan 1+ ] - [ innermost-frame-quot ] bi - ] dip call - ] - [ drop set-innermost-frame-quot ] - [ drop ] - 2tri - ] curry change-call ; inline + [ clone ] dip '[ _ (change-frame) ] change-call ; inline PRIVATE> @@ -101,7 +98,7 @@ PRIVATE> [ 2dup length = [ nip [ break ] append ] [ 2dup nth \ break = [ nip ] [ - swap 1+ cut [ break ] glue + swap 1 + cut [ break ] glue ] if ] if ] change-frame ; @@ -109,7 +106,6 @@ PRIVATE> : continuation-step-out ( continuation -- continuation' ) [ nip \ break suffix ] change-frame ; - { { call [ (step-into-quot) ] } { dip [ (step-into-dip) ] } @@ -124,7 +120,7 @@ PRIVATE> ! Never step into these words : don't-step-into ( word -- ) - dup [ execute break ] curry "step-into" set-word-prop ; + dup '[ _ execute break ] "step-into" set-word-prop ; { >n ndrop >c c> @@ -151,6 +147,4 @@ PRIVATE> ] change-frame ; : continuation-current ( continuation -- obj ) - call>> - [ innermost-frame-scan 1+ ] - [ innermost-frame-quot ] bi ?nth ; + call>> >innermost-frame< ?nth ; diff --git a/basis/tools/walker/walker-tests.factor b/basis/tools/walker/walker-tests.factor index 6f87792faa..b6094d7d7e 100644 --- a/basis/tools/walker/walker-tests.factor +++ b/basis/tools/walker/walker-tests.factor @@ -2,7 +2,7 @@ USING: tools.walker io io.streams.string kernel math math.private namespaces prettyprint sequences tools.test continuations math.parser threads arrays tools.walker.debug generic.single sequences.private kernel.private -tools.continuations accessors words ; +tools.continuations accessors words combinators ; IN: tools.walker.tests [ { } ] [ @@ -131,4 +131,18 @@ M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ; \ method-breakpoint-test don't-step-into [ { 3 } ] -[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test \ No newline at end of file +[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test + +: case-breakpoint-test ( -- x ) + 5 { [ break 1 + ] } case ; + +\ case-breakpoint-test don't-step-into + +[ { 6 } ] [ [ case-breakpoint-test ] test-walker ] unit-test + +: call(-breakpoint-test ( -- x ) + [ break 1 ] call( -- x ) 2 + ; + +\ call(-breakpoint-test don't-step-into + +[ { 3 } ] [ [ call(-breakpoint-test ] test-walker ] unit-test diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index e5a6bbe5fa..83276cd3f2 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -493,7 +493,7 @@ tuple { "(sleep)" "threads.private" (( us -- )) } { "" "classes.tuple.private" (( ... layout -- tuple )) } { "callstack>array" "kernel" (( callstack -- array )) } - { "innermost-frame-quot" "kernel.private" (( callstack -- quot )) } + { "innermost-frame-executing" "kernel.private" (( callstack -- obj )) } { "innermost-frame-scan" "kernel.private" (( callstack -- n )) } { "set-innermost-frame-quot" "kernel.private" (( n callstack -- )) } { "call-clear" "kernel" (( quot -- )) } diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 56056426dd..ade0b45db7 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -195,9 +195,9 @@ stack_frame *innermost_stack_frame_quot(callstack *callstack) /* Some primitives implementing a limited form of callstack mutation. Used by the single stepper. */ -PRIMITIVE(innermost_stack_frame_quot) +PRIMITIVE(innermost_stack_frame_executing) { - dpush(frame_executing(innermost_stack_frame_quot(untag_check(dpop())))); + dpush(frame_executing(innermost_stack_frame(untag_check(dpop())))); } PRIMITIVE(innermost_stack_frame_scan) diff --git a/vm/callstack.hpp b/vm/callstack.hpp index efdbc7ba05..ec2e8e37d1 100755 --- a/vm/callstack.hpp +++ b/vm/callstack.hpp @@ -22,7 +22,7 @@ cell frame_type(stack_frame *frame); PRIMITIVE(callstack); PRIMITIVE(set_callstack); PRIMITIVE(callstack_to_array); -PRIMITIVE(innermost_stack_frame_quot); +PRIMITIVE(innermost_stack_frame_executing); PRIMITIVE(innermost_stack_frame_scan); PRIMITIVE(set_innermost_stack_frame_quot); diff --git a/vm/primitives.cpp b/vm/primitives.cpp index 08db684ff6..f1c5468949 100755 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -135,7 +135,7 @@ const primitive_type primitives[] = { primitive_sleep, primitive_tuple_boa, primitive_callstack_to_array, - primitive_innermost_stack_frame_quot, + primitive_innermost_stack_frame_executing, primitive_innermost_stack_frame_scan, primitive_set_innermost_stack_frame_quot, primitive_call_clear, From 08d4a6020305b6c5512f14cf8f7354271a5a09da Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 09:12:39 -0500 Subject: [PATCH 007/210] alien.strings cleanup --- core/alien/strings/strings.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor index 943530d4f2..896fb7f09f 100644 --- a/core/alien/strings/strings.factor +++ b/core/alien/strings/strings.factor @@ -34,16 +34,16 @@ M: string string>alien HOOK: alien>native-string os ( alien -- string ) -HOOK: native-string>alien os ( string -- alien ) - M: windows alien>native-string utf16n alien>string ; +M: unix alien>native-string utf8 alien>string ; + +HOOK: native-string>alien os ( string -- alien ) + M: wince native-string>alien utf16n string>alien ; M: winnt native-string>alien utf8 string>alien ; -M: unix alien>native-string utf8 alien>string ; - M: unix native-string>alien utf8 string>alien ; : dll-path ( dll -- string ) From e906885c16a1edaacc81b71d2b92278ca21b583a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 09:12:49 -0500 Subject: [PATCH 008/210] generic.standard: remove bogus error check --- core/generic/standard/standard.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 87611a76d0..bf801c4e47 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -8,9 +8,7 @@ IN: generic.standard TUPLE: standard-combination < single-combination # ; -: ( n -- standard-combination ) - dup 0 2 between? [ "Bad dispatch position" throw ] unless - standard-combination boa ; +C: standard-combination PREDICATE: standard-generic < generic "combination" word-prop standard-combination? ; From 90cb9ab0d3fe350f976e74f535d3502117c749dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 09:40:58 -0500 Subject: [PATCH 009/210] cocoa: don't need to explicitly compile words anymore, as if more than a year ago... --- basis/cocoa/cocoa.factor | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index 3e933e6643..b78bb020d0 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006 Slava Pestov +! Copyright (C) 2006, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: compiler io kernel cocoa.runtime cocoa.subclassing cocoa.messages cocoa.types sequences words vocabs parser @@ -27,22 +27,16 @@ SYMBOL: frameworks frameworks [ V{ } clone ] initialize -[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook +[ frameworks get [ load-framework ] each ] "cocoa" add-init-hook SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ; SYNTAX: IMPORT: scan [ ] import-objc-class ; -"Compiling Objective C bridge..." print +"Importing Cocoa classes..." print "cocoa.classes" create-vocab drop -{ - "cocoa" "cocoa.runtime" "cocoa.messages" "cocoa.subclassing" -} [ words ] map concat compile - -"Importing Cocoa classes..." print - [ { "NSApplication" From fbe5f83306a95e2cb779bdf6f86623b8ff00a49f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 5 May 2009 09:45:43 -0500 Subject: [PATCH 010/210] mouse support for game-input --- basis/windows/dinput/dinput.factor | 12 +++++ extra/game-input/dinput/dinput.factor | 60 ++++++++++++++++++++- extra/game-input/game-input.factor | 9 ++++ extra/game-input/iokit/iokit.factor | 77 +++++++++++++++++++++++---- 4 files changed, 146 insertions(+), 12 deletions(-) diff --git a/basis/windows/dinput/dinput.factor b/basis/windows/dinput/dinput.factor index 20a54dff98..e5e32aac0e 100755 --- a/basis/windows/dinput/dinput.factor +++ b/basis/windows/dinput/dinput.factor @@ -444,6 +444,18 @@ CONSTANT: DISCL_FOREGROUND HEX: 00000004 CONSTANT: DISCL_BACKGROUND HEX: 00000008 CONSTANT: DISCL_NOWINKEY HEX: 00000010 +CONSTANT: DIMOFS_X 0 +CONSTANT: DIMOFS_Y 4 +CONSTANT: DIMOFS_Z 8 +CONSTANT: DIMOFS_BUTTON0 12 +CONSTANT: DIMOFS_BUTTON1 13 +CONSTANT: DIMOFS_BUTTON2 14 +CONSTANT: DIMOFS_BUTTON3 15 +CONSTANT: DIMOFS_BUTTON4 16 +CONSTANT: DIMOFS_BUTTON5 17 +CONSTANT: DIMOFS_BUTTON6 18 +CONSTANT: DIMOFS_BUTTON7 19 + CONSTANT: DIK_ESCAPE HEX: 01 CONSTANT: DIK_1 HEX: 02 CONSTANT: DIK_2 HEX: 03 diff --git a/extra/game-input/dinput/dinput.factor b/extra/game-input/dinput/dinput.factor index 20815859ab..90141c29e1 100755 --- a/extra/game-input/dinput/dinput.factor +++ b/extra/game-input/dinput/dinput.factor @@ -8,13 +8,16 @@ byte-arrays game-input.dinput.keys-array game-input ui.backend.windows windows.errors ; IN: game-input.dinput +CONSTANT: MOUSE-BUFFER-SIZE 16 + SINGLETON: dinput-game-input-backend dinput-game-input-backend game-input-backend set-global SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ +controller-devices+ +controller-guids+ - +device-change-window+ +device-change-handle+ ; + +device-change-window+ +device-change-handle+ + +mouse-device+ +mouse-state+ +mouse-buffer+ ; : create-dinput ( -- ) f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid @@ -35,8 +38,24 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ : set-data-format ( device format-symbol -- ) get IDirectInputDevice8W::SetDataFormat ole32-error ; +: ( size -- DIPROPDWORD ) + "DIPROPDWORD" + "DIPROPDWORD" heap-size over set-DIPROPHEADER-dwSize + "DIPROPHEADER" heap-size over set-DIPROPHEADER-dwHeaderSize + 0 over set-DIPROPHEADER-dwObj + DIPH_DEVICE over set-DIPROPHEADER-dwHow + swap over set-DIPROPDWORD-dwData ; + +: set-buffer-size ( device size -- ) + DIPROP_BUFFERSIZE swap + IDirectInputDevice8W::SetProperty ole32-error ; + : configure-keyboard ( keyboard -- ) [ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ; +: configure-mouse ( mouse -- ) + [ c_dfDIMouse2 set-data-format ] + [ MOUSE-BUFFER-SIZE set-buffer-size ] + [ set-coop-level ] tri ; : configure-controller ( controller -- ) [ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ; @@ -47,6 +66,15 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ 256 keyboard-state boa +keyboard-state+ set-global ; +: find-mouse ( -- ) + GUID_SysMouse device-for-guid + [ configure-mouse ] + [ +mouse-device+ set-global ] bi + 0 0 0 0 8 mouse-state boa + +mouse-device+ set-global ; + MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" + +mouse-buffer+ set-global ; + : device-info ( device -- DIDEVICEIMAGEINFOW ) "DIDEVICEINSTANCEW" "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize @@ -190,16 +218,22 @@ TUPLE: window-rect < rect window-loc ; +keyboard-device+ [ com-release f ] change-global f +keyboard-state+ set-global ; +: release-mouse ( -- ) + +mouse-device+ [ com-release f ] change-global + f +mouse-state+ set-global ; + M: dinput-game-input-backend (open-game-input) create-dinput create-device-change-window find-keyboard + find-mouse set-up-controllers add-wm-devicechange ; M: dinput-game-input-backend (close-game-input) remove-wm-devicechange release-controllers + release-mouse release-keyboard close-device-change-window delete-dinput ; @@ -263,6 +297,22 @@ CONSTANT: pov-values [ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ] } 2cleave ; +: read-device-buffer ( device buffer count -- buffer count' ) + [ "DIDEVICEOBJECTDATA" heap-size ] 2dip + [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ; + +: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- ) + [ DIDEVICEOBJECTDATA-dwData ] [ DIDEVICEOBJECTDATA-dwOfs ] bi { + { DIMOFS_X [ [ + ] curry change-dx drop ] } + { DIMOFS_Y [ [ + ] curry change-dy drop ] } + { DIMOFS_Z [ [ + ] curry change-scroll-dy drop ] } + [ [ c-bool> ] [ DIMOFS_BUTTON0 - ] bi* rot buttons>> set-nth ] + } case ; + +: fill-mouse-state ( buffer count -- ) + [ +mouse-state+ get ] 2dip swap + [ DIDEVICEOBJECTDATA-nth (fill-mouse-state) ] curry each ; + : get-device-state ( device byte-array -- ) [ dup IDirectInputDevice8W::Poll ole32-error ] dip [ length ] keep @@ -283,3 +333,11 @@ M: dinput-game-input-backend read-keyboard +keyboard-device+ get [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ] [ ] [ f ] with-acquisition ; + +M: dinput-game-input-backend read-mouse + +mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ] + [ fill-mouse-state ] [ f ] with-acquisition ; + +M: dinput-game-input-backend reset-mouse + +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ] + [ 2drop ] [ ] with-acquisition ; diff --git a/extra/game-input/game-input.factor b/extra/game-input/game-input.factor index 6efe31861a..8281b7bc4c 100755 --- a/extra/game-input/game-input.factor +++ b/extra/game-input/game-input.factor @@ -73,6 +73,15 @@ M: keyboard-state clone HOOK: read-keyboard game-input-backend ( -- keyboard-state ) +TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ; + +M: mouse-state clone + call-next-method dup buttons>> clone >>buttons ; + +HOOK: read-mouse game-input-backend ( -- mouse-state ) + +HOOK: reset-mouse game-input-backend ( -- ) + { { [ os windows? ] [ "game-input.dinput" require ] } { [ os macosx? ] [ "game-input.iokit" require ] } diff --git a/extra/game-input/iokit/iokit.factor b/extra/game-input/iokit/iokit.factor index 2ded263899..0cc8b5d51f 100755 --- a/extra/game-input/iokit/iokit.factor +++ b/extra/game-input/iokit/iokit.factor @@ -3,7 +3,7 @@ kernel cocoa.enumeration destructors math.parser cocoa.application sequences locals combinators.short-circuit threads namespaces assocs vectors arrays combinators core-foundation.run-loop accessors sequences.private -alien.c-types math parser game-input ; +alien.c-types math parser game-input vectors ; IN: game-input.iokit SINGLETON: iokit-game-input-backend @@ -23,9 +23,13 @@ iokit-game-input-backend game-input-backend set-global CONSTANT: game-devices-matching-seq { + H{ { "DeviceUsage" 1 } { "DeviceUsagePage" 1 } } ! pointers + H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards + H{ { "DeviceUsage" 7 } { "DeviceUsagePage" 1 } } ! keypads + H{ { "DeviceUsage" 8 } { "DeviceUsagePage" 1 } } ! multiaxis controllers } CONSTANT: buttons-matching-hash @@ -46,6 +50,8 @@ CONSTANT: rz-axis-matching-hash H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } } CONSTANT: slider-matching-hash H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } } +CONSTANT: wheel-matching-hash + H{ { "UsagePage" 1 } { "Usage" HEX: 38 } { "Type" 1 } } CONSTANT: hat-switch-matching-hash H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } } @@ -90,10 +96,17 @@ CONSTANT: hat-switch-matching-hash : transfer-element-property ( element from-key to-key -- ) [ dupd element-property ] dip swap set-element-property ; +: mouse-device? ( device -- ? ) + { + [ 1 1 IOHIDDeviceConformsTo ] + [ 1 2 IOHIDDeviceConformsTo ] + } 1|| ; + : controller-device? ( device -- ? ) { [ 1 4 IOHIDDeviceConformsTo ] [ 1 5 IOHIDDeviceConformsTo ] + [ 1 8 IOHIDDeviceConformsTo ] } 1|| ; : element-usage ( element -- {usage-page,usage} ) @@ -118,6 +131,8 @@ CONSTANT: hat-switch-matching-hash { 1 HEX: 35 } = ; inline : slider? ( {usage-page,usage} -- ? ) { 1 HEX: 36 } = ; inline +: wheel? ( {usage-page,usage} -- ? ) + { 1 HEX: 38 } = ; inline : hat-switch? ( {usage-page,usage} -- ? ) { 1 HEX: 39 } = ; inline @@ -132,12 +147,17 @@ CONSTANT: pov-values IOHIDValueGetIntegerValue dup zero? [ drop f ] when ; : axis-value ( value -- [-1,1] ) kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ; +: mouse-axis-value ( value -- n ) + IOHIDValueGetIntegerValue ; : pov-value ( value -- pov-direction ) IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ; +: record-button ( hid-value usage state -- ) + [ button-value ] [ second 1- ] [ buttons>> ] tri* set-nth ; + : record-controller ( controller-state value -- ) dup IOHIDValueGetElement element-usage { - { [ dup button? ] [ [ button-value ] [ second 1- ] bi* rot buttons>> set-nth ] } + { [ dup button? ] [ rot record-button ] } { [ dup x-axis? ] [ drop axis-value >>x drop ] } { [ dup y-axis? ] [ drop axis-value >>y drop ] } { [ dup z-axis? ] [ drop axis-value >>z drop ] } @@ -149,7 +169,7 @@ CONSTANT: pov-values [ 3drop ] } cond ; -SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ; +SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ; : ?set-nth ( value nth seq -- ) 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ; @@ -161,6 +181,27 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ; +keyboard-state+ get ?set-nth ] [ drop ] if ; +: record-mouse ( value -- ) + dup IOHIDValueGetElement element-usage { + { [ dup button? ] [ +mouse-state+ get record-button ] } + { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] } + { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] } + { [ dup wheel? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] } + { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] } + [ 2drop ] + } cond ; + +M: iokit-game-input-backend read-mouse + +mouse-state+ get ; + +M: iokit-game-input-backend reset-mouse + +mouse-state+ get + 0 >>dx + 0 >>dy + 0 >>scroll-dx + 0 >>scroll-dy + drop ; + : default-calibrate-saturation ( element -- ) [ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ] [ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ] @@ -194,12 +235,21 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ; [ button-count f ] } cleave controller-state boa ; +: ?add-mouse-buttons ( device -- ) + button-count +mouse-state+ get buttons>> + 2dup length > + [ set-length ] [ 2drop ] if ; + : device-matched-callback ( -- alien ) [| context result sender device | - device controller-device? [ - device - device +controller-states+ get set-at - ] when + { + { [ device controller-device? ] [ + device + device +controller-states+ get set-at + ] } + { [ device mouse-device? ] [ device ?add-mouse-buttons ] } + [ ] + } cond ] IOHIDDeviceCallback ; : device-removed-callback ( -- alien ) @@ -209,15 +259,20 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ; : device-input-callback ( -- alien ) [| context result sender value | - sender controller-device? - [ sender +controller-states+ get at value record-controller ] - [ value record-keyboard ] - if + { + { [ sender controller-device? ] [ + sender +controller-states+ get at value record-controller + ] } + { [ sender mouse-device? ] [ value record-mouse ] } + [ value record-keyboard ] + } cond ] IOHIDValueCallback ; : initialize-variables ( manager -- ) +hid-manager+ set-global 4 +controller-states+ set-global + 0 0 0 0 2 mouse-state boa + +mouse-state+ set-global 256 f +keyboard-state+ set-global ; M: iokit-game-input-backend (open-game-input) From 27b712914989454d4a7955942c2769f1e51a2199 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 5 May 2009 09:45:54 -0500 Subject: [PATCH 011/210] docs for mouse words --- extra/game-input/game-input-docs.factor | 29 ++++++++++++++++++++++--- 1 file changed, 26 insertions(+), 3 deletions(-) diff --git a/extra/game-input/game-input-docs.factor b/extra/game-input/game-input-docs.factor index 5428ca66d0..b46cf9a295 100755 --- a/extra/game-input/game-input-docs.factor +++ b/extra/game-input/game-input-docs.factor @@ -3,7 +3,7 @@ sequences strings math ; IN: game-input ARTICLE: "game-input" "Game controller input" -"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard input." $nl +"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl "The game input interface must be initialized before being used:" { $subsection open-game-input } { $subsection close-game-input } @@ -18,11 +18,13 @@ ARTICLE: "game-input" "Game controller input" { $subsection instance-id } "A hook is provided for invoking the system calibration tool:" { $subsection calibrate-controller } -"The current state of a controller or the keyboard can be read:" +"The current state of a controller, the keyboard, and the mouse can be read:" { $subsection read-controller } { $subsection read-keyboard } +{ $subsection read-mouse } { $subsection controller-state } -{ $subsection keyboard-state } ; +{ $subsection keyboard-state } +{ $subsection mouse-state } ; HELP: open-game-input { $description "Initializes the game input interface. An exception will be thrown if the initialization fails. If the game input interface is already opened, nothing happens." } ; @@ -86,6 +88,14 @@ HELP: read-keyboard { $warning "For efficiency, the implementation may reuse the returned " { $snippet "keyboard-state" } " object next time " { $snippet "read-keyboard" } " is called. You should " { $link clone } " any values from the returned tuple you need to preserve." $nl "The keyboard state returned by this word is unprocessed by any keymaps, modifier keys, key repeat settings, or other operating environment postprocessing. Because of this, " { $snippet "read-keyboard" } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ; +HELP: read-mouse +{ $values { "mouse-state" mouse-state } } +{ $description "Reads the current mouse state relative to either when the game input interface was opened with " { $link open-game-input } " or when the mouse state was reset with " { $link reset-mouse } "." } +{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "mouse-state" } " object for future " { $snippet "read-mouse" } " or " { $snippet "reset-mouse" } " calls. You should " { $link clone } " the " { $snippet "mouse-state" } " object if you need to preserve it." } ; + +HELP: reset-mouse +{ $description "Resets the mouse state. Future " { $link read-mouse } " values will be relative to the time this word is called." } ; + HELP: controller-state { $class-description "The " { $link read-controller } " word returns objects of this class. " { $snippet "controller-state" } " objects have the following slots:" { $list @@ -121,6 +131,19 @@ HELP: keyboard-state { $class-description "The " { $link read-keyboard } " word returns objects of this class. The " { $snippet "keys" } " slot of a " { $snippet "keyboard-state" } " object contains a " { $link sequence } " of 256 members representing the state of the keys on the keyboard. Each element is a boolean value indicating whether the corresponding key is pressed. The sequence is indexed by scancode as defined under usage page 7 of the USB HID standard. Named scancode constants are provided in the " { $vocab-link "game-input.scancodes" } " vocabulary." } { $warning "The scancodes used to index " { $snippet "keyboard-state" } " objects correspond to physical key positions on the keyboard--they are unaffected by keymaps, modifier keys, or other operating environment postprocessing. The face value of the constants in " { $vocab-link "game-input.scancodes" } " do not necessarily correspond to what the user expects the key to type. Because of this, " { $link read-keyboard } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ; +HELP: mouse-state +{ $class-description "The " { $link read-mouse } " word returns objects of this class. " { $snippet "mouse-state" } " objects have the following slots:" +{ $list + { { $snippet "dx" } " contains the mouse's X axis movement." } + { { $snippet "dy" } " contains the mouse's Y axis movement." } + { { $snippet "scroll-dx" } " contains the scroller's X axis movement." } + { { $snippet "scroll-dy" } " contains the scroller's Y axis movement." } + { { $snippet "buttons" } " contains a sequence of boolean values indicate the state of the mouse's buttons." } +} +"Mouse movement is recorded relative to when the game input interface was opened with " { $link open-game-input } " or the mouse state is reset with " { $link reset-mouse } "." +} ; + + { keyboard-state read-keyboard } related-words ABOUT: "game-input" From 4764f1c676335105c955170857c3c260ee4582cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 10:29:22 -0500 Subject: [PATCH 012/210] Fix botched replace all in VM source, clean up image saving code, and fix save-image-and-exit to actually call (save-image-and-exit) instead of (save-image) --- basis/tools/deploy/shaker/shaker.factor | 10 ++-------- core/memory/memory.factor | 2 +- vm/factor.cpp | 2 +- vm/image.cpp | 20 ++++++-------------- vm/run.hpp | 7 ++++++- 5 files changed, 16 insertions(+), 25 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index fd43d1ccc9..e8f4238ed6 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -346,13 +346,6 @@ IN: tools.deploy.shaker : compress-wrappers ( -- ) [ wrapper? ] [ ] "wrappers" compress ; -: finish-deploy ( final-image -- ) - "Finishing up" show - V{ } set-namestack - V{ } set-catchstack - "Saving final image" show - save-image-and-exit ; - SYMBOL: deploy-vocab : [:c] ( -- word ) ":c" "debugger" lookup ; @@ -437,7 +430,8 @@ SYMBOL: deploy-vocab "Vocabulary has no MAIN: word." print flush 1 exit ] unless strip - finish-deploy + "Saving final image" show + save-image-and-exit ] deploy-error-handler ] bind ; diff --git a/core/memory/memory.factor b/core/memory/memory.factor index c748f71c8e..1c61e33d83 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -26,6 +26,6 @@ IN: memory normalize-path native-string>alien (save-image) ; : save-image-and-exit ( path -- ) - normalize-path native-string>alien (save-image) ; + normalize-path native-string>alien (save-image-and-exit) ; : save ( -- ) image save-image ; diff --git a/vm/factor.cpp b/vm/factor.cpp index b607adba63..f8f7901304 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -134,7 +134,7 @@ VM_C_API void init_factor(vm_parameters *p) userenv[CPU_ENV] = allot_alien(F,(cell)FACTOR_CPU_STRING); userenv[OS_ENV] = allot_alien(F,(cell)FACTOR_OS_STRING); - userenv[cell_SIZE_ENV] = tag_fixnum(sizeof(cell)); + userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(cell)); userenv[EXECUTABLE_ENV] = allot_alien(F,(cell)p->executable_path); userenv[ARGS_ENV] = F; userenv[EMBEDDED_ENV] = F; diff --git a/vm/image.cpp b/vm/image.cpp index 2aa7727136..fd547cca50 100755 --- a/vm/image.cpp +++ b/vm/image.cpp @@ -106,14 +106,8 @@ bool save_image(const vm_char *filename) h.bignum_pos_one = bignum_pos_one; h.bignum_neg_one = bignum_neg_one; - cell i; - for(i = 0; i < USER_ENV; i++) - { - if(i < FIRST_SAVE_ENV) - h.userenv[i] = F; - else - h.userenv[i] = userenv[i]; - } + for(cell i = 0; i < USER_ENV; i++) + h.userenv[i] = (save_env_p(i) ? userenv[i] : F); bool ok = true; @@ -149,12 +143,10 @@ PRIMITIVE(save_image_and_exit) path.untag_check(); /* strip out userenv data which is set on startup anyway */ - cell i; - for(i = 0; i < FIRST_SAVE_ENV; i++) - userenv[i] = F; - - for(i = LAST_SAVE_ENV + 1; i < STACK_TRACES_ENV; i++) - userenv[i] = F; + for(cell i = 0; i < USER_ENV; i++) + { + if(!save_env_p(i)) userenv[i] = F; + } /* do a full GC + code heap compaction */ performing_compaction = true; diff --git a/vm/run.hpp b/vm/run.hpp index 2204585fe5..829e25d2f7 100755 --- a/vm/run.hpp +++ b/vm/run.hpp @@ -14,7 +14,7 @@ enum special_object { BREAK_ENV = 5, /* quotation called by throw primitive */ ERROR_ENV, /* a marker consed onto kernel errors */ - cell_SIZE_ENV = 7, /* sizeof(cell) */ + CELL_SIZE_ENV = 7, /* sizeof(cell) */ CPU_ENV, /* CPU architecture */ OS_ENV, /* operating system name */ @@ -93,6 +93,11 @@ enum special_object { #define FIRST_SAVE_ENV BOOT_ENV #define LAST_SAVE_ENV STAGE2_ENV +inline static bool save_env_p(cell i) +{ + return (i >= FIRST_SAVE_ENV && i <= LAST_SAVE_ENV) || i == STACK_TRACES_ENV; +} + /* Canonical T object. It's just a word */ extern cell T; From bec40fd54b5f7694fe3301c115a3b8bfd629192a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 11:07:20 -0500 Subject: [PATCH 013/210] Store forwarding table off to the side instead of in the code block; saves one cell per code block --- vm/callstack.cpp | 2 +- vm/code_block.cpp | 28 ++++++++++++++-------------- vm/code_gc.cpp | 38 +++++++++++++++++++------------------- vm/code_gc.hpp | 4 ++-- vm/code_heap.cpp | 10 ++++++---- vm/inline_cache.cpp | 4 ++-- vm/layouts.hpp | 13 +++---------- vm/master.hpp | 5 +++++ vm/quotations.cpp | 2 +- vm/words.cpp | 2 +- vm/words.hpp | 2 +- 11 files changed, 55 insertions(+), 55 deletions(-) diff --git a/vm/callstack.cpp b/vm/callstack.cpp index ade0b45db7..2ad58534b5 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -100,7 +100,7 @@ code_block *frame_code(stack_frame *frame) cell frame_type(stack_frame *frame) { - return frame_code(frame)->block.type; + return frame_code(frame)->type; } cell frame_executing(stack_frame *frame) diff --git a/vm/code_block.cpp b/vm/code_block.cpp index 4694381ed3..80adb1feac 100644 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -5,7 +5,7 @@ namespace factor void flush_icache_for(code_block *block) { - flush_icache((cell)block,block->block.size); + flush_icache((cell)block,block->size); } void iterate_relocations(code_block *compiled, relocation_iterator iter) @@ -122,7 +122,7 @@ void update_literal_references_step(relocation_entry rel, cell index, code_block /* Update pointers to literals from compiled code. */ void update_literal_references(code_block *compiled) { - if(!compiled->block.needs_fixup) + if(!compiled->needs_fixup) { iterate_relocations(compiled,update_literal_references_step); flush_icache_for(compiled); @@ -133,12 +133,12 @@ void update_literal_references(code_block *compiled) aging and nursery collections */ void copy_literal_references(code_block *compiled) { - if(collecting_gen >= compiled->block.last_scan) + if(collecting_gen >= compiled->last_scan) { if(collecting_accumulation_gen_p()) - compiled->block.last_scan = collecting_gen; + compiled->last_scan = collecting_gen; else - compiled->block.last_scan = collecting_gen + 1; + compiled->last_scan = collecting_gen + 1; /* initialize chase pointer */ cell scan = newspace->here; @@ -208,7 +208,7 @@ to update references to other words, without worrying about literals or dlsyms. */ void update_word_references(code_block *compiled) { - if(compiled->block.needs_fixup) + if(compiled->needs_fixup) relocate_code_block(compiled); /* update_word_references() is always applied to every block in the code heap. Since it resets all call sites to point to @@ -217,8 +217,8 @@ void update_word_references(code_block *compiled) are referenced after this is done. So instead of polluting the code heap with dead PICs that will be freed on the next GC, we add them to the free list immediately. */ - else if(compiled->block.type == PIC_TYPE) - heap_free(&code,&compiled->block); + else if(compiled->type == PIC_TYPE) + heap_free(&code,compiled); else { iterate_relocations(compiled,update_word_references_step); @@ -248,7 +248,7 @@ void mark_code_block(code_block *compiled) { check_code_address((cell)compiled); - mark_block(&compiled->block); + mark_block(compiled); copy_handle(&compiled->literals); copy_handle(&compiled->relocation); @@ -405,8 +405,8 @@ void relocate_code_block_step(relocation_entry rel, cell index, code_block *comp /* Perform all fixups on a code block */ void relocate_code_block(code_block *compiled) { - compiled->block.last_scan = NURSERY; - compiled->block.needs_fixup = false; + compiled->last_scan = NURSERY; + compiled->needs_fixup = false; iterate_relocations(compiled,relocate_code_block_step); flush_icache_for(compiled); } @@ -474,9 +474,9 @@ code_block *add_code_block( code_block *compiled = allot_code_block(code_length); /* compiled header */ - compiled->block.type = type; - compiled->block.last_scan = NURSERY; - compiled->block.needs_fixup = true; + compiled->type = type; + compiled->last_scan = NURSERY; + compiled->needs_fixup = true; compiled->relocation = relocation.value(); /* slight space optimization */ diff --git a/vm/code_gc.cpp b/vm/code_gc.cpp index b86d08cf52..721c3f3a7a 100755 --- a/vm/code_gc.cpp +++ b/vm/code_gc.cpp @@ -22,9 +22,9 @@ void new_heap(heap *heap, cell size) static void add_to_free_list(heap *heap, free_heap_block *block) { - if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) + if(block->size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) { - int index = block->block.size / BLOCK_SIZE_INCREMENT; + int index = block->size / BLOCK_SIZE_INCREMENT; block->next_free = heap->free.small_blocks[index]; heap->free.small_blocks[index] = block; } @@ -73,8 +73,8 @@ void build_free_list(heap *heap, cell size) branch is only taken after loading a new image, not after code GC */ if((cell)(end + 1) <= heap->seg->end) { - end->block.status = B_FREE; - end->block.size = heap->seg->end - (cell)end; + end->status = B_FREE; + end->size = heap->seg->end - (cell)end; /* add final free block */ add_to_free_list(heap,end); @@ -93,7 +93,7 @@ void build_free_list(heap *heap, cell size) static void assert_free_block(free_heap_block *block) { - if(block->block.status != B_FREE) + if(block->status != B_FREE) critical_error("Invalid block in free list",(cell)block); } @@ -121,7 +121,7 @@ static free_heap_block *find_free_block(heap *heap, cell size) while(block) { assert_free_block(block); - if(block->block.size >= size) + if(block->size >= size) { if(prev) prev->next_free = block->next_free; @@ -139,14 +139,14 @@ static free_heap_block *find_free_block(heap *heap, cell size) static free_heap_block *split_free_block(heap *heap, free_heap_block *block, cell size) { - if(block->block.size != size ) + if(block->size != size ) { /* split the block in two */ free_heap_block *split = (free_heap_block *)((cell)block + size); - split->block.status = B_FREE; - split->block.size = block->block.size - size; + split->status = B_FREE; + split->size = block->size - size; split->next_free = block->next_free; - block->block.size = size; + block->size = size; add_to_free_list(heap,split); } @@ -163,8 +163,8 @@ heap_block *heap_allot(heap *heap, cell size) { block = split_free_block(heap,block,size); - block->block.status = B_ALLOCATED; - return &block->block; + block->status = B_ALLOCATED; + return block; } else return NULL; @@ -303,16 +303,16 @@ cell heap_size(heap *heap) } /* Compute where each block is going to go, after compaction */ -cell compute_heap_forwarding(heap *heap) + cell compute_heap_forwarding(heap *heap, std::tr1::unordered_map &forwarding) { heap_block *scan = first_block(heap); - cell address = (cell)first_block(heap); + char *address = (char *)first_block(heap); while(scan) { if(scan->status == B_ALLOCATED) { - scan->forwarding = (heap_block *)address; + forwarding[scan] = address; address += scan->size; } else if(scan->status == B_MARKED) @@ -321,10 +321,10 @@ cell compute_heap_forwarding(heap *heap) scan = next_block(heap,scan); } - return address - heap->seg->start; + return (cell)address - heap->seg->start; } -void compact_heap(heap *heap) + void compact_heap(heap *heap, std::tr1::unordered_map &forwarding) { heap_block *scan = first_block(heap); @@ -332,8 +332,8 @@ void compact_heap(heap *heap) { heap_block *next = next_block(heap,scan); - if(scan->status == B_ALLOCATED && scan != scan->forwarding) - memcpy(scan->forwarding,scan,scan->size); + if(scan->status == B_ALLOCATED) + memmove(forwarding[scan],scan,scan->size); scan = next; } } diff --git a/vm/code_gc.hpp b/vm/code_gc.hpp index 3879d3c8e8..1ad68f46fd 100755 --- a/vm/code_gc.hpp +++ b/vm/code_gc.hpp @@ -25,8 +25,8 @@ void unmark_marked(heap *heap); void free_unmarked(heap *heap, heap_iterator iter); void heap_usage(heap *h, cell *used, cell *total_free, cell *max_free); cell heap_size(heap *h); -cell compute_heap_forwarding(heap *h); -void compact_heap(heap *h); +cell compute_heap_forwarding(heap *h, std::tr1::unordered_map &forwarding); +void compact_heap(heap *h, std::tr1::unordered_map &forwarding); inline static heap_block *next_block(heap *h, heap_block *block) { diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index 5dca29b420..2342a3dd09 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -119,9 +119,11 @@ PRIMITIVE(code_room) dpush(tag_fixnum(max_free / 1024)); } +static std::tr1::unordered_map forwarding; + code_block *forward_xt(code_block *compiled) { - return (code_block *)compiled->block.forwarding; + return (code_block *)forwarding[compiled]; } void forward_frame_xt(stack_frame *frame) @@ -132,7 +134,7 @@ void forward_frame_xt(stack_frame *frame) FRAME_RETURN_ADDRESS(frame) = (void *)((cell)forwarded + offset); } -void forward_object_xts(void) +void forward_object_xts() { begin_scan(); @@ -215,13 +217,13 @@ void compact_code_heap(void) gc(); /* Figure out where the code heap blocks are going to end up */ - cell size = compute_heap_forwarding(&code); + cell size = compute_heap_forwarding(&code, forwarding); /* Update word and quotation code pointers */ forward_object_xts(); /* Actually perform the compaction */ - compact_heap(&code); + compact_heap(&code,forwarding); /* Update word and quotation XTs */ fixup_object_xts(); diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp index 5d9fbf069e..23c4b27c47 100644 --- a/vm/inline_cache.cpp +++ b/vm/inline_cache.cpp @@ -22,7 +22,7 @@ void deallocate_inline_cache(cell return_address) /* Find the call target. */ void *old_xt = get_call_target(return_address); code_block *old_block = (code_block *)old_xt - 1; - cell old_type = old_block->block.type; + cell old_type = old_block->type; #ifdef FACTOR_DEBUG /* The call target was either another PIC, @@ -31,7 +31,7 @@ void deallocate_inline_cache(cell return_address) #endif if(old_type == PIC_TYPE) - heap_free(&code,&old_block->block); + heap_free(&code,old_block); } /* Figure out what kind of type check the PIC needs based on the methods diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 4928fda632..114b88b925 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -193,26 +193,19 @@ struct heap_block unsigned char status; /* free or allocated? */ unsigned char type; /* this is WORD_TYPE or QUOTATION_TYPE */ unsigned char last_scan; /* the youngest generation in which this block's literals may live */ - char needs_fixup; /* is this a new block that needs full fixup? */ + unsigned char needs_fixup; /* is this a new block that needs full fixup? */ /* In bytes, includes this header */ cell size; - - /* Used during compaction */ - heap_block *forwarding; }; -struct free_heap_block +struct free_heap_block : public heap_block { - heap_block block; - - /* Filled in on image load */ free_heap_block *next_free; }; -struct code_block +struct code_block : public heap_block { - heap_block block; cell literals; /* # bytes */ cell relocation; /* tagged pointer to byte-array or f */ diff --git a/vm/master.hpp b/vm/master.hpp index fa7d7fa1a4..65d17fab4b 100644 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -9,6 +9,7 @@ #include #endif +/* C headers */ #include #include #include @@ -20,6 +21,10 @@ #include #include +/* C++ headers */ +#include + +/* Factor headers */ #include "layouts.hpp" #include "platform.hpp" #include "primitives.hpp" diff --git a/vm/quotations.cpp b/vm/quotations.cpp index c87cf8dc82..af00bb468b 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -251,7 +251,7 @@ void quotation_jit::iterate_quotation() void set_quot_xt(quotation *quot, code_block *code) { - if(code->block.type != QUOTATION_TYPE) + if(code->type != QUOTATION_TYPE) critical_error("Bad param to set_quot_xt",(cell)code); quot->code = code; diff --git a/vm/words.cpp b/vm/words.cpp index cb2fdf0dd6..6e7c633c84 100644 --- a/vm/words.cpp +++ b/vm/words.cpp @@ -44,7 +44,7 @@ PRIMITIVE(word_xt) word *w = untag_check(dpop()); code_block *code = (profiling_p ? w->profiling : w->code); dpush(allot_cell((cell)code->xt())); - dpush(allot_cell((cell)code + code->block.size)); + dpush(allot_cell((cell)code + code->size)); } /* Allocates memory */ diff --git a/vm/words.hpp b/vm/words.hpp index 9c8e7ad57a..f9d5a7aff4 100644 --- a/vm/words.hpp +++ b/vm/words.hpp @@ -9,7 +9,7 @@ void update_word_xt(cell word); inline bool word_optimized_p(word *word) { - return word->code->block.type == WORD_TYPE; + return word->code->type == WORD_TYPE; } PRIMITIVE(optimized_p); From ec943c22990df678662783d2875d7058bb426445 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 11:33:35 -0500 Subject: [PATCH 014/210] Change (void) to () --- vm/alien.cpp | 4 ++-- vm/alien.hpp | 2 +- vm/callstack.cpp | 2 +- vm/code_block.cpp | 2 +- vm/code_block.hpp | 2 +- vm/code_heap.cpp | 8 ++++---- vm/code_heap.hpp | 4 ++-- vm/contexts.cpp | 14 +++++++------- vm/contexts.hpp | 12 ++++++------ vm/data_gc.cpp | 16 ++++++++-------- vm/data_gc.hpp | 10 +++++----- vm/data_heap.cpp | 8 ++++---- vm/data_heap.hpp | 8 ++++---- vm/debug.cpp | 12 ++++++------ vm/debug.hpp | 4 ++-- vm/errors.cpp | 10 +++++----- vm/errors.hpp | 10 +++++----- vm/factor.cpp | 6 +++--- vm/factor.hpp | 2 +- vm/io.cpp | 8 ++++---- vm/io.hpp | 8 ++++---- vm/mach_signal.cpp | 2 +- vm/mach_signal.hpp | 2 +- vm/math.cpp | 2 +- vm/math.hpp | 2 +- vm/os-freebsd.cpp | 2 +- vm/os-freebsd.hpp | 2 +- vm/os-genunix.cpp | 6 +++--- vm/os-genunix.hpp | 8 ++++---- vm/os-linux.cpp | 6 +++--- vm/os-linux.hpp | 2 +- vm/os-macosx.hpp | 8 ++++---- vm/os-netbsd.cpp | 2 +- vm/os-openbsd.cpp | 2 +- vm/os-solaris.cpp | 2 +- vm/os-unix.cpp | 10 +++++----- vm/os-unix.hpp | 8 ++++---- vm/os-windows-ce.cpp | 4 ++-- vm/os-windows-ce.hpp | 4 ++-- vm/os-windows-nt.cpp | 4 ++-- vm/os-windows-nt.hpp | 2 +- vm/os-windows.cpp | 8 ++++---- vm/os-windows.hpp | 14 +++++++------- vm/profiler.cpp | 2 +- vm/profiler.hpp | 2 +- vm/quotations.cpp | 2 +- vm/quotations.hpp | 2 +- vm/stacks.hpp | 2 +- vm/utilities.cpp | 4 ++-- vm/utilities.hpp | 4 ++-- 50 files changed, 136 insertions(+), 136 deletions(-) diff --git a/vm/alien.cpp b/vm/alien.cpp index 06dee31a14..29d18033c7 100755 --- a/vm/alien.cpp +++ b/vm/alien.cpp @@ -77,7 +77,7 @@ PRIMITIVE(alien_address) } /* pop ( alien n ) from datastack, return alien's address plus n */ -static void *alien_pointer(void) +static void *alien_pointer() { fixnum offset = to_fixnum(dpop()); return unbox_alien() + offset; @@ -182,7 +182,7 @@ VM_C_API char *alien_offset(cell obj) } /* pop an object representing a C pointer */ -VM_C_API char *unbox_alien(void) +VM_C_API char *unbox_alien() { return alien_offset(dpop()); } diff --git a/vm/alien.hpp b/vm/alien.hpp index a66135cf92..6235a2d6c7 100755 --- a/vm/alien.hpp +++ b/vm/alien.hpp @@ -39,7 +39,7 @@ PRIMITIVE(dlclose); PRIMITIVE(dll_validp); VM_C_API char *alien_offset(cell object); -VM_C_API char *unbox_alien(void); +VM_C_API char *unbox_alien(); VM_C_API void box_alien(void *ptr); VM_C_API void to_value_struct(cell src, void *dest, cell size); VM_C_API void box_value_struct(void *src, cell size); diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 2ad58534b5..d9ac8d6073 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -54,7 +54,7 @@ This means that if 'callstack' is called in tail position, we will have popped a necessary frame... however this word is only called by continuation implementation, and user code shouldn't be calling it at all, so we leave it as it is for now. */ -stack_frame *capture_start(void) +stack_frame *capture_start() { stack_frame *frame = stack_chain->callstack_bottom - 1; while(frame >= stack_chain->callstack_top diff --git a/vm/code_block.cpp b/vm/code_block.cpp index 80adb1feac..d27460853d 100644 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -302,7 +302,7 @@ void mark_object_code_block(object *object) /* References to undefined symbols are patched up to call this function on image load */ -void undefined_symbol(void) +void undefined_symbol() { general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL); } diff --git a/vm/code_block.hpp b/vm/code_block.hpp index 9689ea5419..9ca1a419b6 100644 --- a/vm/code_block.hpp +++ b/vm/code_block.hpp @@ -82,7 +82,7 @@ void mark_object_code_block(object *scan); void relocate_code_block(code_block *relocating); -inline static bool stack_traces_p(void) +inline static bool stack_traces_p() { return userenv[STACK_TRACES_ENV] != F; } diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index 2342a3dd09..db1fd8f880 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -45,14 +45,14 @@ void iterate_code_heap(code_heap_iterator iter) /* Copy literals referenced from all code blocks to newspace. Only for aging and nursery collections */ -void copy_code_heap_roots(void) +void copy_code_heap_roots() { iterate_code_heap(copy_literal_references); } /* Update pointers to words referenced from all code blocks. Only after defining a new word. */ -void update_code_heap_words(void) +void update_code_heap_words() { iterate_code_heap(update_word_references); } @@ -178,7 +178,7 @@ void forward_object_xts() } /* Set the XT fields now that the heap has been compacted */ -void fixup_object_xts(void) +void fixup_object_xts() { begin_scan(); @@ -211,7 +211,7 @@ void fixup_object_xts(void) since it makes several passes over the code and data heaps, but we only ever do this before saving a deployed image and exiting, so performaance is not critical here */ -void compact_code_heap(void) +void compact_code_heap() { /* Free all unreachable code blocks */ gc(); diff --git a/vm/code_heap.hpp b/vm/code_heap.hpp index 056a6a88c6..6f139a4728 100755 --- a/vm/code_heap.hpp +++ b/vm/code_heap.hpp @@ -14,13 +14,13 @@ typedef void (*code_heap_iterator)(code_block *compiled); void iterate_code_heap(code_heap_iterator iter); -void copy_code_heap_roots(void); +void copy_code_heap_roots(); PRIMITIVE(modify_code_heap); PRIMITIVE(code_room); -void compact_code_heap(void); +void compact_code_heap(); inline static void check_code_pointer(cell ptr) { diff --git a/vm/contexts.cpp b/vm/contexts.cpp index 66570abc31..239b70876a 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -8,19 +8,19 @@ namespace factor cell ds_size, rs_size; context *unused_contexts; -void reset_datastack(void) +void reset_datastack() { ds = ds_bot - sizeof(cell); } -void reset_retainstack(void) +void reset_retainstack() { rs = rs_bot - sizeof(cell); } #define RESERVED (64 * sizeof(cell)) -void fix_stacks(void) +void fix_stacks() { if(ds + sizeof(cell) < ds_bot || ds + RESERVED >= ds_top) reset_datastack(); if(rs + sizeof(cell) < rs_bot || rs + RESERVED >= rs_top) reset_retainstack(); @@ -28,7 +28,7 @@ void fix_stacks(void) /* called before entry into foreign C code. Note that ds and rs might be stored in registers, so callbacks must save and restore the correct values */ -void save_stacks(void) +void save_stacks() { if(stack_chain) { @@ -37,7 +37,7 @@ void save_stacks(void) } } -context *alloc_context(void) +context *alloc_context() { context *new_context; @@ -63,7 +63,7 @@ void dealloc_context(context *old_context) } /* called on entry into a compiled callback */ -void nest_stacks(void) +void nest_stacks() { context *new_context = alloc_context(); @@ -95,7 +95,7 @@ void nest_stacks(void) } /* called when leaving a compiled callback */ -void unnest_stacks(void) +void unnest_stacks() { ds = stack_chain->datastack_save; rs = stack_chain->retainstack_save; diff --git a/vm/contexts.hpp b/vm/contexts.hpp index 13af17f2f0..4a6f401f0b 100644 --- a/vm/contexts.hpp +++ b/vm/contexts.hpp @@ -46,9 +46,9 @@ extern cell ds_size, rs_size; DEFPUSHPOP(d,ds) DEFPUSHPOP(r,rs) -void reset_datastack(void); -void reset_retainstack(void); -void fix_stacks(void); +void reset_datastack(); +void reset_retainstack(); +void fix_stacks(); void init_stacks(cell ds_size, cell rs_size); PRIMITIVE(datastack); @@ -57,9 +57,9 @@ PRIMITIVE(set_datastack); PRIMITIVE(set_retainstack); PRIMITIVE(check_datastack); -VM_C_API void save_stacks(void); -VM_C_API void nest_stacks(void); -VM_C_API void unnest_stacks(void); +VM_C_API void save_stacks(); +VM_C_API void nest_stacks(); +VM_C_API void unnest_stacks(); } diff --git a/vm/data_gc.cpp b/vm/data_gc.cpp index e26edc9721..c9dbe9a953 100755 --- a/vm/data_gc.cpp +++ b/vm/data_gc.cpp @@ -33,7 +33,7 @@ cell last_code_heap_scan; bool growing_data_heap; data_heap *old_data_heap; -void init_data_gc(void) +void init_data_gc() { performing_gc = false; last_code_heap_scan = NURSERY; @@ -244,7 +244,7 @@ static void copy_gen_cards(cell gen) /* Scan cards in all generations older than the one being collected, copying old->new references */ -static void copy_cards(void) +static void copy_cards() { u64 start = current_micros(); @@ -264,7 +264,7 @@ static void copy_stack_elements(segment *region, cell top) copy_handle((cell*)ptr); } -static void copy_registered_locals(void) +static void copy_registered_locals() { cell scan = gc_locals_region->start; @@ -272,7 +272,7 @@ static void copy_registered_locals(void) copy_handle(*(cell **)scan); } -static void copy_registered_bignums(void) +static void copy_registered_bignums() { cell scan = gc_bignums_region->start; @@ -295,7 +295,7 @@ static void copy_registered_bignums(void) /* Copy roots over at the start of GC, namely various constants, stacks, the user environment and extra roots registered by local_roots.hpp */ -static void copy_roots(void) +static void copy_roots() { copy_handle(&T); copy_handle(&bignum_zero); @@ -593,7 +593,7 @@ void garbage_collection(cell gen, performing_gc = false; } -void gc(void) +void gc() { garbage_collection(TENURED,false,0); } @@ -633,7 +633,7 @@ PRIMITIVE(gc_stats) dpush(result.elements.value()); } -void clear_gc_stats(void) +void clear_gc_stats() { int i; for(i = 0; i < MAX_GEN_COUNT; i++) @@ -681,7 +681,7 @@ PRIMITIVE(become) compile_all_words(); } -VM_C_API void minor_gc(void) +VM_C_API void minor_gc() { garbage_collection(NURSERY,false,0); } diff --git a/vm/data_gc.hpp b/vm/data_gc.hpp index 2869179394..01bff2ef68 100755 --- a/vm/data_gc.hpp +++ b/vm/data_gc.hpp @@ -18,11 +18,11 @@ extern bool collecting_aging_again; extern cell last_code_heap_scan; -void init_data_gc(void); +void init_data_gc(); -void gc(void); +void gc(); -inline static bool collecting_accumulation_gen_p(void) +inline static bool collecting_accumulation_gen_p() { return ((HAVE_AGING_P && collecting_gen == AGING @@ -114,7 +114,7 @@ void copy_reachable_objects(cell scan, cell *end); PRIMITIVE(gc); PRIMITIVE(gc_stats); -void clear_gc_stats(void); +void clear_gc_stats(); PRIMITIVE(clear_gc_stats); PRIMITIVE(become); @@ -143,6 +143,6 @@ inline static void check_tagged_pointer(cell tagged) #endif } -VM_C_API void minor_gc(void); +VM_C_API void minor_gc(); } diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp index d83773de9c..0045539549 100644 --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -24,7 +24,7 @@ cell init_zone(zone *z, cell size, cell start) return z->end; } -void init_card_decks(void) +void init_card_decks() { cell start = align(data->seg->start,DECK_SIZE); allot_markers_offset = (cell)data->allot_markers - (start >> CARD_BITS); @@ -312,7 +312,7 @@ references to an object for debugging purposes. */ cell heap_scan_ptr; /* Disables GC and activates next-object ( -- obj ) primitive */ -void begin_scan(void) +void begin_scan() { heap_scan_ptr = data->generations[TENURED].start; gc_off = true; @@ -323,7 +323,7 @@ PRIMITIVE(begin_scan) begin_scan(); } -cell next_object(void) +cell next_object() { if(!gc_off) general_error(ERROR_HEAP_SCAN,F,F,NULL); @@ -348,7 +348,7 @@ PRIMITIVE(end_scan) gc_off = false; } -cell find_all_words(void) +cell find_all_words() { growable_array words; diff --git a/vm/data_heap.hpp b/vm/data_heap.hpp index bb8b35341e..bec86a2d0d 100644 --- a/vm/data_heap.hpp +++ b/vm/data_heap.hpp @@ -56,7 +56,7 @@ inline static bool in_zone(zone *z, object *pointer) cell init_zone(zone *z, cell size, cell base); -void init_card_decks(void); +void init_card_decks(); data_heap *grow_data_heap(data_heap *data, cell requested_bytes); @@ -86,8 +86,8 @@ cell unaligned_object_size(object *pointer); cell binary_payload_start(object *pointer); cell object_size(cell tagged); -void begin_scan(void); -cell next_object(void); +void begin_scan(); +cell next_object(); PRIMITIVE(data_room); PRIMITIVE(size); @@ -99,7 +99,7 @@ PRIMITIVE(end_scan); /* GC is off during heap walking */ extern bool gc_off; -cell find_all_words(void); +cell find_all_words(); /* Every object has a regular representation in the runtime, which makes GC much simpler. Every slot of the object until binary_payload_start is a pointer diff --git a/vm/debug.cpp b/vm/debug.cpp index 3cd05711ad..49fdd92541 100755 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -155,13 +155,13 @@ void print_objects(cell *start, cell *end) } } -void print_datastack(void) +void print_datastack() { print_string("==== DATA STACK:\n"); print_objects((cell *)ds_bot,(cell *)ds); } -void print_retainstack(void) +void print_retainstack() { print_string("==== RETAIN STACK:\n"); print_objects((cell *)rs_bot,(cell *)rs); @@ -179,7 +179,7 @@ void print_stack_frame(stack_frame *frame) print_string("\n"); } -void print_callstack(void) +void print_callstack() { print_string("==== CALL STACK:\n"); cell bottom = (cell)stack_chain->callstack_bottom; @@ -210,7 +210,7 @@ void dump_zone(zone *z) print_string(", here="); print_cell(z->here - z->start); nl(); } -void dump_generations(void) +void dump_generations() { cell i; @@ -285,7 +285,7 @@ void find_data_references(cell look_for_) } /* Dump all code blocks for debugging */ -void dump_code_heap(void) +void dump_code_heap() { cell reloc_size = 0, literal_size = 0; @@ -325,7 +325,7 @@ void dump_code_heap(void) print_cell(literal_size); print_string(" bytes of literal data\n"); } -void factorbug(void) +void factorbug() { if(fep_disabled) { diff --git a/vm/debug.hpp b/vm/debug.hpp index 81874bf2ac..cb84c9256c 100755 --- a/vm/debug.hpp +++ b/vm/debug.hpp @@ -3,8 +3,8 @@ namespace factor void print_obj(cell obj); void print_nested_obj(cell obj, fixnum nesting); -void dump_generations(void); -void factorbug(void); +void dump_generations(); +void factorbug(); void dump_zone(zone *z); PRIMITIVE(die); diff --git a/vm/errors.cpp b/vm/errors.cpp index f2ba355293..610482f576 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -9,7 +9,7 @@ cell signal_number; cell signal_fault_addr; stack_frame *signal_callstack_top; -void out_of_memory(void) +void out_of_memory() { print_string("Out of memory\n\n"); dump_generations(); @@ -88,7 +88,7 @@ void type_error(cell type, cell tagged) general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL); } -void not_implemented_error(void) +void not_implemented_error() { general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL); } @@ -125,7 +125,7 @@ void signal_error(int signal, stack_frame *native_stack) general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack); } -void divide_by_zero_error(void) +void divide_by_zero_error() { general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL); } @@ -141,12 +141,12 @@ PRIMITIVE(unimplemented) not_implemented_error(); } -void memory_signal_handler_impl(void) +void memory_signal_handler_impl() { memory_protection_error(signal_fault_addr,signal_callstack_top); } -void misc_signal_handler_impl(void) +void misc_signal_handler_impl() { signal_error(signal_number,signal_callstack_top); } diff --git a/vm/errors.hpp b/vm/errors.hpp index e5968468a5..11180508e5 100755 --- a/vm/errors.hpp +++ b/vm/errors.hpp @@ -22,7 +22,7 @@ enum vm_error_type ERROR_MEMORY, }; -void out_of_memory(void); +void out_of_memory(); void fatal_error(const char* msg, cell tagged); void critical_error(const char* msg, cell tagged); @@ -30,11 +30,11 @@ PRIMITIVE(die); void throw_error(cell error, stack_frame *native_stack); void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *native_stack); -void divide_by_zero_error(void); +void divide_by_zero_error(); void memory_protection_error(cell addr, stack_frame *native_stack); void signal_error(int signal, stack_frame *native_stack); void type_error(cell type, cell tagged); -void not_implemented_error(void); +void not_implemented_error(); PRIMITIVE(call_clear); PRIMITIVE(unimplemented); @@ -45,7 +45,7 @@ extern cell signal_number; extern cell signal_fault_addr; extern stack_frame *signal_callstack_top; -void memory_signal_handler_impl(void); -void misc_signal_handler_impl(void); +void memory_signal_handler_impl(); +void misc_signal_handler_impl(); } diff --git a/vm/factor.cpp b/vm/factor.cpp index f8f7901304..33d8b73dfe 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -81,7 +81,7 @@ VM_C_API void init_parameters_from_args(vm_parameters *p, int argc, vm_char **ar } /* Do some initialization that we do once only */ -static void do_stage1_init(void) +static void do_stage1_init() { print_string("*** Stage 2 early init... "); fflush(stdout); @@ -198,9 +198,9 @@ VM_C_API void factor_eval_free(char *result) free(result); } -VM_C_API void factor_yield(void) +VM_C_API void factor_yield() { - void (*callback)(void) = (void (*)(void))alien_offset(userenv[YIELD_CALLBACK_ENV]); + void (*callback)() = (void (*)())alien_offset(userenv[YIELD_CALLBACK_ENV]); callback(); } diff --git a/vm/factor.hpp b/vm/factor.hpp index e9ba920e9f..6e00bc012e 100644 --- a/vm/factor.hpp +++ b/vm/factor.hpp @@ -10,7 +10,7 @@ VM_C_API void start_standalone_factor(int argc, vm_char **argv); VM_C_API char *factor_eval_string(char *string); VM_C_API void factor_eval_free(char *result); -VM_C_API void factor_yield(void); +VM_C_API void factor_yield(); VM_C_API void factor_sleep(long ms); } diff --git a/vm/io.cpp b/vm/io.cpp index 2d6c94faf0..5bb5834691 100755 --- a/vm/io.cpp +++ b/vm/io.cpp @@ -14,14 +14,14 @@ The Factor library provides platform-specific code for Unix and Windows with many more capabilities so these words are not usually used in normal operation. */ -void init_c_io(void) +void init_c_io() { userenv[STDIN_ENV] = allot_alien(F,(cell)stdin); userenv[STDOUT_ENV] = allot_alien(F,(cell)stdout); userenv[STDERR_ENV] = allot_alien(F,(cell)stderr); } -void io_error(void) +void io_error() { #ifndef WINCE if(errno == EINTR) @@ -216,12 +216,12 @@ PRIMITIVE(fclose) /* This function is used by FFI I/O. Accessing the errno global directly is not portable, since on some libc's errno is not a global but a funky macro that reads thread-local storage. */ -VM_C_API int err_no(void) +VM_C_API int err_no() { return errno; } -VM_C_API void clear_err_no(void) +VM_C_API void clear_err_no() { errno = 0; } diff --git a/vm/io.hpp b/vm/io.hpp index 968e96f0b5..d94d6402d9 100755 --- a/vm/io.hpp +++ b/vm/io.hpp @@ -1,8 +1,8 @@ namespace factor { -void init_c_io(void); -void io_error(void); +void init_c_io(); +void io_error(); PRIMITIVE(fopen); PRIMITIVE(fgetc); @@ -18,7 +18,7 @@ PRIMITIVE(open_file); PRIMITIVE(existsp); PRIMITIVE(read_dir); -VM_C_API int err_no(void); -VM_C_API void clear_err_no(void); +VM_C_API int err_no(); +VM_C_API void clear_err_no(); } diff --git a/vm/mach_signal.cpp b/vm/mach_signal.cpp index f752c3cb8f..03edf862a8 100644 --- a/vm/mach_signal.cpp +++ b/vm/mach_signal.cpp @@ -169,7 +169,7 @@ mach_exception_thread (void *arg) } /* Initialize the Mach exception handler thread. */ -void mach_initialize (void) +void mach_initialize () { mach_port_t self; exception_mask_t mask; diff --git a/vm/mach_signal.hpp b/vm/mach_signal.hpp index 5dd344c080..a2ef07b0ec 100644 --- a/vm/mach_signal.hpp +++ b/vm/mach_signal.hpp @@ -79,6 +79,6 @@ catch_exception_raise_state_identity (mach_port_t exception_port, namespace factor { -void mach_initialize (void); +void mach_initialize (); } diff --git a/vm/math.cpp b/vm/math.cpp index 57d5e4a517..37768f5542 100644 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -219,7 +219,7 @@ PRIMITIVE(byte_array_to_bignum) drepl(tag(result)); } -cell unbox_array_size(void) +cell unbox_array_size() { switch(tagged(dpeek()).type()) { diff --git a/vm/math.hpp b/vm/math.hpp index 763ed55f9a..198960d3b5 100644 --- a/vm/math.hpp +++ b/vm/math.hpp @@ -59,7 +59,7 @@ inline static cell allot_cell(cell x) return tag_fixnum(x); } -cell unbox_array_size(void); +cell unbox_array_size(); inline static double untag_float(cell tagged) { diff --git a/vm/os-freebsd.cpp b/vm/os-freebsd.cpp index 63313f61e0..d259658284 100644 --- a/vm/os-freebsd.cpp +++ b/vm/os-freebsd.cpp @@ -4,7 +4,7 @@ namespace factor { /* From SBCL */ -const char *vm_executable_path(void) +const char *vm_executable_path() { char path[PATH_MAX + 1]; diff --git a/vm/os-freebsd.hpp b/vm/os-freebsd.hpp index 0acf537d45..7797a7199b 100644 --- a/vm/os-freebsd.hpp +++ b/vm/os-freebsd.hpp @@ -1,7 +1,7 @@ #include #include -extern "C" int getosreldate(void); +extern "C" int getosreldate(); #ifndef KERN_PROC_PATHNAME #define KERN_PROC_PATHNAME 12 diff --git a/vm/os-genunix.cpp b/vm/os-genunix.cpp index 731527d208..6cca455eb7 100755 --- a/vm/os-genunix.cpp +++ b/vm/os-genunix.cpp @@ -8,17 +8,17 @@ void c_to_factor_toplevel(cell quot) c_to_factor(quot); } -void init_signals(void) +void init_signals() { unix_init_signals(); } -void early_init(void) { } +void early_init() { } #define SUFFIX ".image" #define SUFFIX_LEN 6 -const char *default_image_path(void) +const char *default_image_path() { const char *path = vm_executable_path(); diff --git a/vm/os-genunix.hpp b/vm/os-genunix.hpp index bc12f716cf..1972a728e6 100644 --- a/vm/os-genunix.hpp +++ b/vm/os-genunix.hpp @@ -5,9 +5,9 @@ namespace factor #define NULL_DLL NULL void c_to_factor_toplevel(cell quot); -void init_signals(void); -void early_init(void); -const char *vm_executable_path(void); -const char *default_image_path(void); +void init_signals(); +void early_init(); +const char *vm_executable_path(); +const char *default_image_path(); } diff --git a/vm/os-linux.cpp b/vm/os-linux.cpp index ecc8973ebe..f5814d7f18 100644 --- a/vm/os-linux.cpp +++ b/vm/os-linux.cpp @@ -4,7 +4,7 @@ namespace factor { /* Snarfed from SBCL linux-so.c. You must free() this yourself. */ -const char *vm_executable_path(void) +const char *vm_executable_path() { char *path = (char *)safe_malloc(PATH_MAX + 1); @@ -23,7 +23,7 @@ const char *vm_executable_path(void) #ifdef SYS_inotify_init -int inotify_init(void) +int inotify_init() { return syscall(SYS_inotify_init); } @@ -40,7 +40,7 @@ int inotify_rm_watch(int fd, u32 wd) #else -int inotify_init(void) +int inotify_init() { not_implemented_error(); return -1; diff --git a/vm/os-linux.hpp b/vm/os-linux.hpp index 4e2f22b95f..257a6b0692 100644 --- a/vm/os-linux.hpp +++ b/vm/os-linux.hpp @@ -3,7 +3,7 @@ namespace factor { -int inotify_init(void); +int inotify_init(); int inotify_add_watch(int fd, const char *name, u32 mask); int inotify_rm_watch(int fd, u32 wd); diff --git a/vm/os-macosx.hpp b/vm/os-macosx.hpp index aa166910f5..cdc0ff7b42 100644 --- a/vm/os-macosx.hpp +++ b/vm/os-macosx.hpp @@ -5,11 +5,11 @@ namespace factor #define FACTOR_OS_STRING "macosx" #define NULL_DLL "libfactor.dylib" -void init_signals(void); -void early_init(void); +void init_signals(); +void early_init(); -const char *vm_executable_path(void); -const char *default_image_path(void); +const char *vm_executable_path(); +const char *default_image_path(); inline static void *ucontext_stack_pointer(void *uap) { diff --git a/vm/os-netbsd.cpp b/vm/os-netbsd.cpp index 7a3cb30652..e280d99a80 100755 --- a/vm/os-netbsd.cpp +++ b/vm/os-netbsd.cpp @@ -5,7 +5,7 @@ namespace factor extern "C" int main(); -const char *vm_executable_path(void) +const char *vm_executable_path() { static Dl_info info = {0}; if (!info.dli_fname) diff --git a/vm/os-openbsd.cpp b/vm/os-openbsd.cpp index fc8aac8cf7..f763f8055f 100644 --- a/vm/os-openbsd.cpp +++ b/vm/os-openbsd.cpp @@ -3,7 +3,7 @@ namespace factor { -const char *vm_executable_path(void) +const char *vm_executable_path() { return NULL; } diff --git a/vm/os-solaris.cpp b/vm/os-solaris.cpp index fc8aac8cf7..f763f8055f 100644 --- a/vm/os-solaris.cpp +++ b/vm/os-solaris.cpp @@ -3,7 +3,7 @@ namespace factor { -const char *vm_executable_path(void) +const char *vm_executable_path() { return NULL; } diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index c0a268018e..18300949bd 100755 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -19,7 +19,7 @@ void start_thread(void *(*start_routine)(void *)) static void *null_dll; -s64 current_micros(void) +s64 current_micros() { struct timeval t; gettimeofday(&t,NULL); @@ -31,7 +31,7 @@ void sleep_micros(cell usec) usleep(usec); } -void init_ffi(void) +void init_ffi() { /* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic unix */ null_dll = dlopen(NULL_DLL,RTLD_LAZY); @@ -145,7 +145,7 @@ static void sigaction_safe(int signum, const struct sigaction *act, struct sigac fatal_error("sigaction failed", 0); } -void unix_init_signals(void) +void unix_init_signals() { struct sigaction memory_sigaction; struct sigaction misc_sigaction; @@ -279,7 +279,7 @@ void *stdin_loop(void *arg) return NULL; } -void open_console(void) +void open_console() { int filedes[2]; @@ -304,7 +304,7 @@ void open_console(void) start_thread(stdin_loop); } -VM_C_API void wait_for_stdin(void) +VM_C_API void wait_for_stdin() { if(write(control_write,"X",1) != 1) { diff --git a/vm/os-unix.hpp b/vm/os-unix.hpp index 24e8016db4..07ec385763 100755 --- a/vm/os-unix.hpp +++ b/vm/os-unix.hpp @@ -42,18 +42,18 @@ typedef char symbol_char; void start_thread(void *(*start_routine)(void *)); -void init_ffi(void); +void init_ffi(); void ffi_dlopen(dll *dll); void *ffi_dlsym(dll *dll, symbol_char *symbol); void ffi_dlclose(dll *dll); -void unix_init_signals(void); +void unix_init_signals(); void signal_handler(int signal, siginfo_t* siginfo, void* uap); void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap); -s64 current_micros(void); +s64 current_micros(); void sleep_micros(cell usec); -void open_console(void); +void open_console(); } diff --git a/vm/os-windows-ce.cpp b/vm/os-windows-ce.cpp index 71c72e55f8..2e69a1eb5b 100755 --- a/vm/os-windows-ce.cpp +++ b/vm/os-windows-ce.cpp @@ -3,7 +3,7 @@ namespace factor { -s64 current_micros(void) +s64 current_micros() { SYSTEMTIME st; FILETIME ft; @@ -40,6 +40,6 @@ void c_to_factor_toplevel(cell quot) c_to_factor(quot); } -void open_console(void) { } +void open_console() { } } diff --git a/vm/os-windows-ce.hpp b/vm/os-windows-ce.hpp index 49450f91c7..f41262e54b 100755 --- a/vm/os-windows-ce.hpp +++ b/vm/os-windows-ce.hpp @@ -22,8 +22,8 @@ char *getenv(char *name); #define snprintf _snprintf #define snwprintf _snwprintf -s64 current_micros(void); +s64 current_micros(); void c_to_factor_toplevel(cell quot); -void open_console(void); +void open_console(); } diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index 0a63dce513..5a60fff11b 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -3,7 +3,7 @@ namespace factor { -s64 current_micros(void) +s64 current_micros() { FILETIME t; GetSystemTimeAsFileTime(&t); @@ -49,7 +49,7 @@ void c_to_factor_toplevel(cell quot) RemoveVectoredExceptionHandler((void*)exception_handler); } -void open_console(void) +void open_console() { } diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index 107e42ea2e..9dbb8a9970 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -19,6 +19,6 @@ typedef char symbol_char; void c_to_factor_toplevel(cell quot); long exception_handler(PEXCEPTION_POINTERS pe); -void open_console(void); +void open_console(); } diff --git a/vm/os-windows.cpp b/vm/os-windows.cpp index 796a1c7184..90461a93d0 100755 --- a/vm/os-windows.cpp +++ b/vm/os-windows.cpp @@ -5,7 +5,7 @@ namespace factor HMODULE hFactorDll; -void init_ffi(void) +void init_ffi() { hFactorDll = GetModuleHandle(FACTOR_DLL); if(!hFactorDll) @@ -63,7 +63,7 @@ void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int len } /* You must free() this yourself. */ -const vm_char *default_image_path(void) +const vm_char *default_image_path() { vm_char full_path[MAX_UNICODE_PATH]; vm_char *ptr; @@ -82,7 +82,7 @@ const vm_char *default_image_path(void) } /* You must free() this yourself. */ -const vm_char *vm_executable_path(void) +const vm_char *vm_executable_path() { vm_char full_path[MAX_UNICODE_PATH]; if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH)) @@ -131,7 +131,7 @@ void dealloc_segment(segment *block) free(block); } -long getpagesize(void) +long getpagesize() { static long g_pagesize = 0; if (! g_pagesize) diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp index 2926ea50a8..5422216593 100755 --- a/vm/os-windows.hpp +++ b/vm/os-windows.hpp @@ -41,19 +41,19 @@ typedef wchar_t vm_char; /* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */ #define EPOCH_OFFSET 0x019db1ded53e8000LL -void init_ffi(void); +void init_ffi(); void ffi_dlopen(dll *dll); void *ffi_dlsym(dll *dll, symbol_char *symbol); void ffi_dlclose(dll *dll); void sleep_micros(u64 msec); -inline static void init_signals(void) {} -inline static void early_init(void) {} -const vm_char *vm_executable_path(void); -const vm_char *default_image_path(void); -long getpagesize (void); +inline static void init_signals() {} +inline static void early_init() {} +const vm_char *vm_executable_path(); +const vm_char *default_image_path(); +long getpagesize (); -s64 current_micros(void); +s64 current_micros(); } diff --git a/vm/profiler.cpp b/vm/profiler.cpp index 9651e4a27e..a3265e0ffa 100755 --- a/vm/profiler.cpp +++ b/vm/profiler.cpp @@ -5,7 +5,7 @@ namespace factor bool profiling_p; -void init_profiler(void) +void init_profiler() { profiling_p = false; } diff --git a/vm/profiler.hpp b/vm/profiler.hpp index 00f3e8067b..b83ef3d354 100755 --- a/vm/profiler.hpp +++ b/vm/profiler.hpp @@ -2,7 +2,7 @@ namespace factor { extern bool profiling_p; -void init_profiler(void); +void init_profiler(); code_block *compile_profiling_stub(cell word); PRIMITIVE(profiling); diff --git a/vm/quotations.cpp b/vm/quotations.cpp index af00bb468b..555ecc6420 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -297,7 +297,7 @@ PRIMITIVE(quotation_xt) drepl(allot_cell((cell)quot->xt)); } -void compile_all_words(void) +void compile_all_words() { gc_root words(find_all_words()); diff --git a/vm/quotations.hpp b/vm/quotations.hpp index a4545f3956..719a94176e 100755 --- a/vm/quotations.hpp +++ b/vm/quotations.hpp @@ -28,7 +28,7 @@ fixnum quot_code_offset_to_scan(cell quot, cell offset); PRIMITIVE(jit_compile); -void compile_all_words(void); +void compile_all_words(); PRIMITIVE(array_to_quotation); PRIMITIVE(quotation_xt); diff --git a/vm/stacks.hpp b/vm/stacks.hpp index 4af31e17d9..bc1aac8154 100644 --- a/vm/stacks.hpp +++ b/vm/stacks.hpp @@ -4,7 +4,7 @@ namespace factor #define DEFPUSHPOP(prefix,ptr) \ inline static cell prefix##peek() { return *(cell *)ptr; } \ inline static void prefix##repl(cell tagged) { *(cell *)ptr = tagged; } \ - inline static cell prefix##pop(void) \ + inline static cell prefix##pop() \ { \ cell value = prefix##peek(); \ ptr -= sizeof(cell); \ diff --git a/vm/utilities.cpp b/vm/utilities.cpp index 532de80ed1..df5c09847d 100755 --- a/vm/utilities.cpp +++ b/vm/utilities.cpp @@ -20,7 +20,7 @@ vm_char *safe_strdup(const vm_char *str) /* We don't use printf directly, because format directives are not portable. Instead we define the common cases here. */ -void nl(void) +void nl() { fputs("\n",stdout); } @@ -50,7 +50,7 @@ void print_fixnum(fixnum x) printf(FIXNUM_FORMAT,x); } -cell read_cell_hex(void) +cell read_cell_hex() { cell cell; if(scanf(cell_HEX_FORMAT,&cell) < 0) exit(1); diff --git a/vm/utilities.hpp b/vm/utilities.hpp index d311b954ed..7e7765170e 100755 --- a/vm/utilities.hpp +++ b/vm/utilities.hpp @@ -4,12 +4,12 @@ namespace factor void *safe_malloc(size_t size); vm_char *safe_strdup(const vm_char *str); -void nl(void); +void nl(); void print_string(const char *str); void print_cell(cell x); void print_cell_hex(cell x); void print_cell_hex_pad(cell x); void print_fixnum(fixnum x); -cell read_cell_hex(void); +cell read_cell_hex(); } From 280b50891da73520b9f7e0cb596f95c7744fc2ec Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 11:40:28 -0500 Subject: [PATCH 015/210] alien.strings: fix native-string>alien on Windows --- core/alien/strings/strings.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor index 896fb7f09f..3b778d2bd1 100644 --- a/core/alien/strings/strings.factor +++ b/core/alien/strings/strings.factor @@ -40,9 +40,7 @@ M: unix alien>native-string utf8 alien>string ; HOOK: native-string>alien os ( string -- alien ) -M: wince native-string>alien utf16n string>alien ; - -M: winnt native-string>alien utf8 string>alien ; +M: windows native-string>alien utf16n string>alien ; M: unix native-string>alien utf8 string>alien ; From 8085d9dddc1240d32b9a9350724007d98fd85087 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 12:35:27 -0500 Subject: [PATCH 016/210] Update README.txt --- README.txt | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) diff --git a/README.txt b/README.txt index addbe38f0d..54d53b090a 100755 --- a/README.txt +++ b/README.txt @@ -20,25 +20,17 @@ implementation. It is not an introduction to the language itself. * Compiling the Factor VM -The Factor runtime is written in GNU C++, and is built with GNU make and -gcc. - Factor supports various platforms. For an up-to-date list, see . -Factor requires gcc 3.4 or later. - -On x86, Factor /will not/ build using gcc 3.3 or earlier. - -If you are using gcc 4.3, you might get an unusable Factor binary unless -you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line -arguments for make. +The Factor VM is written in C++ and uses the GNU and TR1 extensions. +As a result, it requires GCC 4.x to compile. Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM. * Bootstrapping the Factor image -Once you have compiled the Factor runtime, you must bootstrap the Factor +Once you have compiled the Factor VM, you must bootstrap the Factor system using the image that corresponds to your CPU architecture. Boot images can be obtained from . @@ -97,7 +89,7 @@ When compiling Factor, pass the X11=1 parameter: Then bootstrap with the following switches: - ./factor -i=boot..image -ui-backend=x11 -ui-text-backend=pango + ./factor -i=boot..image -ui-backend=x11 Now if $DISPLAY is set, running ./factor will start the UI. @@ -138,7 +130,7 @@ usage documentation, enter the following in the UI listener: The Factor source tree is organized as follows: build-support/ - scripts used for compiling Factor - vm/ - sources for the Factor VM, written in C++ + vm/ - Factor VM core/ - Factor core library basis/ - Factor basis library, compiler, tools extra/ - more libraries and applications From e63caa50eceb189e2e6e834cac0167fd20c3138c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 12:36:17 -0500 Subject: [PATCH 017/210] udis: use a real structure instead of a char[] to fix buffer overflow on 64-bit --- .../tools/disassembler/udis/udis-tests.factor | 8 +++ basis/tools/disassembler/udis/udis.factor | 52 ++++++++++++++++++- 2 files changed, 59 insertions(+), 1 deletion(-) create mode 100644 basis/tools/disassembler/udis/udis-tests.factor diff --git a/basis/tools/disassembler/udis/udis-tests.factor b/basis/tools/disassembler/udis/udis-tests.factor new file mode 100644 index 0000000000..db100a4f31 --- /dev/null +++ b/basis/tools/disassembler/udis/udis-tests.factor @@ -0,0 +1,8 @@ +IN: tools.disassembler.udis.tests +USING: tools.disassembler.udis tools.test alien.c-types system combinators kernel ; + +{ + { [ os linux? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] } + { [ os macosx? cpu x86.32? and ] [ [ 592 ] [ "ud" heap-size ] unit-test ] } + { [ os macosx? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] } +} cond \ No newline at end of file diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index cd9dd9cf4b..1ffe3e0222 100755 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -16,7 +16,57 @@ IN: tools.disassembler.udis LIBRARY: libudis86 -TYPEDEF: char[592] ud +C-STRUCT: ud_operand + { "int" "type" } + { "uint8_t" "size" } + { "uint64_t" "lval" } + { "int" "base" } + { "int" "index" } + { "uint8_t" "offset" } + { "uint8_t" "scale" } ; + +C-STRUCT: ud + { "void*" "inp_hook" } + { "uint8_t" "inp_curr" } + { "uint8_t" "inp_fill" } + { "FILE*" "inp_file" } + { "uint8_t" "inp_ctr" } + { "uint8_t*" "inp_buff" } + { "uint8_t*" "inp_buff_end" } + { "uint8_t" "inp_end" } + { "void*" "translator" } + { "uint64_t" "insn_offset" } + { "char[32]" "insn_hexcode" } + { "char[64]" "insn_buffer" } + { "uint" "insn_fill" } + { "uint8_t" "dis_mode" } + { "uint64_t" "pc" } + { "uint8_t" "vendor" } + { "struct map_entry*" "mapen" } + { "int" "mnemonic" } + { "ud_operand[3]" "operand" } + { "uint8_t" "error" } + { "uint8_t" " " "pfx_rex" } + { "uint8_t" "pfx_seg" } + { "uint8_t" "pfx_opr" } + { "uint8_t" "pfx_adr" } + { "uint8_t" "pfx_lock" } + { "uint8_t" "pfx_rep" } + { "uint8_t" "pfx_repe" } + { "uint8_t" "pfx_repne" } + { "uint8_t" "pfx_insn" } + { "uint8_t" "default64" } + { "uint8_t" "opr_mode" } + { "uint8_t" "adr_mode" } + { "uint8_t" "br_far" } + { "uint8_t" "br_near" } + { "uint8_t" "implicit_addr" } + { "uint8_t" "c1" } + { "uint8_t" "c2" } + { "uint8_t" "c3" } + { "uint8_t[256]" "inp_cache" } + { "uint8_t[64]" "inp_sess" } + { "ud_itab_entry*" "itab_entry" } ; FUNCTION: void ud_translate_intel ( ud* u ) ; FUNCTION: void ud_translate_att ( ud* u ) ; From f6f7ded95a8441888d04f2643614e5a69c2e8ae5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 12:47:33 -0500 Subject: [PATCH 018/210] continuations: update tests for word renaming --- core/continuations/continuations-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 6409fc588e..a2617d0ebb 100644 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -64,7 +64,7 @@ IN: continuations.tests [ 1 2 ] [ bar ] unit-test -[ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test +[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test [ 1 ] [ "c" get innermost-frame-scan ] unit-test From 2e55b1af73715b22dc2439a75feb7249d609d45f Mon Sep 17 00:00:00 2001 From: unknown Date: Tue, 5 May 2009 13:03:24 -0500 Subject: [PATCH 019/210] Fixing compile errors on Windows --- vm/Config.windows | 2 +- vm/alien.cpp | 2 +- vm/os-windows-nt.cpp | 4 ++-- vm/os-windows-nt.hpp | 2 +- vm/os-windows.cpp | 9 +++++---- 5 files changed, 10 insertions(+), 9 deletions(-) diff --git a/vm/Config.windows b/vm/Config.windows index cdb72f4e24..b0b1352cb2 100644 --- a/vm/Config.windows +++ b/vm/Config.windows @@ -6,5 +6,5 @@ EXE_EXTENSION=.exe CONSOLE_EXTENSION=.com DLL_EXTENSION=.dll SHARED_DLL_EXTENSION=.dll -LINKER = $(CC) -shared -mno-cygwin -o +LINKER = $(CPP) -shared -mno-cygwin -o LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX) diff --git a/vm/alien.cpp b/vm/alien.cpp index 06dee31a14..1eb9c5a68d 100755 --- a/vm/alien.cpp +++ b/vm/alien.cpp @@ -128,7 +128,7 @@ PRIMITIVE(dlsym) gc_root name(dpop()); name.untag_check(); - vm_char *sym = (vm_char *)(name.untagged() + 1); + symbol_char *sym = name->data(); if(library.value() == F) box_alien(ffi_dlsym(NULL,sym)); diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index 0a63dce513..5e0a4c70c6 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -17,7 +17,7 @@ long exception_handler(PEXCEPTION_POINTERS pe) CONTEXT *c = (CONTEXT*)pe->ContextRecord; if(in_code_heap_p(c->EIP)) - signal_callstack_top = (void *)c->ESP; + signal_callstack_top = (stack_frame *)c->ESP; else signal_callstack_top = NULL; @@ -43,7 +43,7 @@ long exception_handler(PEXCEPTION_POINTERS pe) void c_to_factor_toplevel(cell quot) { - if(!AddVectoredExceptionHandler(0, (void*)exception_handler)) + if(!AddVectoredExceptionHandler(0, exception_handler)) fatal_error("AddVectoredExceptionHandler failed", 0); c_to_factor(quot); RemoveVectoredExceptionHandler((void*)exception_handler); diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index 107e42ea2e..2765f0a180 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -5,8 +5,8 @@ #define UNICODE #endif -#include #include +#include namespace factor { diff --git a/vm/os-windows.cpp b/vm/os-windows.cpp index 796a1c7184..001b48ab4d 100755 --- a/vm/os-windows.cpp +++ b/vm/os-windows.cpp @@ -14,12 +14,12 @@ void init_ffi(void) void ffi_dlopen(dll *dll) { - dll->dll = LoadLibraryEx(alien_offset(dll->path), NULL, 0); + dll->dll = LoadLibraryEx((WCHAR *)alien_offset(dll->path), NULL, 0); } void *ffi_dlsym(dll *dll, symbol_char *symbol) { - return GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol); + return (void *)GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol); } void ffi_dlclose(dll *dll) @@ -93,7 +93,8 @@ const vm_char *vm_executable_path(void) PRIMITIVE(existsp) { - vm_char *path = (vm_char *)(untag_check(dpop()) + 1); + vm_char *path = untag_check(dpop())->data(); + wprintf(L"existsp: path is %s\n",path); box_boolean(windows_stat(path)); } @@ -113,7 +114,7 @@ segment *alloc_segment(cell size) getpagesize(), PAGE_NOACCESS, &ignore)) fatal_error("Cannot allocate high guard page", (cell)mem); - segment *block = safe_malloc(sizeof(segment)); + segment *block = (segment *)safe_malloc(sizeof(segment)); block->start = (cell)mem + getpagesize(); block->size = size; From ca0c8937cad859da5a7d1081be5333122ebfec4a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 5 May 2009 13:55:00 -0500 Subject: [PATCH 020/210] lerp functions --- basis/math/functions/functions-tests.factor | 5 +++++ basis/math/functions/functions.factor | 3 +++ basis/math/vectors/vectors-tests.factor | 5 +++++ basis/math/vectors/vectors.factor | 9 +++++++++ 4 files changed, 22 insertions(+) diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index 397a7cc2f3..66d813bab8 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -157,3 +157,8 @@ IN: math.functions.tests 2135623355842621559 [ >bignum ] tri@ ^mod ] unit-test + +[ 1.0 ] [ 1.0 2.5 0.0 lerp ] unit-test +[ 2.5 ] [ 1.0 2.5 1.0 lerp ] unit-test +[ 1.75 ] [ 1.0 2.5 0.5 lerp ] unit-test + diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index c21053317e..41cb52a396 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -262,3 +262,6 @@ M: real atan fatan ; [ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable : ceiling ( x -- y ) neg floor neg ; foldable + +: lerp ( a b t -- a_t ) [ over - ] dip * + ; inline + diff --git a/basis/math/vectors/vectors-tests.factor b/basis/math/vectors/vectors-tests.factor index aef4ade877..b4b12d619b 100644 --- a/basis/math/vectors/vectors-tests.factor +++ b/basis/math/vectors/vectors-tests.factor @@ -9,3 +9,8 @@ USING: math.vectors tools.test ; [ 5 ] [ { 1 2 } norm-sq ] unit-test [ 13 ] [ { 2 3 } norm-sq ] unit-test +[ { 1.0 2.5 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.0 vnlerp ] unit-test +[ { 2.5 1.0 } ] [ { 1.0 2.5 } { 2.5 1.0 } 1.0 vnlerp ] unit-test +[ { 1.75 1.75 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.5 vnlerp ] unit-test + +[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index eb5fa7b970..f93a5f2b1e 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -32,6 +32,12 @@ IN: math.vectors : set-axis ( u v axis -- w ) [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; +: vlerp ( a b t -- a_t ) + [ lerp ] 3map ; + +: vnlerp ( a b t -- a_t ) + [ lerp ] curry 2map ; + HINTS: vneg { array } ; HINTS: norm-sq { array } ; HINTS: norm { array } ; @@ -50,3 +56,6 @@ HINTS: v/ { array array } ; HINTS: vmax { array array } ; HINTS: vmin { array array } ; HINTS: v. { array array } ; + +HINTS: vlerp { array array array } ; +HINTS: vnlerp { array array object } ; From 7dfa61c098a34172830d63ceff6cab9aff9e4096 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 14:17:02 -0500 Subject: [PATCH 021/210] VM now compiles with GCC 3.4 on Windows --- vm/code_gc.cpp | 4 ++-- vm/code_gc.hpp | 4 ++-- vm/code_heap.cpp | 2 +- vm/data_heap.cpp | 4 ++-- vm/dispatch.cpp | 2 +- vm/inline_cache.cpp | 2 +- vm/layouts.hpp | 3 +++ vm/master.hpp | 10 +++++++++- vm/math.cpp | 6 +++--- vm/os-windows-nt.cpp | 6 +++--- vm/os-windows-nt.hpp | 4 +++- 11 files changed, 30 insertions(+), 17 deletions(-) mode change 100644 => 100755 vm/data_heap.cpp mode change 100644 => 100755 vm/dispatch.cpp mode change 100644 => 100755 vm/inline_cache.cpp mode change 100644 => 100755 vm/master.hpp mode change 100644 => 100755 vm/math.cpp diff --git a/vm/code_gc.cpp b/vm/code_gc.cpp index 721c3f3a7a..59110d13f8 100755 --- a/vm/code_gc.cpp +++ b/vm/code_gc.cpp @@ -303,7 +303,7 @@ cell heap_size(heap *heap) } /* Compute where each block is going to go, after compaction */ - cell compute_heap_forwarding(heap *heap, std::tr1::unordered_map &forwarding) + cell compute_heap_forwarding(heap *heap, unordered_map &forwarding) { heap_block *scan = first_block(heap); char *address = (char *)first_block(heap); @@ -324,7 +324,7 @@ cell heap_size(heap *heap) return (cell)address - heap->seg->start; } - void compact_heap(heap *heap, std::tr1::unordered_map &forwarding) + void compact_heap(heap *heap, unordered_map &forwarding) { heap_block *scan = first_block(heap); diff --git a/vm/code_gc.hpp b/vm/code_gc.hpp index 1ad68f46fd..ebd6349ab9 100755 --- a/vm/code_gc.hpp +++ b/vm/code_gc.hpp @@ -25,8 +25,8 @@ void unmark_marked(heap *heap); void free_unmarked(heap *heap, heap_iterator iter); void heap_usage(heap *h, cell *used, cell *total_free, cell *max_free); cell heap_size(heap *h); -cell compute_heap_forwarding(heap *h, std::tr1::unordered_map &forwarding); -void compact_heap(heap *h, std::tr1::unordered_map &forwarding); +cell compute_heap_forwarding(heap *h, unordered_map &forwarding); +void compact_heap(heap *h, unordered_map &forwarding); inline static heap_block *next_block(heap *h, heap_block *block) { diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index db1fd8f880..77c78ad533 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -119,7 +119,7 @@ PRIMITIVE(code_room) dpush(tag_fixnum(max_free / 1024)); } -static std::tr1::unordered_map forwarding; +static unordered_map forwarding; code_block *forward_xt(code_block *compiled) { diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp old mode 100644 new mode 100755 index 0045539549..9c84a993c8 --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -241,7 +241,7 @@ cell unaligned_object_size(object *pointer) return callstack_size(untag_fixnum(((callstack *)pointer)->length)); default: critical_error("Invalid header",(cell)pointer); - return -1; /* can't happen */ + return 0; /* can't happen */ } } @@ -283,7 +283,7 @@ cell binary_payload_start(object *pointer) return sizeof(wrapper); default: critical_error("Invalid header",(cell)pointer); - return -1; /* can't happen */ + return 0; /* can't happen */ } } diff --git a/vm/dispatch.cpp b/vm/dispatch.cpp old mode 100644 new mode 100755 index bbcf20c57b..847a19d738 --- a/vm/dispatch.cpp +++ b/vm/dispatch.cpp @@ -103,7 +103,7 @@ static cell lookup_hairy_method(cell obj, cell methods) break; default: critical_error("Bad methods array",methods); - return -1; + return 0; } } } diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp old mode 100644 new mode 100755 index 23c4b27c47..259a3e0c77 --- a/vm/inline_cache.cpp +++ b/vm/inline_cache.cpp @@ -70,7 +70,7 @@ static cell determine_inline_cache_type(array *cache_entries) if(!seen_hi_tag && !seen_tuple) return PIC_TAG; critical_error("Oops",0); - return -1; + return 0; } static void update_pic_count(cell type) diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 114b88b925..8c96cf3187 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -93,6 +93,9 @@ class object; struct header { cell value; + /* Default ctor to make gcc 3.x happy */ + header() { abort(); } + header(cell value_) : value(value_ << TAG_BITS) {} void check_header() { diff --git a/vm/master.hpp b/vm/master.hpp old mode 100644 new mode 100755 index 65d17fab4b..6409d65494 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -22,7 +22,15 @@ #include /* C++ headers */ -#include +#if __GNUC__ == 4 + #include + #define unordered_map std::tr1::unordered_map +#elif __GNUC__ == 3 + #include + #define unordered_map boost::unordered_map +#else + #error Factor requires GCC 3.x or later +#endif /* Factor headers */ #include "layouts.hpp" diff --git a/vm/math.cpp b/vm/math.cpp old mode 100644 new mode 100755 index 37768f5542..7a2abe7463 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -377,7 +377,7 @@ VM_C_API fixnum to_fixnum(cell tagged) return bignum_to_fixnum(untag(tagged)); default: type_error(FIXNUM_TYPE,tagged); - return -1; /* can't happen */ + return 0; /* can't happen */ } } @@ -444,7 +444,7 @@ VM_C_API s64 to_signed_8(cell obj) return bignum_to_long_long(untag(obj)); default: type_error(BIGNUM_TYPE,obj); - return -1; + return 0; } } @@ -466,7 +466,7 @@ VM_C_API u64 to_unsigned_8(cell obj) return bignum_to_ulong_long(untag(obj)); default: type_error(BIGNUM_TYPE,obj); - return -1; + return 0; } } diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index f07fdaeb87..c4349f243b 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -11,7 +11,7 @@ s64 current_micros() - EPOCH_OFFSET) / 10; } -long exception_handler(PEXCEPTION_POINTERS pe) +FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe) { PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord; CONTEXT *c = (CONTEXT*)pe->ContextRecord; @@ -43,10 +43,10 @@ long exception_handler(PEXCEPTION_POINTERS pe) void c_to_factor_toplevel(cell quot) { - if(!AddVectoredExceptionHandler(0, exception_handler)) + if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)exception_handler)) fatal_error("AddVectoredExceptionHandler failed", 0); c_to_factor(quot); - RemoveVectoredExceptionHandler((void*)exception_handler); + RemoveVectoredExceptionHandler((void *)exception_handler); } void open_console() diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index 551a798b45..4371771c13 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -17,8 +17,10 @@ typedef char symbol_char; #define FACTOR_DLL L"factor.dll" #define FACTOR_DLL_NAME "factor.dll" +#define FACTOR_STDCALL __attribute__((stdcall)) + void c_to_factor_toplevel(cell quot); -long exception_handler(PEXCEPTION_POINTERS pe); +FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe); void open_console(); } From 3acadbd23f887ce8695e01592b2781ded47fcd69 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 14:27:22 -0500 Subject: [PATCH 022/210] Remove debug messages from VM --- vm/code_block.cpp | 1 - vm/os-windows.cpp | 1 - 2 files changed, 2 deletions(-) mode change 100644 => 100755 vm/code_block.cpp diff --git a/vm/code_block.cpp b/vm/code_block.cpp old mode 100644 new mode 100755 index d27460853d..bb3481904e --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -329,7 +329,6 @@ void *get_rel_symbol(array *literals, cell index) return sym; else { - printf("%s\n",name); return (void *)undefined_symbol; } } diff --git a/vm/os-windows.cpp b/vm/os-windows.cpp index bd87c96155..7db19ff560 100755 --- a/vm/os-windows.cpp +++ b/vm/os-windows.cpp @@ -94,7 +94,6 @@ const vm_char *vm_executable_path() PRIMITIVE(existsp) { vm_char *path = untag_check(dpop())->data(); - wprintf(L"existsp: path is %s\n",path); box_boolean(windows_stat(path)); } From b207d4498999194e577b53819ec6c93156c62885 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 14:36:15 -0500 Subject: [PATCH 023/210] Update README.txt for new compilation dependencies --- README.txt | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/README.txt b/README.txt index 54d53b090a..a33a85b218 100755 --- a/README.txt +++ b/README.txt @@ -23,8 +23,9 @@ implementation. It is not an introduction to the language itself. Factor supports various platforms. For an up-to-date list, see . -The Factor VM is written in C++ and uses the GNU and TR1 extensions. -As a result, it requires GCC 4.x to compile. +The Factor VM is written in C++ and uses GNU extensions. When compiling +with GCC 3.x, boost::unordered_map must be installed. On GCC 4.x, Factor +uses std::tr1::unordered_map which is shipped as part of GCC. Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM. From 5eb74d1d8d5ec35cf0ab9e167f718e1cdab92fab Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 14:41:38 -0500 Subject: [PATCH 024/210] alien.strings: fix symbol>string for Windows --- core/alien/strings/strings.factor | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor index 3b778d2bd1..c74c325726 100644 --- a/core/alien/strings/strings.factor +++ b/core/alien/strings/strings.factor @@ -47,10 +47,19 @@ M: unix native-string>alien utf8 string>alien ; : dll-path ( dll -- string ) path>> alien>native-string ; -: string>symbol ( str -- alien ) - dup string? - [ native-string>alien ] - [ [ native-string>alien ] map ] if ; +HOOK: string>symbol* os ( str/seq -- alien ) + +M: winnt string>symbol* utf8 string>alien ; + +M: wince string>symbol* utf16n string>alien ; + +M: unix string>symbol* utf8 string>alien ; + +GENERIC: string>symbol ( str -- alien ) + +M: string string>symbol string>symbol* ; + +M: sequence string>symbol [ string>symbol* ] map ; [ 8 getenv utf8 alien>string string>cpu \ cpu set-global From 259586e89ebf0a66463164f74f8ede0b1f091089 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 15:06:05 -0500 Subject: [PATCH 025/210] compiler.constants: update compiled-header-size --- basis/compiler/constants/constants.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 2f0494b58a..cc6397bd65 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -23,7 +23,7 @@ CONSTANT: deck-bits 18 : quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline : word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline : array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline -: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline +: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline ! Relocation classes CONSTANT: rc-absolute-cell 0 From 8b4a48361e26605c2d1c4b39c03d86c312ae442b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 15:54:49 -0500 Subject: [PATCH 026/210] literals: Improve ${ word --- basis/literals/literals-tests.factor | 6 ++++-- basis/literals/literals.factor | 19 ++++++++++++++++--- 2 files changed, 20 insertions(+), 5 deletions(-) mode change 100644 => 100755 basis/literals/literals-tests.factor mode change 100644 => 100755 basis/literals/literals.factor diff --git a/basis/literals/literals-tests.factor b/basis/literals/literals-tests.factor old mode 100644 new mode 100755 index 29072f1299..d7256a64b1 --- a/basis/literals/literals-tests.factor +++ b/basis/literals/literals-tests.factor @@ -20,8 +20,10 @@ IN: literals.tests [ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test -<< CONSTANT: constant-a 3 ->> [ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test + +: sixty-nine ( -- a b ) 6 9 ; + +[ { 6 9 } ] [ ${ sixty-nine } ] unit-test diff --git a/basis/literals/literals.factor b/basis/literals/literals.factor old mode 100644 new mode 100755 index 7c7592dda8..ba1da393b1 --- a/basis/literals/literals.factor +++ b/basis/literals/literals.factor @@ -1,8 +1,21 @@ ! (c) Joe Groff, see license for details USING: accessors continuations kernel parser words quotations -combinators.smart vectors sequences ; +combinators.smart vectors sequences fry ; IN: literals -SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ; +> call so that CONSTANT:s defined in the same file can +! be called + +: expand-literal ( seq obj -- seq' ) + '[ _ dup word? [ def>> call ] when ] with-datastack ; + +: expand-literals ( seq -- seq' ) + [ [ { } ] dip expand-literal ] map concat ; + +PRIVATE> + +SYNTAX: $ scan-word expand-literal >vector ; SYNTAX: $[ parse-quotation with-datastack >vector ; -SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ; +SYNTAX: ${ \ } [ expand-literals ] parse-literal ; From 33d93e48efe3f3958f1cab84fc85177d1bdb5134 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 15:55:41 -0500 Subject: [PATCH 027/210] Fix VM code to export the right symbols on Windows --- vm/cpu-x86.32.hpp | 2 +- vm/cpu-x86.64.hpp | 2 +- vm/write_barrier.hpp | 9 ++++----- 3 files changed, 6 insertions(+), 7 deletions(-) mode change 100644 => 100755 vm/cpu-x86.64.hpp mode change 100644 => 100755 vm/write_barrier.hpp diff --git a/vm/cpu-x86.32.hpp b/vm/cpu-x86.32.hpp index 6b6328aa4f..902b33b0b4 100755 --- a/vm/cpu-x86.32.hpp +++ b/vm/cpu-x86.32.hpp @@ -6,6 +6,6 @@ namespace factor register cell ds asm("esi"); register cell rs asm("edi"); -#define VM_ASM_API extern "C" __attribute__ ((regparm (2))) +#define VM_ASM_API VM_C_API __attribute__ ((regparm (2))) } diff --git a/vm/cpu-x86.64.hpp b/vm/cpu-x86.64.hpp old mode 100644 new mode 100755 index be71a78aa8..679c301548 --- a/vm/cpu-x86.64.hpp +++ b/vm/cpu-x86.64.hpp @@ -6,6 +6,6 @@ namespace factor register cell ds asm("r14"); register cell rs asm("r15"); -#define VM_ASM_API extern "C" +#define VM_ASM_API VM_C_API } diff --git a/vm/write_barrier.hpp b/vm/write_barrier.hpp old mode 100644 new mode 100755 index ae7fbb25dd..e656b66a56 --- a/vm/write_barrier.hpp +++ b/vm/write_barrier.hpp @@ -6,6 +6,9 @@ card has a slot written to. the offset of the first object is set by the allocator. */ +VM_C_API factor::cell cards_offset; +VM_C_API factor::cell decks_offset; + namespace factor { @@ -19,8 +22,6 @@ typedef u8 card; #define CARD_SIZE (1<> CARD_BITS) + cards_offset); @@ -42,8 +43,6 @@ typedef u8 card_deck; #define DECK_SIZE (1<> DECK_BITS) + decks_offset); @@ -61,7 +60,7 @@ inline static card *deck_to_card(card_deck *d) #define INVALID_ALLOT_MARKER 0xff -VM_C_API cell allot_markers_offset; +cell allot_markers_offset; inline static card *addr_to_allot_marker(object *a) { From 7a714bfd66eb2c1309e71323abdef3bfcf19d145 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 15:56:53 -0500 Subject: [PATCH 028/210] tools.disassembler.udis: fix types for Windows --- basis/tools/disassembler/udis/udis.factor | 70 +++++++++++------------ 1 file changed, 35 insertions(+), 35 deletions(-) diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index 1ffe3e0222..df624cab28 100755 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -18,54 +18,54 @@ LIBRARY: libudis86 C-STRUCT: ud_operand { "int" "type" } - { "uint8_t" "size" } - { "uint64_t" "lval" } + { "uchar" "size" } + { "ulonglong" "lval" } { "int" "base" } { "int" "index" } - { "uint8_t" "offset" } - { "uint8_t" "scale" } ; + { "uchar" "offset" } + { "uchar" "scale" } ; C-STRUCT: ud { "void*" "inp_hook" } - { "uint8_t" "inp_curr" } - { "uint8_t" "inp_fill" } + { "uchar" "inp_curr" } + { "uchar" "inp_fill" } { "FILE*" "inp_file" } - { "uint8_t" "inp_ctr" } - { "uint8_t*" "inp_buff" } - { "uint8_t*" "inp_buff_end" } - { "uint8_t" "inp_end" } + { "uchar" "inp_ctr" } + { "uchar*" "inp_buff" } + { "uchar*" "inp_buff_end" } + { "uchar" "inp_end" } { "void*" "translator" } - { "uint64_t" "insn_offset" } + { "ulonglong" "insn_offset" } { "char[32]" "insn_hexcode" } { "char[64]" "insn_buffer" } { "uint" "insn_fill" } - { "uint8_t" "dis_mode" } - { "uint64_t" "pc" } - { "uint8_t" "vendor" } + { "uchar" "dis_mode" } + { "ulonglong" "pc" } + { "uchar" "vendor" } { "struct map_entry*" "mapen" } { "int" "mnemonic" } { "ud_operand[3]" "operand" } - { "uint8_t" "error" } - { "uint8_t" " " "pfx_rex" } - { "uint8_t" "pfx_seg" } - { "uint8_t" "pfx_opr" } - { "uint8_t" "pfx_adr" } - { "uint8_t" "pfx_lock" } - { "uint8_t" "pfx_rep" } - { "uint8_t" "pfx_repe" } - { "uint8_t" "pfx_repne" } - { "uint8_t" "pfx_insn" } - { "uint8_t" "default64" } - { "uint8_t" "opr_mode" } - { "uint8_t" "adr_mode" } - { "uint8_t" "br_far" } - { "uint8_t" "br_near" } - { "uint8_t" "implicit_addr" } - { "uint8_t" "c1" } - { "uint8_t" "c2" } - { "uint8_t" "c3" } - { "uint8_t[256]" "inp_cache" } - { "uint8_t[64]" "inp_sess" } + { "uchar" "error" } + { "uchar" "pfx_rex" } + { "uchar" "pfx_seg" } + { "uchar" "pfx_opr" } + { "uchar" "pfx_adr" } + { "uchar" "pfx_lock" } + { "uchar" "pfx_rep" } + { "uchar" "pfx_repe" } + { "uchar" "pfx_repne" } + { "uchar" "pfx_insn" } + { "uchar" "default64" } + { "uchar" "opr_mode" } + { "uchar" "adr_mode" } + { "uchar" "br_far" } + { "uchar" "br_near" } + { "uchar" "implicit_addr" } + { "uchar" "c1" } + { "uchar" "c2" } + { "uchar" "c3" } + { "uchar[256]" "inp_cache" } + { "uchar[64]" "inp_sess" } { "ud_itab_entry*" "itab_entry" } ; FUNCTION: void ud_translate_intel ( ud* u ) ; From 56d30c9536b35f65436b0ba52ca634421e55bd57 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 15:57:08 -0500 Subject: [PATCH 029/210] bootstrap.compiler: clean up --- basis/bootstrap/compiler/compiler.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 basis/bootstrap/compiler/compiler.factor diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor old mode 100644 new mode 100755 index 7940703140..3aefdec29f --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -41,7 +41,7 @@ nl ! which are also quick to compile are replaced by ! compiled definitions as soon as possible. { - roll -roll declare not + not array? hashtable? vector? tuple? sbuf? tombstone? From 13d52f371c3c35f5ecd31b2447ceb135b0fd9837 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 16:00:31 -0500 Subject: [PATCH 030/210] alien.libraries: Fix dlsym on Windows --- basis/alien/libraries/libraries.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 basis/alien/libraries/libraries.factor diff --git a/basis/alien/libraries/libraries.factor b/basis/alien/libraries/libraries.factor old mode 100644 new mode 100755 index 6c18065ab6..0b39bedadd --- a/basis/alien/libraries/libraries.factor +++ b/basis/alien/libraries/libraries.factor @@ -5,7 +5,7 @@ IN: alien.libraries : dlopen ( path -- dll ) native-string>alien (dlopen) ; -: dlsym ( name dll -- alien ) [ native-string>alien ] dip (dlsym) ; +: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ; SYMBOL: libraries From 79c87e86e711a9abef5bcedbbdab118b4cba26d8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 16:19:13 -0500 Subject: [PATCH 031/210] Fix VM compile error --- vm/write_barrier.cpp | 6 +++++- vm/write_barrier.hpp | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) mode change 100644 => 100755 vm/write_barrier.cpp diff --git a/vm/write_barrier.cpp b/vm/write_barrier.cpp old mode 100644 new mode 100755 index 4137b0a6eb..0e87434b56 --- a/vm/write_barrier.cpp +++ b/vm/write_barrier.cpp @@ -4,4 +4,8 @@ using namespace factor; cell cards_offset; cell decks_offset; -cell allot_markers_offset; + +namespace factor +{ + cell allot_markers_offset; +} diff --git a/vm/write_barrier.hpp b/vm/write_barrier.hpp index e656b66a56..eaede538ed 100755 --- a/vm/write_barrier.hpp +++ b/vm/write_barrier.hpp @@ -60,7 +60,7 @@ inline static card *deck_to_card(card_deck *d) #define INVALID_ALLOT_MARKER 0xff -cell allot_markers_offset; +extern cell allot_markers_offset; inline static card *addr_to_allot_marker(object *a) { From 03726ce8c5be454fcb1366df71608cc67c9090e1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 16:46:57 -0500 Subject: [PATCH 032/210] images.viewer: now accepts image objects --- extra/images/viewer/viewer.factor | 27 ++++++++++++++++----------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index 2818c16f9f..b891142d5b 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -5,23 +5,28 @@ opengl opengl.gl opengl.textures sequences strings ui ui.gadgets ui.gadgets.panes ui.render ui.images ; IN: images.viewer -TUPLE: image-gadget < gadget image-name ; +TUPLE: image-gadget < gadget image texture ; -M: image-gadget pref-dim* - image-name>> image-dim ; +M: image-gadget pref-dim* image>> dim>> ; + +: image-gadget-texture ( gadget -- texture ) + dup texture>> [ ] [ dup image>> { 0 0 } >>texture texture>> ] ?if ; M: image-gadget draw-gadget* ( gadget -- ) - image-name>> draw-image ; + [ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture ; -: ( image-name -- gadget ) +! Todo: delete texture on ungraft + +GENERIC: ( object -- gadget ) + +M: image \ image-gadget new - swap >>image-name ; + swap >>image ; -: image-window ( path -- gadget ) - [ dup ] [ open-window ] bi ; +M: string load-image ; -GENERIC: image. ( object -- ) +M: pathname load-image ; -M: string image. ( image -- ) gadget. ; +: image-window ( object -- ) "Image" open-window ; -M: pathname image. ( image -- ) gadget. ; +: image. ( object -- ) gadget. ; From e720ba2dba9c81fba18a2caf3979ec6abcf2db78 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 17:35:06 -0500 Subject: [PATCH 033/210] tools.disassembler.udis: fix unix tests --- basis/tools/disassembler/udis/udis-tests.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/tools/disassembler/udis/udis-tests.factor b/basis/tools/disassembler/udis/udis-tests.factor index db100a4f31..9ad3dbbcc2 100644 --- a/basis/tools/disassembler/udis/udis-tests.factor +++ b/basis/tools/disassembler/udis/udis-tests.factor @@ -5,4 +5,5 @@ USING: tools.disassembler.udis tools.test alien.c-types system combinators kerne { [ os linux? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] } { [ os macosx? cpu x86.32? and ] [ [ 592 ] [ "ud" heap-size ] unit-test ] } { [ os macosx? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] } + [ ] } cond \ No newline at end of file From 66a3e1e565d2cd920972a97329a0eb2b67957603 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 18:34:52 -0500 Subject: [PATCH 034/210] math.polynomials: use instead of --- basis/math/polynomials/polynomials.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index 749bde3a10..ec09b366a1 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -16,7 +16,7 @@ IN: math.polynomials PRIVATE> : powers ( n x -- seq ) - 1 [ * ] accumulate nip ; + 1 [ * ] accumulate nip ; : p= ( p q -- ? ) pextend = ; From c5d3bbd5b6101c390a49498982d0e738102a4465 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 18:37:40 -0500 Subject: [PATCH 035/210] Fix bool type; its actually 1 byte not 4 in structs. Bug reported by jedahu --- basis/alien/c-types/c-types.factor | 8 ++++---- basis/compiler/tests/alien.factor | 13 +++++++++++++ vm/ffi_test.c | 5 +++++ vm/ffi_test.h | 10 ++++++++++ 4 files changed, 32 insertions(+), 4 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 9cd57f61ab..6067c90f2d 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -409,10 +409,10 @@ CONSTANT: primitive-types "uchar" define-primitive-type - [ alien-unsigned-4 zero? not ] >>getter - [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter - 4 >>size - 4 >>align + [ alien-unsigned-1 zero? not ] >>getter + [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter + 1 >>size + 1 >>align "box_boolean" >>boxer "to_boolean" >>unboxer "bool" define-primitive-type diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 42ed90d64a..f7f24433d7 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -588,3 +588,16 @@ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ; C{ 1.0 2.0 } C{ 1.5 1.0 } ffi_test_47 ] unit-test + +! Reported by jedahu +C-STRUCT: bool-field-test + { "char*" "name" } + { "bool" "on" } + { "short" "parents" } ; + +FUNCTION: short ffi_test_48 ( bool-field-test x ) ; + +[ 123 ] [ + "bool-field-test" 123 over set-bool-field-test-parents + ffi_test_48 +] unit-test \ No newline at end of file diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 680b144140..d45ceb4514 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -319,3 +319,8 @@ _Complex float ffi_test_47(_Complex float x, _Complex double y) { return x + 2 * y; } + +short ffi_test_48(struct bool_field_test x) +{ + return x.parents; +} diff --git a/vm/ffi_test.h b/vm/ffi_test.h index 835f9e942f..af0c0b46a4 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -1,3 +1,5 @@ +#include + #if defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32) #define F_STDCALL __attribute__((stdcall)) #else @@ -102,3 +104,11 @@ F_EXPORT _Complex float ffi_test_45(int x); F_EXPORT _Complex double ffi_test_46(int x); F_EXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y); + +struct bool_field_test { + char *name; + bool on; + short parents; +}; + +F_EXPORT short ffi_test_48(struct bool_field_test x); From e3e23c139e733e43eac3f68968b557fcd0374fdd Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 5 May 2009 18:36:15 -0700 Subject: [PATCH 036/210] get dinput mouse support working --- extra/game-input/dinput/dinput.factor | 31 ++++++++++++++++----------- 1 file changed, 19 insertions(+), 12 deletions(-) diff --git a/extra/game-input/dinput/dinput.factor b/extra/game-input/dinput/dinput.factor index 90141c29e1..8540907db9 100755 --- a/extra/game-input/dinput/dinput.factor +++ b/extra/game-input/dinput/dinput.factor @@ -5,7 +5,8 @@ windows.user32 windows.messages sequences combinators locals math.rectangles accessors math alien alien.strings io.encodings.utf16 io.encodings.utf16n continuations byte-arrays game-input.dinput.keys-array game-input -ui.backend.windows windows.errors ; +ui.backend.windows windows.errors struct-arrays +math.bitwise ; IN: game-input.dinput CONSTANT: MOUSE-BUFFER-SIZE 16 @@ -70,8 +71,8 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ GUID_SysMouse device-for-guid [ configure-mouse ] [ +mouse-device+ set-global ] bi - 0 0 0 0 8 mouse-state boa - +mouse-device+ set-global ; + 0 0 0 0 8 f mouse-state boa + +mouse-state+ set-global MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" +mouse-buffer+ set-global ; @@ -301,17 +302,17 @@ CONSTANT: pov-values [ "DIDEVICEOBJECTDATA" heap-size ] 2dip [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ; -: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- ) - [ DIDEVICEOBJECTDATA-dwData ] [ DIDEVICEOBJECTDATA-dwOfs ] bi { - { DIMOFS_X [ [ + ] curry change-dx drop ] } - { DIMOFS_Y [ [ + ] curry change-dy drop ] } - { DIMOFS_Z [ [ + ] curry change-scroll-dy drop ] } - [ [ c-bool> ] [ DIMOFS_BUTTON0 - ] bi* rot buttons>> set-nth ] +: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state ) + [ DIDEVICEOBJECTDATA-dwData 32 >signed ] [ DIDEVICEOBJECTDATA-dwOfs ] bi { + { DIMOFS_X [ [ + ] curry change-dx ] } + { DIMOFS_Y [ [ + ] curry change-dy ] } + { DIMOFS_Z [ [ + ] curry change-scroll-dy ] } + [ [ c-bool> ] [ DIMOFS_BUTTON0 - ] bi* rot [ buttons>> set-nth ] keep ] } case ; -: fill-mouse-state ( buffer count -- ) +: fill-mouse-state ( buffer count -- state ) [ +mouse-state+ get ] 2dip swap - [ DIDEVICEOBJECTDATA-nth (fill-mouse-state) ] curry each ; + [ "DIDEVICEOBJECTDATA" byte-array>struct-array nth (fill-mouse-state) ] curry each ; : get-device-state ( device byte-array -- ) [ dup IDirectInputDevice8W::Poll ole32-error ] dip @@ -340,4 +341,10 @@ M: dinput-game-input-backend read-mouse M: dinput-game-input-backend reset-mouse +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ] - [ 2drop ] [ ] with-acquisition ; + [ 2drop ] [ ] with-acquisition + +mouse-state+ get + 0 >>dx + 0 >>dy + 0 >>scroll-dx + 0 >>scroll-dy + drop ; From 0ca1d013f888bf079c021d6879f20e16b83e2198 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 20:56:23 -0500 Subject: [PATCH 037/210] Add new RC_ABSOLUTE_PPC_2 relocation type --- basis/compiler/constants/constants.factor | 11 ++++++----- vm/code_block.cpp | 3 +++ vm/code_block.hpp | 5 ++++- 3 files changed, 13 insertions(+), 6 deletions(-) diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index cc6397bd65..e30cc10ee2 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -30,11 +30,12 @@ CONSTANT: rc-absolute-cell 0 CONSTANT: rc-absolute 1 CONSTANT: rc-relative 2 CONSTANT: rc-absolute-ppc-2/2 3 -CONSTANT: rc-relative-ppc-2 4 -CONSTANT: rc-relative-ppc-3 5 -CONSTANT: rc-relative-arm-3 6 -CONSTANT: rc-indirect-arm 7 -CONSTANT: rc-indirect-arm-pc 8 +CONSTANT: rc-absolute-ppc-2 4 +CONSTANT: rc-relative-ppc-2 5 +CONSTANT: rc-relative-ppc-3 6 +CONSTANT: rc-relative-arm-3 7 +CONSTANT: rc-indirect-arm 8 +CONSTANT: rc-indirect-arm-pc 9 ! Relocation types CONSTANT: rt-primitive 0 diff --git a/vm/code_block.cpp b/vm/code_block.cpp index bb3481904e..cd87da3801 100755 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -84,6 +84,9 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value) case RC_ABSOLUTE_PPC_2_2: store_address_2_2((cell *)offset,absolute_value); break; + case RC_ABSOLUTE_PPC_2: + store_address_masked((cell *)offset,absolute_value,REL_ABSOLUTE_PPC_2_MASK,0); + break; case RC_RELATIVE_PPC_2: store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0); break; diff --git a/vm/code_block.hpp b/vm/code_block.hpp index 9ca1a419b6..85ae373845 100644 --- a/vm/code_block.hpp +++ b/vm/code_block.hpp @@ -31,8 +31,10 @@ enum relocation_class { RC_ABSOLUTE, /* relative address in a 32-bit location */ RC_RELATIVE, - /* relative address in a PowerPC LIS/ORI sequence */ + /* absolute address in a PowerPC LIS/ORI sequence */ RC_ABSOLUTE_PPC_2_2, + /* absolute address in a PowerPC LWZ instruction */ + RC_ABSOLUTE_PPC_2, /* relative address in a PowerPC LWZ/STW/BC instruction */ RC_RELATIVE_PPC_2, /* relative address in a PowerPC B/BL instruction */ @@ -45,6 +47,7 @@ enum relocation_class { RC_INDIRECT_ARM_PC }; +#define REL_ABSOLUTE_PPC_2_MASK 0xffff #define REL_RELATIVE_PPC_2_MASK 0xfffc #define REL_RELATIVE_PPC_3_MASK 0x3fffffc #define REL_INDIRECT_ARM_MASK 0xfff From 9e34307f58fa60737efae99db0f40d2757d68c85 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 20:56:36 -0500 Subject: [PATCH 038/210] cpu.ppc.assembler: update for code_format=1 --- .../cpu/ppc/assembler/assembler-tests.factor | 220 +++++++++--------- .../cpu/ppc/assembler/backend/backend.factor | 4 +- 2 files changed, 112 insertions(+), 112 deletions(-) diff --git a/basis/cpu/ppc/assembler/assembler-tests.factor b/basis/cpu/ppc/assembler/assembler-tests.factor index 09db4cb050..14327d08b8 100644 --- a/basis/cpu/ppc/assembler/assembler-tests.factor +++ b/basis/cpu/ppc/assembler/assembler-tests.factor @@ -3,114 +3,114 @@ USING: cpu.ppc.assembler tools.test arrays kernel namespaces make vocabs sequences ; : test-assembler ( expected quot -- ) - [ 1array ] [ [ { } make ] curry ] bi* unit-test ; + [ 1array ] [ [ B{ } make ] curry ] bi* unit-test ; -{ HEX: 38220003 } [ 1 2 3 ADDI ] test-assembler -{ HEX: 3c220003 } [ 1 2 3 ADDIS ] test-assembler -{ HEX: 30220003 } [ 1 2 3 ADDIC ] test-assembler -{ HEX: 34220003 } [ 1 2 3 ADDIC. ] test-assembler -{ HEX: 38400001 } [ 1 2 LI ] test-assembler -{ HEX: 3c400001 } [ 1 2 LIS ] test-assembler -{ HEX: 3822fffd } [ 1 2 3 SUBI ] test-assembler -{ HEX: 1c220003 } [ 1 2 3 MULI ] test-assembler -{ HEX: 7c221a14 } [ 1 2 3 ADD ] test-assembler -{ HEX: 7c221a15 } [ 1 2 3 ADD. ] test-assembler -{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler -{ HEX: 7c221e15 } [ 1 2 3 ADDO. ] test-assembler -{ HEX: 7c221814 } [ 1 2 3 ADDC ] test-assembler -{ HEX: 7c221815 } [ 1 2 3 ADDC. ] test-assembler -{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler -{ HEX: 7c221c15 } [ 1 2 3 ADDCO. ] test-assembler -{ HEX: 7c221914 } [ 1 2 3 ADDE ] test-assembler -{ HEX: 7c411838 } [ 1 2 3 AND ] test-assembler -{ HEX: 7c411839 } [ 1 2 3 AND. ] test-assembler -{ HEX: 7c221bd6 } [ 1 2 3 DIVW ] test-assembler -{ HEX: 7c221b96 } [ 1 2 3 DIVWU ] test-assembler -{ HEX: 7c411a38 } [ 1 2 3 EQV ] test-assembler -{ HEX: 7c411bb8 } [ 1 2 3 NAND ] test-assembler -{ HEX: 7c4118f8 } [ 1 2 3 NOR ] test-assembler -{ HEX: 7c4110f8 } [ 1 2 NOT ] test-assembler -{ HEX: 60410003 } [ 1 2 3 ORI ] test-assembler -{ HEX: 64410003 } [ 1 2 3 ORIS ] test-assembler -{ HEX: 7c411b78 } [ 1 2 3 OR ] test-assembler -{ HEX: 7c411378 } [ 1 2 MR ] test-assembler -{ HEX: 7c221896 } [ 1 2 3 MULHW ] test-assembler -{ HEX: 1c220003 } [ 1 2 3 MULLI ] test-assembler -{ HEX: 7c221816 } [ 1 2 3 MULHWU ] test-assembler -{ HEX: 7c2219d6 } [ 1 2 3 MULLW ] test-assembler -{ HEX: 7c411830 } [ 1 2 3 SLW ] test-assembler -{ HEX: 7c411e30 } [ 1 2 3 SRAW ] test-assembler -{ HEX: 7c411c30 } [ 1 2 3 SRW ] test-assembler -{ HEX: 7c411e70 } [ 1 2 3 SRAWI ] test-assembler -{ HEX: 7c221850 } [ 1 2 3 SUBF ] test-assembler -{ HEX: 7c221810 } [ 1 2 3 SUBFC ] test-assembler -{ HEX: 7c221910 } [ 1 2 3 SUBFE ] test-assembler -{ HEX: 7c410774 } [ 1 2 EXTSB ] test-assembler -{ HEX: 68410003 } [ 1 2 3 XORI ] test-assembler -{ HEX: 7c411a78 } [ 1 2 3 XOR ] test-assembler -{ HEX: 7c2200d0 } [ 1 2 NEG ] test-assembler -{ HEX: 2c220003 } [ 1 2 3 CMPI ] test-assembler -{ HEX: 28220003 } [ 1 2 3 CMPLI ] test-assembler -{ HEX: 7c411800 } [ 1 2 3 CMP ] test-assembler -{ HEX: 5422190a } [ 1 2 3 4 5 RLWINM ] test-assembler -{ HEX: 54221838 } [ 1 2 3 SLWI ] test-assembler -{ HEX: 5422e8fe } [ 1 2 3 SRWI ] test-assembler -{ HEX: 88220003 } [ 1 2 3 LBZ ] test-assembler -{ HEX: 8c220003 } [ 1 2 3 LBZU ] test-assembler -{ HEX: a8220003 } [ 1 2 3 LHA ] test-assembler -{ HEX: ac220003 } [ 1 2 3 LHAU ] test-assembler -{ HEX: a0220003 } [ 1 2 3 LHZ ] test-assembler -{ HEX: a4220003 } [ 1 2 3 LHZU ] test-assembler -{ HEX: 80220003 } [ 1 2 3 LWZ ] test-assembler -{ HEX: 84220003 } [ 1 2 3 LWZU ] test-assembler -{ HEX: 7c4118ae } [ 1 2 3 LBZX ] test-assembler -{ HEX: 7c4118ee } [ 1 2 3 LBZUX ] test-assembler -{ HEX: 7c411aae } [ 1 2 3 LHAX ] test-assembler -{ HEX: 7c411aee } [ 1 2 3 LHAUX ] test-assembler -{ HEX: 7c411a2e } [ 1 2 3 LHZX ] test-assembler -{ HEX: 7c411a6e } [ 1 2 3 LHZUX ] test-assembler -{ HEX: 7c41182e } [ 1 2 3 LWZX ] test-assembler -{ HEX: 7c41186e } [ 1 2 3 LWZUX ] test-assembler -{ HEX: 48000001 } [ 1 B ] test-assembler -{ HEX: 48000001 } [ 1 BL ] test-assembler -{ HEX: 41800004 } [ 1 BLT ] test-assembler -{ HEX: 41810004 } [ 1 BGT ] test-assembler -{ HEX: 40810004 } [ 1 BLE ] test-assembler -{ HEX: 40800004 } [ 1 BGE ] test-assembler -{ HEX: 41800004 } [ 1 BLT ] test-assembler -{ HEX: 40820004 } [ 1 BNE ] test-assembler -{ HEX: 41820004 } [ 1 BEQ ] test-assembler -{ HEX: 41830004 } [ 1 BO ] test-assembler -{ HEX: 40830004 } [ 1 BNO ] test-assembler -{ HEX: 4c200020 } [ 1 BCLR ] test-assembler -{ HEX: 4e800020 } [ BLR ] test-assembler -{ HEX: 4e800021 } [ BLRL ] test-assembler -{ HEX: 4c200420 } [ 1 BCCTR ] test-assembler -{ HEX: 4e800420 } [ BCTR ] test-assembler -{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler -{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler -{ HEX: 7c6902a6 } [ 3 MFCTR ] test-assembler -{ HEX: 7c6103a6 } [ 3 MTXER ] test-assembler -{ HEX: 7c6803a6 } [ 3 MTLR ] test-assembler -{ HEX: 7c6903a6 } [ 3 MTCTR ] test-assembler -{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler -{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler -{ HEX: c0220003 } [ 1 2 3 LFS ] test-assembler -{ HEX: c4220003 } [ 1 2 3 LFSU ] test-assembler -{ HEX: c8220003 } [ 1 2 3 LFD ] test-assembler -{ HEX: cc220003 } [ 1 2 3 LFDU ] test-assembler -{ HEX: d0220003 } [ 1 2 3 STFS ] test-assembler -{ HEX: d4220003 } [ 1 2 3 STFSU ] test-assembler -{ HEX: d8220003 } [ 1 2 3 STFD ] test-assembler -{ HEX: dc220003 } [ 1 2 3 STFDU ] test-assembler -{ HEX: fc201048 } [ 1 2 FMR ] test-assembler -{ HEX: fc20101e } [ 1 2 FCTIWZ ] test-assembler -{ HEX: fc22182a } [ 1 2 3 FADD ] test-assembler -{ HEX: fc22182b } [ 1 2 3 FADD. ] test-assembler -{ HEX: fc221828 } [ 1 2 3 FSUB ] test-assembler -{ HEX: fc2200f2 } [ 1 2 3 FMUL ] test-assembler -{ HEX: fc221824 } [ 1 2 3 FDIV ] test-assembler -{ HEX: fc20102c } [ 1 2 FSQRT ] test-assembler -{ HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler -{ HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler -{ HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler +B{ HEX: 38 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDI ] test-assembler +B{ HEX: 3c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIS ] test-assembler +B{ HEX: 30 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC ] test-assembler +B{ HEX: 34 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC. ] test-assembler +B{ HEX: 38 HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LI ] test-assembler +B{ HEX: 3c HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LIS ] test-assembler +B{ HEX: 38 HEX: 22 HEX: ff HEX: fd } [ 1 2 3 SUBI ] test-assembler +B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULI ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 1a HEX: 14 } [ 1 2 3 ADD ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 1a HEX: 15 } [ 1 2 3 ADD. ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 1e HEX: 15 } [ 1 2 3 ADDO. ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 18 HEX: 14 } [ 1 2 3 ADDC ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 18 HEX: 15 } [ 1 2 3 ADDC. ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 1c HEX: 15 } [ 1 2 3 ADDCO. ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 19 HEX: 14 } [ 1 2 3 ADDE ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: 38 } [ 1 2 3 AND ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: 39 } [ 1 2 3 AND. ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 1b HEX: d6 } [ 1 2 3 DIVW ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 1b HEX: 96 } [ 1 2 3 DIVWU ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1a HEX: 38 } [ 1 2 3 EQV ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1b HEX: b8 } [ 1 2 3 NAND ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: f8 } [ 1 2 3 NOR ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 10 HEX: f8 } [ 1 2 NOT ] test-assembler +B{ HEX: 60 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORI ] test-assembler +B{ HEX: 64 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORIS ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1b HEX: 78 } [ 1 2 3 OR ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 13 HEX: 78 } [ 1 2 MR ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 18 HEX: 96 } [ 1 2 3 MULHW ] test-assembler +B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULLI ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 18 HEX: 16 } [ 1 2 3 MULHWU ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 19 HEX: d6 } [ 1 2 3 MULLW ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: 30 } [ 1 2 3 SLW ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1e HEX: 30 } [ 1 2 3 SRAW ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1c HEX: 30 } [ 1 2 3 SRW ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1e HEX: 70 } [ 1 2 3 SRAWI ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 18 HEX: 50 } [ 1 2 3 SUBF ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 18 HEX: 10 } [ 1 2 3 SUBFC ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 19 HEX: 10 } [ 1 2 3 SUBFE ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 07 HEX: 74 } [ 1 2 EXTSB ] test-assembler +B{ HEX: 68 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 XORI ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1a HEX: 78 } [ 1 2 3 XOR ] test-assembler +B{ HEX: 7c HEX: 22 HEX: 00 HEX: d0 } [ 1 2 NEG ] test-assembler +B{ HEX: 2c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPI ] test-assembler +B{ HEX: 28 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPLI ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 CMP ] test-assembler +B{ HEX: 54 HEX: 22 HEX: 19 HEX: 0a } [ 1 2 3 4 5 RLWINM ] test-assembler +B{ HEX: 54 HEX: 22 HEX: 18 HEX: 38 } [ 1 2 3 SLWI ] test-assembler +B{ HEX: 54 HEX: 22 HEX: e8 HEX: fe } [ 1 2 3 SRWI ] test-assembler +B{ HEX: 88 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZ ] test-assembler +B{ HEX: 8c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZU ] test-assembler +B{ HEX: a8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHA ] test-assembler +B{ HEX: ac HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHAU ] test-assembler +B{ HEX: a0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZ ] test-assembler +B{ HEX: a4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZU ] test-assembler +B{ HEX: 80 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZ ] test-assembler +B{ HEX: 84 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZU ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: ae } [ 1 2 3 LBZX ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: ee } [ 1 2 3 LBZUX ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1a HEX: ae } [ 1 2 3 LHAX ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1a HEX: ee } [ 1 2 3 LHAUX ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1a HEX: 2e } [ 1 2 3 LHZX ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 1a HEX: 6e } [ 1 2 3 LHZUX ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: 2e } [ 1 2 3 LWZX ] test-assembler +B{ HEX: 7c HEX: 41 HEX: 18 HEX: 6e } [ 1 2 3 LWZUX ] test-assembler +B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 B ] test-assembler +B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 BL ] test-assembler +B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler +B{ HEX: 41 HEX: 81 HEX: 00 HEX: 04 } [ 1 BGT ] test-assembler +B{ HEX: 40 HEX: 81 HEX: 00 HEX: 04 } [ 1 BLE ] test-assembler +B{ HEX: 40 HEX: 80 HEX: 00 HEX: 04 } [ 1 BGE ] test-assembler +B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler +B{ HEX: 40 HEX: 82 HEX: 00 HEX: 04 } [ 1 BNE ] test-assembler +B{ HEX: 41 HEX: 82 HEX: 00 HEX: 04 } [ 1 BEQ ] test-assembler +B{ HEX: 41 HEX: 83 HEX: 00 HEX: 04 } [ 1 BO ] test-assembler +B{ HEX: 40 HEX: 83 HEX: 00 HEX: 04 } [ 1 BNO ] test-assembler +B{ HEX: 4c HEX: 20 HEX: 00 HEX: 20 } [ 1 BCLR ] test-assembler +B{ HEX: 4e HEX: 80 HEX: 00 HEX: 20 } [ BLR ] test-assembler +B{ HEX: 4e HEX: 80 HEX: 00 HEX: 21 } [ BLRL ] test-assembler +B{ HEX: 4c HEX: 20 HEX: 04 HEX: 20 } [ 1 BCCTR ] test-assembler +B{ HEX: 4e HEX: 80 HEX: 04 HEX: 20 } [ BCTR ] test-assembler +B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler +B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler +B{ HEX: 7c HEX: 69 HEX: 02 HEX: a6 } [ 3 MFCTR ] test-assembler +B{ HEX: 7c HEX: 61 HEX: 03 HEX: a6 } [ 3 MTXER ] test-assembler +B{ HEX: 7c HEX: 68 HEX: 03 HEX: a6 } [ 3 MTLR ] test-assembler +B{ HEX: 7c HEX: 69 HEX: 03 HEX: a6 } [ 3 MTCTR ] test-assembler +B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler +B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler +B{ HEX: c0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFS ] test-assembler +B{ HEX: c4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFSU ] test-assembler +B{ HEX: c8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFD ] test-assembler +B{ HEX: cc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFDU ] test-assembler +B{ HEX: d0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFS ] test-assembler +B{ HEX: d4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFSU ] test-assembler +B{ HEX: d8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFD ] test-assembler +B{ HEX: dc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFDU ] test-assembler +B{ HEX: fc HEX: 20 HEX: 10 HEX: 48 } [ 1 2 FMR ] test-assembler +B{ HEX: fc HEX: 20 HEX: 10 HEX: 1e } [ 1 2 FCTIWZ ] test-assembler +B{ HEX: fc HEX: 22 HEX: 18 HEX: 2a } [ 1 2 3 FADD ] test-assembler +B{ HEX: fc HEX: 22 HEX: 18 HEX: 2b } [ 1 2 3 FADD. ] test-assembler +B{ HEX: fc HEX: 22 HEX: 18 HEX: 28 } [ 1 2 3 FSUB ] test-assembler +B{ HEX: fc HEX: 22 HEX: 00 HEX: f2 } [ 1 2 3 FMUL ] test-assembler +B{ HEX: fc HEX: 22 HEX: 18 HEX: 24 } [ 1 2 3 FDIV ] test-assembler +B{ HEX: fc HEX: 20 HEX: 10 HEX: 2c } [ 1 2 FSQRT ] test-assembler +B{ HEX: fc HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 FCMPU ] test-assembler +B{ HEX: fc HEX: 41 HEX: 18 HEX: 40 } [ 1 2 3 FCMPO ] test-assembler +B{ HEX: 3c HEX: 60 HEX: 12 HEX: 34 HEX: 60 HEX: 63 HEX: 56 HEX: 78 } [ HEX: 12345678 3 LOAD ] test-assembler diff --git a/basis/cpu/ppc/assembler/backend/backend.factor b/basis/cpu/ppc/assembler/backend/backend.factor index befbe112bd..946aca6990 100644 --- a/basis/cpu/ppc/assembler/backend/backend.factor +++ b/basis/cpu/ppc/assembler/backend/backend.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: compiler.codegen.fixup cpu.architecture compiler.constants kernel namespaces make sequences words math math.bitwise io.binary parser lexer ; IN: cpu.ppc.assembler.backend -: insn ( operand opcode -- ) { 26 0 } bitfield , ; +: insn ( operand opcode -- ) { 26 0 } bitfield 4 >be % ; : a-insn ( d a b c xo rc opcode -- ) [ { 0 1 6 11 16 21 } bitfield ] dip insn ; From 18454e4e6ed5fddd9623f71b75eb49044275baaf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 May 2009 20:56:44 -0500 Subject: [PATCH 039/210] cpu.x86.bootstrap: remove obsolete comment --- basis/cpu/x86/bootstrap.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 4fe5e5cd33..fcd8ed0eee 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -152,9 +152,6 @@ big-endian off ! ! ! Polymorphic inline caches -! temp0 contains the object being dispatched on -! temp1 contains its class - ! Load a value from a stack position [ temp1 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel From 2f6152de986bd8917a20c9517caaff70aff4fe08 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 5 May 2009 22:43:07 -0400 Subject: [PATCH 040/210] Add combination support to math.combinatorics --- basis/math/combinatorics/combinatorics.factor | 72 ++++++++++++++----- 1 file changed, 56 insertions(+), 16 deletions(-) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index afdf4e378e..0ca306b68c 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -1,7 +1,7 @@ -! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer. +! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel math math.order math.ranges mirrors -namespaces sequences sorting fry ; +USING: accessors assocs fry kernel locals math math.order math.ranges mirrors + namespaces sequences sorting ; IN: math.combinatorics [ dupd - ] when ; inline -! See this article for explanation of the factoradic-based permutation methodology: -! http://msdn2.microsoft.com/en-us/library/aa302371.aspx +PRIVATE> + +: factorial ( n -- n! ) + 1 [ 1 + * ] reduce ; + +: nPk ( n k -- nPk ) + 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ; + +: nCk ( n k -- nCk ) + twiddle [ nPk ] keep factorial / ; + + +! Factoradic-based permutation methodology + + ] [ 1+ [ /mod ] keep swap ] produce reverse 2nip ; + 0 [ over 0 > ] [ 1 + [ /mod ] keep swap ] produce reverse 2nip ; : (>permutation) ( seq n -- seq ) - [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ; + [ '[ _ dupd >= [ 1 + ] when ] map ] keep prefix ; : >permutation ( factoradic -- permutation ) reverse 1 cut [ (>permutation) ] each ; @@ -29,15 +42,6 @@ IN: math.combinatorics PRIVATE> -: factorial ( n -- n! ) - 1 [ 1+ * ] reduce ; - -: nPk ( n k -- nPk ) - 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ; - -: nCk ( n k -- nCk ) - twiddle [ nPk ] keep factorial / ; - : permutation ( n seq -- seq ) [ permutation-indices ] keep nths ; @@ -53,3 +57,39 @@ PRIVATE> : inverse-permutation ( seq -- permutation ) >alist sort-values keys ; + + +! Combinadic-based combination methodology + +TUPLE: combination + { n integer } + { k integer } ; + +C: combination + +> ] [ k>> ] bi nCk 1 - ] dip - ; + +: largest-value ( a b x -- v ) + #! TODO: use a binary search instead of find-last + [ [0,b) ] 2dip '[ _ nCk _ <= ] find-last nip ; + +:: next-values ( a b x -- a' b' x' v ) + a b x largest-value dup :> v ! a' + b 1 - ! b' + x v b nCk - ! x' + v ; ! v == a' + +: initial-values ( combination m -- a b x ) + [ [ n>> ] [ k>> ] [ ] tri ] dip dual-index ; + +: combinadic ( combination m -- combinadic ) + initial-values [ over 0 > ] [ next-values ] produce + [ 3drop ] dip ; + +PRIVATE> + +: combination ( m combination -- seq ) + swap [ drop n>> 1 - ] [ combinadic ] 2bi [ - ] with map ; From e4c84a91f67da7decd268a45f7f507c5dbcdfc35 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 5 May 2009 22:17:04 -0500 Subject: [PATCH 041/210] more vector operations; perlin noise vocab --- basis/math/vectors/vectors.factor | 9 +++ extra/perlin-noise/perlin-noise.factor | 83 ++++++++++++++++++++++++++ 2 files changed, 92 insertions(+) create mode 100644 extra/perlin-noise/perlin-noise.factor diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index f93a5f2b1e..eb203a5f12 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -6,6 +6,11 @@ IN: math.vectors : vneg ( u -- v ) [ neg ] map ; +: v+n ( u n -- v ) [ + ] curry map ; +: n+v ( n u -- v ) [ + ] with map ; +: v-n ( u n -- v ) [ - ] curry map ; +: n-v ( n u -- v ) [ - ] with map ; + : v*n ( u n -- v ) [ * ] curry map ; : n*v ( n u -- v ) [ * ] with map ; : v/n ( u n -- v ) [ / ] curry map ; @@ -19,6 +24,10 @@ IN: math.vectors : vmax ( u v -- w ) [ max ] 2map ; : vmin ( u v -- w ) [ min ] 2map ; +: vfloor ( v -- _v_ ) [ floor ] map ; +: vceiling ( v -- ^v^ ) [ ceiling ] map ; +: vtruncate ( v -- -v- ) [ truncate ] map ; + : vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ; : vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; diff --git a/extra/perlin-noise/perlin-noise.factor b/extra/perlin-noise/perlin-noise.factor new file mode 100644 index 0000000000..e662202ca1 --- /dev/null +++ b/extra/perlin-noise/perlin-noise.factor @@ -0,0 +1,83 @@ +USING: byte-arrays combinators images kernel locals math +math.functions math.polynomials math.vectors random sequences +sequences.product ; +IN: perlin-noise + +: ( -- table ) + 256 iota >byte-array randomize dup append ; + +: fade ( point -- point' ) + { 0.0 0.0 0.0 10.0 -15.0 6.0 } swap [ polyval ] with map ; + +:: grad ( hash gradients -- gradient ) + hash 8 bitand zero? [ gradients first ] [ gradients second ] if + :> u + hash 12 bitand zero? + [ gradients second ] + [ hash 13 bitand 12 = [ gradients first ] [ gradients third ] if ] if + :> v + + hash 1 bitand zero? [ u ] [ u neg ] if + hash 2 bitand zero? [ v ] [ v neg ] if + ; + +: unit-cube ( point -- cube ) + [ floor >fixnum 256 mod ] map ; + +:: hashes ( table cube -- aaa baa aba bba aab bab abb bbb ) + cube first :> x + cube second :> y + cube third :> z + x table nth y + :> a + x 1 + table nth y + :> b + + a table nth z + :> aa + b table nth z + :> ba + a 1 + table nth z + :> ab + b 1 + table nth z + :> bb + + aa table nth + ba table nth + ab table nth + bb table nth + aa 1 + table nth + ba 1 + table nth + ab 1 + table nth + bb 1 + table nth ; + +:: 2tetra@ ( p q r s t u v w quot -- ) + p q quot call + r s quot call + t u quot call + v w quot call + ; inline + +:: noise ( table point -- value ) + point unit-cube :> cube + point dup vfloor v- :> gradients + gradients fade :> faded + + table cube hashes { + [ gradients grad ] + [ gradients { -1.0 0.0 0.0 } v+ grad ] + [ gradients { 0.0 -1.0 0.0 } v+ grad ] + [ gradients { -1.0 -1.0 0.0 } v+ grad ] + [ gradients { 0.0 0.0 -1.0 } v+ grad ] + [ gradients { -1.0 0.0 -1.0 } v+ grad ] + [ gradients { 0.0 -1.0 -1.0 } v+ grad ] + [ gradients { -1.0 -1.0 -1.0 } v+ grad ] + } spread + [ faded first lerp ] 2tetra@ + [ faded second lerp ] 2bi@ + faded third lerp ; + +: noise-map ( table scale dim -- map ) + [ iota ] map [ v* 0.0 suffix noise ] with with product-map ; + +: normalize ( sequence -- sequence' ) + [ supremum ] [ infimum [ - ] keep ] [ ] tri + [ swap - ] with map [ swap / ] with map ; + +: noise-image ( table scale dim -- image ) + [ noise-map normalize [ 255.0 * >fixnum ] B{ } map-as ] + [ swap [ L f ] dip image boa ] bi ; + From ff0cef1627f7b53b2ec9f4d1e115aa9ad5483d58 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 5 May 2009 22:58:38 -0500 Subject: [PATCH 042/210] throw more errors on tiff if formats are unsupported --- basis/images/tiff/tiff.factor | 69 ++++++++++++++++++++++------------- 1 file changed, 44 insertions(+), 25 deletions(-) diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 6bf1ea2ff1..27dc25de73 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -5,7 +5,7 @@ compression.lzw constructors endian fry grouping images io io.binary io.encodings.ascii io.encodings.binary io.encodings.string io.encodings.utf8 io.files kernel math math.bitwise math.order math.parser pack prettyprint sequences -strings math.vectors specialized-arrays.float ; +strings math.vectors specialized-arrays.float locals ; IN: images.tiff TUPLE: tiff-image < image ; @@ -184,7 +184,7 @@ samples-per-pixel new-subfile-type subfile-type orientation software date-time photoshop exif-ifd sub-ifd inter-color-profile xmp iptc fill-order document-name page-number page-name x-position y-position host-computer copyright artist -min-sample-value max-sample-value make model cell-width cell-length +min-sample-value max-sample-value tiff-make tiff-model cell-width cell-length gray-response-unit gray-response-curve color-map threshholding image-description free-offsets free-byte-counts tile-width tile-length matteing data-type image-depth tile-depth @@ -243,10 +243,13 @@ ERROR: bad-tiff-magic bytes ; ERROR: no-tag class ; -: find-tag ( idf class -- tag ) - swap processed-tags>> ?at [ no-tag ] unless ; +: find-tag* ( ifd class -- tag/class ? ) + swap processed-tags>> ?at ; -: tag? ( idf class -- tag ) +: find-tag ( ifd class -- tag ) + find-tag* [ no-tag ] unless ; + +: tag? ( ifd class -- tag ) swap processed-tags>> key? ; : read-strips ( ifd -- ifd ) @@ -339,8 +342,8 @@ ERROR: bad-small-ifd-type n ; { 266 [ fill-order ] } { 269 [ ascii decode document-name ] } { 270 [ ascii decode image-description ] } - { 271 [ ascii decode make ] } - { 272 [ ascii decode model ] } + { 271 [ ascii decode tiff-make ] } + { 272 [ ascii decode tiff-model ] } { 273 [ strip-offsets ] } { 274 [ orientation ] } { 277 [ samples-per-pixel ] } @@ -350,7 +353,7 @@ ERROR: bad-small-ifd-type n ; { 281 [ max-sample-value ] } { 282 [ first x-resolution ] } { 283 [ first y-resolution ] } - { 284 [ planar-configuration ] } + { 284 [ lookup-planar-configuration planar-configuration ] } { 285 [ page-name ] } { 286 [ x-position ] } { 287 [ y-position ] } @@ -437,8 +440,8 @@ ERROR: unhandled-compression compression ; [ samples-per-pixel find-tag ] tri [ * ] keep '[ - _ group [ _ group [ rest ] [ first ] bi - [ v+ ] accumulate swap suffix concat ] map + _ group + [ _ group unclip [ v+ ] accumulate swap suffix concat ] map concat >byte-array ] change-bitmap ; @@ -521,23 +524,39 @@ ERROR: unknown-component-order ifd ; ] with-tiff-endianness ] with-file-reader ; -: process-tif-ifds ( parsed-tiff -- parsed-tiff ) - dup ifds>> [ - read-strips - uncompress-strips - strips>bitmap - fix-bitmap-endianness - strips-predictor - dup extra-samples tag? [ handle-alpha-data ] when - drop - ] each ; +: process-chunky-ifd ( ifd -- ) + read-strips + uncompress-strips + strips>bitmap + fix-bitmap-endianness + strips-predictor + dup extra-samples tag? [ handle-alpha-data ] when + drop ; + +: process-planar-ifd ( ifd -- ) + "planar ifd not supported" throw ; + +: dispatch-planar-configuration ( ifd planar-configuration -- ) + { + { planar-configuration-chunky [ process-chunky-ifd ] } + { planar-configuration-planar [ process-planar-ifd ] } + } case ; + +: process-ifd ( ifd -- ) + dup planar-configuration find-tag* [ + dispatch-planar-configuration + ] [ + drop "no planar configuration" throw + ] if ; + +: process-tif-ifds ( parsed-tiff -- ) + ifds>> [ process-ifd ] each ; : load-tiff ( path -- parsed-tiff ) - [ load-tiff-ifds ] [ - binary [ - [ process-tif-ifds ] with-tiff-endianness - ] with-file-reader - ] bi ; + [ load-tiff-ifds dup ] keep + binary [ + [ process-tif-ifds ] with-tiff-endianness + ] with-file-reader ; ! tiff files can store several images -- we just take the first for now M: tiff-image load-image* ( path tiff-image -- image ) From d39e5ffe934f7f37d59fb0d8720c7fc8af9deab0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 5 May 2009 23:25:26 -0500 Subject: [PATCH 043/210] _finally_ cleaned up miller-rabin. it's passable now --- basis/math/miller-rabin/miller-rabin.factor | 33 ++++++++++----------- 1 file changed, 15 insertions(+), 18 deletions(-) diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor index 8c237d0dc3..62d8ee4432 100755 --- a/basis/math/miller-rabin/miller-rabin.factor +++ b/basis/math/miller-rabin/miller-rabin.factor @@ -6,31 +6,28 @@ IN: math.miller-rabin odd ( n -- int ) dup even? [ 1+ ] when ; foldable +: >odd ( n -- int ) dup even? [ 1 + ] when ; foldable TUPLE: positive-even-expected n ; :: (miller-rabin) ( n trials -- ? ) - [let | r [ n 1- factor-2s drop ] - s [ n 1- factor-2s nip ] - prime?! [ t ] - a! [ 0 ] - count! [ 0 ] | - trials [ - n 1- [1,b] random a! - a s n ^mod 1 = [ - 0 count! - r [ - 2^ s * a swap n ^mod n - -1 = - [ count 1+ count! r + ] when - ] each - count zero? [ f prime?! trials + ] when - ] unless drop - ] each prime? ] ; + n 1 - :> n-1 + n-1 factor-2s :> s :> r + 0 :> a! + trials [ + drop + n-1 [1,b] random a! + a s n ^mod 1 = [ + f + ] [ + r [ 2^ s * a swap n ^mod n - -1 = ] any? + ] if + ] any? ; + PRIVATE> -: next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ; +: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; : miller-rabin* ( n numtrials -- ? ) over { From c2fe62f7d6e5bf3f9683a6084244bd89db3afba9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 5 May 2009 23:32:23 -0500 Subject: [PATCH 044/210] remove 1-, 1+, use iota somewhere --- basis/math/bits/bits.factor | 2 +- basis/math/bitwise/bitwise.factor | 12 ++++++------ basis/math/blas/vectors/vectors.factor | 2 +- basis/math/functions/functions.factor | 10 +++++----- basis/math/intervals/intervals.factor | 6 +++--- basis/math/polynomials/polynomials.factor | 4 ++-- basis/math/ranges/ranges.factor | 2 +- basis/math/statistics/statistics.factor | 6 +++--- 8 files changed, 22 insertions(+), 22 deletions(-) diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor index 8920955df3..72b83a991f 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 + dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + ] if ; inline M: bits length length>> ; diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 3148567bc0..73d111f91e 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -13,10 +13,10 @@ IN: math.bitwise : unmask? ( x n -- ? ) unmask 0 > ; inline : mask ( x n -- ? ) bitand ; inline : mask? ( x n -- ? ) mask 0 > ; inline -: wrap ( m n -- m' ) 1- bitand ; inline +: wrap ( m n -- m' ) 1 - bitand ; inline : bits ( m n -- m' ) 2^ wrap ; inline : mask-bit ( m n -- m' ) 2^ mask ; inline -: on-bits ( n -- m ) 2^ 1- ; inline +: on-bits ( n -- m ) 2^ 1 - ; inline : toggle-bit ( m n -- m' ) 2^ bitxor ; inline : shift-mod ( n s w -- n ) @@ -64,8 +64,8 @@ DEFER: byte-bit-count << \ byte-bit-count -256 [ - 8 0 [ [ 1+ ] when ] reduce +256 iota [ + 8 0 [ [ 1 + ] when ] reduce ] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ] (( byte -- table )) define-declared @@ -97,12 +97,12 @@ PRIVATE> ! Signed byte array to integer conversion : signed-le> ( bytes -- x ) - [ le> ] [ length 8 * 1- on-bits ] bi + [ le> ] [ length 8 * 1 - on-bits ] bi 2dup > [ bitnot bitor ] [ drop ] if ; : signed-be> ( bytes -- x ) signed-le> ; : >signed ( x n -- y ) - 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; + 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ; diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index d7c6ebc927..3017a12b18 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -164,7 +164,7 @@ M: VECTOR element-type M: VECTOR Vswap (prepare-swap) [ XSWAP ] 2dip ; M: VECTOR Viamax - (prepare-nrm2) IXAMAX 1- ; + (prepare-nrm2) IXAMAX 1 - ; M: VECTOR (blas-vector-like) drop ; diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 41cb52a396..0a5e89ccd6 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -18,7 +18,7 @@ M: real sqrt : factor-2s ( n -- r s ) #! factor an integer into 2^r * s dup 0 = [ 1 ] [ - 0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] while + 0 swap [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while ] if ; inline > first 1 max dup most-positive-fixnum > [ drop full-interval interval-log2 ] - [ 1+ >integer log2 0 swap [a,b] ] + [ 1 + >integer log2 0 swap [a,b] ] if ] } case ; @@ -407,7 +407,7 @@ SYMBOL: incomparable : integral-closure ( i1 -- i2 ) dup special-interval? [ - [ from>> first2 [ 1+ ] unless ] - [ to>> first2 [ 1- ] unless ] + [ from>> first2 [ 1 + ] unless ] + [ to>> first2 [ 1 - ] unless ] bi [a,b] ] unless ; diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index ec09b366a1..f65c4ecaaf 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -29,7 +29,7 @@ PRIVATE> : n*p ( n p -- n*p ) n*v ; : pextend-conv ( p q -- p q ) - 2dup [ length ] bi@ + 1- 2pad-tail [ >vector ] bi@ ; + 2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ; : p* ( p q -- r ) 2unempty pextend-conv dup length @@ -44,7 +44,7 @@ PRIVATE> 2ptrim 2dup [ length ] bi@ - dup 1 < [ drop 1 ] when - [ over length + 0 pad-head pextend ] keep 1+ ; + [ over length + 0 pad-head pextend ] keep 1 + ; : /-last ( seq seq -- a ) #! divide the last two numbers in the sequences diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index 068f599b6f..883be006dc 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -10,7 +10,7 @@ TUPLE: range { step read-only } ; : ( a b step -- range ) - [ over - ] dip [ /i 1+ 0 max ] keep range boa ; inline + [ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline M: range length ( seq -- n ) length>> ; diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 589876184f..4cd8c5b888 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -15,7 +15,7 @@ IN: math.statistics : median ( seq -- n ) natural-sort dup length even? [ - [ midpoint@ dup 1- 2array ] keep nths mean + [ midpoint@ dup 1 - 2array ] keep nths mean ] [ [ midpoint@ ] keep nth ] if ; @@ -33,7 +33,7 @@ IN: math.statistics drop 0 ] [ [ [ mean ] keep [ - sq ] with sigma ] keep - length 1- / + length 1 - / ] if ; : std ( seq -- x ) @@ -47,7 +47,7 @@ IN: math.statistics 0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ; : (r) ( mean(x) mean(y) {x} {y} sx sy -- r ) - * recip [ [ ((r)) ] keep length 1- / ] dip * ; + * recip [ [ ((r)) ] keep length 1 - / ] dip * ; : [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy ) first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ; From 647c8315150224739c172bf5eb546895c383ab09 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 01:17:35 -0400 Subject: [PATCH 045/210] Combinations now map to input sequences directly --- basis/math/combinatorics/combinatorics.factor | 47 +++++++++++++------ 1 file changed, 33 insertions(+), 14 deletions(-) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index 0ca306b68c..dd71ded8c2 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -52,7 +52,7 @@ PRIVATE> [ [ length factorial ] keep ] dip '[ _ permutation @ ] each ; inline -: reduce-permutations ( seq initial quot -- result ) +: reduce-permutations ( seq identity quot -- result ) swapd each-permutation ; inline : inverse-permutation ( seq -- permutation ) @@ -61,16 +61,13 @@ PRIVATE> ! Combinadic-based combination methodology -TUPLE: combination - { n integer } - { k integer } ; - -C: combination - > ] [ k>> ] bi nCk 1 - ] dip - ; +TUPLE: combo + { seq sequence } + { k integer } ; + +C: combo : largest-value ( a b x -- v ) #! TODO: use a binary search instead of find-last @@ -82,14 +79,36 @@ C: combination x v b nCk - ! x' v ; ! v == a' -: initial-values ( combination m -- a b x ) - [ [ n>> ] [ k>> ] [ ] tri ] dip dual-index ; +: dual-index ( combo m -- x ) + [ [ seq>> length ] [ k>> ] bi nCk 1 - ] dip - ; -: combinadic ( combination m -- combinadic ) +: initial-values ( combo m -- a b x ) + [ [ seq>> length ] [ k>> ] [ ] tri ] dip dual-index ; + +: combinadic ( combo m -- combinadic ) initial-values [ over 0 > ] [ next-values ] produce [ 3drop ] dip ; +: combination-indices ( m combo -- seq ) + [ swap combinadic ] keep + seq>> length 1 - swap [ - ] with map ; + +: apply-combination ( m combo -- seq ) + [ combination-indices ] keep seq>> nths ; + +: choose ( combo -- nCk ) + [ seq>> length ] [ k>> ] bi nCk ; + PRIVATE> -: combination ( m combination -- seq ) - swap [ drop n>> 1 - ] [ combinadic ] 2bi [ - ] with map ; +: combination ( m seq k -- seq ) + apply-combination ; + +: all-combinations ( seq k -- seq ) + [ choose [0,b) ] keep + '[ _ apply-combination ] map ; + +: each-combination ( seq k quot -- ) + [ [ choose [0,b) ] keep ] dip + '[ _ apply-combination @ ] each ; inline + From 92732f4c65e59aaf8b0c788d2884dba23954d20a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 6 May 2009 00:54:14 -0500 Subject: [PATCH 046/210] fix miller-rabin, it's correct but a little ugly still. bed time --- .../miller-rabin/miller-rabin-tests.factor | 12 ++++- basis/math/miller-rabin/miller-rabin.factor | 52 +++++++++++++++---- 2 files changed, 52 insertions(+), 12 deletions(-) diff --git a/basis/math/miller-rabin/miller-rabin-tests.factor b/basis/math/miller-rabin/miller-rabin-tests.factor index 5f1b9835e4..676c4bf20d 100644 --- a/basis/math/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/miller-rabin/miller-rabin-tests.factor @@ -1,4 +1,4 @@ -USING: math.miller-rabin tools.test ; +USING: math.miller-rabin tools.test kernel sequences ; IN: math.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test @@ -8,4 +8,12 @@ IN: math.miller-rabin.tests [ t ] [ 37 miller-rabin ] unit-test [ 101 ] [ 100 next-prime ] unit-test [ t ] [ 2135623355842621559 miller-rabin ] unit-test -[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test \ No newline at end of file +[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test + +[ 863 ] [ 862 next-safe-prime ] unit-test +[ f ] [ 862 safe-prime? ] unit-test +[ t ] [ 7 safe-prime? ] unit-test +[ f ] [ 31 safe-prime? ] unit-test +[ t ] [ 863 safe-prime? ] unit-test + +[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor index 62d8ee4432..93d7f4c582 100755 --- a/basis/math/miller-rabin/miller-rabin.factor +++ b/basis/math/miller-rabin/miller-rabin.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel locals math math.functions math.ranges -random sequences sets ; +random sequences sets combinators.short-circuit ; IN: math.miller-rabin n-1 n-1 factor-2s :> s :> r 0 :> a! - + t :> prime?! trials [ - drop - n-1 [1,b] random a! + n 1 - [1,b] random a! a s n ^mod 1 = [ - f - ] [ - r [ 2^ s * a swap n ^mod n - -1 = ] any? - ] if - ] any? ; - + r iota [ + 2^ s * a swap n ^mod n - -1 = + ] any? not [ f prime?! trials + ] when + ] unless drop + ] each prime? ; + PRIVATE> : next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; @@ -71,3 +70,36 @@ ERROR: too-few-primes ; dup 5 < [ too-few-primes ] when 2dup [ random-prime ] curry replicate dup all-unique? [ 2nip ] [ drop unique-primes ] if ; + +! Safe primes are of the form p = 2q + 1, p,q are prime +! See http://en.wikipedia.org/wiki/Safe_prime + +safe-prime-form ( q -- p ) 2 * 1 + ; + +: safe-prime-candidate? ( n -- ? ) + >safe-prime-form + 1 + 6 divisor? ; + +: next-safe-prime-candidate ( n -- candidate ) + 1 - 2/ + next-prime dup safe-prime-candidate? + [ next-safe-prime-candidate ] unless ; + +PRIVATE> + +: safe-prime? ( q -- ? ) + { + [ 1 - 2 / dup integer? [ miller-rabin ] [ drop f ] if ] + [ miller-rabin ] + } 1&& ; + +: next-safe-prime ( n -- q ) + next-safe-prime-candidate + dup >safe-prime-form + dup miller-rabin + [ nip ] [ drop next-safe-prime ] if ; + +: random-safe-prime ( numbits -- p ) + random-bits next-safe-prime ; From e1889c398155f380ac5eba02cdf90d033480948e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 10:38:39 -0500 Subject: [PATCH 047/210] specialized-arrays: fix unit tests for bool type change --- basis/specialized-arrays/specialized-arrays-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index 73e719b806..f64542fa00 100644 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -2,7 +2,7 @@ IN: specialized-arrays.tests USING: tools.test specialized-arrays sequences specialized-arrays.int specialized-arrays.bool specialized-arrays.ushort alien.c-types accessors kernel -specialized-arrays.direct.int arrays ; +specialized-arrays.direct.int specialized-arrays.char arrays ; [ t ] [ { 1 2 3 } >int-array int-array? ] unit-test @@ -10,7 +10,7 @@ specialized-arrays.direct.int arrays ; [ 2 ] [ int-array{ 1 2 3 } second ] unit-test -[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >int-array underlying>> = ] unit-test +[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >char-array underlying>> = ] unit-test [ ushort-array{ 1234 } ] [ little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array From 9b5933d97cdb6f6adf023acba84a2c43819efd9f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 11:03:04 -0500 Subject: [PATCH 048/210] Move modules to unmaintained since it has a few issues --- {extra => unmaintained}/modules/remote-loading/authors.txt | 0 .../modules/remote-loading/remote-loading.factor | 0 {extra => unmaintained}/modules/remote-loading/summary.txt | 0 {extra => unmaintained}/modules/rpc-server/authors.txt | 0 {extra => unmaintained}/modules/rpc-server/rpc-server.factor | 0 {extra => unmaintained}/modules/rpc-server/summary.txt | 0 {extra => unmaintained}/modules/rpc/authors.txt | 0 {extra => unmaintained}/modules/rpc/rpc-docs.factor | 0 {extra => unmaintained}/modules/rpc/rpc.factor | 0 {extra => unmaintained}/modules/rpc/summary.txt | 0 {extra => unmaintained}/modules/uploads/authors.txt | 0 {extra => unmaintained}/modules/uploads/summary.txt | 0 {extra => unmaintained}/modules/uploads/uploads.factor | 0 {extra => unmaintained}/modules/using/authors.txt | 0 {extra => unmaintained}/modules/using/summary.txt | 0 {extra => unmaintained}/modules/using/tests/tags.txt | 0 {extra => unmaintained}/modules/using/tests/test-server.factor | 0 {extra => unmaintained}/modules/using/tests/tests.factor | 0 {extra => unmaintained}/modules/using/using-docs.factor | 0 {extra => unmaintained}/modules/using/using.factor | 0 20 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/modules/remote-loading/authors.txt (100%) rename {extra => unmaintained}/modules/remote-loading/remote-loading.factor (100%) rename {extra => unmaintained}/modules/remote-loading/summary.txt (100%) rename {extra => unmaintained}/modules/rpc-server/authors.txt (100%) rename {extra => unmaintained}/modules/rpc-server/rpc-server.factor (100%) rename {extra => unmaintained}/modules/rpc-server/summary.txt (100%) rename {extra => unmaintained}/modules/rpc/authors.txt (100%) rename {extra => unmaintained}/modules/rpc/rpc-docs.factor (100%) rename {extra => unmaintained}/modules/rpc/rpc.factor (100%) rename {extra => unmaintained}/modules/rpc/summary.txt (100%) rename {extra => unmaintained}/modules/uploads/authors.txt (100%) rename {extra => unmaintained}/modules/uploads/summary.txt (100%) rename {extra => unmaintained}/modules/uploads/uploads.factor (100%) rename {extra => unmaintained}/modules/using/authors.txt (100%) rename {extra => unmaintained}/modules/using/summary.txt (100%) rename {extra => unmaintained}/modules/using/tests/tags.txt (100%) rename {extra => unmaintained}/modules/using/tests/test-server.factor (100%) rename {extra => unmaintained}/modules/using/tests/tests.factor (100%) rename {extra => unmaintained}/modules/using/using-docs.factor (100%) rename {extra => unmaintained}/modules/using/using.factor (100%) diff --git a/extra/modules/remote-loading/authors.txt b/unmaintained/modules/remote-loading/authors.txt similarity index 100% rename from extra/modules/remote-loading/authors.txt rename to unmaintained/modules/remote-loading/authors.txt diff --git a/extra/modules/remote-loading/remote-loading.factor b/unmaintained/modules/remote-loading/remote-loading.factor similarity index 100% rename from extra/modules/remote-loading/remote-loading.factor rename to unmaintained/modules/remote-loading/remote-loading.factor diff --git a/extra/modules/remote-loading/summary.txt b/unmaintained/modules/remote-loading/summary.txt similarity index 100% rename from extra/modules/remote-loading/summary.txt rename to unmaintained/modules/remote-loading/summary.txt diff --git a/extra/modules/rpc-server/authors.txt b/unmaintained/modules/rpc-server/authors.txt similarity index 100% rename from extra/modules/rpc-server/authors.txt rename to unmaintained/modules/rpc-server/authors.txt diff --git a/extra/modules/rpc-server/rpc-server.factor b/unmaintained/modules/rpc-server/rpc-server.factor similarity index 100% rename from extra/modules/rpc-server/rpc-server.factor rename to unmaintained/modules/rpc-server/rpc-server.factor diff --git a/extra/modules/rpc-server/summary.txt b/unmaintained/modules/rpc-server/summary.txt similarity index 100% rename from extra/modules/rpc-server/summary.txt rename to unmaintained/modules/rpc-server/summary.txt diff --git a/extra/modules/rpc/authors.txt b/unmaintained/modules/rpc/authors.txt similarity index 100% rename from extra/modules/rpc/authors.txt rename to unmaintained/modules/rpc/authors.txt diff --git a/extra/modules/rpc/rpc-docs.factor b/unmaintained/modules/rpc/rpc-docs.factor similarity index 100% rename from extra/modules/rpc/rpc-docs.factor rename to unmaintained/modules/rpc/rpc-docs.factor diff --git a/extra/modules/rpc/rpc.factor b/unmaintained/modules/rpc/rpc.factor similarity index 100% rename from extra/modules/rpc/rpc.factor rename to unmaintained/modules/rpc/rpc.factor diff --git a/extra/modules/rpc/summary.txt b/unmaintained/modules/rpc/summary.txt similarity index 100% rename from extra/modules/rpc/summary.txt rename to unmaintained/modules/rpc/summary.txt diff --git a/extra/modules/uploads/authors.txt b/unmaintained/modules/uploads/authors.txt similarity index 100% rename from extra/modules/uploads/authors.txt rename to unmaintained/modules/uploads/authors.txt diff --git a/extra/modules/uploads/summary.txt b/unmaintained/modules/uploads/summary.txt similarity index 100% rename from extra/modules/uploads/summary.txt rename to unmaintained/modules/uploads/summary.txt diff --git a/extra/modules/uploads/uploads.factor b/unmaintained/modules/uploads/uploads.factor similarity index 100% rename from extra/modules/uploads/uploads.factor rename to unmaintained/modules/uploads/uploads.factor diff --git a/extra/modules/using/authors.txt b/unmaintained/modules/using/authors.txt similarity index 100% rename from extra/modules/using/authors.txt rename to unmaintained/modules/using/authors.txt diff --git a/extra/modules/using/summary.txt b/unmaintained/modules/using/summary.txt similarity index 100% rename from extra/modules/using/summary.txt rename to unmaintained/modules/using/summary.txt diff --git a/extra/modules/using/tests/tags.txt b/unmaintained/modules/using/tests/tags.txt similarity index 100% rename from extra/modules/using/tests/tags.txt rename to unmaintained/modules/using/tests/tags.txt diff --git a/extra/modules/using/tests/test-server.factor b/unmaintained/modules/using/tests/test-server.factor similarity index 100% rename from extra/modules/using/tests/test-server.factor rename to unmaintained/modules/using/tests/test-server.factor diff --git a/extra/modules/using/tests/tests.factor b/unmaintained/modules/using/tests/tests.factor similarity index 100% rename from extra/modules/using/tests/tests.factor rename to unmaintained/modules/using/tests/tests.factor diff --git a/extra/modules/using/using-docs.factor b/unmaintained/modules/using/using-docs.factor similarity index 100% rename from extra/modules/using/using-docs.factor rename to unmaintained/modules/using/using-docs.factor diff --git a/extra/modules/using/using.factor b/unmaintained/modules/using/using.factor similarity index 100% rename from extra/modules/using/using.factor rename to unmaintained/modules/using/using.factor From a2a5129a84972001054c4afc88a5fb633b433856 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 6 May 2009 12:21:30 -0500 Subject: [PATCH 049/210] fix miller-rabin, safe primes --- basis/math/miller-rabin/miller-rabin.factor | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor index 93d7f4c582..8c36dd96fe 100755 --- a/basis/math/miller-rabin/miller-rabin.factor +++ b/basis/math/miller-rabin/miller-rabin.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel locals math math.functions math.ranges -random sequences sets combinators.short-circuit ; +random sequences sets combinators.short-circuit math.bitwise ; IN: math.miller-rabin n-1 n-1 factor-2s :> s :> r 0 :> a! - t :> prime?! trials [ + drop n 1 - [1,b] random a! a s n ^mod 1 = [ + f + ] [ r iota [ 2^ s * a swap n ^mod n - -1 = - ] any? not [ f prime?! trials + ] when - ] unless drop - ] each prime? ; + ] any? not + ] if + ] any? not ; PRIVATE> @@ -83,7 +85,6 @@ ERROR: too-few-primes ; 1 + 6 divisor? ; : next-safe-prime-candidate ( n -- candidate ) - 1 - 2/ next-prime dup safe-prime-candidate? [ next-safe-prime-candidate ] unless ; @@ -101,5 +102,8 @@ PRIVATE> dup miller-rabin [ nip ] [ drop next-safe-prime ] if ; +: random-bits* ( numbits -- n ) + [ random-bits ] keep set-bit ; + : random-safe-prime ( numbits -- p ) - random-bits next-safe-prime ; + 1- random-bits* next-safe-prime ; From 58fd3a415ffaa80c89862c2520b567e6aaf7d93d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 6 May 2009 12:36:34 -0500 Subject: [PATCH 050/210] make ^n foldable --- basis/math/functions/functions.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 41cb52a396..c8d71b1279 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -23,7 +23,7 @@ M: real sqrt Date: Wed, 6 May 2009 12:38:14 -0500 Subject: [PATCH 051/210] add 2pi constant --- basis/math/constants/constants.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/math/constants/constants.factor b/basis/math/constants/constants.factor index 118a8e8197..a2d3213e78 100644 --- a/basis/math/constants/constants.factor +++ b/basis/math/constants/constants.factor @@ -7,6 +7,7 @@ IN: math.constants : euler ( -- gamma ) 0.57721566490153286060 ; inline : phi ( -- phi ) 1.61803398874989484820 ; inline : pi ( -- pi ) 3.14159265358979323846 ; inline +: 2pi ( -- pi ) 2 pi * ; inline : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline : smallest-float ( -- x ) HEX: 1 bits>double ; foldable : largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable From 3e67e571cdd7225cc5d41301a315aed01c53f7ab Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 6 May 2009 13:22:53 -0500 Subject: [PATCH 052/210] uniform and normal distributed random floats. uniform is done the lame way for now --- basis/random/random.factor | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/basis/random/random.factor b/basis/random/random.factor index d972e1e7ac..e3f1ecccb9 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -3,7 +3,7 @@ USING: alien.c-types kernel math namespaces sequences io.backend io.binary combinators system vocabs.loader summary math.bitwise byte-vectors fry byte-arrays -math.ranges ; +math.ranges math.constants math.functions ; IN: random SYMBOL: system-random-generator @@ -69,6 +69,17 @@ PRIVATE> : with-secure-random ( quot -- ) secure-random-generator get swap with-random ; inline +: uniform-random-float ( min max -- n ) + 64 random-bits >float [ over - 2.0 -64 ^ * ] dip + * + ; + +: normal-random-float ( mean sigma -- n ) + 0.0 1.0 uniform-random-float + 0.0 1.0 uniform-random-float + [ 2 pi * * cos ] + [ 1.0 swap - log -2.0 * sqrt ] + bi* * * + ; + USE: vocabs.loader { From f86b077180a23eff07eb2e73d2a9f2ed14184982 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 6 May 2009 13:47:35 -0500 Subject: [PATCH 053/210] make noise-map/noise-image take an affine-transform --- extra/perlin-noise/perlin-noise.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/perlin-noise/perlin-noise.factor b/extra/perlin-noise/perlin-noise.factor index e662202ca1..0a12eef12c 100644 --- a/extra/perlin-noise/perlin-noise.factor +++ b/extra/perlin-noise/perlin-noise.factor @@ -1,4 +1,4 @@ -USING: byte-arrays combinators images kernel locals math +USING: byte-arrays combinators images kernel locals math math.affine-transforms math.functions math.polynomials math.vectors random sequences sequences.product ; IN: perlin-noise @@ -70,14 +70,14 @@ IN: perlin-noise [ faded second lerp ] 2bi@ faded third lerp ; -: noise-map ( table scale dim -- map ) - [ iota ] map [ v* 0.0 suffix noise ] with with product-map ; +: noise-map ( table transform dim -- map ) + [ iota ] map [ a.v 0.0 suffix noise ] with with product-map ; -: normalize ( sequence -- sequence' ) +: normalize-0-1 ( sequence -- sequence' ) [ supremum ] [ infimum [ - ] keep ] [ ] tri [ swap - ] with map [ swap / ] with map ; -: noise-image ( table scale dim -- image ) - [ noise-map normalize [ 255.0 * >fixnum ] B{ } map-as ] +: noise-image ( table transform dim -- image ) + [ noise-map normalize-0-1 [ 255.0 * >fixnum ] B{ } map-as ] [ swap [ L f ] dip image boa ] bi ; From c0156d462e0969f1844cb26d8f3c9d4212ab96ed Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 6 May 2009 14:10:29 -0500 Subject: [PATCH 054/210] fix miller-rabin --- basis/math/miller-rabin/miller-rabin.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor index 8c36dd96fe..5e999aa956 100755 --- a/basis/math/miller-rabin/miller-rabin.factor +++ b/basis/math/miller-rabin/miller-rabin.factor @@ -8,6 +8,8 @@ IN: math.miller-rabin : >odd ( n -- int ) dup even? [ 1 + ] when ; foldable +: >even ( n -- int ) 0 clear-bit ; foldable + TUPLE: positive-even-expected n ; :: (miller-rabin) ( n trials -- ? ) @@ -97,6 +99,7 @@ PRIVATE> } 1&& ; : next-safe-prime ( n -- q ) + 1 - >even 2 / next-safe-prime-candidate dup >safe-prime-form dup miller-rabin From b752b59c19d19b21343708e4d1830398d0bc93e2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 6 May 2009 14:38:38 -0500 Subject: [PATCH 055/210] document ${ --- basis/literals/literals-docs.factor | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/basis/literals/literals-docs.factor b/basis/literals/literals-docs.factor index 0d61dcb467..9dd398d962 100644 --- a/basis/literals/literals-docs.factor +++ b/basis/literals/literals-docs.factor @@ -21,7 +21,7 @@ CONSTANT: five 5 USING: kernel literals prettyprint ; IN: scratchpad -<< : seven-eleven ( -- a b ) 7 11 ; >> +: seven-eleven ( -- a b ) 7 11 ; { $ seven-eleven } . "> "{ 7 11 }" } @@ -43,7 +43,24 @@ IN: scratchpad } ; -{ POSTPONE: $ POSTPONE: $[ } related-words +HELP: ${ +{ $syntax "${ code }" } +{ $description "Outputs an array containing the results of executing " { $snippet "code" } " at parse time." } +{ $notes { $snippet "code" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." } +{ $examples + + { $example <" +USING: kernel literals math prettyprint ; +IN: scratchpad + +CONSTANT: five 5 +CONSTANT: six 6 +${ five six 7 } . + "> "{ 5 6 7 }" + } +} ; + +{ POSTPONE: $ POSTPONE: $[ POSTPONE: ${ } related-words ARTICLE: "literals" "Interpolating code results into literal values" "The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values." @@ -51,11 +68,12 @@ ARTICLE: "literals" "Interpolating code results into literal values" USING: kernel literals math prettyprint ; IN: scratchpad -<< CONSTANT: five 5 >> +CONSTANT: five 5 { $ five $[ five dup 1+ dup 2 + ] } . "> "{ 5 5 6 8 }" } { $subsection POSTPONE: $ } { $subsection POSTPONE: $[ } +{ $subsection POSTPONE: ${ } ; ABOUT: "literals" From 7b81f24a4a0e48e4bbfdb476af92bd023965781a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 14:56:50 -0500 Subject: [PATCH 056/210] tools.time: remove unneeded math.vectors dependency --- basis/tools/time/time.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index 65e87f976f..948c0d482d 100644 --- a/basis/tools/time/time.factor +++ b/basis/tools/time/time.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.vectors memory io io.styles prettyprint +USING: kernel math memory io io.styles prettyprint namespaces system sequences splitting grouping assocs strings generic.single combinators ; IN: tools.time From bb246d5afce74a5aaec792a7121fde29a64bc238 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 14:57:17 -0500 Subject: [PATCH 057/210] Remove some unused constants and update an obsolete comment --- basis/cpu/x86/bootstrap.factor | 2 +- vm/cpu-x86.32.S | 1 - vm/cpu-x86.64.S | 1 - 3 files changed, 1 insertion(+), 3 deletions(-) diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index fcd8ed0eee..fc7fbc88b9 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -194,7 +194,7 @@ big-endian off [ ! Untag temp0 temp0 tag-mask get bitnot AND - ! Set temp1 to 0 for objects, and 8 for tuples + ! Set temp1 to 0 for objects, and bootstrap-cell for tuples temp1 1 tag-fixnum AND bootstrap-cell 4 = [ temp1 1 SHR ] when ! Load header cell or tuple layout cell diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index 3c0db36935..0c08ea7b46 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -30,7 +30,6 @@ and the callstack top is passed in EDX */ pop %ebx #define QUOT_XT_OFFSET 16 -#define WORD_XT_OFFSET 30 /* We pass a function pointer to memcpy to work around a Mac OS X ABI limitation which would otherwise require us to do a bizzaro PC-relative diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index a110bf1d51..5a70280ddf 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -62,7 +62,6 @@ #endif #define QUOT_XT_OFFSET 36 -#define WORD_XT_OFFSET 66 /* We pass a function pointer to memcpy to work around a Mac OS X ABI limitation which would otherwise require us to do a bizzaro PC-relative From 6a46fb3fb020259d142593067779c98f90b3ae23 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 15:30:30 -0500 Subject: [PATCH 058/210] hashtables: use each-integer instead of iota ... each in >alist --- core/hashtables/hashtables.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 0914134bb6..03bc3e01fd 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -139,14 +139,14 @@ M: hashtable set-at ( value key hash -- ) PRIVATE> M: hashtable >alist - [ array>> [ length 2/ iota ] keep ] [ assoc-size ] bi [ + [ array>> [ length 2/ ] keep ] [ assoc-size ] bi [ [ [ [ 1 fixnum-shift-fast ] dip [ array-nth ] [ [ 1 fixnum+fast ] dip array-nth ] 2bi ] dip pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if - ] 2curry each + ] 2curry each-integer ] keep { } like ; M: hashtable clone From ddf05d82ce72894a4cef4652af94bc8dbae9fb29 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 15:30:52 -0500 Subject: [PATCH 059/210] cpu.ppc.bootstrap: working on polymorphic inline caching for PowerPC --- basis/cpu/ppc/bootstrap.factor | 108 +++++++++++++++++++++++++++++---- 1 file changed, 97 insertions(+), 11 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 7278fd2092..5451cf2b79 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -9,8 +9,8 @@ IN: bootstrap.ppc 4 \ cell set big-endian on -CONSTANT: ds-reg 29 -CONSTANT: rs-reg 30 +CONSTANT: ds-reg 13 +CONSTANT: rs-reg 14 : factor-area-size ( -- n ) 4 bootstrap-cells ; @@ -138,6 +138,16 @@ CONSTANT: rs-reg 30 jit-3r> ] jit-3dip jit-define +: prepare-(execute) ( -- operand ) + 3 ds-reg 0 LWZ + ds-reg dup 4 SUBI + 4 3 word-xt-offset LWZ + 4 ; + +[ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define + +[ prepare-(execute) MTLR BLRL ] jit-execute-call jit-define + [ 0 1 lr-save stack-frame + LWZ 1 1 stack-frame ADDI @@ -146,7 +156,91 @@ CONSTANT: rs-reg 30 [ BLR ] jit-return jit-define -! Sub-primitives +! ! ! Polymorphic inline caches + +! Load a value from a stack position +[ + 4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel +] pic-load jit-define + +! Tag +: load-tag ( -- ) + 4 4 tag-mask get ANDI + 4 4 tag-bits get SLWI ; + +[ load-tag ] pic-tag jit-define + +! Hi-tag +[ + 3 4 MR + load-tag + 0 4 object tag-number tag-fixnum CMPI + 2 BNE + 4 3 object tag-number neg LWZ +] pic-hi-tag jit-define + +! Tuple +[ + 3 4 MR + load-tag + 0 4 tuple tag-number tag-fixnum CMPI + 2 BNE + 4 3 tuple tag-number neg bootstrap-cell + LWZ +] pic-tuple jit-define + +! Hi-tag and tuple +[ + 3 4 MR + load-tag + ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple) + 0 4 BIN: 110 tag-fixnum CMPI + 5 BLT + ! Untag r3 + 3 3 0 0 31 tag-bits get - RLWINM + ! Set r4 to 0 for objects, and bootstrap-cell for tuples + 4 4 1 tag-fixnum ANDI + 4 4 1 SRAWI + ! Load header cell or tuple layout cell + 4 4 3 LWZX +] pic-hi-tag-tuple jit-define + +[ + 0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel +] pic-check-tag jit-define + +[ + 0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + 4 0 5 CMP +] pic-check jit-define + +[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define + +! ! ! Megamorphic caches + +[ + ! cache = ... + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + ! key = class + 5 4 MR + ! key &= cache.length - 1 + 5 5 mega-cache-size get 1- bootstrap-cell * ANDI + ! cache += array-start-offset + 3 3 array-start-offset ADDI + ! cache += key + 3 3 5 ADD + ! if(get(cache) == class) + 6 3 0 LWZ + 6 0 4 CMP + 5 BNE + ! ... goto get(cache + bootstrap-cell) + 3 3 4 LWZ + 3 3 word-xt-offset LWZ + 3 MTCTR + BCTR + ! fall-through on miss +] mega-lookup jit-define + +! ! ! Sub-primitives ! Quotations and words [ @@ -157,14 +251,6 @@ CONSTANT: rs-reg 30 BCTR ] \ (call) define-sub-primitive -[ - 3 ds-reg 0 LWZ - ds-reg dup 4 SUBI - 4 3 word-xt-offset LWZ - 4 MTCTR - BCTR -] \ (execute) define-sub-primitive - ! Objects [ 3 ds-reg 0 LWZ From 5e9066233715198f85f0c4a27aa955add8121e17 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 15:39:03 -0500 Subject: [PATCH 060/210] Working on PowerPC backend --- basis/cpu/ppc/ppc.factor | 25 +++++++------ vm/cpu-ppc.S | 76 ++++++++++++++++++++++------------------ vm/cpu-ppc.hpp | 60 ++++++++++++++++++++++++++----- vm/inline_cache.cpp | 2 ++ 4 files changed, 107 insertions(+), 56 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 85bf188bb8..a6beb42399 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -1,20 +1,19 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs sequences kernel combinators make math math.order math.ranges system namespaces locals layouts words -alien alien.c-types cpu.architecture cpu.ppc.assembler -compiler.cfg.registers compiler.cfg.instructions +alien alien.c-types literals cpu.architecture cpu.ppc.assembler +literals compiler.cfg.registers compiler.cfg.instructions compiler.constants compiler.codegen compiler.codegen.fixup compiler.cfg.intrinsics compiler.cfg.stack-frame ; IN: cpu.ppc ! PowerPC register assignments: -! r2-r27: integer vregs -! r28: integer scratch -! r29: data stack -! r30: retain stack +! r2-r12: integer vregs +! r15-r29 +! r30: integer scratch ! f0-f29: float vregs -! f30, f31: float scratch +! f30: float scratch enable-float-intrinsics @@ -23,11 +22,11 @@ enable-float-intrinsics M: ppc machine-registers { - { int-regs T{ range f 2 26 1 } } - { double-float-regs T{ range f 0 29 1 } } + { int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] } + { double-float-regs $[ 0 29 [a,b] ] } } ; -CONSTANT: scratch-reg 28 +CONSTANT: scratch-reg 30 CONSTANT: fp-scratch-reg 30 M: ppc two-operand? f ; @@ -40,8 +39,8 @@ M: ppc %load-reference ( reg obj -- ) M: ppc %alien-global ( register symbol dll -- ) [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ; -CONSTANT: ds-reg 29 -CONSTANT: rs-reg 30 +CONSTANT: ds-reg 13 +CONSTANT: rs-reg 14 GENERIC: loc-reg ( loc -- reg ) diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index 5e77c004aa..f8dad4b2b2 100755 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -2,7 +2,7 @@ in the public domain. */ #include "asm.h" -#define DS_REG r29 +#define DS_REG r13 DEF(void,primitive_fixnum_add,(void)): lwz r3,0(DS_REG) @@ -45,7 +45,7 @@ multiply_overflow: /* Note that the XT is passed to the quotation in r11 */ #define CALL_OR_JUMP_QUOT \ - lwz r11,14(r3) /* load quotation-xt slot */ XX \ + lwz r11,16(r3) /* load quotation-xt slot */ XX \ #define CALL_QUOT \ CALL_OR_JUMP_QUOT XX \ @@ -100,22 +100,22 @@ the Factor compiler treats the entire register file as volatile. */ DEF(void,c_to_factor,(CELL quot)): PROLOGUE - SAVE_INT(r13,0) /* save GPRs */ - SAVE_INT(r14,1) - SAVE_INT(r15,2) - SAVE_INT(r16,3) - SAVE_INT(r17,4) - SAVE_INT(r18,5) - SAVE_INT(r19,6) - SAVE_INT(r20,7) - SAVE_INT(r21,8) - SAVE_INT(r22,9) - SAVE_INT(r23,10) - SAVE_INT(r24,11) - SAVE_INT(r25,12) - SAVE_INT(r26,13) - SAVE_INT(r27,14) - SAVE_INT(r28,15) + SAVE_INT(r15,0) /* save GPRs */ + SAVE_INT(r16,1) + SAVE_INT(r17,2) + SAVE_INT(r18,3) + SAVE_INT(r19,4) + SAVE_INT(r20,5) + SAVE_INT(r21,6) + SAVE_INT(r22,7) + SAVE_INT(r23,8) + SAVE_INT(r24,9) + SAVE_INT(r25,10) + SAVE_INT(r26,11) + SAVE_INT(r27,12) + SAVE_INT(r28,13) + SAVE_INT(r29,14) + SAVE_INT(r30,15) SAVE_INT(r31,16) SAVE_FP(f14,20) /* save FPRs */ @@ -165,22 +165,22 @@ DEF(void,c_to_factor,(CELL quot)): RESTORE_FP(f14,20) /* save FPRs */ RESTORE_INT(r31,16) /* restore GPRs */ - RESTORE_INT(r28,15) - RESTORE_INT(r27,14) - RESTORE_INT(r26,13) - RESTORE_INT(r25,12) - RESTORE_INT(r24,11) - RESTORE_INT(r23,10) - RESTORE_INT(r22,9) - RESTORE_INT(r21,8) - RESTORE_INT(r20,7) - RESTORE_INT(r19,6) - RESTORE_INT(r18,5) - RESTORE_INT(r17,4) - RESTORE_INT(r16,3) - RESTORE_INT(r15,2) - RESTORE_INT(r14,1) - RESTORE_INT(r13,0) + RESTORE_INT(r30,15) + RESTORE_INT(r29,14) + RESTORE_INT(r28,13) + RESTORE_INT(r27,12) + RESTORE_INT(r26,11) + RESTORE_INT(r25,10) + RESTORE_INT(r24,9) + RESTORE_INT(r23,8) + RESTORE_INT(r22,7) + RESTORE_INT(r21,6) + RESTORE_INT(r20,5) + RESTORE_INT(r19,4) + RESTORE_INT(r18,3) + RESTORE_INT(r17,2) + RESTORE_INT(r16,1) + RESTORE_INT(r15,0) EPILOGUE blr @@ -234,3 +234,11 @@ DEF(void,flush_icache,(void *start, int len)): sync /* finish up */ isync blr + +DEF(void,primitive_inline_cache_miss,(void)): + mflr r3 + PROLOGUE + bl MANGLE(inline_cache_miss) + EPILOGUE + mtctr r3 + bctr diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index 7e8ae05fac..d393223d8d 100755 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -2,16 +2,58 @@ namespace factor { #define FACTOR_CPU_STRING "ppc" -#define VM_ASM_API +#define VM_ASM_API VM_C_API -register cell ds asm("r29"); -register cell rs asm("r30"); +register cell ds asm("r13"); +register cell rs asm("r14"); -void c_to_factor(cell quot); -void undefined(cell word); -void set_callstack(stack_frame *to, stack_frame *from, cell length, void *memcpy); -void throw_impl(cell quot, stack_frame *rewind); -void lazy_jit_compile(cell quot); -void flush_icache(cell start, cell len); +inline static void check_call_site(cell return_address) +{ +#ifdef FACTOR_DEBUG + cell insn = *(cell *)return_address; + assert((insn & 0x3) == 0x1); + assert((insn >> 26) == 0x12); +#endif +} + +#define B_MASK 0x3fffffc + +inline static void *get_call_target(cell return_address) +{ + return_address -= sizeof(cell); + + check_call_site(return_address); + cell insn = *(cell *)return_address; + cell unsigned_addr = (insn & B_MASK); + fixnum signed_addr = (fixnum)(unsigned_addr << 6) >> 6; + return (void *)(signed_addr + return_address); +} + +inline static void set_call_target(cell return_address, void *target) +{ + return_address -= sizeof(cell); + +#ifdef FACTOR_DEBUG + assert((return_address & ~B_MASK) == 0); + check_call_site(return_address); +#endif + cell insn = *(cell *)return_address; + insn = ((insn & ~B_MASK) | (((cell)target - return_address) & B_MASK)); + *(cell *)return_address = insn; + + /* Flush the cache line containing the call we just patched */ + __asm__ __volatile__ ("icbi 0, %0\n" "sync\n"::"r" (return_address):); +} + +/* Defined in assembly */ +VM_ASM_API void c_to_factor(cell quot); +VM_ASM_API void throw_impl(cell quot, stack_frame *rewind); +VM_ASM_API void lazy_jit_compile(cell quot); +VM_ASM_API void flush_icache(cell start, cell len); + +VM_ASM_API void set_callstack(stack_frame *to, + stack_frame *from, + cell length, + void *(*memcpy)(void*,const void*, size_t)); } diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp index 259a3e0c77..59632c4185 100755 --- a/vm/inline_cache.cpp +++ b/vm/inline_cache.cpp @@ -21,6 +21,8 @@ void deallocate_inline_cache(cell return_address) { /* Find the call target. */ void *old_xt = get_call_target(return_address); + check_code_pointer((cell)old_xt); + code_block *old_block = (code_block *)old_xt - 1; cell old_type = old_block->type; From f1b5c9bc6866901e26d35d9cf0731617aad7a293 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 6 May 2009 15:49:29 -0500 Subject: [PATCH 061/210] rename perlin-noise to noise; add words for uniform and normal noise --- .../noise.factor} | 62 +++++++++++++++---- 1 file changed, 50 insertions(+), 12 deletions(-) rename extra/{perlin-noise/perlin-noise.factor => noise/noise.factor} (55%) diff --git a/extra/perlin-noise/perlin-noise.factor b/extra/noise/noise.factor similarity index 55% rename from extra/perlin-noise/perlin-noise.factor rename to extra/noise/noise.factor index 0a12eef12c..f2ca8ad59b 100644 --- a/extra/perlin-noise/perlin-noise.factor +++ b/extra/noise/noise.factor @@ -1,11 +1,14 @@ -USING: byte-arrays combinators images kernel locals math math.affine-transforms -math.functions math.polynomials math.vectors random sequences -sequences.product ; -IN: perlin-noise +USING: byte-arrays combinators fry images kernel locals math +math.affine-transforms math.functions math.order +math.polynomials math.vectors random random.mersenne-twister +sequences sequences.product ; +IN: noise -: ( -- table ) +: ( -- table ) 256 iota >byte-array randomize dup append ; + ] dip with-random ; inline + +: >byte-map ( floats -- bytes ) + [ 255.0 * >fixnum ] B{ } map-as ; + +: >image ( bytes dim -- image ) + swap [ L f ] dip image boa ; + +PRIVATE> + +:: perlin-noise ( table point -- value ) point unit-cube :> cube point dup vfloor v- :> gradients gradients fade :> faded @@ -70,14 +84,38 @@ IN: perlin-noise [ faded second lerp ] 2bi@ faded third lerp ; -: noise-map ( table transform dim -- map ) - [ iota ] map [ a.v 0.0 suffix noise ] with with product-map ; - : normalize-0-1 ( sequence -- sequence' ) [ supremum ] [ infimum [ - ] keep ] [ ] tri [ swap - ] with map [ swap / ] with map ; -: noise-image ( table transform dim -- image ) - [ noise-map normalize-0-1 [ 255.0 * >fixnum ] B{ } map-as ] - [ swap [ L f ] dip image boa ] bi ; +: clamp-0-1 ( sequence -- sequence' ) + [ 0.0 max 1.0 min ] map ; +: perlin-noise-map ( table transform dim -- map ) + [ iota ] map [ a.v 0.0 suffix perlin-noise ] with with product-map ; + +: perlin-noise-byte-map ( table transform dim -- map ) + perlin-noise-map normalize-0-1 >byte-map ; + +: perlin-noise-image ( table transform dim -- image ) + [ perlin-noise-byte-map ] [ >image ] bi ; + +: uniform-noise-map ( seed dim -- map ) + [ product [ 0.0 1.0 uniform-random-float ] replicate ] + curry with-seed ; + +: uniform-noise-byte-map ( seed dim -- map ) + uniform-noise-map >byte-map ; + +: uniform-noise-image ( seed dim -- image ) + [ uniform-noise-byte-map ] [ >image ] bi ; + +: normal-noise-map ( seed sigma dim -- map ) + swap '[ _ product [ 0.5 _ normal-random-float ] replicate ] + with-seed ; + +: normal-noise-byte-map ( seed sigma dim -- map ) + normal-noise-map clamp-0-1 >byte-map ; + +: normal-noise-image ( seed sigma dim -- image ) + [ normal-noise-byte-map ] [ >image ] bi ; From 478d29a17550da2902965a5df4c7c40ec207b78d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 16:14:53 -0500 Subject: [PATCH 062/210] Better separation of concerns: cpu.{x86,ppc}.assembler no longer depends on compiler.codegen.fixup and cpu.architecture. Rename rt-xt-direct to rt-xt-pic to better explain its purpose --- basis/compiler/codegen/codegen.factor | 2 +- basis/compiler/codegen/fixup/fixup.factor | 4 +-- basis/compiler/constants/constants.factor | 2 +- basis/cpu/architecture/architecture.factor | 1 + basis/cpu/ppc/assembler/assembler.factor | 4 +-- .../cpu/ppc/assembler/backend/backend.factor | 14 +++------ basis/cpu/ppc/bootstrap.factor | 2 +- basis/cpu/ppc/ppc.factor | 13 ++++++-- basis/cpu/x86/32/32.factor | 4 +-- basis/cpu/x86/32/bootstrap.factor | 2 +- basis/cpu/x86/assembler/assembler.factor | 30 +++++-------------- basis/cpu/x86/bootstrap.factor | 16 +++++----- basis/cpu/x86/x86.factor | 9 ++++-- 13 files changed, 48 insertions(+), 55 deletions(-) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 826fa87b73..47593878fa 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -88,7 +88,7 @@ M: ##call generate-insn word>> dup sub-primitive>> [ first % ] [ [ add-call ] [ %call ] bi ] ?if ; -M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ; +M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ; M: ##return generate-insn drop %return ; diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index 99f258d93c..b52bb51b26 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -56,8 +56,8 @@ SYMBOL: literal-table : rel-word ( word class -- ) [ add-literal ] dip rt-xt rel-fixup ; -: rel-word-direct ( word class -- ) - [ add-literal ] dip rt-xt-direct rel-fixup ; +: rel-word-pic ( word class -- ) + [ add-literal ] dip rt-xt-pic rel-fixup ; : rel-primitive ( word class -- ) [ def>> first add-literal ] dip rt-primitive rel-fixup ; diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index e30cc10ee2..886933b5cd 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -42,7 +42,7 @@ CONSTANT: rt-primitive 0 CONSTANT: rt-dlsym 1 CONSTANT: rt-dispatch 2 CONSTANT: rt-xt 3 -CONSTANT: rt-xt-direct 4 +CONSTANT: rt-xt-pic 4 CONSTANT: rt-here 5 CONSTANT: rt-this 6 CONSTANT: rt-immediate 7 diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 2c9675426b..de5d1da4e0 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -47,6 +47,7 @@ HOOK: %inc-r cpu ( n -- ) HOOK: stack-frame-size cpu ( stack-frame -- n ) HOOK: %call cpu ( word -- ) +HOOK: %jump cpu ( word -- ) HOOK: %jump-label cpu ( label -- ) HOOK: %return cpu ( -- ) diff --git a/basis/cpu/ppc/assembler/assembler.factor b/basis/cpu/ppc/assembler/assembler.factor index fbb878a888..2daf3678ce 100644 --- a/basis/cpu/ppc/assembler/assembler.factor +++ b/basis/cpu/ppc/assembler/assembler.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: compiler.codegen.fixup kernel namespaces words -io.binary math math.order cpu.ppc.assembler.backend ; +USING: kernel namespaces words io.binary math math.order +cpu.ppc.assembler.backend ; IN: cpu.ppc.assembler ! See the Motorola or IBM documentation for details. The opcode diff --git a/basis/cpu/ppc/assembler/backend/backend.factor b/basis/cpu/ppc/assembler/backend/backend.factor index 946aca6990..1e6365b1e7 100644 --- a/basis/cpu/ppc/assembler/backend/backend.factor +++ b/basis/cpu/ppc/assembler/backend/backend.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: compiler.codegen.fixup cpu.architecture -compiler.constants kernel namespaces make sequences words math -math.bitwise io.binary parser lexer ; +USING: kernel namespaces make sequences words math +math.bitwise io.binary parser lexer fry ; IN: cpu.ppc.assembler.backend : insn ( operand opcode -- ) { 26 0 } bitfield 4 >be % ; @@ -74,21 +73,16 @@ SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ; GENERIC# (B) 2 ( dest aa lk -- ) M: integer (B) 18 i-insn ; -M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ; -M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ; GENERIC: BC ( a b c -- ) M: integer BC 0 0 16 b-insn ; -M: word BC [ 0 BC ] dip rc-relative-ppc-2 rel-word ; -M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ; : CREATE-B ( -- word ) scan "B" prepend create-in ; SYNTAX: BC: CREATE-B scan-word scan-word - [ rot BC ] 2curry (( c -- )) define-declared ; + '[ [ _ _ ] dip BC ] (( c -- )) define-declared ; SYNTAX: B: CREATE-B scan-word scan-word scan-word scan-word scan-word - [ b-insn ] curry curry curry curry curry - (( bo -- )) define-declared ; + '[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ; diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 5451cf2b79..8001868e0c 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -58,7 +58,7 @@ CONSTANT: rs-reg 14 BCTR ] jit-primitive jit-define -[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define +[ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define [ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index a6beb42399..c239bacbc0 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -15,10 +15,16 @@ IN: cpu.ppc ! f0-f29: float vregs ! f30: float scratch +! Add some methods to the assembler that are useful to us +M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ; +M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ; + enable-float-intrinsics -<< \ ##integer>float t frame-required? set-word-prop -\ ##float>integer t frame-required? set-word-prop >> +<< +\ ##integer>float t frame-required? set-word-prop +\ ##float>integer t frame-required? set-word-prop +>> M: ppc machine-registers { @@ -107,7 +113,8 @@ M: ppc stack-frame-size ( stack-frame -- i ) factor-area-size + 4 cells align ; -M: ppc %call ( label -- ) BL ; +M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ; +M: ppc %jump ( word -- ) 0 B rc-relative-ppc-3 rel-word ; M: ppc %jump-label ( label -- ) B ; M: ppc %return ( -- ) BLR ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 10cd9c8657..376edeb202 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -44,9 +44,9 @@ M: x86.32 param-reg-2 EDX ; M: x86.32 reserved-area-size 0 ; -M: x86.32 %alien-invoke (CALL) rel-dlsym ; +M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; -M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ; +M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ; M: x86.32 return-struct-in-registers? ( c-type -- ? ) c-type diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index be21344815..660a428dfb 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -29,7 +29,7 @@ IN: bootstrap.x86 ] jit-save-stack jit-define [ - (JMP) drop rc-relative rt-primitive jit-rel + 0 JMP rc-relative rt-primitive jit-rel ] jit-primitive jit-define << "vocab:cpu/x86/bootstrap.factor" parse-file parsed >> diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 5560d17a1e..2b40aa2053 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -1,12 +1,11 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays cpu.architecture compiler.constants -compiler.codegen.fixup io.binary kernel combinators -kernel.private math namespaces make sequences words system -layouts math.order accessors cpu.x86.assembler.syntax ; +USING: arrays io.binary kernel combinators +kernel.private math namespaces make sequences words system layouts +math.order accessors cpu.x86.assembler.syntax ; IN: cpu.x86.assembler -! A postfix assembler for x86 and AMD64. +! A postfix assembler for x86-32 and x86-64. ! In 32-bit mode, { 1234 } is absolute indirect addressing. ! In 64-bit mode, { 1234 } is RIP-relative. @@ -296,36 +295,23 @@ M: operand (MOV-I) { BIN: 000 t HEX: c6 } pick byte? [ immediate-1 ] [ immediate-4 ] if ; -PREDICATE: callable < word register? not ; - GENERIC: MOV ( dst src -- ) M: immediate MOV swap (MOV-I) ; -M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ; M: operand MOV HEX: 88 2-operand ; : LEA ( dst src -- ) swap HEX: 8d 2-operand ; ! Control flow GENERIC: JMP ( op -- ) -: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ; -M: f JMP (JMP) 2drop ; -M: callable JMP (JMP) rel-word ; -M: label JMP (JMP) label-fixup ; +M: integer JMP HEX: e9 , 4, ; M: operand JMP { BIN: 100 t HEX: ff } 1-operand ; GENERIC: CALL ( op -- ) -: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ; -M: f CALL (CALL) 2drop ; -M: callable CALL (CALL) rel-word-direct ; -M: label CALL (CALL) label-fixup ; +M: integer CALL HEX: e8 , 4, ; M: operand CALL { BIN: 010 t HEX: ff } 1-operand ; GENERIC# JUMPcc 1 ( addr opcode -- ) -: (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ; -M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ; -M: integer JUMPcc (JUMPcc) drop ; -M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ; -M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ; +M: integer JUMPcc extended-opcode, 4, ; : JO ( dst -- ) HEX: 80 JUMPcc ; : JNO ( dst -- ) HEX: 81 JUMPcc ; diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index fc7fbc88b9..4b409102c9 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -42,11 +42,11 @@ big-endian off ] jit-push-immediate jit-define [ - f JMP rc-relative rt-xt jit-rel + 0 JMP rc-relative rt-xt jit-rel ] jit-word-jump jit-define [ - f CALL rc-relative rt-xt-direct jit-rel + 0 CALL rc-relative rt-xt-pic jit-rel ] jit-word-call jit-define [ @@ -57,12 +57,12 @@ big-endian off ! compare boolean with f temp0 \ f tag-number CMP ! jump to true branch if not equal - f JNE rc-relative rt-xt jit-rel + 0 JNE rc-relative rt-xt jit-rel ] jit-if-1 jit-define [ ! jump to false branch if equal - f JMP rc-relative rt-xt jit-rel + 0 JMP rc-relative rt-xt jit-rel ] jit-if-2 jit-define : jit->r ( -- ) @@ -115,19 +115,19 @@ big-endian off [ jit->r - f CALL rc-relative rt-xt jit-rel + 0 CALL rc-relative rt-xt jit-rel jit-r> ] jit-dip jit-define [ jit-2>r - f CALL rc-relative rt-xt jit-rel + 0 CALL rc-relative rt-xt jit-rel jit-2r> ] jit-2dip jit-define [ jit-3>r - f CALL rc-relative rt-xt jit-rel + 0 CALL rc-relative rt-xt jit-rel jit-3r> ] jit-3dip jit-define @@ -211,7 +211,7 @@ big-endian off temp1 temp2 CMP ] pic-check jit-define -[ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define +[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define ! ! ! Megamorphic caches diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 2859e71be2..d508d7740b 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -11,6 +11,10 @@ IN: cpu.x86 << enable-fixnum-log2 >> +! Add some methods to the assembler to be more useful to the backend +M: label JMP 0 JMP rc-relative label-fixup ; +M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ; + M: x86 two-operand? t ; HOOK: temp-reg-1 cpu ( -- reg ) @@ -53,8 +57,9 @@ M: x86 stack-frame-size ( stack-frame -- i ) reserved-area-size + align-stack ; -M: x86 %call ( label -- ) CALL ; -M: x86 %jump-label ( label -- ) JMP ; +M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ; +M: x86 %jump ( word -- ) 0 JMP rc-relative rel-word ; +M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ; M: x86 %return ( -- ) 0 RET ; : code-alignment ( align -- n ) From abd35fad0b777409c3209cfc653a626debc35646 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 6 May 2009 16:26:06 -0500 Subject: [PATCH 063/210] Document miller-rabin, more unit tests for some corner cases --- .../miller-rabin/miller-rabin-docs.factor | 100 ++++++++++++++++++ .../miller-rabin/miller-rabin-tests.factor | 12 ++- basis/math/miller-rabin/miller-rabin.factor | 40 +++---- 3 files changed, 133 insertions(+), 19 deletions(-) create mode 100644 basis/math/miller-rabin/miller-rabin-docs.factor diff --git a/basis/math/miller-rabin/miller-rabin-docs.factor b/basis/math/miller-rabin/miller-rabin-docs.factor new file mode 100644 index 0000000000..4aa318f674 --- /dev/null +++ b/basis/math/miller-rabin/miller-rabin-docs.factor @@ -0,0 +1,100 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel sequences math ; +IN: math.miller-rabin + +HELP: find-relative-prime +{ $values + { "n" integer } + { "p" integer } +} +{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ; + +HELP: find-relative-prime* +{ $values + { "n" integer } { "guess" integer } + { "p" integer } +} +{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ; + +HELP: miller-rabin +{ $values + { "n" integer } + { "?" "a boolean" } +} +{ $description "Returns true if the number is a prime. Calls " { $link miller-rabin* } " with a default of 10 Miller-Rabin tests." } ; + +{ miller-rabin miller-rabin* } related-words + +HELP: miller-rabin* +{ $values + { "n" integer } { "numtrials" integer } + { "?" "a boolean" } +} +{ $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ; + +HELP: next-prime +{ $values + { "n" integer } + { "p" integer } +} +{ $description "Tests consecutive numbers for primality with " { $link miller-rabin } " and returns the next prime." } ; + +HELP: next-safe-prime +{ $values + { "n" integer } + { "q" integer } +} +{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ; + +HELP: random-bits* +{ $values + { "numbits" integer } + { "n" integer } +} +{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ; + +HELP: random-prime +{ $values + { "numbits" integer } + { "p" integer } +} +{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; + +HELP: random-safe-prime +{ $values + { "numbits" integer } + { "p" integer } +} +{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; + +HELP: safe-prime? +{ $values + { "q" integer } + { "?" "a boolean" } +} +{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ; + +HELP: unique-primes +{ $values + { "numbits" integer } { "n" integer } + { "seq" sequence } +} +{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ; + +ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test" +"The " { $vocab-link "math.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl +"The Miller-Rabin probabilistic primality test:" +{ $subsection miller-rabin } +{ $subsection miller-rabin* } +"Generating relative prime numbers:" +{ $subsection find-relative-prime } +{ $subsection find-relative-prime* } +"Generating prime numbers:" +{ $subsection next-prime } +{ $subsection random-prime } +"Generating safe prime numbers:" +{ $subsection next-safe-prime } +{ $subsection random-safe-prime } ; + +ABOUT: "math.miller-rabin" diff --git a/basis/math/miller-rabin/miller-rabin-tests.factor b/basis/math/miller-rabin/miller-rabin-tests.factor index 676c4bf20d..9981064ec0 100644 --- a/basis/math/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/miller-rabin/miller-rabin-tests.factor @@ -1,4 +1,5 @@ -USING: math.miller-rabin tools.test kernel sequences ; +USING: math.miller-rabin tools.test kernel sequences +math.miller-rabin.private math ; IN: math.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test @@ -6,6 +7,9 @@ IN: math.miller-rabin.tests [ t ] [ 3 miller-rabin ] unit-test [ f ] [ 36 miller-rabin ] unit-test [ t ] [ 37 miller-rabin ] unit-test +[ 2 ] [ 1 next-prime ] unit-test +[ 3 ] [ 2 next-prime ] unit-test +[ 5 ] [ 3 next-prime ] unit-test [ 101 ] [ 100 next-prime ] unit-test [ t ] [ 2135623355842621559 miller-rabin ] unit-test [ 100000000000031 ] [ 100000000000000 next-prime ] unit-test @@ -14,6 +18,12 @@ IN: math.miller-rabin.tests [ f ] [ 862 safe-prime? ] unit-test [ t ] [ 7 safe-prime? ] unit-test [ f ] [ 31 safe-prime? ] unit-test +[ t ] [ 47 safe-prime-candidate? ] unit-test +[ t ] [ 47 safe-prime? ] unit-test [ t ] [ 863 safe-prime? ] unit-test [ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test + +[ 47 ] [ 31 next-safe-prime ] unit-test +[ 49 ] [ 50 random-prime log2 ] unit-test +[ 49 ] [ 50 random-bits* log2 ] unit-test diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor index 5e999aa956..9fd604a003 100755 --- a/basis/math/miller-rabin/miller-rabin.factor +++ b/basis/math/miller-rabin/miller-rabin.factor @@ -1,15 +1,20 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel locals math math.functions math.ranges -random sequences sets combinators.short-circuit math.bitwise ; +random sequences sets combinators.short-circuit math.bitwise +math math.order ; IN: math.miller-rabin odd ( n -- int ) dup even? [ 1 + ] when ; foldable +: >odd ( n -- int ) 0 set-bit ; foldable : >even ( n -- int ) 0 clear-bit ; foldable +: next-even ( m -- n ) >even 2 + ; + +: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; + TUPLE: positive-even-expected n ; :: (miller-rabin) ( n trials -- ? ) @@ -18,7 +23,7 @@ TUPLE: positive-even-expected n ; 0 :> a! trials [ drop - n 1 - [1,b] random a! + 2 n 2 - [a,b] random a! a s n ^mod 1 = [ f ] [ @@ -30,8 +35,6 @@ TUPLE: positive-even-expected n ; PRIVATE> -: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; - : miller-rabin* ( n numtrials -- ? ) over { { [ dup 1 <= ] [ 3drop f ] } @@ -42,11 +45,21 @@ PRIVATE> : miller-rabin ( n -- ? ) 10 miller-rabin* ; +ERROR: prime-range-error n ; + : next-prime ( n -- p ) - next-odd dup miller-rabin [ next-prime ] unless ; + dup 1 < [ prime-range-error ] when + dup 1 = [ + drop 2 + ] [ + next-odd dup miller-rabin [ next-prime ] unless + ] if ; + +: random-bits* ( numbits -- n ) + 1 - [ random-bits ] keep set-bit ; : random-prime ( numbits -- p ) - random-bits next-prime ; + random-bits* next-prime ; ERROR: no-relative-prime n ; @@ -80,10 +93,7 @@ ERROR: too-few-primes ; safe-prime-form ( q -- p ) 2 * 1 + ; - : safe-prime-candidate? ( n -- ? ) - >safe-prime-form 1 + 6 divisor? ; : next-safe-prime-candidate ( n -- candidate ) @@ -99,14 +109,8 @@ PRIVATE> } 1&& ; : next-safe-prime ( n -- q ) - 1 - >even 2 / next-safe-prime-candidate - dup >safe-prime-form - dup miller-rabin - [ nip ] [ drop next-safe-prime ] if ; - -: random-bits* ( numbits -- n ) - [ random-bits ] keep set-bit ; + dup safe-prime? [ next-safe-prime ] unless ; : random-safe-prime ( numbits -- p ) - 1- random-bits* next-safe-prime ; + random-bits* next-safe-prime ; From 150f85b85a6dfcb34dc2debd3e4a7dc843426346 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 6 May 2009 17:26:21 -0500 Subject: [PATCH 064/210] uniform-random-float speed --- basis/random/random.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/basis/random/random.factor b/basis/random/random.factor index e3f1ecccb9..6b02c8a3e8 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -3,7 +3,7 @@ USING: alien.c-types kernel math namespaces sequences io.backend io.binary combinators system vocabs.loader summary math.bitwise byte-vectors fry byte-arrays -math.ranges math.constants math.functions ; +math.ranges math.constants math.functions accessors ; IN: random SYMBOL: system-random-generator @@ -70,8 +70,11 @@ PRIVATE> secure-random-generator get swap with-random ; inline : uniform-random-float ( min max -- n ) - 64 random-bits >float [ over - 2.0 -64 ^ * ] dip - * + ; + 4 random-bytes underlying>> *uint >float + 4 random-bytes underlying>> *uint >float + 2.0 32 ^ * + + [ over - 2.0 -64 ^ * ] dip + * + ; inline : normal-random-float ( mean sigma -- n ) 0.0 1.0 uniform-random-float From e8d1f86ccc067f02e23134f9fd0c93c82a64b2cd Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 19:33:58 -0400 Subject: [PATCH 065/210] Add tests for combinations --- .../combinatorics/combinatorics-tests.factor | 51 ++++++++++++++----- 1 file changed, 39 insertions(+), 12 deletions(-) diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor index 5ef435a4e0..8cd02399bc 100644 --- a/basis/math/combinatorics/combinatorics-tests.factor +++ b/basis/math/combinatorics/combinatorics-tests.factor @@ -1,18 +1,6 @@ USING: math.combinatorics math.combinatorics.private tools.test ; IN: math.combinatorics.tests -[ { } ] [ 0 factoradic ] unit-test -[ { 1 0 } ] [ 1 factoradic ] unit-test -[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test - -[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test -[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test -[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test - -[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test -[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test -[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test - [ 1 ] [ 0 factorial ] unit-test [ 1 ] [ 1 factorial ] unit-test [ 3628800 ] [ 10 factorial ] unit-test @@ -31,6 +19,19 @@ IN: math.combinatorics.tests [ 2598960 ] [ 52 5 nCk ] unit-test [ 2598960 ] [ 52 47 nCk ] unit-test + +[ { } ] [ 0 factoradic ] unit-test +[ { 1 0 } ] [ 1 factoradic ] unit-test +[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test + +[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test +[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test +[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test + +[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test +[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test +[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test + [ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test [ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test [ { "d" "a" "b" "c" } ] [ 18 { "a" "b" "c" "d" } permutation ] unit-test @@ -43,3 +44,29 @@ IN: math.combinatorics.tests [ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test [ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test + +[ 2598960 ] [ 52 5 choose ] unit-test + +[ 6 3 13 6 ] [ 7 4 28 next-values ] unit-test +[ 5 2 3 5 ] [ 6 3 13 next-values ] unit-test +[ 3 1 0 3 ] [ 5 2 3 next-values ] unit-test +[ 0 0 0 0 ] [ 3 1 0 next-values ] unit-test + +[ 9 ] [ 0 5 3 dual-index ] unit-test +[ 0 ] [ 9 5 3 dual-index ] unit-test +[ 179 ] [ 72 10 5 dual-index ] unit-test + +[ { 5 3 2 1 } ] [ 7 4 8 combinadic ] unit-test +[ { 4 3 2 1 0 } ] [ 10 5 0 combinadic ] unit-test +[ { 8 6 3 1 0 } ] [ 10 5 72 combinadic ] unit-test +[ { 9 8 7 6 5 } ] [ 10 5 251 combinadic ] unit-test + +[ { 0 1 2 } ] [ 0 5 3 combination-indices ] unit-test +[ { 2 3 4 } ] [ 9 5 3 combination-indices ] unit-test + +[ { "a" "b" "c" } ] [ 0 { "a" "b" "c" "d" "e" } 3 combination ] unit-test +[ { "c" "d" "e" } ] [ 9 { "a" "b" "c" "d" "e" } 3 combination ] unit-test + +[ { { "a" "b" } { "a" "c" } + { "a" "d" } { "b" "c" } + { "b" "d" } { "c" "d" } } ] [ { "a" "b" "c" "d" } 2 all-combinations ] unit-test From 88553ea2620c47e74c8f263ea90ef76b3a512e4a Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 20:18:21 -0400 Subject: [PATCH 066/210] Clean up combinations a bit --- basis/math/combinatorics/combinatorics.factor | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index dd71ded8c2..b2e21e429a 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -46,7 +46,8 @@ PRIVATE> [ permutation-indices ] keep nths ; : all-permutations ( seq -- seq ) - [ length factorial ] keep '[ _ permutation ] map ; + [ length factorial ] keep + '[ _ permutation ] map ; : each-permutation ( seq quot -- ) [ [ length factorial ] keep ] dip @@ -69,6 +70,9 @@ TUPLE: combo C: combo +: choose ( combo -- nCk ) + [ seq>> length ] [ k>> ] bi nCk ; + : largest-value ( a b x -- v ) #! TODO: use a binary search instead of find-last [ [0,b) ] 2dip '[ _ nCk _ <= ] find-last nip ; @@ -79,26 +83,23 @@ C: combo x v b nCk - ! x' v ; ! v == a' -: dual-index ( combo m -- x ) - [ [ seq>> length ] [ k>> ] bi nCk 1 - ] dip - ; +: dual-index ( m combo -- m' ) + choose 1 - swap - ; -: initial-values ( combo m -- a b x ) - [ [ seq>> length ] [ k>> ] [ ] tri ] dip dual-index ; +: initial-values ( combo m -- n k m ) + [ [ seq>> length ] [ k>> ] bi ] dip ; : combinadic ( combo m -- combinadic ) initial-values [ over 0 > ] [ next-values ] produce [ 3drop ] dip ; : combination-indices ( m combo -- seq ) - [ swap combinadic ] keep + [ tuck dual-index combinadic ] keep seq>> length 1 - swap [ - ] with map ; : apply-combination ( m combo -- seq ) [ combination-indices ] keep seq>> nths ; -: choose ( combo -- nCk ) - [ seq>> length ] [ k>> ] bi nCk ; - PRIVATE> : combination ( m seq k -- seq ) From d3b85c14c9b01ac78387fc04715e56b5b30e88c6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 19:22:22 -0500 Subject: [PATCH 067/210] Working on inline caching for tail call sites --- basis/bootstrap/image/image.factor | 45 ++++++++++-------- basis/compiler/codegen/fixup/fixup.factor | 3 ++ basis/compiler/constants/constants.factor | 24 +++++----- basis/cpu/ppc/ppc.factor | 6 ++- basis/cpu/x86/32/32.factor | 2 + basis/cpu/x86/64/64.factor | 2 + basis/cpu/x86/bootstrap.factor | 2 + basis/cpu/x86/x86.factor | 9 +++- core/bootstrap/primitives.factor | 4 +- core/generic/hook/hook.factor | 2 - core/generic/single/single-tests.factor | 2 +- core/generic/single/single.factor | 8 +++- core/generic/standard/standard.factor | 13 ++++-- core/words/words.factor | 3 +- vm/code_block.cpp | 57 +++++++++++++++++------ vm/code_block.hpp | 8 ++-- vm/code_heap.cpp | 4 +- vm/cpu-x86.32.S | 5 +- vm/cpu-x86.64.S | 4 +- vm/cpu-x86.hpp | 21 ++++++--- vm/inline_cache.cpp | 35 ++++++++++---- vm/inline_cache.hpp | 3 +- vm/layouts.hpp | 4 +- vm/primitives.cpp | 1 + vm/run.hpp | 5 +- vm/words.cpp | 3 +- 26 files changed, 187 insertions(+), 88 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index cad40b6384..675c50732d 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -168,6 +168,7 @@ SYMBOL: pic-check-tag SYMBOL: pic-check SYMBOL: pic-hit SYMBOL: pic-miss-word +SYMBOL: pic-miss-tail-word ! Megamorphic dispatch SYMBOL: mega-lookup @@ -193,25 +194,26 @@ SYMBOL: undefined-quot { jit-return 34 } { jit-profiling 35 } { jit-push-immediate 36 } - { jit-save-stack 38 } - { jit-dip-word 39 } - { jit-dip 40 } - { jit-2dip-word 41 } - { jit-2dip 42 } - { jit-3dip-word 43 } - { jit-3dip 44 } - { jit-execute-word 45 } - { jit-execute-jump 46 } - { jit-execute-call 47 } - { pic-load 48 } - { pic-tag 49 } - { pic-hi-tag 50 } - { pic-tuple 51 } - { pic-hi-tag-tuple 52 } - { pic-check-tag 53 } - { pic-check 54 } - { pic-hit 55 } - { pic-miss-word 56 } + { jit-save-stack 37 } + { jit-dip-word 38 } + { jit-dip 39 } + { jit-2dip-word 40 } + { jit-2dip 41 } + { jit-3dip-word 42 } + { jit-3dip 43 } + { jit-execute-word 44 } + { jit-execute-jump 45 } + { jit-execute-call 46 } + { pic-load 47 } + { pic-tag 48 } + { pic-hi-tag 49 } + { pic-tuple 50 } + { pic-hi-tag-tuple 51 } + { pic-check-tag 52 } + { pic-check 53 } + { pic-hit 54 } + { pic-miss-word 55 } + { pic-miss-tail-word 56 } { mega-lookup 57 } { mega-lookup-word 58 } { mega-miss-word 59 } @@ -351,7 +353,8 @@ M: f ' [ vocabulary>> , ] [ def>> , ] [ props>> , ] - [ direct-entry-def>> , ] ! direct-entry-def + [ pic-def>> , ] + [ pic-tail-def>> , ] [ drop 0 , ] ! count [ word-sub-primitive , ] [ drop 0 , ] ! xt @@ -524,6 +527,7 @@ M: quotation ' \ 3dip jit-3dip-word set \ (execute) jit-execute-word set \ inline-cache-miss \ pic-miss-word set + \ inline-cache-miss-tail \ pic-miss-tail-word set \ mega-cache-lookup \ mega-lookup-word set \ mega-cache-miss \ mega-miss-word set [ undefined ] undefined-quot set @@ -559,6 +563,7 @@ M: quotation ' pic-check pic-hit pic-miss-word + pic-miss-tail-word mega-lookup mega-lookup-word mega-miss-word diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index b52bb51b26..d0c874feb0 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -59,6 +59,9 @@ SYMBOL: literal-table : rel-word-pic ( word class -- ) [ add-literal ] dip rt-xt-pic rel-fixup ; +: rel-word-pic-tail ( word class -- ) + [ add-literal ] dip rt-xt-pic-tail rel-fixup ; + : rel-primitive ( word class -- ) [ def>> first add-literal ] dip rt-primitive rel-fixup ; diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 886933b5cd..5e0ee98606 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel layouts system strings words quotations byte-arrays -alien arrays ; +alien arrays literals sequences ; IN: compiler.constants ! These constants must match vm/memory.h @@ -14,14 +14,14 @@ CONSTANT: deck-bits 18 : float-offset ( -- n ) 8 float tag-number - ; inline : string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline : string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline -: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline +: profile-count-offset ( -- n ) 8 bootstrap-cells \ word tag-number - ; inline : byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline : alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline : underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline -: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline +: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline : quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline -: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline +: word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline : array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline @@ -43,14 +43,12 @@ CONSTANT: rt-dlsym 1 CONSTANT: rt-dispatch 2 CONSTANT: rt-xt 3 CONSTANT: rt-xt-pic 4 -CONSTANT: rt-here 5 -CONSTANT: rt-this 6 -CONSTANT: rt-immediate 7 -CONSTANT: rt-stack-chain 8 -CONSTANT: rt-untagged 9 +CONSTANT: rt-xt-pic-tail 5 +CONSTANT: rt-here 6 +CONSTANT: rt-this 7 +CONSTANT: rt-immediate 8 +CONSTANT: rt-stack-chain 9 +CONSTANT: rt-untagged 10 : rc-absolute? ( n -- ? ) - [ rc-absolute-ppc-2/2 = ] - [ rc-absolute-cell = ] - [ rc-absolute = ] - tri or or ; + ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ; diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index c239bacbc0..a11b0daa86 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -114,7 +114,11 @@ M: ppc stack-frame-size ( stack-frame -- i ) 4 cells align ; M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ; -M: ppc %jump ( word -- ) 0 B rc-relative-ppc-3 rel-word ; + +M: ppc %jump ( word -- ) + 0 3 LOAD32 rc-absolute-ppc-2/2 rel-here + 0 B rc-relative-ppc-3 rel-word-pic-tail ; + M: ppc %jump-label ( label -- ) B ; M: ppc %return ( -- ) BLR ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 376edeb202..0a0ac4a53e 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -42,6 +42,8 @@ M:: x86.32 %dispatch ( src temp offset -- ) M: x86.32 param-reg-1 EAX ; M: x86.32 param-reg-2 EDX ; +M: x86.32 pic-tail-reg EBX ; + M: x86.32 reserved-area-size 0 ; M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 8cc69958a4..ad1b487e44 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -39,6 +39,8 @@ M: x86.64 param-reg-1 int-regs param-regs first ; M: x86.64 param-reg-2 int-regs param-regs second ; : param-reg-3 ( -- reg ) int-regs param-regs third ; inline +M: x86.64 pic-tail-reg RBX ; + M: int-regs return-reg drop RAX ; M: float-regs return-reg drop XMM0 ; diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 4b409102c9..8d35d4ed8a 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -152,6 +152,8 @@ big-endian off ! ! ! Polymorphic inline caches +! The PIC and megamorphic code stubs are not permitted to touch temp3. + ! Load a value from a stack position [ temp1 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index d508d7740b..5ae9e1c489 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -23,6 +23,8 @@ HOOK: temp-reg-2 cpu ( -- reg ) HOOK: param-reg-1 cpu ( -- reg ) HOOK: param-reg-2 cpu ( -- reg ) +HOOK: pic-tail-reg cpu ( -- reg ) + M: x86 %load-immediate MOV ; M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ; @@ -58,8 +60,13 @@ M: x86 stack-frame-size ( stack-frame -- i ) align-stack ; M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ; -M: x86 %jump ( word -- ) 0 JMP rc-relative rel-word ; + +M: x86 %jump ( word -- ) + pic-tail-reg 0 MOV 2 cells 1 + rc-absolute-cell rel-here + 0 JMP rc-relative rel-word-pic-tail ; + M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ; + M: x86 %return ( -- ) 0 RET ; : code-alignment ( align -- n ) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 83276cd3f2..57bc61a005 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -231,7 +231,8 @@ bi "vocabulary" { "def" { "quotation" "quotations" } initial: [ ] } "props" - { "direct-entry-def" } + "pic-def" + "pic-tail-def" { "counter" { "fixnum" "math" } } { "sub-primitive" read-only } } define-builtin @@ -505,6 +506,7 @@ tuple { "load-locals" "locals.backend" (( ... n -- )) } { "check-datastack" "kernel.private" (( array in# out# -- ? )) } { "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) } + { "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) } { "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) } { "lookup-method" "generic.single.private" (( object methods -- method )) } { "reset-dispatch-stats" "generic.single" (( -- )) } diff --git a/core/generic/hook/hook.factor b/core/generic/hook/hook.factor index fe5b62f6c0..5edbc54bd8 100644 --- a/core/generic/hook/hook.factor +++ b/core/generic/hook/hook.factor @@ -17,8 +17,6 @@ M: hook-combination picker M: hook-combination dispatch# drop 0 ; -M: hook-combination inline-cache-quot 2drop f ; - M: hook-combination mega-cache-quot 1quotation picker [ lookup-method (execute) ] surround ; diff --git a/core/generic/single/single-tests.factor b/core/generic/single/single-tests.factor index c8cab970fd..e48d404b92 100644 --- a/core/generic/single/single-tests.factor +++ b/core/generic/single/single-tests.factor @@ -273,5 +273,5 @@ M: growable call-next-hooker call-next-method "growable " prepend ; [ ] [ "IN: generic.single.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test [ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test -[ f ] [ "xyz" "generic.single.tests" lookup direct-entry-def>> ] unit-test +[ f ] [ "xyz" "generic.single.tests" lookup pic-def>> ] unit-test [ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test \ No newline at end of file diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index d8fa04edd6..36a76153f9 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -238,10 +238,14 @@ M: f compile-engine ; [ compile-engine ] bi ] tri ; -HOOK: inline-cache-quot combination ( word methods -- quot/f ) +HOOK: inline-cache-quots combination ( word methods -- pic-quot/f pic-tail-quot/f ) + +M: single-combination inline-cache-quots 2drop f f ; : define-inline-cache-quot ( word methods -- ) - [ drop ] [ inline-cache-quot ] 2bi >>direct-entry-def drop ; + [ drop ] [ inline-cache-quots ] 2bi + [ >>pic-def ] [ >>pic-tail-def ] bi* + drop ; HOOK: mega-cache-quot combination ( methods -- quot/f ) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index bf801c4e47..b76bcaa582 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -3,7 +3,7 @@ USING: accessors definitions generic generic.single kernel namespaces words math math.order combinators sequences generic.single.private quotations kernel.private -assocs arrays layouts ; +assocs arrays layouts make ; IN: generic.standard TUPLE: standard-combination < single-combination # ; @@ -38,17 +38,22 @@ M: standard-generic effective-method [ datastack ] dip [ "combination" word-prop #>> swap nth ] keep (effective-method) ; -M: standard-combination inline-cache-quot ( word methods -- ) +: inline-cache-quot ( word methods miss-word -- quot ) + [ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ; + +M: standard-combination inline-cache-quots #! Direct calls to the generic word (not tail calls or indirect calls) #! will jump to the inline cache entry point instead of the megamorphic #! dispatch entry point. - combination get #>> [ { } inline-cache-miss ] 3curry [ ] like ; + [ \ inline-cache-miss inline-cache-quot ] + [ \ inline-cache-miss-tail inline-cache-quot ] + 2bi ; : make-empty-cache ( -- array ) mega-cache-size get f ; M: standard-combination mega-cache-quot - combination get #>> make-empty-cache [ mega-cache-lookup ] 3curry [ ] like ; + combination get #>> make-empty-cache \ mega-cache-lookup [ ] 4sequence ; M: standard-generic definer drop \ GENERIC# f ; diff --git a/core/words/words.factor b/core/words/words.factor index 1976c1e4cd..c01cf13bcd 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -155,7 +155,8 @@ M: word reset-word [ subwords forget-all ] [ reset-word ] [ - f >>direct-entry-def + f >>pic-def + f >>pic-tail-def { "methods" "combination" diff --git a/vm/code_block.cpp b/vm/code_block.cpp index cd87da3801..1da16ad0a1 100755 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -27,7 +27,8 @@ void iterate_relocations(code_block *compiled, relocation_iterator iter) { case RT_PRIMITIVE: case RT_XT: - case RT_XT_DIRECT: + case RT_XT_PIC: + case RT_XT_PIC_TAIL: case RT_IMMEDIATE: case RT_HERE: case RT_UNTAGGED: @@ -171,9 +172,8 @@ void *object_xt(cell obj) } } -void *word_direct_xt(word *w) +static void *xt_pic(word *w, cell tagged_quot) { - cell tagged_quot = w->direct_entry_def; if(tagged_quot == F || max_pic_size == 0) return w->xt; else @@ -186,20 +186,42 @@ void *word_direct_xt(word *w) } } +void *word_xt_pic(word *w) +{ + return xt_pic(w,w->pic_def); +} + +void *word_xt_pic_tail(word *w) +{ + return xt_pic(w,w->pic_tail_def); +} + void update_word_references_step(relocation_entry rel, cell index, code_block *compiled) { relocation_type type = REL_TYPE(rel); - if(type == RT_XT || type == RT_XT_DIRECT) + if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL) { cell offset = REL_OFFSET(rel) + (cell)(compiled + 1); array *literals = untag(compiled->literals); cell obj = array_nth(literals,index); void *xt; - if(type == RT_XT) + switch(type) + { + case RT_XT: xt = object_xt(obj); - else - xt = word_direct_xt(untag(obj)); + break; + case RT_XT_PIC: + xt = word_xt_pic(untag(obj)); + break; + case RT_XT_PIC_TAIL: + xt = word_xt_pic_tail(untag(obj)); + break; + default: + critical_error("Oops",type); + xt = NULL; + break; + } store_address_in_code_block(REL_CLASS(rel),offset,(cell)xt); } @@ -367,25 +389,30 @@ void relocate_code_block_step(relocation_entry rel, cell index, code_block *comp array *literals = untag(compiled->literals); fixnum absolute_value; +#define ARG array_nth(literals,index) + switch(REL_TYPE(rel)) { case RT_PRIMITIVE: - absolute_value = (cell)primitives[untag_fixnum(array_nth(literals,index))]; + absolute_value = (cell)primitives[untag_fixnum(ARG)]; break; case RT_DLSYM: absolute_value = (cell)get_rel_symbol(literals,index); break; case RT_IMMEDIATE: - absolute_value = array_nth(literals,index); + absolute_value = ARG; break; case RT_XT: - absolute_value = (cell)object_xt(array_nth(literals,index)); + absolute_value = (cell)object_xt(ARG); break; - case RT_XT_DIRECT: - absolute_value = (cell)word_direct_xt(untag(array_nth(literals,index))); + case RT_XT_PIC: + absolute_value = (cell)word_xt_pic(untag(ARG)); + break; + case RT_XT_PIC_TAIL: + absolute_value = (cell)word_xt_pic_tail(untag(ARG)); break; case RT_HERE: - absolute_value = offset + (short)untag_fixnum(array_nth(literals,index)); + absolute_value = offset + (short)untag_fixnum(ARG); break; case RT_THIS: absolute_value = (cell)(compiled + 1); @@ -394,13 +421,15 @@ void relocate_code_block_step(relocation_entry rel, cell index, code_block *comp absolute_value = (cell)&stack_chain; break; case RT_UNTAGGED: - absolute_value = untag_fixnum(array_nth(literals,index)); + absolute_value = untag_fixnum(ARG); break; default: critical_error("Bad rel type",rel); return; /* Can't happen */ } +#undef ARG + store_address_in_code_block(REL_CLASS(rel),offset,absolute_value); } diff --git a/vm/code_block.hpp b/vm/code_block.hpp index 85ae373845..b30de9d148 100644 --- a/vm/code_block.hpp +++ b/vm/code_block.hpp @@ -8,10 +8,12 @@ enum relocation_type { RT_DLSYM, /* a pointer to a compiled word reference */ RT_DISPATCH, - /* a word's general entry point XT */ + /* a word or quotation's general entry point */ RT_XT, - /* a word's direct entry point XT */ - RT_XT_DIRECT, + /* a word's PIC entry point */ + RT_XT_PIC, + /* a word's tail-call PIC entry point */ + RT_XT_PIC_TAIL, /* current offset */ RT_HERE, /* current code block */ diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index 77c78ad533..c8c7639930 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -26,8 +26,8 @@ void jit_compile_word(cell word_, cell def_, bool relocate) word->code = def->code; - if(word->direct_entry_def != F) - jit_compile(word->direct_entry_def,relocate); + if(word->pic_def != F) jit_compile(word->pic_def,relocate); + if(word->pic_tail_def != F) jit_compile(word->pic_tail_def,relocate); } /* Apply a function to every code block */ diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index 0c08ea7b46..a1ce83932e 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -60,9 +60,10 @@ DEF(bool,check_sse2,(void)): ret DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): - mov (%esp),%eax + mov (%esp),%ebx +DEF(F_FASTCALL void,primitive_inline_cache_miss_tail,(void)): sub $8,%esp - push %eax + push %ebx call MANGLE(inline_cache_miss) add $12,%esp jmp *%eax diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 5a70280ddf..0ace354308 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -73,8 +73,10 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi ret /* return _with new stack_ */ DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): - mov (%rsp),ARG0 + mov (%rsp),%rbx +DEF(F_FASTCALL void,primitive_inline_cache_miss_tail,(void)): sub $STACK_PADDING,%rsp + mov %rbx,ARG0 call MANGLE(inline_cache_miss) add $STACK_PADDING,%rsp jmp *%rax diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp index c0b4651811..9b6f2ed577 100755 --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -7,15 +7,19 @@ namespace factor inline static void flush_icache(cell start, cell len) {} +static const unsigned char call_opcode = 0xe8; +static const unsigned char jmp_opcode = 0xe9; + +inline static unsigned char call_site_opcode(cell return_address) +{ + return *(unsigned char *)(return_address - 5); +} + inline static void check_call_site(cell return_address) { - /* An x86 CALL instruction looks like so: - |e8|..|..|..|..| - where the ... are a PC-relative jump address. - The return_address points to right after the - instruction. */ #ifdef FACTOR_DEBUG - assert(*(unsigned char *)(return_address - 5) == 0xe8); + unsigned char opcode = call_site_opcode(return_address); + assert(opcode == call_opcode || opcode == jmp_opcode); #endif } @@ -31,6 +35,11 @@ inline static void set_call_target(cell return_address, void *target) *(int *)(return_address - 4) = ((cell)target - return_address); } +inline static bool tail_call_site_p(cell return_address) +{ + return call_site_opcode(return_address) == jmp_opcode; +} + /* Defined in assembly */ VM_ASM_API void c_to_factor(cell quot); VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to); diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp index 59632c4185..34d03e24f0 100755 --- a/vm/inline_cache.cpp +++ b/vm/inline_cache.cpp @@ -86,7 +86,11 @@ struct inline_cache_jit : public jit { inline_cache_jit(cell generic_word_) : jit(PIC_TYPE,generic_word_) {}; void emit_check(cell klass); - void compile_inline_cache(fixnum index, cell generic_word_, cell methods_, cell cache_entries_); + void compile_inline_cache(fixnum index, + cell generic_word_, + cell methods_, + cell cache_entries_, + bool tail_call_p); }; void inline_cache_jit::emit_check(cell klass) @@ -102,7 +106,11 @@ void inline_cache_jit::emit_check(cell klass) /* index: 0 = top of stack, 1 = item underneath, etc cache_entries: array of class/method pairs */ -void inline_cache_jit::compile_inline_cache(fixnum index, cell generic_word_, cell methods_, cell cache_entries_) +void inline_cache_jit::compile_inline_cache(fixnum index, + cell generic_word_, + cell methods_, + cell cache_entries_, + bool tail_call_p) { gc_root generic_word(generic_word_); gc_root methods(methods_); @@ -136,20 +144,25 @@ void inline_cache_jit::compile_inline_cache(fixnum index, cell generic_word_, ce push(methods.value()); push(tag_fixnum(index)); push(cache_entries.value()); - word_jump(userenv[PIC_MISS_WORD]); + word_jump(userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]); } static code_block *compile_inline_cache(fixnum index, - cell generic_word_, - cell methods_, - cell cache_entries_) + cell generic_word_, + cell methods_, + cell cache_entries_, + bool tail_call_p) { gc_root generic_word(generic_word_); gc_root methods(methods_); gc_root cache_entries(cache_entries_); inline_cache_jit jit(generic_word.value()); - jit.compile_inline_cache(index,generic_word.value(),methods.value(),cache_entries.value()); + jit.compile_inline_cache(index, + generic_word.value(), + methods.value(), + cache_entries.value(), + tail_call_p); code_block *code = jit.to_code_block(); relocate_code_block(code); return code; @@ -227,14 +240,18 @@ void *inline_cache_miss(cell return_address) xt = compile_inline_cache(index, generic_word.value(), methods.value(), - new_cache_entries.value()) + 1; + new_cache_entries.value(), + tail_call_site_p(return_address))->xt(); } /* Install the new stub. */ set_call_target(return_address,xt); #ifdef PIC_DEBUG - printf("Updated call site 0x%lx with 0x%lx\n",return_address,(cell)xt); + printf("Updated %s call site 0x%lx with 0x%lx\n", + tail_call_site_p(return_address) ? "tail" : "non-tail", + return_address, + (cell)xt); #endif return xt; diff --git a/vm/inline_cache.hpp b/vm/inline_cache.hpp index 84334efc78..e2a6ae8cf9 100644 --- a/vm/inline_cache.hpp +++ b/vm/inline_cache.hpp @@ -8,7 +8,8 @@ void init_inline_caching(int max_size); PRIMITIVE(reset_inline_cache_stats); PRIMITIVE(inline_cache_stats); PRIMITIVE(inline_cache_miss); +PRIMITIVE(inline_cache_miss_tail); -extern "C" void *inline_cache_miss(cell return_address); +VM_C_API void *inline_cache_miss(cell return_address); } diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 8c96cf3187..f8d114210a 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -229,7 +229,9 @@ struct word : public object { /* TAGGED property assoc for library code */ cell props; /* TAGGED alternative entry point for direct non-tail calls. Used for inline caching */ - cell direct_entry_def; + cell pic_def; + /* TAGGED alternative entry point for direct tail calls. Used for inline caching */ + cell pic_tail_def; /* TAGGED call count for profiling */ cell counter; /* TAGGED machine code for sub-primitive */ diff --git a/vm/primitives.cpp b/vm/primitives.cpp index f1c5468949..bd761625d8 100755 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -147,6 +147,7 @@ const primitive_type primitives[] = { primitive_load_locals, primitive_check_datastack, primitive_inline_cache_miss, + primitive_inline_cache_miss_tail, primitive_mega_cache_miss, primitive_lookup_method, primitive_reset_dispatch_stats, diff --git a/vm/run.hpp b/vm/run.hpp index 829e25d2f7..48ebb8cf41 100755 --- a/vm/run.hpp +++ b/vm/run.hpp @@ -48,7 +48,7 @@ enum special_object { JIT_RETURN, JIT_PROFILING, JIT_PUSH_IMMEDIATE, - JIT_SAVE_STACK = 38, + JIT_SAVE_STACK, JIT_DIP_WORD, JIT_DIP, JIT_2DIP_WORD, @@ -60,7 +60,7 @@ enum special_object { JIT_EXECUTE_CALL, /* Polymorphic inline cache generation in inline_cache.c */ - PIC_LOAD = 48, + PIC_LOAD = 47, PIC_TAG, PIC_HI_TAG, PIC_TUPLE, @@ -69,6 +69,7 @@ enum special_object { PIC_CHECK, PIC_HIT, PIC_MISS_WORD, + PIC_MISS_TAIL_WORD, /* Megamorphic cache generation in dispatch.c */ MEGA_LOOKUP = 57, diff --git a/vm/words.cpp b/vm/words.cpp index 6e7c633c84..fa090c9cea 100644 --- a/vm/words.cpp +++ b/vm/words.cpp @@ -16,7 +16,8 @@ word *allot_word(cell vocab_, cell name_) new_word->def = userenv[UNDEFINED_ENV]; new_word->props = F; new_word->counter = tag_fixnum(0); - new_word->direct_entry_def = F; + new_word->pic_def = F; + new_word->pic_tail_def = F; new_word->subprimitive = F; new_word->profiling = NULL; new_word->code = NULL; From 085b30337fe73b04dfddaacff3c5b7a42729a01b Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 20:46:41 -0400 Subject: [PATCH 068/210] Use binary-search instead of find-last for combinations --- basis/math/combinatorics/combinatorics.factor | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index b2e21e429a..5bda23f738 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs fry kernel locals math math.order math.ranges mirrors - namespaces sequences sorting ; +USING: accessors assocs binary-search fry kernel locals math math.order + math.ranges mirrors namespaces sequences sorting ; IN: math.combinatorics combo [ seq>> length ] [ k>> ] bi nCk ; : largest-value ( a b x -- v ) - #! TODO: use a binary search instead of find-last - [ [0,b) ] 2dip '[ _ nCk _ <= ] find-last nip ; + dup 0 = [ + drop 1 - nip + ] [ + [ [0,b) ] 2dip '[ _ nCk _ >=< ] search nip + ] if ; :: next-values ( a b x -- a' b' x' v ) a b x largest-value dup :> v ! a' From c1e25f3b43632f2fbbf54904136677986f77aeed Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 20:04:49 -0500 Subject: [PATCH 069/210] JIT now supports multiple relocations per code template. This simplifies non-optimizing compiler backends --- basis/bootstrap/image/image.factor | 31 ++++++++++-------------------- basis/cpu/ppc/bootstrap.factor | 8 +------- basis/cpu/x86/32/bootstrap.factor | 6 ++---- basis/cpu/x86/64/bootstrap.factor | 5 +---- basis/cpu/x86/bootstrap.factor | 5 +---- vm/jit.cpp | 29 ++++++++++++---------------- vm/jit.hpp | 4 ++-- vm/quotations.cpp | 6 +++--- vm/run.hpp | 6 ++---- 9 files changed, 34 insertions(+), 66 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 675c50732d..7b39cee101 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -93,24 +93,19 @@ CONSTANT: -1-offset 9 SYMBOL: sub-primitives -SYMBOL: jit-define-rc -SYMBOL: jit-define-rt -SYMBOL: jit-define-offset +SYMBOL: jit-relocations -: compute-offset ( -- offset ) - building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ; +: compute-offset ( rc -- offset ) + [ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ; : jit-rel ( rc rt -- ) - jit-define-rt set - jit-define-rc set - compute-offset jit-define-offset set ; + over compute-offset 3array jit-relocations get push-all ; -: make-jit ( quot -- quad ) +: make-jit ( quot -- jit-data ) [ + V{ } clone jit-relocations set call( -- ) - jit-define-rc get - jit-define-rt get - jit-define-offset get 3array + jit-relocations get >array ] B{ } make prefix ; : jit-define ( quot name -- ) @@ -142,8 +137,7 @@ SYMBOL: jit-word-jump SYMBOL: jit-word-call SYMBOL: jit-push-immediate SYMBOL: jit-if-word -SYMBOL: jit-if-1 -SYMBOL: jit-if-2 +SYMBOL: jit-if SYMBOL: jit-dip-word SYMBOL: jit-dip SYMBOL: jit-2dip-word @@ -156,7 +150,6 @@ SYMBOL: jit-execute-call SYMBOL: jit-epilog SYMBOL: jit-return SYMBOL: jit-profiling -SYMBOL: jit-save-stack ! PIC stubs SYMBOL: pic-load @@ -188,13 +181,11 @@ SYMBOL: undefined-quot { jit-word-jump 26 } { jit-word-call 27 } { jit-if-word 28 } - { jit-if-1 29 } - { jit-if-2 30 } + { jit-if 29 } { jit-epilog 33 } { jit-return 34 } { jit-profiling 35 } { jit-push-immediate 36 } - { jit-save-stack 37 } { jit-dip-word 38 } { jit-dip 39 } { jit-2dip-word 40 } @@ -539,8 +530,7 @@ M: quotation ' jit-word-call jit-push-immediate jit-if-word - jit-if-1 - jit-if-2 + jit-if jit-dip-word jit-dip jit-2dip-word @@ -553,7 +543,6 @@ M: quotation ' jit-epilog jit-return jit-profiling - jit-save-stack pic-load pic-tag pic-hi-tag diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 8001868e0c..768b919d4f 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -50,9 +50,6 @@ CONSTANT: rs-reg 14 0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel 7 6 0 LWZ 1 7 0 STW -] jit-save-stack jit-define - -[ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel 6 MTCTR BCTR @@ -68,11 +65,8 @@ CONSTANT: rs-reg 14 0 3 \ f tag-number CMPI 2 BEQ 0 B rc-relative-ppc-3 rt-xt jit-rel -] jit-if-1 jit-define - -[ 0 B rc-relative-ppc-3 rt-xt jit-rel -] jit-if-2 jit-define +] jit-if jit-define : jit->r ( -- ) 4 ds-reg 0 LWZ diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 660a428dfb..490d37ccbc 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system cpu.x86.assembler layouts vocabs parser compiler.constants ; @@ -26,9 +26,7 @@ IN: bootstrap.x86 temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel ! save stack pointer temp0 [] stack-reg MOV -] jit-save-stack jit-define - -[ + ! call the primitive 0 JMP rc-relative rt-primitive jit-rel ] jit-primitive jit-define diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 8d1ed086e7..c5c7e63dbc 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system cpu.x86.assembler layouts vocabs parser compiler.constants math ; @@ -25,9 +25,6 @@ IN: bootstrap.x86 temp0 temp0 [] MOV ! save stack pointer temp0 [] stack-reg MOV -] jit-save-stack jit-define - -[ ! load XT temp1 0 MOV rc-absolute-cell rt-primitive jit-rel ! go diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 8d35d4ed8a..ee75281a9d 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -58,12 +58,9 @@ big-endian off temp0 \ f tag-number CMP ! jump to true branch if not equal 0 JNE rc-relative rt-xt jit-rel -] jit-if-1 jit-define - -[ ! jump to false branch if equal 0 JMP rc-relative rt-xt jit-rel -] jit-if-2 jit-define +] jit-if jit-define : jit->r ( -- ) rs-reg bootstrap-cell ADD diff --git a/vm/jit.cpp b/vm/jit.cpp index bb86506058..a3f222a953 100644 --- a/vm/jit.cpp +++ b/vm/jit.cpp @@ -23,24 +23,21 @@ jit::jit(cell type_, cell owner_) if(stack_traces_p()) literal(owner.value()); } -relocation_entry jit::rel_to_emit(cell code_template, bool *rel_p) +void jit::emit_relocation(cell code_template_) { - array *quadruple = untag(code_template); - cell rel_class = array_nth(quadruple,1); - cell rel_type = array_nth(quadruple,2); - cell offset = array_nth(quadruple,3); + gc_root code_template(code_template_); + cell capacity = array_capacity(code_template.untagged()); + for(cell i = 1; i < capacity; i += 3) + { + cell rel_class = array_nth(code_template.untagged(),i); + cell rel_type = array_nth(code_template.untagged(),i + 1); + cell offset = array_nth(code_template.untagged(),i + 2); - if(rel_class == F) - { - *rel_p = false; - return 0; - } - else - { - *rel_p = true; - return (untag_fixnum(rel_type) << 28) + relocation_entry new_entry + = (untag_fixnum(rel_type) << 28) | (untag_fixnum(rel_class) << 24) | ((code.count + untag_fixnum(offset))); + relocation.append_bytes(&new_entry,sizeof(relocation_entry)); } } @@ -49,9 +46,7 @@ void jit::emit(cell code_template_) { gc_root code_template(code_template_); - bool rel_p; - relocation_entry rel = rel_to_emit(code_template.value(),&rel_p); - if(rel_p) relocation.append_bytes(&rel,sizeof(relocation_entry)); + emit_relocation(code_template.value()); gc_root insns(array_nth(code_template.untagged(),0)); diff --git a/vm/jit.hpp b/vm/jit.hpp index 30b5163b4a..976be9ef3b 100644 --- a/vm/jit.hpp +++ b/vm/jit.hpp @@ -14,7 +14,7 @@ struct jit { jit(cell jit_type, cell owner); void compute_position(cell offset); - relocation_entry rel_to_emit(cell code_template, bool *rel_p); + void emit_relocation(cell code_template); void emit(cell code_template); void literal(cell literal) { literals.add(literal); } @@ -35,7 +35,7 @@ struct jit { void emit_subprimitive(cell word_) { gc_root word(word_); gc_root code_template(word->subprimitive); - if(array_nth(code_template.untagged(),1) != F) literal(T); + if(array_capacity(code_template.untagged()) > 1) literal(T); emit(code_template.value()); } diff --git a/vm/quotations.cpp b/vm/quotations.cpp index 555ecc6420..afd9fc3da2 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -165,7 +165,6 @@ void quotation_jit::iterate_quotation() /* Primitive calls */ if(primitive_call_p(i)) { - emit(userenv[JIT_SAVE_STACK]); emit_with(userenv[JIT_PRIMITIVE],obj.value()); i++; @@ -187,8 +186,9 @@ void quotation_jit::iterate_quotation() jit_compile(array_nth(elements.untagged(),i + 1),relocate); } - emit_with(userenv[JIT_IF_1],array_nth(elements.untagged(),i)); - emit_with(userenv[JIT_IF_2],array_nth(elements.untagged(),i + 1)); + literal(array_nth(elements.untagged(),i)); + literal(array_nth(elements.untagged(),i + 1)); + emit(userenv[JIT_IF]); i += 2; diff --git a/vm/run.hpp b/vm/run.hpp index 48ebb8cf41..2072580c79 100755 --- a/vm/run.hpp +++ b/vm/run.hpp @@ -42,14 +42,12 @@ enum special_object { JIT_WORD_JUMP, JIT_WORD_CALL, JIT_IF_WORD, - JIT_IF_1, - JIT_IF_2, + JIT_IF, JIT_EPILOG = 33, JIT_RETURN, JIT_PROFILING, JIT_PUSH_IMMEDIATE, - JIT_SAVE_STACK, - JIT_DIP_WORD, + JIT_DIP_WORD = 38, JIT_DIP, JIT_2DIP_WORD, JIT_2DIP, From b81e5c56106079bc6a74120b7e147f187d9a2ee4 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 21:27:04 -0400 Subject: [PATCH 070/210] Add docs for combination words --- .../combinatorics/combinatorics-docs.factor | 70 +++++++++++++++++-- 1 file changed, 63 insertions(+), 7 deletions(-) diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor index 514c808ee0..7f40969b95 100644 --- a/basis/math/combinatorics/combinatorics-docs.factor +++ b/basis/math/combinatorics/combinatorics-docs.factor @@ -1,37 +1,93 @@ -USING: help.markup help.syntax kernel math math.order sequences ; +USING: help.markup help.syntax kernel math math.order multiline sequences ; IN: math.combinatorics HELP: factorial { $values { "n" "a non-negative integer" } { "n!" integer } } { $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "4 factorial ." "24" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "4 factorial ." "24" } +} ; HELP: nPk { $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } } { $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nPk ." "5040" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "10 4 nPk ." "5040" } +} ; HELP: nCk { $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } } { $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nCk ." "210" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "10 4 nCk ." "210" } +} ; HELP: permutation { $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } } { $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." } { $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "1 3 permutation ." "{ 0 2 1 }" } { $example "USING: math.combinatorics prettyprint ;" "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "1 3 permutation ." "{ 0 2 1 }" } + { $example "USING: math.combinatorics prettyprint ;" + "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } +} ; HELP: all-permutations { $values { "seq" sequence } { "seq" sequence } } { $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } +} ; + +HELP: each-permutation +{ $values { "seq" sequence } { "quot" { $quotation "( seq -- )" } } } +{ $description "Applies the quotation to each permuation of " { $snippet "seq" } " in order." } ; HELP: inverse-permutation { $values { "seq" sequence } { "permutation" sequence } } { $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." } { $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "USING: math.combinatorics prettyprint ;" "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } + { $example "USING: math.combinatorics prettyprint ;" + "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } +} ; + +HELP: combination +{ $values { "m" "a non-negative integer" } { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } } +{ $description "Outputs the " { $snippet "mth" } " lexicographical combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements." } +{ $notes "Combinations are 0-based and a bounds error will be thrown if " { $snippet "m" } " is larger than " { $snippet "seq length k nCk" } "." } +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "6 7 iota 4 combination ." "{ 0 1 3 6 }" } + { $example "USING: math.combinatorics prettyprint ;" + "0 { \"a\" \"b\" \"c\" \"d\" } 2 combination ." "{ \"a\" \"b\" }" } +} ; + +HELP: all-combinations +{ $values { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } } +{ $description "Outputs a sequence containing all combinations of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in lexicographical order." } +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "{ \"a\" \"b\" \"c\" \"d\" } 2 all-combinations ." +<" { + { "a" "b" } + { "a" "c" } + { "a" "d" } + { "b" "c" } + { "b" "d" } + { "c" "d" } +}"> } } ; + +HELP: each-combination +{ $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation "( seq -- )" } } } +{ $description "Applies the quotation to each combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in order." } ; IN: math.combinatorics.private From 1aa8ea8f377c73205879974cc19b8c189312cb6d Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 21:31:37 -0400 Subject: [PATCH 071/210] Use iota where necessary in tests --- .../combinatorics/combinatorics-tests.factor | 24 +++++++++---------- 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor index 8cd02399bc..1bc4bbc825 100644 --- a/basis/math/combinatorics/combinatorics-tests.factor +++ b/basis/math/combinatorics/combinatorics-tests.factor @@ -28,9 +28,9 @@ IN: math.combinatorics.tests [ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test [ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test -[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test -[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test -[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test +[ { 0 1 2 3 } ] [ 0 4 iota permutation-indices ] unit-test +[ { 0 1 3 2 } ] [ 1 4 iota permutation-indices ] unit-test +[ { 1 2 0 6 3 5 4 } ] [ 859 7 iota permutation-indices ] unit-test [ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test [ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test @@ -45,24 +45,24 @@ IN: math.combinatorics.tests [ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test -[ 2598960 ] [ 52 5 choose ] unit-test +[ 2598960 ] [ 52 iota 5 choose ] unit-test [ 6 3 13 6 ] [ 7 4 28 next-values ] unit-test [ 5 2 3 5 ] [ 6 3 13 next-values ] unit-test [ 3 1 0 3 ] [ 5 2 3 next-values ] unit-test [ 0 0 0 0 ] [ 3 1 0 next-values ] unit-test -[ 9 ] [ 0 5 3 dual-index ] unit-test -[ 0 ] [ 9 5 3 dual-index ] unit-test -[ 179 ] [ 72 10 5 dual-index ] unit-test +[ 9 ] [ 0 5 iota 3 dual-index ] unit-test +[ 0 ] [ 9 5 iota 3 dual-index ] unit-test +[ 179 ] [ 72 10 iota 5 dual-index ] unit-test [ { 5 3 2 1 } ] [ 7 4 8 combinadic ] unit-test -[ { 4 3 2 1 0 } ] [ 10 5 0 combinadic ] unit-test -[ { 8 6 3 1 0 } ] [ 10 5 72 combinadic ] unit-test -[ { 9 8 7 6 5 } ] [ 10 5 251 combinadic ] unit-test +[ { 4 3 2 1 0 } ] [ 10 iota 5 0 combinadic ] unit-test +[ { 8 6 3 1 0 } ] [ 10 iota 5 72 combinadic ] unit-test +[ { 9 8 7 6 5 } ] [ 10 iota 5 251 combinadic ] unit-test -[ { 0 1 2 } ] [ 0 5 3 combination-indices ] unit-test -[ { 2 3 4 } ] [ 9 5 3 combination-indices ] unit-test +[ { 0 1 2 } ] [ 0 5 iota 3 combination-indices ] unit-test +[ { 2 3 4 } ] [ 9 5 iota 3 combination-indices ] unit-test [ { "a" "b" "c" } ] [ 0 { "a" "b" "c" "d" "e" } 3 combination ] unit-test [ { "c" "d" "e" } ] [ 9 { "a" "b" "c" "d" "e" } 3 combination ] unit-test From 0d66d65c59b6a72fcec2d3708e7acf3fad0478fe Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 21:44:25 -0400 Subject: [PATCH 072/210] Make a deck of cards an actual tuple --- extra/poker/poker.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index 15e9a96d42..b4353dc925 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -194,8 +194,12 @@ M: hand equal? : >value ( hand -- str ) hand-rank VALUE_STR nth ; +TUPLE: deck + { cards sequence } ; + : ( -- deck ) - RANK_STR SUIT_STR 2array [ concat >ckf ] product-map ; + RANK_STR SUIT_STR 2array [ concat >ckf ] product-map deck boa ; -ALIAS: shuffle randomize +: shuffle ( deck -- deck ) + [ randomize ] change-cards ; From 4f0a1b024e67b3fcb126820d3b4d36c66070d347 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 22:04:01 -0500 Subject: [PATCH 073/210] Clean up bootstrap.image, and implement new calling convention for tail calls; tail call sites now have PICs --- basis/bootstrap/image/image.factor | 172 ++++++--------------- basis/bootstrap/image/syntax/authors.txt | 1 + basis/bootstrap/image/syntax/syntax.factor | 14 ++ basis/cpu/x86/bootstrap.factor | 7 +- vm/cpu-x86.hpp | 2 + vm/inline_cache.cpp | 2 +- vm/jit.hpp | 8 +- vm/quotations.cpp | 11 +- vm/run.hpp | 5 +- 9 files changed, 93 insertions(+), 129 deletions(-) create mode 100644 basis/bootstrap/image/syntax/authors.txt create mode 100644 basis/bootstrap/image/syntax/syntax.factor diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 7b39cee101..55e6a31491 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -9,7 +9,7 @@ classes.builtin classes.tuple classes.tuple.private vocabs vocabs.loader source-files definitions debugger quotations.private sequences.private combinators math.order math.private accessors slots.private generic.single.private compiler.units compiler.constants -fry ; +fry bootstrap.image.syntax ; IN: bootstrap.image : arch ( os cpu -- arch ) @@ -123,96 +123,59 @@ SYMBOL: big-endian ! Bootstrap architecture name SYMBOL: architecture -! Bootstrap global namesapce -SYMBOL: bootstrap-global +RESET ! Boot quotation, set in stage1.factor -SYMBOL: bootstrap-boot-quot +USERENV: bootstrap-boot-quot 20 + +! Bootstrap global namesapce +USERENV: bootstrap-global 21 ! JIT parameters -SYMBOL: jit-prolog -SYMBOL: jit-primitive-word -SYMBOL: jit-primitive -SYMBOL: jit-word-jump -SYMBOL: jit-word-call -SYMBOL: jit-push-immediate -SYMBOL: jit-if-word -SYMBOL: jit-if -SYMBOL: jit-dip-word -SYMBOL: jit-dip -SYMBOL: jit-2dip-word -SYMBOL: jit-2dip -SYMBOL: jit-3dip-word -SYMBOL: jit-3dip -SYMBOL: jit-execute-word -SYMBOL: jit-execute-jump -SYMBOL: jit-execute-call -SYMBOL: jit-epilog -SYMBOL: jit-return -SYMBOL: jit-profiling +USERENV: jit-prolog 23 +USERENV: jit-primitive-word 24 +USERENV: jit-primitive 25 +USERENV: jit-word-jump 26 +USERENV: jit-word-call 27 +USERENV: jit-word-special 28 +USERENV: jit-if-word 29 +USERENV: jit-if 30 +USERENV: jit-epilog 31 +USERENV: jit-return 32 +USERENV: jit-profiling 33 +USERENV: jit-push-immediate 34 +USERENV: jit-dip-word 35 +USERENV: jit-dip 36 +USERENV: jit-2dip-word 37 +USERENV: jit-2dip 38 +USERENV: jit-3dip-word 39 +USERENV: jit-3dip 40 +USERENV: jit-execute-word 41 +USERENV: jit-execute-jump 42 +USERENV: jit-execute-call 43 ! PIC stubs -SYMBOL: pic-load -SYMBOL: pic-tag -SYMBOL: pic-hi-tag -SYMBOL: pic-tuple -SYMBOL: pic-hi-tag-tuple -SYMBOL: pic-check-tag -SYMBOL: pic-check -SYMBOL: pic-hit -SYMBOL: pic-miss-word -SYMBOL: pic-miss-tail-word +USERENV: pic-load 47 +USERENV: pic-tag 48 +USERENV: pic-hi-tag 49 +USERENV: pic-tuple 50 +USERENV: pic-hi-tag-tuple 51 +USERENV: pic-check-tag 52 +USERENV: pic-check 53 +USERENV: pic-hit 54 +USERENV: pic-miss-word 55 +USERENV: pic-miss-tail-word 56 ! Megamorphic dispatch -SYMBOL: mega-lookup -SYMBOL: mega-lookup-word -SYMBOL: mega-miss-word +USERENV: mega-lookup 57 +USERENV: mega-lookup-word 58 +USERENV: mega-miss-word 59 ! Default definition for undefined words -SYMBOL: undefined-quot - -: userenvs ( -- assoc ) - H{ - { bootstrap-boot-quot 20 } - { bootstrap-global 21 } - { jit-prolog 23 } - { jit-primitive-word 24 } - { jit-primitive 25 } - { jit-word-jump 26 } - { jit-word-call 27 } - { jit-if-word 28 } - { jit-if 29 } - { jit-epilog 33 } - { jit-return 34 } - { jit-profiling 35 } - { jit-push-immediate 36 } - { jit-dip-word 38 } - { jit-dip 39 } - { jit-2dip-word 40 } - { jit-2dip 41 } - { jit-3dip-word 42 } - { jit-3dip 43 } - { jit-execute-word 44 } - { jit-execute-jump 45 } - { jit-execute-call 46 } - { pic-load 47 } - { pic-tag 48 } - { pic-hi-tag 49 } - { pic-tuple 50 } - { pic-hi-tag-tuple 51 } - { pic-check-tag 52 } - { pic-check 53 } - { pic-hit 54 } - { pic-miss-word 55 } - { pic-miss-tail-word 56 } - { mega-lookup 57 } - { mega-lookup-word 58 } - { mega-miss-word 59 } - { undefined-quot 60 } - } ; inline +USERENV: undefined-quot 60 : userenv-offset ( symbol -- n ) - userenvs at header-size + ; + userenvs get at header-size + ; : emit ( cell -- ) image get push ; @@ -504,11 +467,7 @@ M: quotation ' class<=-cache class-not-cache classes-intersect-cache class-and-cache class-or-cache next-method-quot-cache } [ H{ } clone ] H{ } map>assoc assoc-union - bootstrap-global set - bootstrap-global emit-userenv ; - -: emit-boot-quot ( -- ) - bootstrap-boot-quot emit-userenv ; + bootstrap-global set ; : emit-jit-data ( -- ) \ if jit-if-word set @@ -521,43 +480,10 @@ M: quotation ' \ inline-cache-miss-tail \ pic-miss-tail-word set \ mega-cache-lookup \ mega-lookup-word set \ mega-cache-miss \ mega-miss-word set - [ undefined ] undefined-quot set - { - jit-prolog - jit-primitive-word - jit-primitive - jit-word-jump - jit-word-call - jit-push-immediate - jit-if-word - jit-if - jit-dip-word - jit-dip - jit-2dip-word - jit-2dip - jit-3dip-word - jit-3dip - jit-execute-word - jit-execute-jump - jit-execute-call - jit-epilog - jit-return - jit-profiling - pic-load - pic-tag - pic-hi-tag - pic-tuple - pic-hi-tag-tuple - pic-check-tag - pic-check - pic-hit - pic-miss-word - pic-miss-tail-word - mega-lookup - mega-lookup-word - mega-miss-word - undefined-quot - } [ emit-userenv ] each ; + [ undefined ] undefined-quot set ; + +: emit-userenvs ( -- ) + userenvs get keys [ emit-userenv ] each ; : fixup-header ( -- ) heap-size data-heap-size-offset fixup ; @@ -574,8 +500,8 @@ M: quotation ' emit-jit-data "Serializing global namespace..." print flush emit-global - "Serializing boot quotation..." print flush - emit-boot-quot + "Serializing user environment..." print flush + emit-userenvs "Performing word fixups..." print flush fixup-words "Performing header fixups..." print flush diff --git a/basis/bootstrap/image/syntax/authors.txt b/basis/bootstrap/image/syntax/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/bootstrap/image/syntax/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/bootstrap/image/syntax/syntax.factor b/basis/bootstrap/image/syntax/syntax.factor new file mode 100644 index 0000000000..29dc09717a --- /dev/null +++ b/basis/bootstrap/image/syntax/syntax.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser kernel namespaces assocs words.symbol ; +IN: bootstrap.image.syntax + +SYMBOL: userenvs + +SYNTAX: RESET H{ } clone userenvs set-global ; + +SYNTAX: USERENV: + CREATE-WORD scan-word + [ swap userenvs get set-at ] + [ drop define-symbol ] + 2bi ; \ No newline at end of file diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index ee75281a9d..06807ce9fb 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -42,13 +42,18 @@ big-endian off ] jit-push-immediate jit-define [ - 0 JMP rc-relative rt-xt jit-rel + temp3 0 MOV rc-absolute-cell rt-here jit-rel + 0 JMP rc-relative rt-xt-pic-tail jit-rel ] jit-word-jump jit-define [ 0 CALL rc-relative rt-xt-pic jit-rel ] jit-word-call jit-define +[ + 0 JMP rc-relative rt-xt jit-rel +] jit-word-special jit-define + [ ! load boolean temp0 ds-reg [] MOV diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp index 9b6f2ed577..71a85b4e82 100755 --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -7,6 +7,8 @@ namespace factor inline static void flush_icache(cell start, cell len) {} +static const fixnum xt_tail_pic_offset = 2 * sizeof(cell) + 1; + static const unsigned char call_opcode = 0xe8; static const unsigned char jmp_opcode = 0xe9; diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp index 34d03e24f0..e9e098de70 100755 --- a/vm/inline_cache.cpp +++ b/vm/inline_cache.cpp @@ -144,7 +144,7 @@ void inline_cache_jit::compile_inline_cache(fixnum index, push(methods.value()); push(tag_fixnum(index)); push(cache_entries.value()); - word_jump(userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]); + word_special(userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]); } static code_block *compile_inline_cache(fixnum index, diff --git a/vm/jit.hpp b/vm/jit.hpp index 976be9ef3b..50b40eca30 100644 --- a/vm/jit.hpp +++ b/vm/jit.hpp @@ -25,13 +25,19 @@ struct jit { } void word_jump(cell word) { - emit_with(userenv[JIT_WORD_JUMP],word); + literal(tag_fixnum(xt_tail_pic_offset)); + literal(word); + emit(userenv[JIT_WORD_JUMP]); } void word_call(cell word) { emit_with(userenv[JIT_WORD_CALL],word); } + void word_special(cell word) { + emit_with(userenv[JIT_WORD_SPECIAL],word); + } + void emit_subprimitive(cell word_) { gc_root word(word_); gc_root code_template(word->subprimitive); diff --git a/vm/quotations.cpp b/vm/quotations.cpp index afd9fc3da2..32e5e37a79 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -152,7 +152,16 @@ void quotation_jit::iterate_quotation() { if(stack_frame) emit(userenv[JIT_EPILOG]); tail_call = true; - word_jump(obj.value()); + /* Inline cache misses are special-cased */ + if(obj.value() == userenv[PIC_MISS_WORD] + || obj.value() == userenv[PIC_MISS_TAIL_WORD]) + { + word_special(obj.value()); + } + else + { + word_jump(obj.value()); + } } else word_call(obj.value()); diff --git a/vm/run.hpp b/vm/run.hpp index 2072580c79..7527889efb 100755 --- a/vm/run.hpp +++ b/vm/run.hpp @@ -41,13 +41,14 @@ enum special_object { JIT_PRIMITIVE, JIT_WORD_JUMP, JIT_WORD_CALL, + JIT_WORD_SPECIAL, JIT_IF_WORD, JIT_IF, - JIT_EPILOG = 33, + JIT_EPILOG, JIT_RETURN, JIT_PROFILING, JIT_PUSH_IMMEDIATE, - JIT_DIP_WORD = 38, + JIT_DIP_WORD, JIT_DIP, JIT_2DIP_WORD, JIT_2DIP, From 74094142fe52fd17b99442933d9f5b3da25e67d2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 22:44:30 -0500 Subject: [PATCH 074/210] Fix tail call PICs on x86-64 --- basis/cpu/x86/x86.factor | 6 +++++- vm/cpu-x86.hpp | 10 +++++++++- vm/quotations.cpp | 9 ++++++++- 3 files changed, 22 insertions(+), 3 deletions(-) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 5ae9e1c489..e12cec9738 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -61,8 +61,12 @@ M: x86 stack-frame-size ( stack-frame -- i ) M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ; +: xt-tail-pic-offset ( -- n ) + #! See the comment in vm/cpu-x86.hpp + cell 4 + 1 + ; inline + M: x86 %jump ( word -- ) - pic-tail-reg 0 MOV 2 cells 1 + rc-absolute-cell rel-here + pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here 0 JMP rc-relative rel-word-pic-tail ; M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ; diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp index 71a85b4e82..e5852f9ad9 100755 --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -7,7 +7,15 @@ namespace factor inline static void flush_icache(cell start, cell len) {} -static const fixnum xt_tail_pic_offset = 2 * sizeof(cell) + 1; +/* In the instruction sequence: + + MOV EBX,... + JMP blah + + the offset from the immediate operand to MOV to the instruction after + the jump is a cell for the immediate operand, 4 bytes for the JMP + destination, and one byte for the JMP opcode. */ +static const fixnum xt_tail_pic_offset = sizeof(cell) + 4 + 1; static const unsigned char call_opcode = 0xe8; static const unsigned char jmp_opcode = 0xe9; diff --git a/vm/quotations.cpp b/vm/quotations.cpp index 32e5e37a79..b049f528e4 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -152,7 +152,14 @@ void quotation_jit::iterate_quotation() { if(stack_frame) emit(userenv[JIT_EPILOG]); tail_call = true; - /* Inline cache misses are special-cased */ + /* Inline cache misses are special-cased. + The calling convention for tail + calls stores the address of the next + instruction in a register. However, + PIC miss stubs themselves tail-call + the inline cache miss primitive, and + we don't want to clobber the saved + address. */ if(obj.value() == userenv[PIC_MISS_WORD] || obj.value() == userenv[PIC_MISS_TAIL_WORD]) { From 4950ca76c2b6506efbf9a3bdec262b3b265636d3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 23:40:27 -0500 Subject: [PATCH 075/210] find-window: don't bomb if a world has no child. Reported by Joe Groff --- basis/ui/ui.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index d07403836a..b73de68e26 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -145,7 +145,9 @@ SYMBOL: ui-thread PRIVATE> : find-window ( quot -- world ) - [ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline + [ windows get values ] dip + '[ dup children>> [ ] [ nip first ] if-empty @ ] + find-last nip ; inline : ui-running? ( -- ? ) \ ui-running get-global ; From 9a914d8ce502554f490037b2f1c8e293a46f563a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 23:47:17 -0500 Subject: [PATCH 076/210] tools.trace: fix for call( --- basis/tools/trace/trace-tests.factor | 30 ++++++++++++++++++++++-- basis/tools/trace/trace.factor | 35 +++++++++++++++++----------- 2 files changed, 49 insertions(+), 16 deletions(-) diff --git a/basis/tools/trace/trace-tests.factor b/basis/tools/trace/trace-tests.factor index 74f7c40943..06511c7ada 100644 --- a/basis/tools/trace/trace-tests.factor +++ b/basis/tools/trace/trace-tests.factor @@ -1,4 +1,30 @@ IN: tools.trace.tests -USING: tools.trace tools.test sequences ; +USING: tools.trace tools.test tools.continuations kernel math combinators +sequences ; -[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test \ No newline at end of file +[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test + +GENERIC: method-breakpoint-test ( x -- y ) + +TUPLE: method-breakpoint-tuple ; + +M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ; + +\ method-breakpoint-test don't-step-into + +[ 3 ] +[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] trace ] unit-test + +: case-breakpoint-test ( -- x ) + 5 { [ break 1 + ] } case ; + +\ case-breakpoint-test don't-step-into + +[ 6 ] [ [ case-breakpoint-test ] trace ] unit-test + +: call(-breakpoint-test ( -- x ) + [ break 1 ] call( -- x ) 2 + ; + +\ call(-breakpoint-test don't-step-into + +[ 3 ] [ [ call(-breakpoint-test ] trace ] unit-test diff --git a/basis/tools/trace/trace.factor b/basis/tools/trace/trace.factor index e2c6bf864b..f7f0ae4a69 100644 --- a/basis/tools/trace/trace.factor +++ b/basis/tools/trace/trace.factor @@ -4,19 +4,21 @@ USING: concurrency.promises models tools.continuations kernel sequences concurrency.messaging locals continuations threads namespaces namespaces.private make assocs accessors io strings prettyprint math math.parser words effects summary io.styles classes -generic.math combinators.short-circuit ; +generic.math combinators.short-circuit kernel.private quotations ; IN: tools.trace -: callstack-depth ( callstack -- n ) - callstack>array length 2/ ; - -SYMBOL: end - SYMBOL: exclude-vocabs SYMBOL: include-vocabs exclude-vocabs { "math" "accessors" } swap set-global +array length 2/ ; + +SYMBOL: end + : include? ( vocab -- ? ) include-vocabs get dup [ member? ] [ 2drop t ] if ; @@ -65,15 +67,20 @@ M: trace-step summary [ CHAR: \s write ] [ number>string write ": " write ] bi ; +: trace-into? ( continuation -- ? ) + continuation-current into? ; + : trace-step ( continuation -- continuation' ) - dup continuation-current end eq? [ - [ print-depth ] - [ print-step ] - [ - dup continuation-current into? - [ continuation-step-into ] [ continuation-step ] if - ] tri - ] unless ; + dup call>> innermost-frame-executing quotation? [ + dup continuation-current end eq? [ + [ print-depth ] + [ print-step ] + [ dup trace-into? [ continuation-step-into ] [ continuation-step ] if ] + tri + ] unless + ] when ; + +PRIVATE> : trace ( quot -- data ) [ [ trace-step ] break-hook ] dip From 443815b53de25a0aa71d2cc1f94c75f2304f63ea Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 7 May 2009 10:32:32 +0200 Subject: [PATCH 077/210] reworked insert, save and update; added save-deep --- extra/mongodb/tuple/tuple.factor | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index 9173957979..e5e4867d71 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -54,14 +54,22 @@ M: mdb-persistent id-selector >upsert update ] assoc-each ; inline PRIVATE> -: save-tuple ( tuple -- ) - tuple>storable [ (save-tuples) ] assoc-each ; +: save-tuple-deep ( tuple -- ) + tuple>storable [ (save-tuples) ] assoc-each ; : update-tuple ( tuple -- ) - save-tuple ; + [ tuple-collection name>> ] + [ id-selector ] + [ tuple>assoc ] tri + update ; + +: save-tuple ( tuple -- ) + update-tuple ; : insert-tuple ( tuple -- ) - save-tuple ; + [ tuple-collection name>> ] + [ tuple>assoc ] bi + save ; : delete-tuple ( tuple -- ) [ tuple-collection name>> ] keep From c4d1d80e8c67208e6087c78fd36ac27f2ce4ba18 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 7 May 2009 12:01:01 +0200 Subject: [PATCH 078/210] some bug fixes --- extra/mongodb/tuple/collection/collection.factor | 4 +++- extra/mongodb/tuple/tuple.factor | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/extra/mongodb/tuple/collection/collection.factor b/extra/mongodb/tuple/collection/collection.factor index 1bd2d94e69..60b2d25764 100644 --- a/extra/mongodb/tuple/collection/collection.factor +++ b/extra/mongodb/tuple/collection/collection.factor @@ -92,6 +92,8 @@ GENERIC: mdb-index-map ( tuple -- sequence ) [ ] [ name>> ] bi H{ } clone [ set-at ] keep ] [ 2drop H{ } clone ] if ; + + PRIVATE> : MDB_ADDON_SLOTS ( -- slots ) @@ -116,7 +118,7 @@ PRIVATE> [ drop MDB_USER_KEY set-word-prop ] [ 3drop ] if ; inline : set-index-map ( class index-list -- ) - [ [ dup user-defined-key-index ] dip index-list>map ] output>sequence + [ dup user-defined-key-index ] dip index-list>map 2array assoc-combine MDB_INDEX_MAP set-word-prop ; inline M: tuple-class tuple-collection ( tuple -- mdb-collection ) diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index e5e4867d71..8f7504d9bc 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -69,7 +69,7 @@ PRIVATE> : insert-tuple ( tuple -- ) [ tuple-collection name>> ] [ tuple>assoc ] bi - save ; + save ; : delete-tuple ( tuple -- ) [ tuple-collection name>> ] keep From 3de126aaa4bfae9110e00e2528d141767801cd33 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 10:19:23 -0400 Subject: [PATCH 079/210] Add >5 card evaluator word to poker vocab --- extra/poker/poker.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index b4353dc925..df8d93d9fa 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -2,8 +2,8 @@ ! The contents of this file are licensed under the Simplified BSD License ! A copy of the license is available at http://factorcode.org/license.txt USING: accessors arrays ascii binary-search combinators kernel locals math - math.bitwise math.order poker.arrays random sequences sequences.product - splitting ; + math.bitwise math.combinatorics math.order poker.arrays random sequences + sequences.product splitting ; IN: poker ! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with @@ -194,6 +194,9 @@ M: hand equal? : >value ( hand -- str ) hand-rank VALUE_STR nth ; +: best-hand ( str -- hand ) + " " split 5 all-combinations [ " " join ] map infimum ; + TUPLE: deck { cards sequence } ; From 0180ea782d0ce565e302a75d85bcde8694a5b2d5 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 10:29:44 -0400 Subject: [PATCH 080/210] Speed up best-hand by not converting to ckf repeatedly --- extra/poker/poker.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index df8d93d9fa..a749be239b 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -195,7 +195,8 @@ M: hand equal? hand-rank VALUE_STR nth ; : best-hand ( str -- hand ) - " " split 5 all-combinations [ " " join ] map infimum ; + parse-cards 5 all-combinations + [ dup hand-value hand boa ] map infimum ; TUPLE: deck { cards sequence } ; From 34190701f5d863407c7b3849f455f33c26a95205 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 10:56:33 -0400 Subject: [PATCH 081/210] Eliminate stack shuffling by using bi in PE #25 --- extra/project-euler/025/025.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/025/025.factor b/extra/project-euler/025/025.factor index 80a933dc63..5dfe7b9f56 100644 --- a/extra/project-euler/025/025.factor +++ b/extra/project-euler/025/025.factor @@ -39,7 +39,7 @@ IN: project-euler.025 ! Memoized brute force MEMO: fib ( m -- n ) - dup 1 > [ 1- dup fib swap 1- fib + ] when ; + dup 1 > [ [ 1 - fib ] [ 2 - fib ] bi + ] when ; Date: Thu, 7 May 2009 11:20:01 -0400 Subject: [PATCH 082/210] Add docs for best-hand in poker vocab --- extra/poker/poker-docs.factor | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor index 09019a29d7..ad2131870e 100644 --- a/extra/poker/poker-docs.factor +++ b/extra/poker/poker-docs.factor @@ -28,3 +28,11 @@ HELP: >value "\"AC KC QC JC TC\" >value ." "\"Straight Flush\"" } } { $notes "This should not be used as a basis for hand comparison." } ; + +HELP: best-hand +{ $values { "str" string } { "hand" "a new hand" } } +{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." } +{ $examples + { $example "USING: kernel poker prettyprint ;" + "\"AS KD JC KH 2D 2S KH\" best-hand >value ." "\"Full House\"" } +} ; From 3c19ec1cbb978d5ea2942557121cd726eb0bf28c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 12:32:06 -0500 Subject: [PATCH 083/210] Fix overly-eager strength reduction for mod, and add a type function for >integer (reported by Joe Groff) --- .../known-words/known-words.factor | 19 ++++++++++++------- .../tree/propagation/propagation-tests.factor | 5 ++++- 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index b91a1157f7..2f5c166ac5 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -148,10 +148,6 @@ most-negative-fixnum most-positive-fixnum [a,b] comparison-ops [ dup '[ _ define-comparison-constraints ] each-derived-op ] each -! generic-comparison-ops [ -! dup specific-comparison define-comparison-constraints -! ] each - ! Remove redundant comparisons : fold-comparison ( info1 info2 word -- info ) [ [ interval>> ] bi@ ] dip interval-comparison { @@ -217,6 +213,8 @@ generic-comparison-ops [ { >float float } { fixnum>float float } { bignum>float float } + + { >integer integer } } [ '[ _ @@ -228,19 +226,26 @@ generic-comparison-ops [ ] "outputs" set-word-prop ] assoc-each +: rem-custom-inlining ( #call -- quot/f ) + second value-info literal>> dup integer? + [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ; + { mod-integer-integer mod-integer-fixnum mod-fixnum-integer fixnum-mod - rem } [ [ - in-d>> second value-info >literal< - [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when + in-d>> dup first value-info interval>> [0,inf] interval-subset? + [ rem-custom-inlining ] [ drop f ] if ] "custom-inlining" set-word-prop ] each +\ rem [ + in-d>> rem-custom-inlining +] "custom-inlining" set-word-prop + { bitand-integer-integer bitand-integer-fixnum diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index eba41dbfdf..aba8dc9eda 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -690,4 +690,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ; ! Mutable tuples with circularity should not cause problems TUPLE: circle me ; -[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test \ No newline at end of file +[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test + +! Joe found an oversight +[ V{ integer } ] [ [ >integer ] final-classes ] unit-test \ No newline at end of file From eb515af59974a3f434e29127dcb0fef9e5f88021 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 12:33:31 -0500 Subject: [PATCH 084/210] Code cleanups --- basis/math/intervals/intervals.factor | 6 ++++-- vm/code_gc.cpp | 4 ++-- vm/cpu-x86.32.S | 8 ++------ vm/cpu-x86.64.S | 4 ++-- 4 files changed, 10 insertions(+), 12 deletions(-) diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 0bc25605e7..767197a975 100755 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -48,6 +48,8 @@ TUPLE: interval { from read-only } { to read-only } ; : (a,inf] ( a -- interval ) 1/0. (a,b] ; inline +: [0,inf] ( -- interval ) 0 [a,inf] ; foldable + : [-inf,inf] ( -- interval ) full-interval ; inline : compare-endpoints ( p1 p2 quot -- ? ) @@ -262,7 +264,7 @@ TUPLE: interval { from read-only } { to read-only } ; : interval-abs ( i1 -- i2 ) { { [ dup empty-interval eq? ] [ ] } - { [ dup full-interval eq? ] [ drop 0 [a,inf] ] } + { [ dup full-interval eq? ] [ drop [0,inf] ] } { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] } [ (interval-abs) points>interval ] } cond ; @@ -376,7 +378,7 @@ SYMBOL: incomparable : interval-log2 ( i1 -- i2 ) { { empty-interval [ empty-interval ] } - { full-interval [ 0 [a,inf] ] } + { full-interval [ [0,inf] ] } [ to>> first 1 max dup most-positive-fixnum > [ drop full-interval interval-log2 ] diff --git a/vm/code_gc.cpp b/vm/code_gc.cpp index 59110d13f8..48cf8f7661 100755 --- a/vm/code_gc.cpp +++ b/vm/code_gc.cpp @@ -303,7 +303,7 @@ cell heap_size(heap *heap) } /* Compute where each block is going to go, after compaction */ - cell compute_heap_forwarding(heap *heap, unordered_map &forwarding) +cell compute_heap_forwarding(heap *heap, unordered_map &forwarding) { heap_block *scan = first_block(heap); char *address = (char *)first_block(heap); @@ -324,7 +324,7 @@ cell heap_size(heap *heap) return (cell)address - heap->seg->start; } - void compact_heap(heap *heap, unordered_map &forwarding) +void compact_heap(heap *heap, unordered_map &forwarding) { heap_block *scan = first_block(heap); diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index a1ce83932e..ff45f48066 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -1,9 +1,5 @@ #include "asm.h" -/* Note that primitive word definitions are compiled with -__attribute__((regparm 2), so the pointer to the word object is passed in EAX, -and the callstack top is passed in EDX */ - #define ARG0 %eax #define ARG1 %edx #define STACK_REG %esp @@ -59,9 +55,9 @@ DEF(bool,check_sse2,(void)): mov %edx,%eax ret -DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): +DEF(void,primitive_inline_cache_miss,(void)): mov (%esp),%ebx -DEF(F_FASTCALL void,primitive_inline_cache_miss_tail,(void)): +DEF(void,primitive_inline_cache_miss_tail,(void)): sub $8,%esp push %ebx call MANGLE(inline_cache_miss) diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 0ace354308..6b2faa1c0b 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -72,9 +72,9 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi call *ARG3 /* call memcpy */ ret /* return _with new stack_ */ -DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): +DEF(void,primitive_inline_cache_miss,(void)): mov (%rsp),%rbx -DEF(F_FASTCALL void,primitive_inline_cache_miss_tail,(void)): +DEF(void,primitive_inline_cache_miss_tail,(void)): sub $STACK_PADDING,%rsp mov %rbx,ARG0 call MANGLE(inline_cache_miss) From e55f0d17e5fac890eacfb57802499aafd5cca2ae Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 12:54:23 -0500 Subject: [PATCH 085/210] compiler.tree.modular-arithmetic: convert >integer >fixnum into >fixnum --- basis/compiler/tests/optimizer.factor | 8 +++++++- .../modular-arithmetic/modular-arithmetic-tests.factor | 10 +++++++++- .../tree/modular-arithmetic/modular-arithmetic.factor | 8 ++++++++ 3 files changed, 24 insertions(+), 2 deletions(-) diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index f19a950711..fa1248435b 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -389,4 +389,10 @@ DEFER: loop-bbb [ f ] [ \ broken-declaration optimized? ] unit-test -[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test \ No newline at end of file +[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test + +! Modular arithmetic bug +: modular-arithmetic-bug ( a -- b ) >integer 256 mod ; + +[ 1 ] [ 257 modular-arithmetic-bug ] unit-test +[ -10 ] [ -10 modular-arithmetic-bug ] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor index 5d6a9cdea1..6e1c32d89d 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -98,13 +98,18 @@ TUPLE: declared-fixnum { x fixnum } ; ] { mod fixnum-mod } inlined? ] unit-test - [ f ] [ [ 256 mod ] { mod fixnum-mod } inlined? ] unit-test +[ f ] [ + [ + >fixnum 256 mod + ] { mod fixnum-mod } inlined? +] unit-test + [ f ] [ [ dup 0 >= [ 256 mod ] when @@ -128,3 +133,6 @@ TUPLE: declared-fixnum { x fixnum } ; { integer } declare [ 256 rem ] map ] { mod fixnum-mod rem } inlined? ] unit-test + +[ [ >fixnum 255 fixnum-bitand ] ] +[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor index de2600f691..31939a0d22 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: math math.partial-dispatch namespaces sequences sets accessors assocs words kernel memoize fry combinators +combinators.short-circuit compiler.tree compiler.tree.combinators compiler.tree.def-use @@ -69,6 +70,12 @@ GENERIC: optimize-modular-arithmetic* ( node -- nodes ) : optimize->fixnum ( #call -- nodes ) dup redundant->fixnum? [ drop f ] when ; +: optimize->integer ( #call -- nodes ) + dup out-d>> first actually-used-by dup length 1 = [ + first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&& + [ drop { } ] when + ] [ drop ] if ; + MEMO: fixnum-coercion ( flags -- nodes ) [ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ; @@ -87,6 +94,7 @@ MEMO: fixnum-coercion ( flags -- nodes ) M: #call optimize-modular-arithmetic* dup word>> { { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] } + { [ dup \ >integer eq? ] [ drop optimize->integer ] } { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] } [ drop ] } cond ; From 506f105c520617046874504f4715a6c7d1702c3b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 7 May 2009 13:01:42 -0500 Subject: [PATCH 086/210] link seeking docs to the seek descriptors --- core/io/io-docs.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 3469a81064..97b143e989 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -117,6 +117,7 @@ HELP: seek-relative } { $description "Seeks to an offset from the current position of the stream pointer." } ; +{ seek-absolute seek-relative seek-end } related-words HELP: seek-input { $values @@ -343,6 +344,10 @@ $nl { $subsection bl } "Seeking on the default output stream:" { $subsection seek-output } +"Seeking descriptors:" +{ $subsection seek-absolute } +{ $subsection seek-relative } +{ $subsection seek-end } "A pair of combinators for rebinding the " { $link output-stream } " variable:" { $subsection with-output-stream } { $subsection with-output-stream* } From 9b419aa0b1cc66a35f23fded7edb9b7aed548922 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 14:26:08 -0500 Subject: [PATCH 087/210] Count megamorphic cache hits --- basis/compiler/constants/constants.factor | 37 +-- basis/cpu/ppc/bootstrap.factor | 5 + basis/cpu/x86/bootstrap.factor | 13 +- vm/code_block.cpp | 354 ++++++++++------------ vm/code_block.hpp | 2 + vm/dispatch.hpp | 3 + 6 files changed, 200 insertions(+), 214 deletions(-) diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 5e0ee98606..6b383388ef 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -26,29 +26,30 @@ CONSTANT: deck-bits 18 : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline ! Relocation classes -CONSTANT: rc-absolute-cell 0 -CONSTANT: rc-absolute 1 -CONSTANT: rc-relative 2 +CONSTANT: rc-absolute-cell 0 +CONSTANT: rc-absolute 1 +CONSTANT: rc-relative 2 CONSTANT: rc-absolute-ppc-2/2 3 -CONSTANT: rc-absolute-ppc-2 4 -CONSTANT: rc-relative-ppc-2 5 -CONSTANT: rc-relative-ppc-3 6 -CONSTANT: rc-relative-arm-3 7 -CONSTANT: rc-indirect-arm 8 -CONSTANT: rc-indirect-arm-pc 9 +CONSTANT: rc-absolute-ppc-2 4 +CONSTANT: rc-relative-ppc-2 5 +CONSTANT: rc-relative-ppc-3 6 +CONSTANT: rc-relative-arm-3 7 +CONSTANT: rc-indirect-arm 8 +CONSTANT: rc-indirect-arm-pc 9 ! Relocation types -CONSTANT: rt-primitive 0 -CONSTANT: rt-dlsym 1 -CONSTANT: rt-dispatch 2 -CONSTANT: rt-xt 3 -CONSTANT: rt-xt-pic 4 +CONSTANT: rt-primitive 0 +CONSTANT: rt-dlsym 1 +CONSTANT: rt-dispatch 2 +CONSTANT: rt-xt 3 +CONSTANT: rt-xt-pic 4 CONSTANT: rt-xt-pic-tail 5 -CONSTANT: rt-here 6 -CONSTANT: rt-this 7 -CONSTANT: rt-immediate 8 +CONSTANT: rt-here 6 +CONSTANT: rt-this 7 +CONSTANT: rt-immediate 8 CONSTANT: rt-stack-chain 9 -CONSTANT: rt-untagged 10 +CONSTANT: rt-untagged 10 +CONSTANT: rt-megamorphic-cache-hits 11 : rc-absolute? ( n -- ? ) ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ; diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 768b919d4f..6a00dec12f 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -226,6 +226,11 @@ CONSTANT: rs-reg 14 6 3 0 LWZ 6 0 4 CMP 5 BNE + ! megamorphic_cache_hits++ + 0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel + 5 4 0 LWZ + 5 5 1 ADDI + 5 4 0 STW ! ... goto get(cache + bootstrap-cell) 3 3 4 LWZ 3 3 word-xt-offset LWZ diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 06807ce9fb..994591adcf 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -233,12 +233,13 @@ big-endian off temp0 temp2 ADD ! if(get(cache) == class) temp0 [] temp1 CMP - ! ... goto get(cache + bootstrap-cell) - [ - temp0 temp0 bootstrap-cell [+] MOV - temp0 word-xt-offset [+] JMP - ] [ ] make - [ length JNE ] [ % ] bi + bootstrap-cell 4 = 14 18 ? JNE ! Yuck! + ! megamorphic_cache_hits++ + temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel + temp1 [] 1 ADD + ! goto get(cache + bootstrap-cell) + temp0 temp0 bootstrap-cell [+] MOV + temp0 word-xt-offset [+] JMP ! fall-through on miss ] mega-lookup jit-define diff --git a/vm/code_block.cpp b/vm/code_block.cpp index 1da16ad0a1..083f7f49e6 100755 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -8,6 +8,159 @@ void flush_icache_for(code_block *block) flush_icache((cell)block,block->size); } +static int number_of_parameters(relocation_type type) +{ + switch(type) + { + case RT_PRIMITIVE: + case RT_XT: + case RT_XT_PIC: + case RT_XT_PIC_TAIL: + case RT_IMMEDIATE: + case RT_HERE: + case RT_UNTAGGED: + return 1; + case RT_DLSYM: + return 2; + case RT_THIS: + case RT_STACK_CHAIN: + case RT_MEGAMORPHIC_CACHE_HITS: + return 0; + default: + critical_error("Bad rel type",type); + return -1; /* Can't happen */ + } +} + +void *object_xt(cell obj) +{ + switch(tagged(obj).type()) + { + case WORD_TYPE: + return untag(obj)->xt; + case QUOTATION_TYPE: + return untag(obj)->xt; + default: + critical_error("Expected word or quotation",obj); + return NULL; + } +} + +static void *xt_pic(word *w, cell tagged_quot) +{ + if(tagged_quot == F || max_pic_size == 0) + return w->xt; + else + { + quotation *quot = untag(tagged_quot); + if(quot->compiledp == F) + return w->xt; + else + return quot->xt; + } +} + +void *word_xt_pic(word *w) +{ + return xt_pic(w,w->pic_def); +} + +void *word_xt_pic_tail(word *w) +{ + return xt_pic(w,w->pic_tail_def); +} + +/* References to undefined symbols are patched up to call this function on +image load */ +void undefined_symbol() +{ + general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL); +} + +/* Look up an external library symbol referenced by a compiled code block */ +void *get_rel_symbol(array *literals, cell index) +{ + cell symbol = array_nth(literals,index); + cell library = array_nth(literals,index + 1); + + dll *d = (library == F ? NULL : untag(library)); + + if(d != NULL && !d->dll) + return (void *)undefined_symbol; + + switch(tagged(symbol).type()) + { + case BYTE_ARRAY_TYPE: + { + symbol_char *name = alien_offset(symbol); + void *sym = ffi_dlsym(d,name); + + if(sym) + return sym; + else + { + return (void *)undefined_symbol; + } + } + case ARRAY_TYPE: + { + cell i; + array *names = untag(symbol); + for(i = 0; i < array_capacity(names); i++) + { + symbol_char *name = alien_offset(array_nth(names,i)); + void *sym = ffi_dlsym(d,name); + + if(sym) + return sym; + } + return (void *)undefined_symbol; + } + default: + critical_error("Bad symbol specifier",symbol); + return (void *)undefined_symbol; + } +} + +cell compute_relocation(relocation_entry rel, cell index, code_block *compiled) +{ + array *literals = untag(compiled->literals); + cell offset = REL_OFFSET(rel) + (cell)compiled->xt(); + +#define ARG array_nth(literals,index) + + switch(REL_TYPE(rel)) + { + case RT_PRIMITIVE: + return (cell)primitives[untag_fixnum(ARG)]; + case RT_DLSYM: + return (cell)get_rel_symbol(literals,index); + case RT_IMMEDIATE: + return ARG; + case RT_XT: + return (cell)object_xt(ARG); + case RT_XT_PIC: + return (cell)word_xt_pic(untag(ARG)); + case RT_XT_PIC_TAIL: + return (cell)word_xt_pic_tail(untag(ARG)); + case RT_HERE: + return offset + (short)untag_fixnum(ARG); + case RT_THIS: + return (cell)(compiled + 1); + case RT_STACK_CHAIN: + return (cell)&stack_chain; + case RT_UNTAGGED: + return untag_fixnum(ARG); + case RT_MEGAMORPHIC_CACHE_HITS: + return (cell)&megamorphic_cache_hits; + default: + critical_error("Bad rel type",rel); + return 0; /* Can't happen */ + } + +#undef ARG +} + void iterate_relocations(code_block *compiled, relocation_iterator iter) { if(compiled->relocation != F) @@ -20,30 +173,8 @@ void iterate_relocations(code_block *compiled, relocation_iterator iter) for(cell i = 0; i < length; i++) { relocation_entry rel = relocation->data()[i]; - iter(rel,index,compiled); - - switch(REL_TYPE(rel)) - { - case RT_PRIMITIVE: - case RT_XT: - case RT_XT_PIC: - case RT_XT_PIC_TAIL: - case RT_IMMEDIATE: - case RT_HERE: - case RT_UNTAGGED: - index++; - break; - case RT_DLSYM: - index += 2; - break; - case RT_THIS: - case RT_STACK_CHAIN: - break; - default: - critical_error("Bad rel type",rel); - return; /* Can't happen */ - } + index += number_of_parameters(REL_TYPE(rel)); } } } @@ -158,73 +289,24 @@ void copy_literal_references(code_block *compiled) } } -void *object_xt(cell obj) +/* Compute an address to store at a relocation */ +void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled) { - switch(tagged(obj).type()) - { - case WORD_TYPE: - return untag(obj)->xt; - case QUOTATION_TYPE: - return untag(obj)->xt; - default: - critical_error("Expected word or quotation",obj); - return NULL; - } -} +#ifdef FACTOR_DEBUG + tagged(compiled->literals).untag_check(); + tagged(compiled->relocation).untag_check(); +#endif -static void *xt_pic(word *w, cell tagged_quot) -{ - if(tagged_quot == F || max_pic_size == 0) - return w->xt; - else - { - quotation *quot = untag(tagged_quot); - if(quot->compiledp == F) - return w->xt; - else - return quot->xt; - } -} - -void *word_xt_pic(word *w) -{ - return xt_pic(w,w->pic_def); -} - -void *word_xt_pic_tail(word *w) -{ - return xt_pic(w,w->pic_tail_def); + store_address_in_code_block(REL_CLASS(rel), + REL_OFFSET(rel) + (cell)compiled->xt(), + compute_relocation(rel,index,compiled)); } void update_word_references_step(relocation_entry rel, cell index, code_block *compiled) { relocation_type type = REL_TYPE(rel); if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL) - { - cell offset = REL_OFFSET(rel) + (cell)(compiled + 1); - array *literals = untag(compiled->literals); - cell obj = array_nth(literals,index); - - void *xt; - switch(type) - { - case RT_XT: - xt = object_xt(obj); - break; - case RT_XT_PIC: - xt = word_xt_pic(untag(obj)); - break; - case RT_XT_PIC_TAIL: - xt = word_xt_pic_tail(untag(obj)); - break; - default: - critical_error("Oops",type); - xt = NULL; - break; - } - - store_address_in_code_block(REL_CLASS(rel),offset,(cell)xt); - } + relocate_code_block_step(rel,index,compiled); } /* Relocate new code blocks completely; updating references to literals, @@ -325,114 +407,6 @@ void mark_object_code_block(object *object) } } -/* References to undefined symbols are patched up to call this function on -image load */ -void undefined_symbol() -{ - general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL); -} - -/* Look up an external library symbol referenced by a compiled code block */ -void *get_rel_symbol(array *literals, cell index) -{ - cell symbol = array_nth(literals,index); - cell library = array_nth(literals,index + 1); - - dll *d = (library == F ? NULL : untag(library)); - - if(d != NULL && !d->dll) - return (void *)undefined_symbol; - - switch(tagged(symbol).type()) - { - case BYTE_ARRAY_TYPE: - { - symbol_char *name = alien_offset(symbol); - void *sym = ffi_dlsym(d,name); - - if(sym) - return sym; - else - { - return (void *)undefined_symbol; - } - } - case ARRAY_TYPE: - { - cell i; - array *names = untag(symbol); - for(i = 0; i < array_capacity(names); i++) - { - symbol_char *name = alien_offset(array_nth(names,i)); - void *sym = ffi_dlsym(d,name); - - if(sym) - return sym; - } - return (void *)undefined_symbol; - } - default: - critical_error("Bad symbol specifier",symbol); - return (void *)undefined_symbol; - } -} - -/* Compute an address to store at a relocation */ -void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled) -{ -#ifdef FACTOR_DEBUG - tagged(compiled->literals).untag_check(); - tagged(compiled->relocation).untag_check(); -#endif - - cell offset = REL_OFFSET(rel) + (cell)(compiled + 1); - array *literals = untag(compiled->literals); - fixnum absolute_value; - -#define ARG array_nth(literals,index) - - switch(REL_TYPE(rel)) - { - case RT_PRIMITIVE: - absolute_value = (cell)primitives[untag_fixnum(ARG)]; - break; - case RT_DLSYM: - absolute_value = (cell)get_rel_symbol(literals,index); - break; - case RT_IMMEDIATE: - absolute_value = ARG; - break; - case RT_XT: - absolute_value = (cell)object_xt(ARG); - break; - case RT_XT_PIC: - absolute_value = (cell)word_xt_pic(untag(ARG)); - break; - case RT_XT_PIC_TAIL: - absolute_value = (cell)word_xt_pic_tail(untag(ARG)); - break; - case RT_HERE: - absolute_value = offset + (short)untag_fixnum(ARG); - break; - case RT_THIS: - absolute_value = (cell)(compiled + 1); - break; - case RT_STACK_CHAIN: - absolute_value = (cell)&stack_chain; - break; - case RT_UNTAGGED: - absolute_value = untag_fixnum(ARG); - break; - default: - critical_error("Bad rel type",rel); - return; /* Can't happen */ - } - -#undef ARG - - store_address_in_code_block(REL_CLASS(rel),offset,absolute_value); -} - /* Perform all fixups on a code block */ void relocate_code_block(code_block *compiled) { diff --git a/vm/code_block.hpp b/vm/code_block.hpp index b30de9d148..fef5b15da4 100644 --- a/vm/code_block.hpp +++ b/vm/code_block.hpp @@ -24,6 +24,8 @@ enum relocation_type { RT_STACK_CHAIN, /* untagged fixnum literal */ RT_UNTAGGED, + /* address of megamorphic_cache_hits var */ + RT_MEGAMORPHIC_CACHE_HITS, }; enum relocation_class { diff --git a/vm/dispatch.hpp b/vm/dispatch.hpp index f5648c7ebe..75368191a7 100644 --- a/vm/dispatch.hpp +++ b/vm/dispatch.hpp @@ -1,6 +1,9 @@ namespace factor { +extern cell megamorphic_cache_hits; +extern cell megamorphic_cache_misses; + cell lookup_method(cell object, cell methods); PRIMITIVE(lookup_method); From 85ccc87447d93d6ee0da282be9f46436cf5c6627 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 16:54:49 -0400 Subject: [PATCH 088/210] Minor logical rearrangement --- extra/poker/poker-docs.factor | 16 ++++++++-------- extra/poker/poker.factor | 8 ++++---- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor index ad2131870e..ab0a59ed4f 100644 --- a/extra/poker/poker-docs.factor +++ b/extra/poker/poker-docs.factor @@ -12,6 +12,14 @@ HELP: } { $notes "Cards may be specified in any order. Hands are directly comparable to each other on the basis of their computed value. Two hands are considered equal when they would tie in a game (despite being composed of different cards)." } ; +HELP: best-hand +{ $values { "str" string } { "hand" "a new hand" } } +{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." } +{ $examples + { $example "USING: kernel poker prettyprint ;" + "\"AS KD JC KH 2D 2S KH\" best-hand >value ." "\"Full House\"" } +} ; + HELP: >cards { $values { "hand" "a hand" } { "str" string } } { $description "Outputs a string representation of a hand's cards." } @@ -28,11 +36,3 @@ HELP: >value "\"AC KC QC JC TC\" >value ." "\"Straight Flush\"" } } { $notes "This should not be used as a basis for hand comparison." } ; - -HELP: best-hand -{ $values { "str" string } { "hand" "a new hand" } } -{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." } -{ $examples - { $example "USING: kernel poker prettyprint ;" - "\"AS KD JC KH 2D 2S KH\" best-hand >value ." "\"Full House\"" } -} ; diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index a749be239b..b7661b83db 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -188,16 +188,16 @@ M: hand equal? : ( str -- hand ) parse-cards dup hand-value hand boa ; +: best-hand ( str -- hand ) + parse-cards 5 all-combinations + [ dup hand-value hand boa ] map infimum ; + : >cards ( hand -- str ) cards>> [ card>string ] map " " join ; : >value ( hand -- str ) hand-rank VALUE_STR nth ; -: best-hand ( str -- hand ) - parse-cards 5 all-combinations - [ dup hand-value hand boa ] map infimum ; - TUPLE: deck { cards sequence } ; From db6ae46c47b49afffce4f61724cabcabb0728b92 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 16:58:18 -0500 Subject: [PATCH 089/210] Fix x86-64 backend --- basis/cpu/x86/bootstrap.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 994591adcf..474ce2ea46 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -233,7 +233,7 @@ big-endian off temp0 temp2 ADD ! if(get(cache) == class) temp0 [] temp1 CMP - bootstrap-cell 4 = 14 18 ? JNE ! Yuck! + bootstrap-cell 4 = 14 22 ? JNE ! Yuck! ! megamorphic_cache_hits++ temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel temp1 [] 1 ADD From dd1769c7445427c2a8c06f72b35721eca3ee171f Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 18:33:55 -0400 Subject: [PATCH 090/210] Make next-odd public again as it's used elsewhere --- basis/math/miller-rabin/miller-rabin.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor index 9fd604a003..cb1d3723b4 100755 --- a/basis/math/miller-rabin/miller-rabin.factor +++ b/basis/math/miller-rabin/miller-rabin.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Doug Coleman. +! Copyright (c) 2008-2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel locals math math.functions math.ranges random sequences sets combinators.short-circuit math.bitwise @@ -13,8 +13,6 @@ IN: math.miller-rabin : next-even ( m -- n ) >even 2 + ; -: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; - TUPLE: positive-even-expected n ; :: (miller-rabin) ( n trials -- ? ) @@ -29,12 +27,14 @@ TUPLE: positive-even-expected n ; ] [ r iota [ 2^ s * a swap n ^mod n - -1 = - ] any? not + ] any? not ] if ] any? not ; PRIVATE> +: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; + : miller-rabin* ( n numtrials -- ? ) over { { [ dup 1 <= ] [ 3drop f ] } From 20d2da7f0f42513b5df67867eddba700fcd2d321 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 18:50:46 -0400 Subject: [PATCH 091/210] Update docs/summary for poker vocab --- extra/poker/poker-docs.factor | 16 ++++++++++++---- extra/poker/summary.txt | 2 +- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor index ab0a59ed4f..388239d549 100644 --- a/extra/poker/poker-docs.factor +++ b/extra/poker/poker-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax strings ; IN: poker HELP: -{ $values { "str" string } { "hand" "a new hand" } } +{ $values { "str" string } { "hand" "a new " { $link hand } } } { $description "Creates a new poker hand containing the cards specified in " { $snippet "str" } "." } { $examples { $example "USING: kernel math.order poker prettyprint ;" @@ -13,7 +13,7 @@ HELP: { $notes "Cards may be specified in any order. Hands are directly comparable to each other on the basis of their computed value. Two hands are considered equal when they would tie in a game (despite being composed of different cards)." } ; HELP: best-hand -{ $values { "str" string } { "hand" "a new hand" } } +{ $values { "str" string } { "hand" "a new " { $link hand } } } { $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." } { $examples { $example "USING: kernel poker prettyprint ;" @@ -21,7 +21,7 @@ HELP: best-hand } ; HELP: >cards -{ $values { "hand" "a hand" } { "str" string } } +{ $values { "hand" hand } { "str" string } } { $description "Outputs a string representation of a hand's cards." } { $examples { $example "USING: poker prettyprint ;" @@ -29,10 +29,18 @@ HELP: >cards } ; HELP: >value -{ $values { "hand" "a hand" } { "str" string } } +{ $values { "hand" hand } { "str" string } } { $description "Outputs a string representation of a hand's value." } { $examples { $example "USING: poker prettyprint ;" "\"AC KC QC JC TC\" >value ." "\"Straight Flush\"" } } { $notes "This should not be used as a basis for hand comparison." } ; + +HELP: +{ $values { "deck" "a new " { $link deck } } } +{ $description "Creates a standard deck of 52 cards." } ; + +HELP: shuffle +{ $values { "deck" deck } { "deck" "a shuffled " { $link deck } } } +{ $description "Shuffles the cards in " { $snippet "deck" } ", in-place, using the Fisher-Yates algorithm." } ; diff --git a/extra/poker/summary.txt b/extra/poker/summary.txt index c8efe851c8..8dbbe9bd74 100644 --- a/extra/poker/summary.txt +++ b/extra/poker/summary.txt @@ -1 +1 @@ -5-card poker hand evaluator +Poker hand evaluator From b45284421d8d9dba3b5704f36a65ab62433ff8e7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 19:40:25 -0500 Subject: [PATCH 092/210] cpu.ppc.bootstrap: updates --- basis/cpu/ppc/bootstrap.factor | 42 ++++++++++++++++++++-------------- 1 file changed, 25 insertions(+), 17 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 6a00dec12f..b09938f4b9 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -21,43 +21,48 @@ CONSTANT: rs-reg 14 : xt-save ( -- n ) stack-frame 2 bootstrap-cells - ; [ - 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel - 11 6 profile-count-offset LWZ + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + 11 3 profile-count-offset LWZ 11 11 1 tag-fixnum ADDI - 11 6 profile-count-offset STW - 11 6 word-code-offset LWZ + 11 3 profile-count-offset STW + 11 3 word-code-offset LWZ 11 11 compiled-header-size ADDI 11 MTCTR BCTR ] jit-profiling jit-define [ - 0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel 0 MFLR 1 1 stack-frame SUBI - 6 1 xt-save STW - stack-frame 6 LI - 6 1 next-save STW + 3 1 xt-save STW + stack-frame 3 LI + 3 1 next-save STW 0 1 lr-save stack-frame + STW ] jit-prolog jit-define [ - 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel - 6 ds-reg 4 STWU + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + 3 ds-reg 4 STWU ] jit-push-immediate jit-define [ - 0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel - 7 6 0 LWZ - 1 7 0 STW - 0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel - 6 MTCTR + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel + 4 3 0 LWZ + 1 4 0 STW + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel + 3 MTCTR BCTR ] jit-primitive jit-define [ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define -[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define +[ + 0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel + 0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel +] jit-word-jump jit-define + +[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-special jit-define [ 3 ds-reg 0 LWZ @@ -152,6 +157,9 @@ CONSTANT: rs-reg 14 ! ! ! Polymorphic inline caches +! Don't touch r6 here; it's used to pass the tail call site +! address for tail PICs + ! Load a value from a stack position [ 4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel @@ -225,7 +233,7 @@ CONSTANT: rs-reg 14 ! if(get(cache) == class) 6 3 0 LWZ 6 0 4 CMP - 5 BNE + 10 BNE ! megamorphic_cache_hits++ 0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel 5 4 0 LWZ From b1f42da336a79bb25ff0fd46cf5154036733d502 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 7 May 2009 19:46:42 -0500 Subject: [PATCH 093/210] un-private some useful words --- basis/opengl/textures/textures.factor | 26 ++++++++++++++------------ extra/noise/noise.factor | 6 +++--- 2 files changed, 17 insertions(+), 15 deletions(-) diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index d103e90bee..49725d2242 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -39,6 +39,8 @@ SLOT: display-list GENERIC: draw-scaled-texture ( dim texture -- ) +DEFER: make-texture + > first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri glTexSubImage2D ; -: make-texture ( image -- id ) - #! We use glTexSubImage2D to work around the power of 2 texture size - #! limitation - gen-texture [ - GL_TEXTURE_BIT [ - GL_TEXTURE_2D swap glBindTexture - non-power-of-2-textures? get - [ dup bitmap>> (tex-image) ] - [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if - ] do-attribs - ] keep ; - : init-texture ( -- ) GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri @@ -176,6 +166,18 @@ CONSTANT: max-texture-size { 512 512 } PRIVATE> +: make-texture ( image -- id ) + #! We use glTexSubImage2D to work around the power of 2 texture size + #! limitation + gen-texture [ + GL_TEXTURE_BIT [ + GL_TEXTURE_2D swap glBindTexture + non-power-of-2-textures? get + [ dup bitmap>> (tex-image) ] + [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if + ] do-attribs + ] keep ; + : ( image loc -- texture ) over dim>> max-texture-size [ <= ] 2all? [ ] diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor index f2ca8ad59b..c28768283c 100644 --- a/extra/noise/noise.factor +++ b/extra/noise/noise.factor @@ -7,6 +7,9 @@ IN: noise : ( -- table ) 256 iota >byte-array randomize dup append ; +: with-seed ( seed quot -- ) + [ ] dip with-random ; inline + ] dip with-random ; inline - : >byte-map ( floats -- bytes ) [ 255.0 * >fixnum ] B{ } map-as ; From 94f92ad0eb1c1074446851712a6a5af2e5a80e8c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 7 May 2009 19:47:05 -0500 Subject: [PATCH 094/210] fix some faux pas in bunny --- extra/bunny/model/model.factor | 2 +- extra/bunny/outlined/outlined.factor | 2 +- extra/opengl/demo-support/demo-support.factor | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 0009e39fa7..3871936902 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -89,7 +89,7 @@ M: bunny-buffers bunny-geom GL_FLOAT 0 0 buffer-offset glNormalPointer [ nv>> "float" heap-size * buffer-offset - 3 GL_FLOAT 0 roll glVertexPointer + [ 3 GL_FLOAT 0 ] dip glVertexPointer ] [ ni>> GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 0ad2a72100..7d614ff947 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -120,7 +120,7 @@ TUPLE: bunny-outlined : outlining-supported? ( -- ? ) "2.0" { - "GL_ARB_shading_objects" + "GL_ARB_shader_objects" "GL_ARB_draw_buffers" "GL_ARB_multitexture" } has-gl-version-or-extensions? { diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 35c64d4ad1..8afbd52647 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -1,9 +1,9 @@ USING: arrays kernel math math.functions math.order math.vectors namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures -ui.gadgets.worlds ui.render accessors combinators ; +ui.gadgets.worlds ui.render accessors combinators literals ; IN: opengl.demo-support -: FOV ( -- x ) 2.0 sqrt 1+ ; inline +CONSTANT: FOV $[ 2.0 sqrt 1+ ] CONSTANT: MOUSE-MOTION-SCALE 0.5 CONSTANT: KEY-ROTATE-STEP 10.0 From cd7e2aecd298bc140d8301db2cb9df56970a8833 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 7 May 2009 19:47:26 -0500 Subject: [PATCH 095/210] typo in cocoa pixel format stuff --- basis/ui/backend/cocoa/cocoa.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 5b1b4b0c2a..ef5c80dcdb 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -29,7 +29,7 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: NSOpenGLPFA { } H{ { fullscreen { $ NSOpenGLPFAFullScreen } } { windowed { $ NSOpenGLPFAWindow } } { accelerated { $ NSOpenGLPFAAccelerated } } - { software-rendered { $ NSOpenGLPFASingleRenderer $ kCGLRendererGenericFloatID } } + { software-rendered { $ NSOpenGLPFARendererID $ kCGLRendererGenericFloatID } } { backing-store { $ NSOpenGLPFABackingStore } } { multisampled { $ NSOpenGLPFAMultisample } } { supersampled { $ NSOpenGLPFASupersample } } From cb9d50887c2fb83ee4cdb5e2d4e2b84567a69b3f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 19:47:38 -0500 Subject: [PATCH 096/210] Update PowerPC %jump and %dispatch-label, and add PIC-related functions to cpu-ppc.hpp --- basis/cpu/ppc/ppc.factor | 11 ++++++----- vm/cpu-ppc.S | 4 +++- vm/cpu-ppc.hpp | 31 ++++++++++++++++++++++++------- 3 files changed, 33 insertions(+), 13 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index a11b0daa86..beee48e5ea 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -3,9 +3,10 @@ USING: accessors assocs sequences kernel combinators make math math.order math.ranges system namespaces locals layouts words alien alien.c-types literals cpu.architecture cpu.ppc.assembler -literals compiler.cfg.registers compiler.cfg.instructions -compiler.constants compiler.codegen compiler.codegen.fixup -compiler.cfg.intrinsics compiler.cfg.stack-frame ; +cpu.ppc.assembler.backend literals compiler.cfg.registers +compiler.cfg.instructions compiler.constants compiler.codegen +compiler.codegen.fixup compiler.cfg.intrinsics +compiler.cfg.stack-frame ; IN: cpu.ppc ! PowerPC register assignments: @@ -116,7 +117,7 @@ M: ppc stack-frame-size ( stack-frame -- i ) M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ; M: ppc %jump ( word -- ) - 0 3 LOAD32 rc-absolute-ppc-2/2 rel-here + 0 6 LOAD32 8 rc-absolute-ppc-2/2 rel-here 0 B rc-relative-ppc-3 rel-word-pic-tail ; M: ppc %jump-label ( label -- ) B ; @@ -130,7 +131,7 @@ M:: ppc %dispatch ( src temp offset -- ) BCTR ; M: ppc %dispatch-label ( word -- ) - 0 , rc-absolute-cell rel-word ; + B{ 0 0 0 0 } % rc-absolute-cell rel-word ; :: (%slot) ( obj slot tag temp -- reg offset ) temp slot obj ADD diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index f8dad4b2b2..a372b2b1f5 100755 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -236,8 +236,10 @@ DEF(void,flush_icache,(void *start, int len)): blr DEF(void,primitive_inline_cache_miss,(void)): - mflr r3 + mflr r6 +DEF(void,primitive_inline_cache_miss_tail,(void)): PROLOGUE + mr r3,r6 bl MANGLE(inline_cache_miss) EPILOGUE mtctr r3 diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index d393223d8d..ae7f93ebf7 100755 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -7,11 +7,22 @@ namespace factor register cell ds asm("r13"); register cell rs asm("r14"); +/* In the instruction sequence: + + LOAD32 r3,... + B blah + + the offset from the immediate operand to LOAD32 to the instruction after + the branch is two instructions. */ +static const fixnum xt_tail_pic_offset = 4 * 2; + inline static void check_call_site(cell return_address) { #ifdef FACTOR_DEBUG cell insn = *(cell *)return_address; - assert((insn & 0x3) == 0x1); + /* Check that absolute bit is 0 */ + assert((insn & 0x2) == 0x0); + /* Check that instruction is branch */ assert((insn >> 26) == 0x12); #endif } @@ -21,8 +32,8 @@ inline static void check_call_site(cell return_address) inline static void *get_call_target(cell return_address) { return_address -= sizeof(cell); - check_call_site(return_address); + cell insn = *(cell *)return_address; cell unsigned_addr = (insn & B_MASK); fixnum signed_addr = (fixnum)(unsigned_addr << 6) >> 6; @@ -32,19 +43,25 @@ inline static void *get_call_target(cell return_address) inline static void set_call_target(cell return_address, void *target) { return_address -= sizeof(cell); - -#ifdef FACTOR_DEBUG - assert((return_address & ~B_MASK) == 0); check_call_site(return_address); -#endif + cell insn = *(cell *)return_address; - insn = ((insn & ~B_MASK) | (((cell)target - return_address) & B_MASK)); + + fixnum relative_address = ((cell)target - return_address); + insn = ((insn & ~B_MASK) | (relative_address & B_MASK)); *(cell *)return_address = insn; /* Flush the cache line containing the call we just patched */ __asm__ __volatile__ ("icbi 0, %0\n" "sync\n"::"r" (return_address):); } +inline static bool tail_call_site_p(cell return_address) +{ + return_address -= sizeof(cell); + cell insn = *(cell *)return_address; + return (insn & 0x1) == 0; +} + /* Defined in assembly */ VM_ASM_API void c_to_factor(cell quot); VM_ASM_API void throw_impl(cell quot, stack_frame *rewind); From 7fc5dfab3d68622e651e5b39af77b1d1abea85da Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 7 May 2009 19:53:56 -0500 Subject: [PATCH 097/210] slow, ugly, unoptimized terrain generation demo --- extra/game-loop/game-loop.factor | 4 +- extra/terrain/generation/generation.factor | 60 +++++++ extra/terrain/shaders/shaders.factor | 46 +++++ extra/terrain/terrain.factor | 190 +++++++++++++++++++++ 4 files changed, 298 insertions(+), 2 deletions(-) create mode 100644 extra/terrain/generation/generation.factor create mode 100644 extra/terrain/shaders/shaders.factor create mode 100644 extra/terrain/terrain.factor diff --git a/extra/game-loop/game-loop.factor b/extra/game-loop/game-loop.factor index 8e7c7017d4..8abbe6ba25 100644 --- a/extra/game-loop/game-loop.factor +++ b/extra/game-loop/game-loop.factor @@ -1,4 +1,4 @@ -USING: accessors destructors kernel math math.order namespaces +USING: accessors calendar destructors kernel math math.order namespaces system threads ; IN: game-loop @@ -50,7 +50,7 @@ CONSTANT: MAX-FRAMES-TO-SKIP 5 : (run-loop) ( loop -- ) dup running?>> - [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ yield (run-loop) ] tri ] + [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ 1 milliseconds sleep (run-loop) ] tri ] [ drop ] if ; : run-loop ( loop -- ) diff --git a/extra/terrain/generation/generation.factor b/extra/terrain/generation/generation.factor new file mode 100644 index 0000000000..18f73e8e8b --- /dev/null +++ b/extra/terrain/generation/generation.factor @@ -0,0 +1,60 @@ +USING: accessors arrays byte-arrays combinators fry grouping +images kernel math math.affine-transforms math.order +math.vectors noise random sequences ; +IN: terrain.generation + +CONSTANT: terrain-segment-size { 512 512 } +CONSTANT: terrain-big-noise-scale { 0.002 0.002 } +CONSTANT: terrain-small-noise-scale { 0.05 0.05 } + +TUPLE: terrain big-noise-table small-noise-table tiny-noise-seed ; + +: ( -- terrain ) + + 32 random-bits terrain boa ; + +: seed-at ( seed at -- seed' ) + first2 [ + ] dip [ 32 random-bits + ] curry with-seed ; + +: big-noise-segment ( terrain at -- map ) + [ big-noise-table>> terrain-big-noise-scale first2 ] dip + terrain-segment-size [ v* a. ] keep perlin-noise-byte-map ; +: small-noise-segment ( terrain at -- map ) + [ small-noise-table>> terrain-small-noise-scale first2 ] dip + terrain-segment-size [ v* a. ] keep perlin-noise-byte-map ; +: tiny-noise-segment ( terrain at -- map ) + [ tiny-noise-seed>> ] dip seed-at 0.1 + terrain-segment-size normal-noise-byte-map ; + +: padding ( terrain at -- padding ) + 2drop terrain-segment-size product 255 ; + +TUPLE: segment image ; + +: terrain-segment ( terrain at -- image ) + { + [ big-noise-segment ] + [ small-noise-segment ] + [ tiny-noise-segment ] + [ padding ] + } 2cleave + 4array flip concat >byte-array + [ terrain-segment-size RGBA f ] dip image boa ; + +: 4max ( a b c d -- max ) + max max max ; inline + +: mipmap ( {{pixels}} quot: ( aa ab ba bb -- c ) -- pixels' ) + [ [ 2 ] map 2 ] dip + '[ first2 [ [ first2 ] bi@ @ ] 2map ] map ; inline + +: group-pixels ( bitmap dim -- scanlines ) + [ 4 ] [ first ] bi* ; + +: concat-pixels ( scanlines -- bitmap ) + [ concat ] map concat ; + +: segment-mipmap ( image -- image' ) + [ clone ] [ bitmap>> ] [ dim>> ] tri + group-pixels [ 4max ] mipmap concat-pixels >>bitmap + [ 2 v/n ] change-dim ; diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor new file mode 100644 index 0000000000..2dc793f078 --- /dev/null +++ b/extra/terrain/shaders/shaders.factor @@ -0,0 +1,46 @@ +USING: multiline ; +IN: terrain.shaders + +STRING: terrain-vertex-shader + +uniform sampler2D heightmap; + +varying vec2 heightcoords; + +const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0); + +float height(sampler2D map, vec2 coords) +{ + vec4 v = texture2D(map, coords); + return dot(v, COMPONENT_SCALE); +} + +void main() +{ + gl_Position = gl_ModelViewProjectionMatrix + * (gl_Vertex + vec4(0, height(heightmap, gl_Vertex.xz), 0, 0)); + heightcoords = gl_Vertex.xz; +} + +; + +STRING: terrain-pixel-shader + +uniform sampler2D heightmap; + +varying vec2 heightcoords; + +const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0); + +float height(sampler2D map, vec2 coords) +{ + vec4 v = texture2D(map, coords); + return dot(v, COMPONENT_SCALE); +} + +void main() +{ + gl_FragColor = texture2D(heightmap, heightcoords); +} + +; diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor new file mode 100644 index 0000000000..725848abb7 --- /dev/null +++ b/extra/terrain/terrain.factor @@ -0,0 +1,190 @@ +USING: accessors arrays combinators game-input +game-input.scancodes game-loop kernel literals locals math +math.constants math.functions math.matrices math.order +math.vectors opengl opengl.capabilities opengl.gl +opengl.shaders opengl.textures opengl.textures.private +sequences sequences.product specialized-arrays.float +terrain.generation terrain.shaders ui ui.gadgets +ui.gadgets.worlds ui.pixel-formats ; +IN: terrain + +CONSTANT: FOV $[ 2.0 sqrt 1+ ] +CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ] +CONSTANT: FAR-PLANE 1.0 +CONSTANT: EYE-START { 0.5 0.5 1.2 } +CONSTANT: TICK-LENGTH $[ 1000 30 /i ] +CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ] +CONSTANT: MOVEMENT-SPEED $[ 1.0 512.0 / ] + +CONSTANT: terrain-vertex-size { 512 512 } +CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] } +CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ] + +TUPLE: terrain-world < world + eye yaw pitch + terrain terrain-segment terrain-texture terrain-program + terrain-vertex-buffer + game-loop ; + +: frustum ( dim -- -x x -y y near far ) + dup first2 min v/n + NEAR-PLANE FOV / v*n first2 [ [ neg ] keep ] bi@ + NEAR-PLANE FAR-PLANE ; + +: set-modelview-matrix ( gadget -- ) + GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear + GL_MODELVIEW glMatrixMode + glLoadIdentity + [ pitch>> 1.0 0.0 0.0 glRotatef ] + [ yaw>> 0.0 1.0 0.0 glRotatef ] + [ eye>> vneg first3 glTranslatef ] tri ; + +: vertex-array-vertex ( x z -- vertex ) + [ terrain-vertex-distance first * ] + [ terrain-vertex-distance second * ] bi* + [ 0 ] dip float-array{ } 3sequence ; + +: vertex-array-row ( z -- vertices ) + dup 1 + 2array + terrain-vertex-size first 1 + iota + 2array [ first2 swap vertex-array-vertex ] product-map + concat ; + +: vertex-array ( -- vertices ) + terrain-vertex-size second iota + [ vertex-array-row ] map concat ; + +: >vertex-buffer ( bytes -- buffer ) + [ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW ; + +: draw-vertex-buffer-row ( i -- ) + [ GL_TRIANGLE_STRIP ] dip + terrain-vertex-row-length * terrain-vertex-row-length + glDrawArrays ; + +: draw-vertex-buffer ( buffer -- ) + [ GL_ARRAY_BUFFER ] dip [ + 3 GL_FLOAT 0 f glVertexPointer + terrain-vertex-size second iota [ draw-vertex-buffer-row ] each + ] with-gl-buffer ; + +: degrees ( deg -- rad ) + pi 180.0 / * ; + +:: eye-rotate ( yaw pitch v -- v' ) + yaw degrees neg :> y + pitch degrees neg :> p + y cos :> cosy + y sin :> siny + p cos :> cosp + p sin :> sinp + + cosy 0.0 siny neg 3array + siny sinp * cosp cosy sinp * 3array + siny cosp * sinp neg cosy cosp * 3array 3array + v swap v.m ; + +: forward-vector ( world -- v ) + [ yaw>> ] [ pitch>> ] bi + { 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ; +: rightward-vector ( world -- v ) + [ yaw>> ] [ pitch>> ] bi + { $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ; + +: move-forward ( world -- ) + dup forward-vector [ v+ ] curry change-eye drop ; +: move-backward ( world -- ) + dup forward-vector [ v- ] curry change-eye drop ; +: move-leftward ( world -- ) + dup rightward-vector [ v- ] curry change-eye drop ; +: move-rightward ( world -- ) + dup rightward-vector [ v+ ] curry change-eye drop ; + +: rotate-with-mouse ( world mouse -- ) + [ dx>> MOUSE-SCALE * [ + ] curry change-yaw ] + [ dy>> MOUSE-SCALE * [ + ] curry change-pitch ] bi + drop ; + +:: handle-input ( world -- ) + read-keyboard keys>> :> keys + key-w keys nth [ world move-forward ] when + key-s keys nth [ world move-backward ] when + key-a keys nth [ world move-leftward ] when + key-d keys nth [ world move-rightward ] when + world read-mouse rotate-with-mouse + reset-mouse ; + +M: terrain-world tick* + [ handle-input ] keep + ! [ eye>> ] [ yaw>> ] [ pitch>> ] tri 3array P ! debug + drop ; + +M: terrain-world draw* + nip draw-world ; + +: set-heightmap-texture-parameters ( texture -- ) + GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit + GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri ; + +M: terrain-world begin-world + "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" } + require-gl-version-or-extensions + GL_DEPTH_TEST glEnable + GL_TEXTURE_2D glEnable + GL_VERTEX_ARRAY glEnableClientState + 0.5 0.5 0.5 1.0 glClearColor + EYE-START >>eye + 0.0 >>yaw + 0.0 >>pitch + [ >>terrain ] keep + { 0 0 } terrain-segment [ >>terrain-segment ] keep + make-texture [ set-heightmap-texture-parameters ] keep >>terrain-texture + terrain-vertex-shader terrain-pixel-shader + >>terrain-program + vertex-array >vertex-buffer >>terrain-vertex-buffer + TICK-LENGTH over [ >>game-loop ] keep start-loop + reset-mouse + drop ; + +M: terrain-world end-world + { + [ game-loop>> stop-loop ] + [ terrain-vertex-buffer>> delete-gl-buffer ] + [ terrain-program>> delete-gl-program ] + [ terrain-texture>> delete-texture ] + } cleave ; + +M: terrain-world resize-world + GL_PROJECTION glMatrixMode + glLoadIdentity + dim>> [ [ 0 0 ] dip first2 glViewport ] + [ frustum glFrustum ] bi ; + +M: terrain-world draw-world* + [ set-modelview-matrix ] + [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ] + [ dup terrain-program>> [ + "heightmap" glGetUniformLocation 0 glUniform1i + terrain-vertex-buffer>> draw-vertex-buffer + ] with-gl-program ] + tri gl-error ; + +M: terrain-world focusable-child* drop t ; +M: terrain-world pref-dim* drop { 640 480 } ; + +: terrain-window ( -- ) + [ + open-game-input + f T{ world-attributes + { world-class terrain-world } + { title "Terrain" } + { pixel-format-attributes { + windowed + double-buffered + T{ depth-bits { value 24 } } + } } + } open-window + ] with-ui ; From 9c69295b2242acf1f581c75001e6c991bc5e7839 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 21:23:58 -0400 Subject: [PATCH 098/210] Speed up best-hands a bit using reduce and add a test --- basis/math/combinatorics/combinatorics.factor | 7 +++++++ extra/poker/poker-tests.factor | 2 ++ extra/poker/poker.factor | 6 +++--- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index 5bda23f738..bc09f9fe0f 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -116,3 +116,10 @@ PRIVATE> [ [ choose [0,b) ] keep ] dip '[ _ apply-combination @ ] each ; inline +: map-combinations ( seq k quot -- ) + [ [ choose [0,b) ] keep ] dip + '[ _ apply-combination @ ] map ; inline + +: reduce-combinations ( seq k identity quot -- result ) + [ -rot ] dip each-combination ; inline + diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor index e2d89620e6..3c8e5159ab 100644 --- a/extra/poker/poker-tests.factor +++ b/extra/poker/poker-tests.factor @@ -26,3 +26,5 @@ IN: poker.tests [ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ = ] unit-test [ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ eq? ] unit-test + +[ 190 ] [ "AS KD JC KH 2D 2S KH" best-hand value>> ] unit-test diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index b7661b83db..baebb25572 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -179,7 +179,7 @@ PRIVATE> TUPLE: hand { cards sequence } - { value integer } ; + { value integer initial: 9999 } ; M: hand <=> [ value>> ] compare ; M: hand equal? @@ -189,8 +189,8 @@ M: hand equal? parse-cards dup hand-value hand boa ; : best-hand ( str -- hand ) - parse-cards 5 all-combinations - [ dup hand-value hand boa ] map infimum ; + parse-cards 5 hand new + [ dup hand-value hand boa min ] reduce-combinations ; : >cards ( hand -- str ) cards>> [ card>string ] map " " join ; From b70160088d80b7466dc152585fd723f495440c55 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 20:52:16 -0500 Subject: [PATCH 099/210] math.miller-rabin: make some utilities not private since math.primes uses them --- basis/math/miller-rabin/miller-rabin.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor index 9fd604a003..88c01d5271 100755 --- a/basis/math/miller-rabin/miller-rabin.factor +++ b/basis/math/miller-rabin/miller-rabin.factor @@ -5,8 +5,6 @@ random sequences sets combinators.short-circuit math.bitwise math math.order ; IN: math.miller-rabin -odd ( n -- int ) 0 set-bit ; foldable : >even ( n -- int ) 0 clear-bit ; foldable @@ -15,7 +13,7 @@ IN: math.miller-rabin : next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; -TUPLE: positive-even-expected n ; + n-1 From 16bddcb91e8abae952a5f01c00d5b709403a3654 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 20:52:39 -0500 Subject: [PATCH 100/210] images.viewer: you can now pass a pathname object to image-window and image. words --- extra/images/viewer/viewer.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index b891142d5b..b41dae9b38 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -25,7 +25,7 @@ M: image M: string load-image ; -M: pathname load-image ; +M: pathname string>> load-image ; : image-window ( object -- ) "Image" open-window ; From 2e774cd3378f43baade2c0f941a569be87a6ea42 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 21:25:55 -0500 Subject: [PATCH 101/210] io.launcher.windows.nt: update unit tests for recent changes to lines and contents words --- basis/io/launcher/windows/nt/nt-tests.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor index 53b3d3ce7e..4587556e0c 100755 --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -42,7 +42,7 @@ IN: io.launcher.windows.nt.tests console-vm "-run=listener" 2array >>command +closed+ >>stdin +stdout+ >>stderr - ascii [ input-stream get contents ] with-process-reader + ascii [ contents ] with-process-reader ] unit-test : launcher-test-path ( -- str ) @@ -85,7 +85,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "stderr.factor" 3array >>command "err2.txt" temp-file >>stderr - ascii lines first + ascii stream-lines first ] with-directory ] unit-test @@ -97,7 +97,7 @@ IN: io.launcher.windows.nt.tests launcher-test-path [ console-vm "-script" "env.factor" 3array >>command - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) os-envs = @@ -109,7 +109,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command +replace-environment+ >>environment-mode os-envs >>environment - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) os-envs = @@ -120,7 +120,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command { { "A" "B" } } >>environment - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) "A" swap at @@ -132,7 +132,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command { { "USERPROFILE" "XXX" } } >>environment +prepend-environment+ >>environment-mode - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) "USERPROFILE" swap at "XXX" = From e173f136a8ac738eb81ac83dbca1436d7714a7a7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 21:26:29 -0500 Subject: [PATCH 102/210] io.backend.windows.privileges: clean up code and fix inference problem --- .../backend/windows/privileges/privileges-tests.factor | 4 ++++ basis/io/backend/windows/privileges/privileges.factor | 9 +++++---- 2 files changed, 9 insertions(+), 4 deletions(-) create mode 100755 basis/io/backend/windows/privileges/privileges-tests.factor mode change 100644 => 100755 basis/io/backend/windows/privileges/privileges.factor diff --git a/basis/io/backend/windows/privileges/privileges-tests.factor b/basis/io/backend/windows/privileges/privileges-tests.factor new file mode 100755 index 0000000000..7237651b80 --- /dev/null +++ b/basis/io/backend/windows/privileges/privileges-tests.factor @@ -0,0 +1,4 @@ +IN: io.backend.windows.privileges.tests +USING: io.backend.windows.privileges tools.test ; + +[ [ ] with-privileges ] must-infer diff --git a/basis/io/backend/windows/privileges/privileges.factor b/basis/io/backend/windows/privileges/privileges.factor old mode 100644 new mode 100755 index 8661ba99d9..58806cc4df --- a/basis/io/backend/windows/privileges/privileges.factor +++ b/basis/io/backend/windows/privileges/privileges.factor @@ -1,12 +1,13 @@ USING: io.backend kernel continuations sequences -system vocabs.loader combinators ; +system vocabs.loader combinators fry ; IN: io.backend.windows.privileges -HOOK: set-privilege io-backend ( name ? -- ) inline +HOOK: set-privilege io-backend ( name ? -- ) : with-privileges ( seq quot -- ) - over [ [ t set-privilege ] each ] curry compose - swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline + [ '[ _ [ t set-privilege ] each @ ] ] + [ drop '[ _ [ f set-privilege ] each ] ] + 2bi [ ] cleanup ; inline { { [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] } From b7b27e81a40a7345e469a30f9d2ae09bda523db5 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 23:11:44 -0400 Subject: [PATCH 103/210] Fix typo in poker test/doc example --- extra/poker/poker-docs.factor | 2 +- extra/poker/poker-tests.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor index 388239d549..fef47b859c 100644 --- a/extra/poker/poker-docs.factor +++ b/extra/poker/poker-docs.factor @@ -17,7 +17,7 @@ HELP: best-hand { $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." } { $examples { $example "USING: kernel poker prettyprint ;" - "\"AS KD JC KH 2D 2S KH\" best-hand >value ." "\"Full House\"" } + "\"AS KD JC KH 2D 2S KC\" best-hand >value ." "\"Full House\"" } } ; HELP: >cards diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor index 3c8e5159ab..6b05178462 100644 --- a/extra/poker/poker-tests.factor +++ b/extra/poker/poker-tests.factor @@ -27,4 +27,4 @@ IN: poker.tests [ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ = ] unit-test [ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ eq? ] unit-test -[ 190 ] [ "AS KD JC KH 2D 2S KH" best-hand value>> ] unit-test +[ 190 ] [ "AS KD JC KH 2D 2S KC" best-hand value>> ] unit-test From 5e35f19312e49fb26509afc8166eb45a5e4fc634 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 23:18:41 -0500 Subject: [PATCH 104/210] cpu.ppc: bools are 4 bytes on OS X/PowerPC --- basis/cpu/ppc/ppc.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index beee48e5ea..5a528ddd5a 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -713,3 +713,4 @@ USE: vocabs.loader } cond "complex-double" c-type t >>return-in-registers? drop +"bool" c-type 4 >>size 4 >>align drop \ No newline at end of file From e007cb56e853c02c39f6a1215ecafd6354034a8b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 23:26:33 -0500 Subject: [PATCH 105/210] cpu.ppc: fix alien-indirect --- basis/cpu/ppc/ppc.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index beee48e5ea..13e19d4f0e 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -652,10 +652,10 @@ M: ppc %alien-callback ( quot -- ) M: ppc %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke - 13 3 MR ; + 15 3 MR ; M: ppc %alien-indirect ( -- ) - 13 MTLR BLRL ; + 15 MTLR BLRL ; M: ppc %callback-value ( ctype -- ) ! Save top of data stack From 83c162adbb7fb960c7c26db921a612922dff09d9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 00:20:54 -0500 Subject: [PATCH 106/210] Remove silly retry word from continuations vocab --- basis/io/files/unique/unique.factor | 3 +++ core/continuations/continuations-docs.factor | 16 ---------------- core/continuations/continuations.factor | 2 -- extra/webapps/wee-url/wee-url.factor | 3 +++ 4 files changed, 6 insertions(+), 18 deletions(-) diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor index 0e4338e3e0..a7ae317668 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -35,6 +35,9 @@ SYMBOL: unique-retries : random-name ( -- string ) unique-length get [ random-ch ] "" replicate-as ; +: retry ( quot: ( -- ? ) n -- ) + swap [ drop ] prepose attempt-all ; inline + : (make-unique-file) ( path prefix suffix -- path ) '[ _ _ _ random-name glue append-path diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 2c91981f13..fa8ecbe385 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -79,7 +79,6 @@ $nl { $subsection continue-with } "Continuations as control-flow:" { $subsection attempt-all } -{ $subsection retry } { $subsection with-return } "Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "." { $subsection "continuations.private" } ; @@ -232,21 +231,6 @@ HELP: attempt-all } } ; -HELP: retry -{ $values - { "quot" quotation } { "n" integer } -} -{ $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 - "Try to get a 0 as a random number:" - { $unchecked-example "USING: continuations math prettyprint random ;" - "[ 5 random 0 = ] 5 retry" - "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 56ac4a71e9..7681c2b089 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -155,8 +155,6 @@ 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 ) diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor index bc429a0af6..8e200a4452 100644 --- a/extra/webapps/wee-url/wee-url.factor +++ b/extra/webapps/wee-url/wee-url.factor @@ -26,6 +26,9 @@ short-url "SHORT_URLS" { : random-url ( -- string ) 1 6 [a,b] random [ letter-bank random ] "" replicate-as ; +: retry ( quot: ( -- ? ) n -- ) + swap [ drop ] prepose attempt-all ; inline + : insert-short-url ( short-url -- short-url ) '[ _ dup random-url >>short insert-tuple ] 10 retry ; From e4216cc4baf647538181f58c9aa14004f09f9094 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 00:41:42 -0500 Subject: [PATCH 107/210] Retry uploads etc up to 5 times so that we don't lose a good binary if network is flaky; put git id in subject --- extra/mason/build/build.factor | 11 +++++++---- extra/mason/common/common.factor | 13 ++++++++++--- extra/mason/email/email.factor | 8 ++++---- extra/mason/release/branch/branch.factor | 10 +++++----- extra/mason/report/report.factor | 2 +- 5 files changed, 27 insertions(+), 17 deletions(-) diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor index 199d48dec0..5031b5d930 100644 --- a/extra/mason/build/build.factor +++ b/extra/mason/build/build.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel calendar io.directories io.encodings.utf8 -io.files io.launcher mason.child mason.cleanup mason.common -mason.help mason.release mason.report mason.email mason.notify -namespaces prettyprint ; +io.files io.launcher namespaces prettyprint mason.child mason.cleanup +mason.common mason.help mason.release mason.report mason.email +mason.notify ; IN: mason.build QUALIFIED: continuations @@ -19,7 +19,10 @@ QUALIFIED: continuations : begin-build ( -- ) "factor" [ git-id ] with-directory - [ "git-id" to-file ] [ notify-begin-build ] bi ; + [ "git-id" to-file ] + [ current-git-id set ] + [ notify-begin-build ] + tri ; : build ( -- ) create-build-dir diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index e4a9d9da13..d020c68fc4 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -4,9 +4,12 @@ USING: kernel namespaces sequences splitting system accessors math.functions make io io.files io.pathnames io.directories io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint combinators.short-circuit parser combinators calendar -calendar.format arrays mason.config locals system debugger ; +calendar.format arrays mason.config locals system debugger fry +continuations ; IN: mason.common +SYMBOL: current-git-id + ERROR: output-process-error output process ; M: output-process-error error. @@ -35,15 +38,19 @@ M: unix really-delete-tree delete-tree ; swap >>command 15 minutes >>timeout + +closed+ >>stdin try-output-process ; +: retry ( n quot -- ) + '[ drop @ f ] attempt-all drop ; inline + :: upload-safely ( local username host remote -- ) [let* | temp [ remote ".incomplete" append ] scp-remote [ { username "@" host ":" temp } concat ] scp [ scp-command get ] ssh [ ssh-command get ] | - { scp local scp-remote } short-running-process - { ssh host "-l" username "mv" temp remote } short-running-process + 5 [ { scp local scp-remote } short-running-process ] retry + 5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry ] ; : eval-file ( file -- obj ) diff --git a/extra/mason/email/email.factor b/extra/mason/email/email.factor index 23203e5222..302df599b4 100644 --- a/extra/mason/email/email.factor +++ b/extra/mason/email/email.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces accessors combinators make smtp debugger -prettyprint io io.streams.string io.encodings.utf8 io.files io.sockets -mason.common mason.platform mason.config ; +prettyprint sequences io io.streams.string io.encodings.utf8 io.files +io.sockets mason.common mason.platform mason.config ; IN: mason.email : prefix-subject ( str -- str' ) @@ -18,11 +18,11 @@ IN: mason.email send-email ; : subject ( status -- str ) - { + [ current-git-id get 7 short head " -- " ] dip { { status-clean [ "clean" ] } { status-dirty [ "dirty" ] } { status-error [ "error" ] } - } case ; + } case 3append ; : email-report ( report status -- ) [ "text/html" ] dip subject email-status ; diff --git a/extra/mason/release/branch/branch.factor b/extra/mason/release/branch/branch.factor index 75ce828c28..07ec5a8bcd 100644 --- a/extra/mason/release/branch/branch.factor +++ b/extra/mason/release/branch/branch.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.directories io.files io.launcher kernel make -mason.common mason.config mason.platform namespaces prettyprint -sequences ; +namespaces prettyprint sequences mason.common mason.config +mason.platform ; IN: mason.release.branch : branch-name ( -- string ) "clean-" platform append ; @@ -21,7 +21,7 @@ IN: mason.release.branch ] { } make ; : push-to-clean-branch ( -- ) - push-to-clean-branch-cmd short-running-process ; + 5 [ push-to-clean-branch-cmd short-running-process ] retry ; : upload-clean-image-cmd ( -- args ) [ @@ -36,7 +36,7 @@ IN: mason.release.branch ] { } make ; : upload-clean-image ( -- ) - upload-clean-image-cmd short-running-process ; + 5 [ upload-clean-image-cmd short-running-process ] retry ; : (update-clean-branch) ( -- ) "factor" [ diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 7707d16299..0340941449 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -12,7 +12,7 @@ IN: mason.report target-cpu get host-name build-dir - "git-id" eval-file + current-git-id get [XML

Build report for <->/<->

From 282c58c572c01112fe65783df5313367836cbbb8 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 8 May 2009 02:24:12 -0400 Subject: [PATCH 108/210] Make lookup indices zero-based for poker values --- extra/poker/poker.factor | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index baebb25572..a5a5a93628 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -49,21 +49,21 @@ CONSTANT: QUEEN 10 CONSTANT: KING 11 CONSTANT: ACE 12 -CONSTANT: STRAIGHT_FLUSH 1 -CONSTANT: FOUR_OF_A_KIND 2 -CONSTANT: FULL_HOUSE 3 -CONSTANT: FLUSH 4 -CONSTANT: STRAIGHT 5 -CONSTANT: THREE_OF_A_KIND 6 -CONSTANT: TWO_PAIR 7 -CONSTANT: ONE_PAIR 8 -CONSTANT: HIGH_CARD 9 +CONSTANT: STRAIGHT_FLUSH 0 +CONSTANT: FOUR_OF_A_KIND 1 +CONSTANT: FULL_HOUSE 2 +CONSTANT: FLUSH 3 +CONSTANT: STRAIGHT 4 +CONSTANT: THREE_OF_A_KIND 5 +CONSTANT: TWO_PAIR 6 +CONSTANT: ONE_PAIR 7 +CONSTANT: HIGH_CARD 8 CONSTANT: SUIT_STR { "C" "D" "H" "S" } CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" } -CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" +CONSTANT: VALUE_STR { "Straight Flush" "Four of a Kind" "Full House" "Flush" "Straight" "Three of a Kind" "Two Pair" "One Pair" "High Card" } : card-rank-prime ( rank -- n ) @@ -159,8 +159,8 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" [ drop "S" ] } cond ; -: hand-rank ( hand -- rank ) - value>> { +: hand-rank ( value -- rank ) + { { [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card { [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair { [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair @@ -196,7 +196,7 @@ M: hand equal? cards>> [ card>string ] map " " join ; : >value ( hand -- str ) - hand-rank VALUE_STR nth ; + value>> hand-rank VALUE_STR nth ; TUPLE: deck { cards sequence } ; From 3aab93e2787df7e1de032da977e44afaa95c36b9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 02:26:05 -0500 Subject: [PATCH 109/210] mason.email: fix unit test --- extra/mason/email/email-tests.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/mason/email/email-tests.factor b/extra/mason/email/email-tests.factor index e2afe01a56..5f48ff0d4f 100644 --- a/extra/mason/email/email-tests.factor +++ b/extra/mason/email/email-tests.factor @@ -1,10 +1,11 @@ IN: mason.email.tests USING: mason.email mason.common mason.config namespaces tools.test ; -[ "mason on linux-x86-64: error" ] [ +[ "mason on linux-x86-64: 12345 -- error" ] [ [ "linux" target-os set "x86.64" target-cpu set + "12345" current-git-id set status-error subject prefix-subject ] with-scope ] unit-test From 3174e81f98352fa5ddc54fe7ef40b370a378f0d8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 02:35:46 -0500 Subject: [PATCH 110/210] tools.deploy.shaker: strip out a few more things --- basis/tools/deploy/shaker/shaker.factor | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index e8f4238ed6..816dbb7979 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -23,7 +23,13 @@ IN: tools.deploy.shaker : strip-init-hooks ( -- ) "Stripping startup hooks" show - { "cpu.x86" "command-line" "libc" "system" "environment" } + { + "command-line" + "cpu.x86" + "environment" + "libc" + "alien.strings" + } [ init-hooks get delete-at ] each deploy-threads? get [ "threads" init-hooks get delete-at @@ -36,8 +42,12 @@ IN: tools.deploy.shaker "io.backend" init-hooks get delete-at ] when strip-dictionary? [ - "compiler.units" init-hooks get delete-at - "vocabs.cache" init-hooks get delete-at + { + "compiler.units" + "vocabs" + "vocabs.cache" + "source-files.errors" + } [ init-hooks get delete-at ] each ] when ; : strip-debugger ( -- ) @@ -260,21 +270,20 @@ IN: tools.deploy.shaker compiler.errors:compiler-errors definition-observers interactive-vocabs - layouts:num-tags - layouts:num-types - layouts:tag-mask - layouts:tag-numbers - layouts:type-numbers lexer-factory print-use-hook root-cache source-files.errors:error-types + source-files.errors:error-observers vocabs:dictionary vocabs:load-vocab-hook + vocabs:vocab-observers word parser-notes } % + { } { "layouts" } strip-vocab-globals % + { } { "math.partial-dispatch" } strip-vocab-globals % { } { "peg" } strip-vocab-globals % From ca3669e7b398ccbc365e08a94e406f482bfd8633 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 02:36:09 -0500 Subject: [PATCH 111/210] Deploy hello-world with optimizing compiler since the image is smaller as a result, and this makes it pass the size test again --- extra/hello-world/deploy.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 48c14f7cba..aadffb6ae8 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-name "Hello world (console)" } - { deploy-c-types? f } - { deploy-word-props? f } - { deploy-ui? f } - { deploy-reflection 1 } - { deploy-compiler? f } { deploy-unicode? f } + { deploy-ui? f } + { deploy-compiler? t } + { deploy-name "Hello world (console)" } { deploy-io 2 } - { deploy-word-defs? f } { deploy-threads? f } - { "stop-after-last-window?" t } + { deploy-reflection 1 } { deploy-math? f } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } } From a2abe1753f763b777a7d5e10d0d65d572442acb4 Mon Sep 17 00:00:00 2001 From: Diego Martinelli Date: Fri, 8 May 2009 10:33:20 +0200 Subject: [PATCH 112/210] Initial commit --- extra/hashcash/authors.txt | 0 extra/hashcash/hashcash.factor | 4 ++++ 2 files changed, 4 insertions(+) create mode 100755 extra/hashcash/authors.txt create mode 100755 extra/hashcash/hashcash.factor diff --git a/extra/hashcash/authors.txt b/extra/hashcash/authors.txt new file mode 100755 index 0000000000..e69de29bb2 diff --git a/extra/hashcash/hashcash.factor b/extra/hashcash/hashcash.factor new file mode 100755 index 0000000000..fe7cf10bd3 --- /dev/null +++ b/extra/hashcash/hashcash.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2009 Your name. +! See http://factorcode.org/license.txt for BSD license. +USING: ; +IN: hashcash From a3257918b0d6f9611b30808bddeec88691de6176 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 09:51:57 -0500 Subject: [PATCH 113/210] cleaning up sha2 --- basis/checksums/sha2/sha2.factor | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 3b092a78de..b4b787a2b7 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -2,12 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel splitting grouping math sequences namespaces make io.binary math.bitwise checksums checksums.common -sbufs strings ; +sbufs strings combinators.smart ; IN: checksums.sha2 Date: Fri, 8 May 2009 10:04:31 -0500 Subject: [PATCH 114/210] more refactoring on sha2 --- basis/checksums/sha2/sha2.factor | 40 ++++++++++++++++++-------------- 1 file changed, 22 insertions(+), 18 deletions(-) diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index b4b787a2b7..57a1db5ac1 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel splitting grouping math sequences namespaces make io.binary math.bitwise checksums checksums.common -sbufs strings combinators.smart ; +sbufs strings combinators.smart math.ranges fry combinators ; IN: checksums.sha2 ] map block-size get 0 pad-tail - dup 16 64 dup [ - process-M-256 - ] with each ; + 16 64 [a,b) over '[ _ process-M-256 ] each ; : ch ( x y z -- x' ) [ bitxor bitand ] keep bitxor ; : maj ( x y z -- x' ) - [ [ bitand ] 2keep bitor ] dip bitand bitor ; + [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; : S0-256 ( x -- x' ) - [ -2 bitroll-32 ] keep - [ -13 bitroll-32 ] keep - -22 bitroll-32 bitxor bitxor ; inline + [ + [ -2 bitroll-32 ] + [ -13 bitroll-32 ] + [ -22 bitroll-32 ] tri + ] [ bitxor ] reduce-outputs ; inline : S1-256 ( x -- x' ) - [ -6 bitroll-32 ] keep - [ -11 bitroll-32 ] keep - -25 bitroll-32 bitxor bitxor ; inline + [ + [ -6 bitroll-32 ] + [ -11 bitroll-32 ] + [ -25 bitroll-32 ] tri + ] [ bitxor ] reduce-outputs ; inline : slice3 ( n seq -- a b c ) [ dup 3 + ] dip first3 ; inline @@ -118,7 +122,7 @@ CONSTANT: K-256 ] with each vars get H get [ w+ ] 2map H set ; : seq>byte-array ( n seq -- string ) - [ swap [ >be % ] curry each ] B{ } make ; + [ swap '[ _ >be % ] each ] B{ } make ; : preprocess-plaintext ( string big-endian? -- padded-string ) #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits From b9bdb888f010a9349ebf87c5dca8c10a38aaa04b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 10:52:25 -0500 Subject: [PATCH 115/210] more refactoring on sha2 --- basis/checksums/sha2/sha2.factor | 114 +++++++++++++++++-------------- 1 file changed, 62 insertions(+), 52 deletions(-) diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 57a1db5ac1..cd67418516 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -2,12 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel splitting grouping math sequences namespaces make io.binary math.bitwise checksums checksums.common -sbufs strings combinators.smart math.ranges fry combinators ; +sbufs strings combinators.smart math.ranges fry combinators +accessors ; IN: checksums.sha2 ] map block-size get 0 pad-tail - 16 64 [a,b) over '[ _ process-M-256 ] each ; - -: ch ( x y z -- x' ) - [ bitxor bitand ] keep bitxor ; - -: maj ( x y z -- x' ) - [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; - : S0-256 ( x -- x' ) [ [ -2 bitroll-32 ] @@ -91,21 +73,42 @@ CONSTANT: K-256 [ -25 bitroll-32 ] tri ] [ bitxor ] reduce-outputs ; inline -: slice3 ( n seq -- a b c ) [ dup 3 + ] dip first3 ; inline +: process-M-256 ( n seq -- ) + { + [ [ 16 - ] dip nth ] + [ [ 15 - ] dip nth s0-256 ] + [ [ 7 - ] dip nth ] + [ [ 2 - ] dip nth s1-256 w+ w+ w+ ] + [ ] + } 2cleave set-nth ; inline -: T1 ( W n -- T1 ) - [ swap nth ] keep - K get nth + - e vars get slice3 ch + - e vars get nth S1-256 + - h vars get nth w+ ; +: ch ( x y z -- x' ) + [ bitxor bitand ] keep bitxor ; -: T2 ( -- T2 ) - a vars get nth S0-256 - a vars get slice3 maj w+ ; +: maj ( x y z -- x' ) + [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; -: update-vars ( T1 T2 -- ) - vars get +: prepare-message-schedule ( seq -- w-seq ) + word-size get [ be> ] map block-size get 0 pad-tail + 16 64 [a,b) over '[ _ process-M-256 ] each ; + +: slice3 ( n seq -- a b c ) + [ dup 3 + ] dip first3 ; inline + +: T1 ( W n H -- T1 ) + [ + [ swap nth ] keep + K-256 nth + + ] dip + [ e swap slice3 ch w+ ] + [ e swap nth S1-256 w+ ] + [ h swap nth w+ ] tri ; + +: T2 ( H -- T2 ) + [ a swap nth S0-256 ] + [ a swap slice3 maj w+ ] bi ; + +: update-H ( T1 T2 H -- ) h g pick exchange g f pick exchange f e pick exchange @@ -115,28 +118,35 @@ CONSTANT: K-256 b a pick exchange [ w+ a ] dip set-nth ; -: process-chunk ( M -- ) - H get clone vars set - prepare-message-schedule block-size get [ - T1 T2 update-vars - ] with each vars get H get [ w+ ] 2map H set ; +: process-chunk ( M block-size H-cloned -- ) + [ + '[ + _ + [ T1 ] + [ T2 ] + [ update-H ] tri + ] with each + ] keep H get [ w+ ] 2map H set ; -: seq>byte-array ( n seq -- string ) - [ swap '[ _ >be % ] each ] B{ } make ; - -: preprocess-plaintext ( string big-endian? -- padded-string ) - #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits - [ >sbuf ] dip over [ +: pad-initial-bytes ( string -- padded-string ) + dup [ HEX: 80 , - dup length HEX: 3f bitand - calculate-pad-length 0 % - length 3 shift 8 rot [ >be ] [ >le ] if % - ] "" make over push-all ; + length + [ HEX: 3f bitand calculate-pad-length 0 % ] + [ 3 shift 8 >be % ] bi + ] "" make append ; + +: seq>byte-array ( seq n -- string ) + '[ _ >be ] map B{ } join ; : byte-array>sha2 ( byte-array -- string ) - t preprocess-plaintext - block-size get group [ process-chunk ] each - 4 H get seq>byte-array ; + pad-initial-bytes + block-size get + [ + prepare-message-schedule + block-size get H get clone process-chunk + ] each + H get 4 seq>byte-array ; PRIVATE> @@ -146,9 +156,9 @@ INSTANCE: sha-256 checksum M: sha-256 checksum-bytes drop [ - K-256 K set initial-H-256 H set 4 word-size set 64 block-size set byte-array>sha2 + ] with-scope ; From ade80c73ada7f7f5e39c691e6c8299b964ba3220 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 May 2009 13:00:34 -0500 Subject: [PATCH 116/210] make open-game-input and close-game-input do reference counting. update demos to show this --- extra/game-input/game-input-docs.factor | 4 +-- extra/game-input/game-input.factor | 48 ++++++++++++++----------- extra/key-caps/key-caps.factor | 5 +-- extra/terrain/terrain.factor | 10 +++--- 4 files changed, 38 insertions(+), 29 deletions(-) diff --git a/extra/game-input/game-input-docs.factor b/extra/game-input/game-input-docs.factor index b46cf9a295..4ef0acdaaf 100755 --- a/extra/game-input/game-input-docs.factor +++ b/extra/game-input/game-input-docs.factor @@ -27,10 +27,10 @@ ARTICLE: "game-input" "Game controller input" { $subsection mouse-state } ; HELP: open-game-input -{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. If the game input interface is already opened, nothing happens." } ; +{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. Calls to open-game-input are reference counted; each call to open-game-input needs a corresponding call to close-game-input to close the game input interface." } ; HELP: close-game-input -{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid. If the game input interface is not opened, nothing happens." } ; +{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid." } ; HELP: game-input-opened? { $values { "?" "a boolean" } } diff --git a/extra/game-input/game-input.factor b/extra/game-input/game-input.factor index 8281b7bc4c..ccf5bd635b 100755 --- a/extra/game-input/game-input.factor +++ b/extra/game-input/game-input.factor @@ -1,34 +1,57 @@ -USING: arrays accessors continuations kernel system +USING: arrays accessors continuations kernel math system sequences namespaces init vocabs vocabs.loader combinators ; IN: game-input SYMBOLS: game-input-backend game-input-opened ; +game-input-opened [ 0 ] initialize + HOOK: (open-game-input) game-input-backend ( -- ) HOOK: (close-game-input) game-input-backend ( -- ) HOOK: (reset-game-input) game-input-backend ( -- ) +HOOK: get-controllers game-input-backend ( -- sequence ) + +HOOK: product-string game-input-backend ( controller -- string ) +HOOK: product-id game-input-backend ( controller -- id ) +HOOK: instance-id game-input-backend ( controller -- id ) + +HOOK: read-controller game-input-backend ( controller -- controller-state ) +HOOK: calibrate-controller game-input-backend ( controller -- ) + +HOOK: read-keyboard game-input-backend ( -- keyboard-state ) + +HOOK: read-mouse game-input-backend ( -- mouse-state ) + +HOOK: reset-mouse game-input-backend ( -- ) + : game-input-opened? ( -- ? ) - game-input-opened get ; + game-input-opened get zero? not ; +ERROR: game-input-not-open ; + : open-game-input ( -- ) game-input-opened? [ (open-game-input) - game-input-opened on - ] unless ; + ] unless + game-input-opened [ 1+ ] change-global + reset-mouse ; : close-game-input ( -- ) + game-input-opened [ + dup zero? [ game-input-not-open ] when + 1- + ] change-global game-input-opened? [ (close-game-input) reset-game-input @@ -48,12 +71,6 @@ SYMBOLS: pov-up pov-up-right pov-right pov-down-right pov-down pov-down-left pov-left pov-up-left ; -HOOK: get-controllers game-input-backend ( -- sequence ) - -HOOK: product-string game-input-backend ( controller -- string ) -HOOK: product-id game-input-backend ( controller -- id ) -HOOK: instance-id game-input-backend ( controller -- id ) - : find-controller-products ( product-id -- sequence ) get-controllers [ product-id = ] with filter ; : find-controller-instance ( product-id instance-id -- controller/f ) @@ -63,25 +80,16 @@ HOOK: instance-id game-input-backend ( controller -- id ) [ instance-id = ] 2bi* and ] with with find nip ; -HOOK: read-controller game-input-backend ( controller -- controller-state ) -HOOK: calibrate-controller game-input-backend ( controller -- ) - TUPLE: keyboard-state keys ; M: keyboard-state clone call-next-method dup keys>> clone >>keys ; -HOOK: read-keyboard game-input-backend ( -- keyboard-state ) - TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ; M: mouse-state clone call-next-method dup buttons>> clone >>buttons ; -HOOK: read-mouse game-input-backend ( -- mouse-state ) - -HOOK: reset-mouse game-input-backend ( -- ) - { { [ os windows? ] [ "game-input.dinput" require ] } { [ os macosx? ] [ "game-input.iokit" require ] } diff --git a/extra/key-caps/key-caps.factor b/extra/key-caps/key-caps.factor index 9f86336f96..b58870fadc 100755 --- a/extra/key-caps/key-caps.factor +++ b/extra/key-caps/key-caps.factor @@ -162,18 +162,19 @@ M: key-caps-gadget pref-dim* drop KEYBOARD-SIZE ; relayout-1 ; M: key-caps-gadget graft* + open-game-input dup '[ _ update-key-caps-state ] FREQUENCY every >>alarm drop ; M: key-caps-gadget ungraft* - alarm>> [ cancel-alarm ] when* ; + alarm>> [ cancel-alarm ] when* + close-game-input ; M: key-caps-gadget handle-gesture drop [ key-down? ] [ key-up? ] bi or not ; : key-caps ( -- ) [ - open-game-input { 5 5 } "Key Caps" open-window ] with-ui ; diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 725848abb7..50c88d6f00 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -10,7 +10,7 @@ IN: terrain CONSTANT: FOV $[ 2.0 sqrt 1+ ] CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ] -CONSTANT: FAR-PLANE 1.0 +CONSTANT: FAR-PLANE 2.0 CONSTANT: EYE-START { 0.5 0.5 1.2 } CONSTANT: TICK-LENGTH $[ 1000 30 /i ] CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ] @@ -126,8 +126,8 @@ M: terrain-world draw* GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri ; + GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ; M: terrain-world begin-world "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" } @@ -146,10 +146,11 @@ M: terrain-world begin-world >>terrain-program vertex-array >vertex-buffer >>terrain-vertex-buffer TICK-LENGTH over [ >>game-loop ] keep start-loop - reset-mouse + open-game-input drop ; M: terrain-world end-world + close-game-input { [ game-loop>> stop-loop ] [ terrain-vertex-buffer>> delete-gl-buffer ] @@ -177,7 +178,6 @@ M: terrain-world pref-dim* drop { 640 480 } ; : terrain-window ( -- ) [ - open-game-input f T{ world-attributes { world-class terrain-world } { title "Terrain" } From 92ae2f7e71c268a459c82022744d0acbb9a88a19 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 15:05:55 -0500 Subject: [PATCH 117/210] VM cleanup: replace some #defines with constants and inline functions --- vm/callstack.cpp | 18 ++++------ vm/callstack.hpp | 2 -- vm/code_block.cpp | 53 ++++++++++++++++++---------- vm/code_block.hpp | 13 +++---- vm/code_gc.cpp | 12 +++---- vm/code_gc.hpp | 6 ++-- vm/contexts.cpp | 6 ++-- vm/cpu-ppc.hpp | 2 +- vm/data_gc.cpp | 83 ++++++++++++++++++++++---------------------- vm/data_gc.hpp | 22 ++++++------ vm/data_heap.cpp | 54 ++++++++++++++-------------- vm/data_heap.hpp | 22 ++++++------ vm/image.cpp | 16 ++++----- vm/image.hpp | 4 +-- vm/layouts.hpp | 26 +++++++++----- vm/math.cpp | 39 +++++++++++++-------- vm/math.hpp | 11 +++--- vm/write_barrier.hpp | 42 +++++++++++----------- 18 files changed, 229 insertions(+), 202 deletions(-) diff --git a/vm/callstack.cpp b/vm/callstack.cpp index d9ac8d6073..e7009183e9 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -24,10 +24,7 @@ void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator) void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator) { - cell top = (cell)FIRST_STACK_FRAME(stack); - cell bottom = top + untag_fixnum(stack->length); - - iterate_callstack(top,bottom,iterator); + iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator); } callstack *allot_callstack(cell size) @@ -75,7 +72,7 @@ PRIMITIVE(callstack) size = 0; callstack *stack = allot_callstack(size); - memcpy(FIRST_STACK_FRAME(stack),top,size); + memcpy(stack->top(),top,size); dpush(tag(stack)); } @@ -84,7 +81,7 @@ PRIMITIVE(set_callstack) callstack *stack = untag_check(dpop()); set_callstack(stack_chain->callstack_bottom, - FIRST_STACK_FRAME(stack), + stack->top(), untag_fixnum(stack->length), memcpy); @@ -173,12 +170,11 @@ PRIMITIVE(callstack_to_array) dpush(tag(frames)); } -stack_frame *innermost_stack_frame(callstack *callstack) +stack_frame *innermost_stack_frame(callstack *stack) { - stack_frame *top = FIRST_STACK_FRAME(callstack); - cell bottom = (cell)top + untag_fixnum(callstack->length); - - stack_frame *frame = (stack_frame *)bottom - 1; + stack_frame *top = stack->top(); + stack_frame *bottom = stack->bottom(); + stack_frame *frame = bottom - 1; while(frame >= top && frame_successor(frame) >= top) frame = frame_successor(frame); diff --git a/vm/callstack.hpp b/vm/callstack.hpp index ec2e8e37d1..a128cfee47 100755 --- a/vm/callstack.hpp +++ b/vm/callstack.hpp @@ -6,8 +6,6 @@ inline static cell callstack_size(cell size) return sizeof(callstack) + size; } -#define FIRST_STACK_FRAME(stack) (stack_frame *)((stack) + 1) - typedef void (*CALLSTACK_ITER)(stack_frame *frame); stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom); diff --git a/vm/code_block.cpp b/vm/code_block.cpp index 083f7f49e6..c34f651750 100755 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -3,6 +3,21 @@ namespace factor { +static relocation_type relocation_type_of(relocation_entry r) +{ + return (relocation_type)((r & 0xf0000000) >> 28); +} + +static relocation_class relocation_class_of(relocation_entry r) +{ + return (relocation_class)((r & 0x0f000000) >> 24); +} + +static cell relocation_offset_of(relocation_entry r) +{ + return (r & 0x00ffffff); +} + void flush_icache_for(code_block *block) { flush_icache((cell)block,block->size); @@ -125,11 +140,11 @@ void *get_rel_symbol(array *literals, cell index) cell compute_relocation(relocation_entry rel, cell index, code_block *compiled) { array *literals = untag(compiled->literals); - cell offset = REL_OFFSET(rel) + (cell)compiled->xt(); + cell offset = relocation_offset_of(rel) + (cell)compiled->xt(); #define ARG array_nth(literals,index) - switch(REL_TYPE(rel)) + switch(relocation_type_of(rel)) { case RT_PRIMITIVE: return (cell)primitives[untag_fixnum(ARG)]; @@ -174,7 +189,7 @@ void iterate_relocations(code_block *compiled, relocation_iterator iter) { relocation_entry rel = relocation->data()[i]; iter(rel,index,compiled); - index += number_of_parameters(REL_TYPE(rel)); + index += number_of_parameters(relocation_type_of(rel)); } } } @@ -217,25 +232,25 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value) store_address_2_2((cell *)offset,absolute_value); break; case RC_ABSOLUTE_PPC_2: - store_address_masked((cell *)offset,absolute_value,REL_ABSOLUTE_PPC_2_MASK,0); + store_address_masked((cell *)offset,absolute_value,rel_absolute_ppc_2_mask,0); break; case RC_RELATIVE_PPC_2: - store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0); + store_address_masked((cell *)offset,relative_value,rel_relative_ppc_2_mask,0); break; case RC_RELATIVE_PPC_3: - store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_3_MASK,0); + store_address_masked((cell *)offset,relative_value,rel_relative_ppc_3_mask,0); break; case RC_RELATIVE_ARM_3: store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2, - REL_RELATIVE_ARM_3_MASK,2); + rel_relative_arm_3_mask,2); break; case RC_INDIRECT_ARM: store_address_masked((cell *)offset,relative_value - sizeof(cell), - REL_INDIRECT_ARM_MASK,0); + rel_indirect_arm_mask,0); break; case RC_INDIRECT_ARM_PC: store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2, - REL_INDIRECT_ARM_MASK,0); + rel_indirect_arm_mask,0); break; default: critical_error("Bad rel class",klass); @@ -245,12 +260,12 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value) void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled) { - if(REL_TYPE(rel) == RT_IMMEDIATE) + if(relocation_type_of(rel) == RT_IMMEDIATE) { - cell offset = REL_OFFSET(rel) + (cell)(compiled + 1); + cell offset = relocation_offset_of(rel) + (cell)(compiled + 1); array *literals = untag(compiled->literals); fixnum absolute_value = array_nth(literals,index); - store_address_in_code_block(REL_CLASS(rel),offset,absolute_value); + store_address_in_code_block(relocation_class_of(rel),offset,absolute_value); } } @@ -297,14 +312,14 @@ void relocate_code_block_step(relocation_entry rel, cell index, code_block *comp tagged(compiled->relocation).untag_check(); #endif - store_address_in_code_block(REL_CLASS(rel), - REL_OFFSET(rel) + (cell)compiled->xt(), + store_address_in_code_block(relocation_class_of(rel), + relocation_offset_of(rel) + (cell)compiled->xt(), compute_relocation(rel,index,compiled)); } void update_word_references_step(relocation_entry rel, cell index, code_block *compiled) { - relocation_type type = REL_TYPE(rel); + relocation_type type = relocation_type_of(rel); if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL) relocate_code_block_step(rel,index,compiled); } @@ -369,7 +384,7 @@ void mark_stack_frame_step(stack_frame *frame) /* Mark code blocks executing in currently active stack frames. */ void mark_active_blocks(context *stacks) { - if(collecting_gen == TENURED) + if(collecting_gen == data->tenured()) { cell top = (cell)stacks->callstack_top; cell bottom = (cell)stacks->callstack_bottom; @@ -410,7 +425,7 @@ void mark_object_code_block(object *object) /* Perform all fixups on a code block */ void relocate_code_block(code_block *compiled) { - compiled->last_scan = NURSERY; + compiled->last_scan = data->nursery(); compiled->needs_fixup = false; iterate_relocations(compiled,relocate_code_block_step); flush_icache_for(compiled); @@ -480,7 +495,7 @@ code_block *add_code_block( /* compiled header */ compiled->type = type; - compiled->last_scan = NURSERY; + compiled->last_scan = data->nursery(); compiled->needs_fixup = true; compiled->relocation = relocation.value(); @@ -499,7 +514,7 @@ code_block *add_code_block( /* next time we do a minor GC, we have to scan the code heap for literals */ - last_code_heap_scan = NURSERY; + last_code_heap_scan = data->nursery(); return compiled; } diff --git a/vm/code_block.hpp b/vm/code_block.hpp index fef5b15da4..d46cd9e885 100644 --- a/vm/code_block.hpp +++ b/vm/code_block.hpp @@ -51,17 +51,14 @@ enum relocation_class { RC_INDIRECT_ARM_PC }; -#define REL_ABSOLUTE_PPC_2_MASK 0xffff -#define REL_RELATIVE_PPC_2_MASK 0xfffc -#define REL_RELATIVE_PPC_3_MASK 0x3fffffc -#define REL_INDIRECT_ARM_MASK 0xfff -#define REL_RELATIVE_ARM_3_MASK 0xffffff +static const cell rel_absolute_ppc_2_mask = 0xffff; +static const cell rel_relative_ppc_2_mask = 0xfffc; +static const cell rel_relative_ppc_3_mask = 0x3fffffc; +static const cell rel_indirect_arm_mask = 0xfff; +static const cell rel_relative_arm_3_mask = 0xffffff; /* code relocation table consists of a table of entries for each fixup */ typedef u32 relocation_entry; -#define REL_TYPE(r) (relocation_type)(((r) & 0xf0000000) >> 28) -#define REL_CLASS(r) (relocation_class)(((r) & 0x0f000000) >> 24) -#define REL_OFFSET(r) ((r) & 0x00ffffff) void flush_icache_for(code_block *compiled); diff --git a/vm/code_gc.cpp b/vm/code_gc.cpp index 48cf8f7661..4710a1baa0 100755 --- a/vm/code_gc.cpp +++ b/vm/code_gc.cpp @@ -22,9 +22,9 @@ void new_heap(heap *heap, cell size) static void add_to_free_list(heap *heap, free_heap_block *block) { - if(block->size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) + if(block->size < free_list_count * block_size_increment) { - int index = block->size / BLOCK_SIZE_INCREMENT; + int index = block->size / block_size_increment; block->next_free = heap->free.small_blocks[index]; heap->free.small_blocks[index] = block; } @@ -45,7 +45,7 @@ void build_free_list(heap *heap, cell size) clear_free_list(heap); - size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1); + size = (size + block_size_increment - 1) & ~(block_size_increment - 1); heap_block *scan = first_block(heap); free_heap_block *end = (free_heap_block *)(heap->seg->start + size); @@ -101,9 +101,9 @@ static free_heap_block *find_free_block(heap *heap, cell size) { cell attempt = size; - while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) + while(attempt < free_list_count * block_size_increment) { - int index = attempt / BLOCK_SIZE_INCREMENT; + int index = attempt / block_size_increment; free_heap_block *block = heap->free.small_blocks[index]; if(block) { @@ -156,7 +156,7 @@ static free_heap_block *split_free_block(heap *heap, free_heap_block *block, cel /* Allocate a block of memory from the mark and sweep GC heap */ heap_block *heap_allot(heap *heap, cell size) { - size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1); + size = (size + block_size_increment - 1) & ~(block_size_increment - 1); free_heap_block *block = find_free_block(heap,size); if(block) diff --git a/vm/code_gc.hpp b/vm/code_gc.hpp index ebd6349ab9..1cfafb69c2 100755 --- a/vm/code_gc.hpp +++ b/vm/code_gc.hpp @@ -1,11 +1,11 @@ namespace factor { -#define FREE_LIST_COUNT 16 -#define BLOCK_SIZE_INCREMENT 32 +static const cell free_list_count = 16; +static const cell block_size_increment = 32; struct heap_free_list { - free_heap_block *small_blocks[FREE_LIST_COUNT]; + free_heap_block *small_blocks[free_list_count]; free_heap_block *large_blocks; }; diff --git a/vm/contexts.cpp b/vm/contexts.cpp index 239b70876a..b0a27ef18f 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -18,12 +18,12 @@ void reset_retainstack() rs = rs_bot - sizeof(cell); } -#define RESERVED (64 * sizeof(cell)) +static const cell stack_reserved = (64 * sizeof(cell)); void fix_stacks() { - if(ds + sizeof(cell) < ds_bot || ds + RESERVED >= ds_top) reset_datastack(); - if(rs + sizeof(cell) < rs_bot || rs + RESERVED >= rs_top) reset_retainstack(); + if(ds + sizeof(cell) < ds_bot || ds + stack_reserved >= ds_top) reset_datastack(); + if(rs + sizeof(cell) < rs_bot || rs + stack_reserved >= rs_top) reset_retainstack(); } /* called before entry into foreign C code. Note that ds and rs might diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index ae7f93ebf7..b256b01c8b 100755 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -27,7 +27,7 @@ inline static void check_call_site(cell return_address) #endif } -#define B_MASK 0x3fffffc +static const cell b_mask = 0x3fffffc; inline static void *get_call_target(cell return_address) { diff --git a/vm/data_gc.cpp b/vm/data_gc.cpp index c9dbe9a953..bcf6387639 100755 --- a/vm/data_gc.cpp +++ b/vm/data_gc.cpp @@ -9,15 +9,15 @@ bool performing_gc; bool performing_compaction; cell collecting_gen; -/* if true, we collecting AGING space for the second time, so if it is still -full, we go on to collect TENURED */ +/* if true, we collecting aging space for the second time, so if it is still +full, we go on to collect tenured */ bool collecting_aging_again; /* in case a generation fills up in the middle of a gc, we jump back up to try collecting the next generation. */ jmp_buf gc_jmp; -gc_stats stats[MAX_GEN_COUNT]; +gc_stats stats[max_gen_count]; u64 cards_scanned; u64 decks_scanned; u64 card_scan_time; @@ -36,7 +36,7 @@ data_heap *old_data_heap; void init_data_gc() { performing_gc = false; - last_code_heap_scan = NURSERY; + last_code_heap_scan = data->nursery(); collecting_aging_again = false; } @@ -66,11 +66,11 @@ static bool should_copy_p(object *untagged) { if(in_zone(newspace,untagged)) return false; - if(collecting_gen == TENURED) + if(collecting_gen == data->tenured()) return true; - else if(HAVE_AGING_P && collecting_gen == AGING) - return !in_zone(&data->generations[TENURED],untagged); - else if(collecting_gen == NURSERY) + else if(data->have_aging_p() && collecting_gen == data->aging()) + return !in_zone(&data->generations[data->tenured()],untagged); + else if(collecting_gen == data->nursery()) return in_zone(&nursery,untagged); else { @@ -186,19 +186,19 @@ static void copy_gen_cards(cell gen) /* if we are collecting the nursery, we care about old->nursery pointers but not old->aging pointers */ - if(collecting_gen == NURSERY) + if(collecting_gen == data->nursery()) { - mask = CARD_POINTS_TO_NURSERY; + mask = card_points_to_nursery; /* after the collection, no old->nursery pointers remain anywhere, but old->aging pointers might remain in tenured space */ - if(gen == TENURED) - unmask = CARD_POINTS_TO_NURSERY; + if(gen == data->tenured()) + unmask = card_points_to_nursery; /* after the collection, all cards in aging space can be cleared */ - else if(HAVE_AGING_P && gen == AGING) - unmask = CARD_MARK_MASK; + else if(data->have_aging_p() && gen == data->aging()) + unmask = card_mark_mask; else { critical_error("bug in copy_gen_cards",gen); @@ -208,20 +208,20 @@ static void copy_gen_cards(cell gen) /* if we are collecting aging space into tenured space, we care about all old->nursery and old->aging pointers. no old->aging pointers can remain */ - else if(HAVE_AGING_P && collecting_gen == AGING) + else if(data->have_aging_p() && collecting_gen == data->aging()) { if(collecting_aging_again) { - mask = CARD_POINTS_TO_AGING; - unmask = CARD_MARK_MASK; + mask = card_points_to_aging; + unmask = card_mark_mask; } /* after we collect aging space into the aging semispace, no old->nursery pointers remain but tenured space might still have pointers to aging space. */ else { - mask = CARD_POINTS_TO_AGING; - unmask = CARD_POINTS_TO_NURSERY; + mask = card_points_to_aging; + unmask = card_points_to_nursery; } } else @@ -366,8 +366,8 @@ static cell copy_next_from_aging(cell scan) { obj++; - cell tenured_start = data->generations[TENURED].start; - cell tenured_end = data->generations[TENURED].end; + cell tenured_start = data->generations[data->tenured()].start; + cell tenured_end = data->generations[data->tenured()].end; cell newspace_start = newspace->start; cell newspace_end = newspace->end; @@ -421,17 +421,17 @@ static cell copy_next_from_tenured(cell scan) void copy_reachable_objects(cell scan, cell *end) { - if(collecting_gen == NURSERY) + if(collecting_gen == data->nursery()) { while(scan < *end) scan = copy_next_from_nursery(scan); } - else if(HAVE_AGING_P && collecting_gen == AGING) + else if(data->have_aging_p() && collecting_gen == data->aging()) { while(scan < *end) scan = copy_next_from_aging(scan); } - else if(collecting_gen == TENURED) + else if(collecting_gen == data->tenured()) { while(scan < *end) scan = copy_next_from_tenured(scan); @@ -443,12 +443,12 @@ static void begin_gc(cell requested_bytes) { if(growing_data_heap) { - if(collecting_gen != TENURED) + if(collecting_gen != data->tenured()) critical_error("Invalid parameters to begin_gc",0); old_data_heap = data; set_data_heap(grow_data_heap(old_data_heap,requested_bytes)); - newspace = &data->generations[TENURED]; + newspace = &data->generations[data->tenured()]; } else if(collecting_accumulation_gen_p()) { @@ -491,12 +491,12 @@ static void end_gc(cell gc_elapsed) if(collecting_accumulation_gen_p()) { /* all younger generations except are now empty. - if collecting_gen == NURSERY here, we only have 1 generation; + if collecting_gen == data->nursery() here, we only have 1 generation; old-school Cheney collector */ - if(collecting_gen != NURSERY) - reset_generations(NURSERY,collecting_gen - 1); + if(collecting_gen != data->nursery()) + reset_generations(data->nursery(),collecting_gen - 1); } - else if(collecting_gen == NURSERY) + else if(collecting_gen == data->nursery()) { nursery.here = nursery.start; } @@ -504,7 +504,7 @@ static void end_gc(cell gc_elapsed) { /* all generations up to and including the one collected are now empty */ - reset_generations(NURSERY,collecting_gen); + reset_generations(data->nursery(),collecting_gen); } collecting_aging_again = false; @@ -534,17 +534,17 @@ void garbage_collection(cell gen, { /* We have no older generations we can try collecting, so we resort to growing the data heap */ - if(collecting_gen == TENURED) + if(collecting_gen == data->tenured()) { growing_data_heap = true; /* see the comment in unmark_marked() */ unmark_marked(&code); } - /* we try collecting AGING space twice before going on to - collect TENURED */ - else if(HAVE_AGING_P - && collecting_gen == AGING + /* we try collecting aging space twice before going on to + collect tenured */ + else if(data->have_aging_p() + && collecting_gen == data->aging() && !collecting_aging_again) { collecting_aging_again = true; @@ -575,7 +575,7 @@ void garbage_collection(cell gen, { code_heap_scans++; - if(collecting_gen == TENURED) + if(collecting_gen == data->tenured()) free_unmarked(&code,(heap_iterator)update_literal_and_word_references); else copy_code_heap_roots(); @@ -595,7 +595,7 @@ void garbage_collection(cell gen, void gc() { - garbage_collection(TENURED,false,0); + garbage_collection(data->tenured(),false,0); } PRIMITIVE(gc) @@ -610,7 +610,7 @@ PRIMITIVE(gc_stats) cell i; u64 total_gc_time = 0; - for(i = 0; i < MAX_GEN_COUNT; i++) + for(i = 0; i < max_gen_count; i++) { gc_stats *s = &stats[i]; result.add(allot_cell(s->collections)); @@ -635,8 +635,7 @@ PRIMITIVE(gc_stats) void clear_gc_stats() { - int i; - for(i = 0; i < MAX_GEN_COUNT; i++) + for(cell i = 0; i < max_gen_count; i++) memset(&stats[i],0,sizeof(gc_stats)); cards_scanned = 0; @@ -683,7 +682,7 @@ PRIMITIVE(become) VM_C_API void minor_gc() { - garbage_collection(NURSERY,false,0); + garbage_collection(data->nursery(),false,0); } } diff --git a/vm/data_gc.hpp b/vm/data_gc.hpp index 01bff2ef68..2d6a1ab897 100755 --- a/vm/data_gc.hpp +++ b/vm/data_gc.hpp @@ -24,10 +24,10 @@ void gc(); inline static bool collecting_accumulation_gen_p() { - return ((HAVE_AGING_P - && collecting_gen == AGING + return ((data->have_aging_p() + && collecting_gen == data->aging() && !collecting_aging_again) - || collecting_gen == TENURED); + || collecting_gen == data->tenured()); } void copy_handle(cell *handle); @@ -39,7 +39,7 @@ void garbage_collection(volatile cell gen, /* We leave this many bytes free at the top of the nursery so that inline allocation (which does not call GC because of possible roots in volatile registers) does not run out of memory */ -#define ALLOT_BUFFER_ZONE 1024 +static const cell allot_buffer_zone = 1024; inline static object *allot_zone(zone *z, cell a) { @@ -63,11 +63,11 @@ inline static object *allot_object(header header, cell size) object *obj; - if(nursery.size - ALLOT_BUFFER_ZONE > size) + if(nursery.size - allot_buffer_zone > size) { /* If there is insufficient room, collect the nursery */ - if(nursery.here + ALLOT_BUFFER_ZONE + size > nursery.end) - garbage_collection(NURSERY,false,0); + if(nursery.here + allot_buffer_zone + size > nursery.end) + garbage_collection(data->nursery(),false,0); cell h = nursery.here; nursery.here = h + align8(size); @@ -77,20 +77,20 @@ inline static object *allot_object(header header, cell size) tenured space */ else { - zone *tenured = &data->generations[TENURED]; + zone *tenured = &data->generations[data->tenured()]; /* If tenured space does not have enough room, collect */ if(tenured->here + size > tenured->end) { gc(); - tenured = &data->generations[TENURED]; + tenured = &data->generations[data->tenured()]; } /* If it still won't fit, grow the heap */ if(tenured->here + size > tenured->end) { - garbage_collection(TENURED,true,size); - tenured = &data->generations[TENURED]; + garbage_collection(data->tenured(),true,size); + tenured = &data->generations[data->tenured()]; } obj = allot_zone(tenured,size); diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp index 9c84a993c8..d921d373da 100755 --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -26,10 +26,10 @@ cell init_zone(zone *z, cell size, cell start) void init_card_decks() { - cell start = align(data->seg->start,DECK_SIZE); - allot_markers_offset = (cell)data->allot_markers - (start >> CARD_BITS); - cards_offset = (cell)data->cards - (start >> CARD_BITS); - decks_offset = (cell)data->decks - (start >> DECK_BITS); + cell start = align(data->seg->start,deck_size); + allot_markers_offset = (cell)data->allot_markers - (start >> card_bits); + cards_offset = (cell)data->cards - (start >> card_bits); + decks_offset = (cell)data->decks - (start >> deck_bits); } data_heap *alloc_data_heap(cell gens, @@ -37,9 +37,9 @@ data_heap *alloc_data_heap(cell gens, cell aging_size, cell tenured_size) { - young_size = align(young_size,DECK_SIZE); - aging_size = align(aging_size,DECK_SIZE); - tenured_size = align(tenured_size,DECK_SIZE); + young_size = align(young_size,deck_size); + aging_size = align(aging_size,deck_size); + tenured_size = align(tenured_size,deck_size); data_heap *data = (data_heap *)safe_malloc(sizeof(data_heap)); data->young_size = young_size; @@ -58,42 +58,42 @@ data_heap *alloc_data_heap(cell gens, return NULL; /* can't happen */ } - total_size += DECK_SIZE; + total_size += deck_size; data->seg = alloc_segment(total_size); data->generations = (zone *)safe_malloc(sizeof(zone) * data->gen_count); data->semispaces = (zone *)safe_malloc(sizeof(zone) * data->gen_count); - cell cards_size = total_size >> CARD_BITS; + cell cards_size = total_size >> card_bits; data->allot_markers = (cell *)safe_malloc(cards_size); data->allot_markers_end = data->allot_markers + cards_size; data->cards = (cell *)safe_malloc(cards_size); data->cards_end = data->cards + cards_size; - cell decks_size = total_size >> DECK_BITS; + cell decks_size = total_size >> deck_bits; data->decks = (cell *)safe_malloc(decks_size); data->decks_end = data->decks + decks_size; - cell alloter = align(data->seg->start,DECK_SIZE); + cell alloter = align(data->seg->start,deck_size); - alloter = init_zone(&data->generations[TENURED],tenured_size,alloter); - alloter = init_zone(&data->semispaces[TENURED],tenured_size,alloter); + alloter = init_zone(&data->generations[data->tenured()],tenured_size,alloter); + alloter = init_zone(&data->semispaces[data->tenured()],tenured_size,alloter); if(data->gen_count == 3) { - alloter = init_zone(&data->generations[AGING],aging_size,alloter); - alloter = init_zone(&data->semispaces[AGING],aging_size,alloter); + alloter = init_zone(&data->generations[data->aging()],aging_size,alloter); + alloter = init_zone(&data->semispaces[data->aging()],aging_size,alloter); } if(data->gen_count >= 2) { - alloter = init_zone(&data->generations[NURSERY],young_size,alloter); - alloter = init_zone(&data->semispaces[NURSERY],0,alloter); + alloter = init_zone(&data->generations[data->nursery()],young_size,alloter); + alloter = init_zone(&data->semispaces[data->nursery()],0,alloter); } - if(data->seg->end - alloter > DECK_SIZE) + if(data->seg->end - alloter > deck_size) critical_error("Bug in alloc_data_heap",alloter); return data; @@ -141,12 +141,12 @@ void clear_allot_markers(cell from, cell to) /* NOTE: reverse order due to heap layout. */ card *first_card = addr_to_allot_marker((object *)data->generations[to].start); card *last_card = addr_to_allot_marker((object *)data->generations[from].end); - memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card); + memset(first_card,invalid_allot_marker,last_card - first_card); } void reset_generation(cell i) { - zone *z = (i == NURSERY ? &nursery : &data->generations[i]); + zone *z = (i == data->nursery() ? &nursery : &data->generations[i]); z->here = z->start; if(secure_gc) @@ -169,11 +169,11 @@ void reset_generations(cell from, cell to) void set_data_heap(data_heap *data_) { data = data_; - nursery = data->generations[NURSERY]; + nursery = data->generations[data->nursery()]; init_card_decks(); - clear_cards(NURSERY,TENURED); - clear_decks(NURSERY,TENURED); - clear_allot_markers(NURSERY,TENURED); + clear_cards(data->nursery(),data->tenured()); + clear_decks(data->nursery(),data->tenured()); + clear_allot_markers(data->nursery(),data->tenured()); } void init_data_heap(cell gens, @@ -298,7 +298,7 @@ PRIMITIVE(data_room) cell gen; for(gen = 0; gen < data->gen_count; gen++) { - zone *z = (gen == NURSERY ? &nursery : &data->generations[gen]); + zone *z = (gen == data->nursery() ? &nursery : &data->generations[gen]); a.add(tag_fixnum((z->end - z->here) >> 10)); a.add(tag_fixnum((z->size) >> 10)); } @@ -314,7 +314,7 @@ cell heap_scan_ptr; /* Disables GC and activates next-object ( -- obj ) primitive */ void begin_scan() { - heap_scan_ptr = data->generations[TENURED].start; + heap_scan_ptr = data->generations[data->tenured()].start; gc_off = true; } @@ -328,7 +328,7 @@ cell next_object() if(!gc_off) general_error(ERROR_HEAP_SCAN,F,F,NULL); - if(heap_scan_ptr >= data->generations[TENURED].here) + if(heap_scan_ptr >= data->generations[data->tenured()].here) return F; object *obj = (object *)heap_scan_ptr; diff --git a/vm/data_heap.hpp b/vm/data_heap.hpp index bec86a2d0d..567c8f9944 100644 --- a/vm/data_heap.hpp +++ b/vm/data_heap.hpp @@ -34,20 +34,22 @@ struct data_heap { cell *decks; cell *decks_end; + + /* the 0th generation is where new objects are allocated. */ + cell nursery() { return 0; } + + /* where objects hang around */ + cell aging() { return gen_count - 2; } + + /* the oldest generation */ + cell tenured() { return gen_count - 1; } + + bool have_aging_p() { return gen_count > 2; } }; extern data_heap *data; -/* the 0th generation is where new objects are allocated. */ -#define NURSERY 0 -/* where objects hang around */ -#define AGING (data->gen_count-2) -#define HAVE_AGING_P (data->gen_count>2) -/* the oldest generation */ -#define TENURED (data->gen_count-1) - -#define MIN_GEN_COUNT 1 -#define MAX_GEN_COUNT 3 +static const cell max_gen_count = 3; inline static bool in_zone(zone *z, object *pointer) { diff --git a/vm/image.cpp b/vm/image.cpp index fd547cca50..9205aad260 100755 --- a/vm/image.cpp +++ b/vm/image.cpp @@ -31,7 +31,7 @@ static void load_data_heap(FILE *file, image_header *h, vm_parameters *p) clear_gc_stats(); - zone *tenured = &data->generations[TENURED]; + zone *tenured = &data->generations[data->tenured()]; fixnum bytes_read = fread((void*)tenured->start,1,h->data_size,file); @@ -92,10 +92,10 @@ bool save_image(const vm_char *filename) return false; } - zone *tenured = &data->generations[TENURED]; + zone *tenured = &data->generations[data->tenured()]; - h.magic = IMAGE_MAGIC; - h.version = IMAGE_VERSION; + h.magic = image_magic; + h.version = image_version; h.data_relocation_base = tenured->start; h.data_size = tenured->here - tenured->start; h.code_relocation_base = code.seg->start; @@ -165,7 +165,7 @@ static void data_fixup(cell *cell) if(immediate_p(*cell)) return; - zone *tenured = &data->generations[TENURED]; + zone *tenured = &data->generations[data->tenured()]; *cell += (tenured->start - data_relocation_base); } @@ -271,7 +271,7 @@ void relocate_data() data_fixup(&bignum_pos_one); data_fixup(&bignum_neg_one); - zone *tenured = &data->generations[TENURED]; + zone *tenured = &data->generations[data->tenured()]; for(relocating = tenured->start; relocating < tenured->here; @@ -313,10 +313,10 @@ void load_image(vm_parameters *p) if(fread(&h,sizeof(image_header),1,file) != 1) fatal_error("Cannot read image header",0); - if(h.magic != IMAGE_MAGIC) + if(h.magic != image_magic) fatal_error("Bad image: magic number check failed",h.magic); - if(h.version != IMAGE_VERSION) + if(h.version != image_version) fatal_error("Bad image: version number check failed",h.version); load_data_heap(file,&h,p); diff --git a/vm/image.hpp b/vm/image.hpp index c306f322de..807a7a6bcf 100755 --- a/vm/image.hpp +++ b/vm/image.hpp @@ -1,8 +1,8 @@ namespace factor { -#define IMAGE_MAGIC 0x0f0e0d0c -#define IMAGE_VERSION 4 +static const cell image_magic = 0x0f0e0d0c; +static const cell image_version = 4; struct image_header { cell magic; diff --git a/vm/layouts.hpp b/vm/layouts.hpp index f8d114210a..42fba35741 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -23,8 +23,15 @@ inline static cell align(cell a, cell b) return (a + (b-1)) & ~(b-1); } -#define align8(a) align(a,8) -#define align_page(a) align(a,getpagesize()) +inline static cell align8(cell a) +{ + return align(a,8); +} + +inline static cell align_page(cell a) +{ + return align(a,getpagesize()); +} #define WORD_SIZE (signed)(sizeof(cell)*8) @@ -297,12 +304,6 @@ struct dll : public object { void *dll; }; -struct callstack : public object { - static const cell type_number = CALLSTACK_TYPE; - /* tagged */ - cell length; -}; - struct stack_frame { void *xt; @@ -310,6 +311,15 @@ struct stack_frame cell size; }; +struct callstack : public object { + static const cell type_number = CALLSTACK_TYPE; + /* tagged */ + cell length; + + stack_frame *top() { return (stack_frame *)(this + 1); } + stack_frame *bottom() { return (stack_frame *)((cell)(this + 1) + untag_fixnum(length)); } +}; + struct tuple : public object { static const cell type_number = TUPLE_TYPE; /* tagged layout */ diff --git a/vm/math.cpp b/vm/math.cpp index 7a2abe7463..76f2c88f38 100755 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -24,8 +24,8 @@ PRIMITIVE(fixnum_divint) fixnum y = untag_fixnum(dpop()); \ fixnum x = untag_fixnum(dpeek()); fixnum result = x / y; - if(result == -FIXNUM_MIN) - drepl(allot_integer(-FIXNUM_MIN)); + if(result == -fixnum_min) + drepl(allot_integer(-fixnum_min)); else drepl(tag_fixnum(result)); } @@ -34,9 +34,9 @@ PRIMITIVE(fixnum_divmod) { cell y = ((cell *)ds)[0]; cell x = ((cell *)ds)[-1]; - if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN)) + if(y == tag_fixnum(-1) && x == tag_fixnum(fixnum_min)) { - ((cell *)ds)[-1] = allot_integer(-FIXNUM_MIN); + ((cell *)ds)[-1] = allot_integer(-fixnum_min); ((cell *)ds)[0] = tag_fixnum(0); } else @@ -50,9 +50,20 @@ PRIMITIVE(fixnum_divmod) * If we're shifting right by n bits, we won't overflow as long as none of the * high WORD_SIZE-TAG_BITS-n bits are set. */ -#define SIGN_MASK(x) ((x) >> (WORD_SIZE - 1)) -#define BRANCHLESS_MAX(x,y) ((x) - (((x) - (y)) & SIGN_MASK((x) - (y)))) -#define BRANCHLESS_ABS(x) ((x ^ SIGN_MASK(x)) - SIGN_MASK(x)) +static inline fixnum sign_mask(fixnum x) +{ + return x >> (WORD_SIZE - 1); +} + +static inline fixnum branchless_max(fixnum x, fixnum y) +{ + return (x - ((x - y) & sign_mask(x - y))); +} + +static inline fixnum branchless_abs(fixnum x) +{ + return (x ^ sign_mask(x)) - sign_mask(x); +} PRIMITIVE(fixnum_shift) { @@ -63,14 +74,14 @@ PRIMITIVE(fixnum_shift) return; else if(y < 0) { - y = BRANCHLESS_MAX(y,-WORD_SIZE + 1); + y = branchless_max(y,-WORD_SIZE + 1); drepl(tag_fixnum(x >> -y)); return; } else if(y < WORD_SIZE - TAG_BITS) { fixnum mask = -((fixnum)1 << (WORD_SIZE - 1 - TAG_BITS - y)); - if(!(BRANCHLESS_ABS(x) & mask)) + if(!(branchless_abs(x) & mask)) { drepl(tag_fixnum(x << y)); return; @@ -226,7 +237,7 @@ cell unbox_array_size() case FIXNUM_TYPE: { fixnum n = untag_fixnum(dpeek()); - if(n >= 0 && n < (fixnum)ARRAY_SIZE_MAX) + if(n >= 0 && n < (fixnum)array_size_max) { dpop(); return n; @@ -236,7 +247,7 @@ cell unbox_array_size() case BIGNUM_TYPE: { bignum * zero = untag(bignum_zero); - bignum * max = cell_to_bignum(ARRAY_SIZE_MAX); + bignum * max = cell_to_bignum(array_size_max); bignum * n = untag(dpeek()); if(bignum_compare(n,zero) != bignum_comparison_less && bignum_compare(n,max) == bignum_comparison_less) @@ -248,7 +259,7 @@ cell unbox_array_size() } } - general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(ARRAY_SIZE_MAX),NULL); + general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(array_size_max),NULL); return 0; /* can't happen */ } @@ -428,7 +439,7 @@ VM_C_API void box_unsigned_cell(cell cell) VM_C_API void box_signed_8(s64 n) { - if(n < FIXNUM_MIN || n > FIXNUM_MAX) + if(n < fixnum_min || n > fixnum_max) dpush(tag(long_long_to_bignum(n))); else dpush(tag_fixnum(n)); @@ -450,7 +461,7 @@ VM_C_API s64 to_signed_8(cell obj) VM_C_API void box_unsigned_8(u64 n) { - if(n > FIXNUM_MAX) + if(n > fixnum_max) dpush(tag(ulong_long_to_bignum(n))); else dpush(tag_fixnum(n)); diff --git a/vm/math.hpp b/vm/math.hpp index 198960d3b5..7828aa3e6c 100644 --- a/vm/math.hpp +++ b/vm/math.hpp @@ -5,10 +5,9 @@ extern cell bignum_zero; extern cell bignum_pos_one; extern cell bignum_neg_one; -#define cell_MAX (cell)(-1) -#define FIXNUM_MAX (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1) -#define FIXNUM_MIN (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1))) -#define ARRAY_SIZE_MAX ((cell)1 << (WORD_SIZE - TAG_BITS - 2)) +static const fixnum fixnum_max = (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1); +static const fixnum fixnum_min = (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1))); +static const fixnum array_size_max = ((cell)1 << (WORD_SIZE - TAG_BITS - 2)); PRIMITIVE(fixnum_add); PRIMITIVE(fixnum_subtract); @@ -45,7 +44,7 @@ PRIMITIVE(byte_array_to_bignum); inline static cell allot_integer(fixnum x) { - if(x < FIXNUM_MIN || x > FIXNUM_MAX) + if(x < fixnum_min || x > fixnum_max) return tag(fixnum_to_bignum(x)); else return tag_fixnum(x); @@ -53,7 +52,7 @@ inline static cell allot_integer(fixnum x) inline static cell allot_cell(cell x) { - if(x > (cell)FIXNUM_MAX) + if(x > (cell)fixnum_max) return tag(cell_to_bignum(x)); else return tag_fixnum(x); diff --git a/vm/write_barrier.hpp b/vm/write_barrier.hpp index eaede538ed..0006581034 100755 --- a/vm/write_barrier.hpp +++ b/vm/write_barrier.hpp @@ -12,24 +12,24 @@ VM_C_API factor::cell decks_offset; namespace factor { -/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */ -#define CARD_POINTS_TO_NURSERY 0x80 -#define CARD_POINTS_TO_AGING 0x40 -#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING) +/* if card_points_to_nursery is set, card_points_to_aging must also be set. */ +static const cell card_points_to_nursery = 0x80; +static const cell card_points_to_aging = 0x40; +static const cell card_mark_mask = (card_points_to_nursery | card_points_to_aging); typedef u8 card; -#define CARD_BITS 8 -#define CARD_SIZE (1<> CARD_BITS) + cards_offset); + return (card*)(((cell)(a) >> card_bits) + cards_offset); } inline static cell card_to_addr(card *c) { - return ((cell)c - cards_offset) << CARD_BITS; + return ((cell)c - cards_offset) << card_bits; } inline static cell card_offset(card *c) @@ -39,48 +39,48 @@ inline static cell card_offset(card *c) typedef u8 card_deck; -#define DECK_BITS (CARD_BITS + 10) -#define DECK_SIZE (1<> DECK_BITS) + decks_offset); + return (card_deck *)(((cell)a >> deck_bits) + decks_offset); } inline static cell deck_to_addr(card_deck *c) { - return ((cell)c - decks_offset) << DECK_BITS; + return ((cell)c - decks_offset) << deck_bits; } inline static card *deck_to_card(card_deck *d) { - return (card *)((((cell)d - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset); + return (card *)((((cell)d - decks_offset) << (deck_bits - card_bits)) + cards_offset); } -#define INVALID_ALLOT_MARKER 0xff +static const cell invalid_allot_marker = 0xff; extern cell allot_markers_offset; inline static card *addr_to_allot_marker(object *a) { - return (card *)(((cell)a >> CARD_BITS) + allot_markers_offset); + return (card *)(((cell)a >> card_bits) + allot_markers_offset); } /* the write barrier must be called any time we are potentially storing a pointer from an older generation to a younger one */ inline static void write_barrier(object *obj) { - *addr_to_card((cell)obj) = CARD_MARK_MASK; - *addr_to_deck((cell)obj) = CARD_MARK_MASK; + *addr_to_card((cell)obj) = card_mark_mask; + *addr_to_deck((cell)obj) = card_mark_mask; } /* we need to remember the first object allocated in the card */ inline static void allot_barrier(object *address) { card *ptr = addr_to_allot_marker(address); - if(*ptr == INVALID_ALLOT_MARKER) - *ptr = ((cell)address & ADDR_CARD_MASK); + if(*ptr == invalid_allot_marker) + *ptr = ((cell)address & addr_card_mask); } } From 3a2a1a6a62f5203534b1f7480ec1d23831d14952 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 May 2009 15:07:15 -0500 Subject: [PATCH 118/210] input grabbing support --- basis/core-graphics/core-graphics.factor | 9 +++++++++ basis/core-graphics/types/types.factor | 5 ++++- basis/math/rectangles/rectangles.factor | 2 ++ basis/ui/backend/backend.factor | 6 +++++- basis/ui/backend/cocoa/cocoa.factor | 11 +++++++++++ basis/ui/backend/windows/windows.factor | 8 ++++++++ basis/ui/gadgets/worlds/worlds.factor | 7 +++++-- basis/ui/ui.factor | 15 ++++++++++++--- basis/windows/user32/user32.factor | 4 ++-- extra/terrain/terrain.factor | 1 + 10 files changed, 59 insertions(+), 9 deletions(-) diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index 5e95e2e36e..924f7130f0 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/basis/core-graphics/core-graphics.factor @@ -105,6 +105,15 @@ CONSTANT: kCGLRendererGenericFloatID HEX: 00020400 FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ; +FUNCTION: CGDirectDisplayID CGMainDisplayID ( ) ; + +FUNCTION: CGError CGDisplayHideCursor ( CGDirectDisplayID display ) ; +FUNCTION: CGError CGDisplayShowCursor ( CGDirectDisplayID display ) ; + +FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ; + +FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ; + > -> release ; +M: cocoa-ui-backend (grab-input) ( handle -- ) + 0 CGAssociateMouseAndMouseCursorPosition drop + CGMainDisplayID CGDisplayHideCursor drop + window>> -> frame CGRect>rect rect-center + first2 CGWarpMouseCursorPosition drop ; + +M: cocoa-ui-backend (ungrab-input) ( handle -- ) + drop + CGMainDisplayID CGDisplayShowCursor drop + 1 CGAssociateMouseAndMouseCursorPosition drop ; + M: cocoa-ui-backend close-window ( gadget -- ) find-world [ handle>> [ diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 24ae72740f..c2d330b9dd 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -706,6 +706,14 @@ M: windows-ui-backend beep ( -- ) : hwnd>RECT ( hwnd -- RECT ) "RECT" [ GetWindowRect win32-error=0/f ] keep ; +M: windows-ui-backend (grab-input) ( handle -- ) + 0 ShowCursor drop + hWnd>> hwnd>RECT ClipCursor drop ; +M: windows-ui-backend (ungrab-input) ( handle -- ) + drop + f ClipCursor drop + 1 ShowCursor drop ; + : fullscreen-flags ( -- n ) { WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 3568559eac..eec5666f0e 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -11,7 +11,7 @@ CONSTANT: default-world-pixel-format-attributes { windowed double-buffered T{ depth-bits { value 16 } } } TUPLE: world < track - active? focused? + active? focused? grab-input? layers title status status-owner text-handle handle images @@ -20,6 +20,7 @@ TUPLE: world < track TUPLE: world-attributes { world-class initial: world } + grab-input? title status gadgets @@ -63,13 +64,15 @@ M: world request-focus-on ( child gadget -- ) vertical swap new-track t >>root? t >>active? - { 0 0 } >>window-loc ; + { 0 0 } >>window-loc + f >>grab-input? ; : apply-world-attributes ( world attributes -- world ) { [ title>> >>title ] [ status>> >>status ] [ pixel-format-attributes>> >>pixel-format-attributes ] + [ grab-input?>> >>grab-input? ] [ gadgets>> [ 1 track-add ] each ] } cleave ; diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index b73de68e26..d53d4c6753 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -41,14 +41,23 @@ SYMBOL: windows lose-focus swap each-gesture gain-focus swap each-gesture ; +: ?grab-input ( world -- ) + dup grab-input?>> [ handle>> (grab-input) ] [ drop ] if ; + +: ?ungrab-input ( world -- ) + dup grab-input?>> [ handle>> (ungrab-input) ] [ drop ] if ; + : focus-world ( world -- ) t >>focused? - dup raised-window - focus-path f focus-gestures ; + [ ?grab-input ] [ + dup raised-window + focus-path f focus-gestures + ] bi ; : unfocus-world ( world -- ) f >>focused? - focus-path f swap focus-gestures ; + [ ?ungrab-input ] + [ focus-path f swap focus-gestures ] bi ; : try-to-open-window ( world -- ) { diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index 1e694bcbe4..b6caa7c039 100644 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -654,7 +654,7 @@ FUNCTION: HWND ChildWindowFromPoint ( HWND hWndParent, POINT point ) ; ! FUNCTION: ClientThreadSetup ! FUNCTION: ClientToScreen ! FUNCTION: CliImmSetHotKey -! FUNCTION: ClipCursor +FUNCTION: int ClipCursor ( RECT* clipRect ) ; FUNCTION: BOOL CloseClipboard ( ) ; ! FUNCTION: CloseDesktop ! FUNCTION: CloseWindow @@ -1363,7 +1363,7 @@ CONSTANT: HWND_TOP f ! FUNCTION: SetWindowWord ! FUNCTION: SetWinEventHook ! FUNCTION: ShowCaret -! FUNCTION: ShowCursor +FUNCTION: int ShowCursor ( BOOL show ) ; ! FUNCTION: ShowOwnedPopups ! FUNCTION: ShowScrollBar ! FUNCTION: ShowStartGlass diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 50c88d6f00..3f94b93138 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -186,5 +186,6 @@ M: terrain-world pref-dim* drop { 640 480 } ; double-buffered T{ depth-bits { value 24 } } } } + { grab-input? t } } open-window ] with-ui ; From b470c4f92e4f65269a01f62cfbb9b8908dde43d9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 15:15:10 -0500 Subject: [PATCH 119/210] Need to include unistd.h --- vm/master.hpp | 1 + 1 file changed, 1 insertion(+) diff --git a/vm/master.hpp b/vm/master.hpp index 6409d65494..6164c9ea30 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -19,6 +19,7 @@ #include #include #include +#include #include /* C++ headers */ From cdd470a945a8086aeffcf7a358a90db7214b28ee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 15:23:44 -0500 Subject: [PATCH 120/210] Fix Windows compile error --- vm/layouts.hpp | 5 ----- vm/math.cpp | 2 +- vm/segments.hpp | 5 +++++ 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 42fba35741..40fd699e18 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -28,11 +28,6 @@ inline static cell align8(cell a) return align(a,8); } -inline static cell align_page(cell a) -{ - return align(a,getpagesize()); -} - #define WORD_SIZE (signed)(sizeof(cell)*8) #define TAG_MASK 7 diff --git a/vm/math.cpp b/vm/math.cpp index 76f2c88f38..eff129a5c9 100755 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -461,7 +461,7 @@ VM_C_API s64 to_signed_8(cell obj) VM_C_API void box_unsigned_8(u64 n) { - if(n > fixnum_max) + if(n > (u64)fixnum_max) dpush(tag(ulong_long_to_bignum(n))); else dpush(tag_fixnum(n)); diff --git a/vm/segments.hpp b/vm/segments.hpp index a715b4dabc..36b5bc747b 100644 --- a/vm/segments.hpp +++ b/vm/segments.hpp @@ -7,4 +7,9 @@ struct segment { cell end; }; +inline static cell align_page(cell a) +{ + return align(a,getpagesize()); +} + } From 977cd6c1479bf91e4e826597e97a5c84dfff0dbf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 May 2009 15:49:29 -0500 Subject: [PATCH 121/210] clip to window client area when grabbing on windows --- basis/ui/backend/windows/windows.factor | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index c2d330b9dd..ba4926d97e 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -11,7 +11,7 @@ threads libc combinators fry combinators.short-circuit continuations command-line shuffle opengl ui.render ascii math.bitwise locals accessors math.rectangles math.order ascii calendar io.encodings.utf16n windows.errors literals ui.pixel-formats -ui.pixel-formats.private memoize classes ; +ui.pixel-formats.private memoize classes struct-arrays ; IN: ui.backend.windows SINGLETON: windows-ui-backend @@ -703,12 +703,18 @@ M: windows-ui-backend beep ( -- ) "MONITORINFOEX" dup length over set-MONITORINFOEX-cbSize [ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ; +: client-area>RECT ( hwnd -- RECT ) + "RECT" + [ GetClientRect win32-error=0/f ] + [ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ] + [ nip ] 2tri ; + : hwnd>RECT ( hwnd -- RECT ) "RECT" [ GetWindowRect win32-error=0/f ] keep ; M: windows-ui-backend (grab-input) ( handle -- ) 0 ShowCursor drop - hWnd>> hwnd>RECT ClipCursor drop ; + hWnd>> client-area>RECT ClipCursor drop ; M: windows-ui-backend (ungrab-input) ( handle -- ) drop f ClipCursor drop From fc49402d40278ec1da6655a9f79bd6f28628d700 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 May 2009 14:09:57 -0700 Subject: [PATCH 122/210] Add missing ClientToScreen export to windows.user32 --- basis/windows/user32/user32.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 basis/windows/user32/user32.factor diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor old mode 100644 new mode 100755 index b6caa7c039..2272695953 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -652,7 +652,7 @@ FUNCTION: HDC BeginPaint ( HWND hwnd, LPPAINTSTRUCT lpPaint ) ; FUNCTION: HWND ChildWindowFromPoint ( HWND hWndParent, POINT point ) ; ! FUNCTION: ChildWindowFromPointEx ! FUNCTION: ClientThreadSetup -! FUNCTION: ClientToScreen +FUNCTION: BOOL ClientToScreen ( HWND hWnd, POINT* point ) ; ! FUNCTION: CliImmSetHotKey FUNCTION: int ClipCursor ( RECT* clipRect ) ; FUNCTION: BOOL CloseClipboard ( ) ; From 25b5a7645a753bb823cfb4f72267fe20cccd2d46 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 May 2009 16:18:56 -0500 Subject: [PATCH 123/210] add escape key to terrain demo --- extra/terrain/terrain.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 3f94b93138..6617275784 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -111,6 +111,7 @@ TUPLE: terrain-world < world key-s keys nth [ world move-backward ] when key-a keys nth [ world move-leftward ] when key-d keys nth [ world move-rightward ] when + key-escape keys nth [ world close-window ] when world read-mouse rotate-with-mouse reset-mouse ; From 9f71446cb5bcac8fdfd2a786fed4b9be3193dc5b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 17:18:43 -0500 Subject: [PATCH 124/210] move sha2 state to a tuple --- basis/checksums/sha2/sha2.factor | 36 +++++++++++++++++++------------- 1 file changed, 22 insertions(+), 14 deletions(-) diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index cd67418516..ff19c4c9a8 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -8,7 +8,7 @@ IN: checksums.sha2 [ be> ] map block-size get 0 pad-tail + sha2 get word-size>> [ be> ] map sha2 get block-size>> 0 pad-tail 16 64 [a,b) over '[ _ process-M-256 ] each ; : slice3 ( n seq -- a b c ) @@ -98,7 +98,7 @@ CONSTANT: K-256 : T1 ( W n H -- T1 ) [ [ swap nth ] keep - K-256 nth + + sha2 get K>> nth + ] dip [ e swap slice3 ch w+ ] [ e swap nth S1-256 w+ ] @@ -126,7 +126,7 @@ CONSTANT: K-256 [ T2 ] [ update-H ] tri ] with each - ] keep H get [ w+ ] 2map H set ; + ] keep sha2 get H>> [ w+ ] 2map sha2 get (>>H) ; : pad-initial-bytes ( string -- padded-string ) dup [ @@ -141,12 +141,12 @@ CONSTANT: K-256 : byte-array>sha2 ( byte-array -- string ) pad-initial-bytes - block-size get + sha2 get block-size>> [ prepare-message-schedule - block-size get H get clone process-chunk + sha2 get [ block-size>> ] [ H>> clone ] bi process-chunk ] each - H get 4 seq>byte-array ; + sha2 get H>> 4 seq>byte-array ; PRIVATE> @@ -154,11 +154,19 @@ SINGLETON: sha-256 INSTANCE: sha-256 checksum -M: sha-256 checksum-bytes - drop [ - initial-H-256 H set - 4 word-size set - 64 block-size set - byte-array>sha2 +TUPLE: sha2-state K H word-size block-size ; - ] with-scope ; +TUPLE: sha-256-state < sha2-state ; + +: ( -- sha2-state ) + sha-256-state new + K-256 >>K + initial-H-256 >>H + 4 >>word-size + 64 >>block-size ; + +M: sha-256 checksum-bytes + drop + sha2 [ + byte-array>sha2 + ] with-variable ; From faab29e88e89778dda1e4ea18c6ba5071a9f745c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 May 2009 17:22:04 -0500 Subject: [PATCH 125/210] oops. got the game-input reference counting backward. also, let go of the mouse state in cocoa backend when closing game-input --- extra/game-input/game-input.factor | 2 +- extra/game-input/iokit/iokit.factor | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/game-input/game-input.factor b/extra/game-input/game-input.factor index ccf5bd635b..922906df48 100755 --- a/extra/game-input/game-input.factor +++ b/extra/game-input/game-input.factor @@ -55,7 +55,7 @@ ERROR: game-input-not-open ; game-input-opened? [ (close-game-input) reset-game-input - ] when ; + ] unless ; : with-game-input ( quot -- ) open-game-input [ close-game-input ] [ ] cleanup ; inline diff --git a/extra/game-input/iokit/iokit.factor b/extra/game-input/iokit/iokit.factor index 0cc8b5d51f..de1529f8df 100755 --- a/extra/game-input/iokit/iokit.factor +++ b/extra/game-input/iokit/iokit.factor @@ -304,6 +304,7 @@ M: iokit-game-input-backend (close-game-input) f ] change-global f +keyboard-state+ set-global + f +mouse-state+ set-global f +controller-states+ set-global ] when ; From 8770f536a3bf7edc34cdad212f66e875f120ca3c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 17:39:11 -0500 Subject: [PATCH 126/210] remove dynamic variables from sha2 --- basis/checksums/sha2/sha2.factor | 89 +++++++++++++++----------------- 1 file changed, 41 insertions(+), 48 deletions(-) diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index ff19c4c9a8..d019a6913b 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -3,7 +3,7 @@ USING: kernel splitting grouping math sequences namespaces make io.binary math.bitwise checksums checksums.common sbufs strings combinators.smart math.ranges fry combinators -accessors ; +accessors locals ; IN: checksums.sha2 > [ be> ] map sha2 get block-size>> 0 pad-tail - 16 64 [a,b) over '[ _ process-M-256 ] each ; + [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline : slice3 ( n seq -- a b c ) [ dup 3 + ] dip first3 ; inline -: T1 ( W n H -- T1 ) - [ - [ swap nth ] keep - sha2 get K>> nth + - ] dip - [ e swap slice3 ch w+ ] - [ e swap nth S1-256 w+ ] - [ h swap nth w+ ] tri ; +: pad-initial-bytes ( string -- padded-string ) + dup [ + HEX: 80 , + length + [ HEX: 3f bitand calculate-pad-length 0 % ] + [ 3 shift 8 >be % ] bi + ] "" make append ; + +: seq>byte-array ( seq n -- string ) + '[ _ >be ] map B{ } join ; + +:: T1 ( n M H sha2 -- T1 ) + n M nth + n sha2 K>> nth + + e H slice3 ch w+ + e H nth S1-256 w+ + h H nth w+ ; : T2 ( H -- T2 ) [ a swap nth S0-256 ] @@ -116,37 +121,28 @@ CONSTANT: K-256 d c pick exchange c b pick exchange b a pick exchange - [ w+ a ] dip set-nth ; + [ w+ a ] dip set-nth ; inline -: process-chunk ( M block-size H-cloned -- ) - [ - '[ - _ - [ T1 ] - [ T2 ] - [ update-H ] tri - ] with each - ] keep sha2 get H>> [ w+ ] 2map sha2 get (>>H) ; +: prepare-message-schedule ( seq sha2 -- w-seq ) + [ word-size>> [ be> ] map ] + [ block-size>> 0 pad-tail 16 64 [a,b) over '[ _ process-M-256 ] each ] bi ; -: pad-initial-bytes ( string -- padded-string ) - dup [ - HEX: 80 , - length - [ HEX: 3f bitand calculate-pad-length 0 % ] - [ 3 shift 8 >be % ] bi - ] "" make append ; - -: seq>byte-array ( seq n -- string ) - '[ _ >be ] map B{ } join ; - -: byte-array>sha2 ( byte-array -- string ) - pad-initial-bytes - sha2 get block-size>> - [ - prepare-message-schedule - sha2 get [ block-size>> ] [ H>> clone ] bi process-chunk +:: process-chunk ( M block-size cloned-H sha2 -- ) + block-size [ + M cloned-H sha2 T1 + cloned-H T2 + cloned-H update-H ] each - sha2 get H>> 4 seq>byte-array ; + cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; + +:: byte-array>sha2 ( bytes state -- string ) + bytes pad-initial-bytes + state block-size>> + [ + state prepare-message-schedule + state [ block-size>> ] [ H>> clone ] bi state process-chunk + ] each + state H>> 4 seq>byte-array ; PRIVATE> @@ -163,10 +159,7 @@ TUPLE: sha-256-state < sha2-state ; K-256 >>K initial-H-256 >>H 4 >>word-size - 64 >>block-size ; + 64 >>block-size ; M: sha-256 checksum-bytes - drop - sha2 [ - byte-array>sha2 - ] with-variable ; + drop byte-array>sha2 ; From 3db1814abe460130402c93808826e8c45238ba46 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 17:41:22 -0500 Subject: [PATCH 127/210] Fix compile error in cpu-ppc.hpp --- vm/cpu-ppc.hpp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index b256b01c8b..6ae2cce27d 100755 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -35,7 +35,7 @@ inline static void *get_call_target(cell return_address) check_call_site(return_address); cell insn = *(cell *)return_address; - cell unsigned_addr = (insn & B_MASK); + cell unsigned_addr = (insn & b_mask); fixnum signed_addr = (fixnum)(unsigned_addr << 6) >> 6; return (void *)(signed_addr + return_address); } @@ -48,7 +48,7 @@ inline static void set_call_target(cell return_address, void *target) cell insn = *(cell *)return_address; fixnum relative_address = ((cell)target - return_address); - insn = ((insn & ~B_MASK) | (relative_address & B_MASK)); + insn = ((insn & ~b_mask) | (relative_address & b_mask)); *(cell *)return_address = insn; /* Flush the cache line containing the call we just patched */ From 947c63fd931c73684f14fea9ef6bdcc0619cb48c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 18:00:53 -0500 Subject: [PATCH 128/210] math.combinatorics: fix unit test and help lint --- basis/math/combinatorics/combinatorics-docs.factor | 2 +- basis/math/combinatorics/combinatorics-tests.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor index 7f40969b95..041539c981 100644 --- a/basis/math/combinatorics/combinatorics-docs.factor +++ b/basis/math/combinatorics/combinatorics-docs.factor @@ -64,7 +64,7 @@ HELP: combination { $description "Outputs the " { $snippet "mth" } " lexicographical combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements." } { $notes "Combinations are 0-based and a bounds error will be thrown if " { $snippet "m" } " is larger than " { $snippet "seq length k nCk" } "." } { $examples - { $example "USING: math.combinatorics prettyprint ;" + { $example "USING: math.combinatorics sequences prettyprint ;" "6 7 iota 4 combination ." "{ 0 1 3 6 }" } { $example "USING: math.combinatorics prettyprint ;" "0 { \"a\" \"b\" \"c\" \"d\" } 2 combination ." "{ \"a\" \"b\" }" } diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor index 1bc4bbc825..ca6ec9cb53 100644 --- a/basis/math/combinatorics/combinatorics-tests.factor +++ b/basis/math/combinatorics/combinatorics-tests.factor @@ -1,4 +1,4 @@ -USING: math.combinatorics math.combinatorics.private tools.test ; +USING: math.combinatorics math.combinatorics.private tools.test sequences ; IN: math.combinatorics.tests [ 1 ] [ 0 factorial ] unit-test From 4e091c236cd39e9c7fa8f372bf93b45721eed20a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 18:11:13 -0500 Subject: [PATCH 129/210] support sha-224, add constants for all sha2 --- basis/checksums/sha2/sha2-tests.factor | 43 ++++++++-- basis/checksums/sha2/sha2.factor | 108 +++++++++++++++++++++---- 2 files changed, 130 insertions(+), 21 deletions(-) diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor index 2f4e3c51c4..1476f04e75 100644 --- a/basis/checksums/sha2/sha2-tests.factor +++ b/basis/checksums/sha2/sha2-tests.factor @@ -1,7 +1,36 @@ -USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ; -[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test -[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test -[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test -[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test -[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test -[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test +USING: arrays kernel math namespaces sequences tools.test +checksums.sha2 checksums ; +IN: checksums.sha2.tests + +: test-checksum ( text identifier -- checksum ) + checksum-bytes hex-string ; + +[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ] +[ + "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" + sha-224 test-checksum +] unit-test + +[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] +[ "" sha-256 test-checksum ] unit-test + +[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] +[ "abc" sha-256 test-checksum ] unit-test + +[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] +[ "message digest" sha-256 test-checksum ] unit-test + +[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] +[ "abcdefghijklmnopqrstuvwxyz" sha-256 test-checksum ] unit-test + +[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] +[ + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" + sha-256 test-checksum +] unit-test + +[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] +[ + "12345678901234567890123456789012345678901234567890123456789012345678901234567890" + sha-256 test-checksum +] unit-test diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index d019a6913b..6a695b0965 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -19,12 +19,42 @@ CONSTANT: f 5 CONSTANT: g 6 CONSTANT: h 7 +CONSTANT: initial-H-224 + { + HEX: c1059ed8 HEX: 367cd507 HEX: 3070dd17 HEX: f70e5939 + HEX: ffc00b31 HEX: 68581511 HEX: 64f98fa7 HEX: befa4fa4 + } + CONSTANT: initial-H-256 { HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19 } +CONSTANT: initial-H-384 + { + HEX: cbbb9d5dc1059ed8 + HEX: 629a292a367cd507 + HEX: 9159015a3070dd17 + HEX: 152fecd8f70e5939 + HEX: 67332667ffc00b31 + HEX: 8eb44a8768581511 + HEX: db0c2e0d64f98fa7 + HEX: 47b5481dbefa4fa4 + } + +CONSTANT: initial-H-512 + { + HEX: 6a09e667f3bcc908 + HEX: bb67ae8584caa73b + HEX: 3c6ef372fe94f82b + HEX: a54ff53a5f1d36f1 + HEX: 510e527fade682d1 + HEX: 9b05688c2b3e6c1f + HEX: 1f83d9abfb41bd6b + HEX: 5be0cd19137e2179 + } + CONSTANT: K-256 { HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5 @@ -45,6 +75,29 @@ CONSTANT: K-256 HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2 } +CONSTANT: K-384 + { + HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694 + HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65 + HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5 + HEX: 983e5152ee66dfab HEX: a831c66d2db43210 HEX: b00327c898fb213f HEX: bf597fc7beef0ee4 + HEX: c6e00bf33da88fc2 HEX: d5a79147930aa725 HEX: 06ca6351e003826f HEX: 142929670a0e6e70 + HEX: 27b70a8546d22ffc HEX: 2e1b21385c26c926 HEX: 4d2c6dfc5ac42aed HEX: 53380d139d95b3df + HEX: 650a73548baf63de HEX: 766a0abb3c77b2a8 HEX: 81c2c92e47edaee6 HEX: 92722c851482353b + HEX: a2bfe8a14cf10364 HEX: a81a664bbc423001 HEX: c24b8b70d0f89791 HEX: c76c51a30654be30 + HEX: d192e819d6ef5218 HEX: d69906245565a910 HEX: f40e35855771202a HEX: 106aa07032bbd1b8 + HEX: 19a4c116b8d2d0c8 HEX: 1e376c085141ab53 HEX: 2748774cdf8eeb99 HEX: 34b0bcb5e19b48a8 + HEX: 391c0cb3c5c95a63 HEX: 4ed8aa4ae3418acb HEX: 5b9cca4f7763e373 HEX: 682e6ff3d6b2b8a3 + HEX: 748f82ee5defb2fc HEX: 78a5636f43172f60 HEX: 84c87814a1f0ab72 HEX: 8cc702081a6439ec + HEX: 90befffa23631e28 HEX: a4506cebde82bde9 HEX: bef9a3f7b2c67915 HEX: c67178f2e372532b + HEX: ca273eceea26619c HEX: d186b8c721c0c207 HEX: eada7dd6cde0eb1e HEX: f57d4f7fee6ed178 + HEX: 06f067aa72176fba HEX: 0a637dc5a2c898a6 HEX: 113f9804bef90dae HEX: 1b710b35131c471b + HEX: 28db77f523047d84 HEX: 32caab7b40c72493 HEX: 3c9ebe0a15c9bebc HEX: 431d67c49c100d4c + HEX: 4cc5d4becb3e42b6 HEX: 597f299cfc657e2a HEX: 5fcb6fab3ad6faec HEX: 6c44198c4a475817 + } + +ALIAS: K-512 K-384 + : s0-256 ( x -- x' ) [ [ -7 bitroll-32 ] @@ -107,11 +160,11 @@ CONSTANT: K-256 n sha2 K>> nth + e H slice3 ch w+ e H nth S1-256 w+ - h H nth w+ ; + h H nth w+ ; inline : T2 ( H -- T2 ) [ a swap nth S0-256 ] - [ a swap slice3 maj w+ ] bi ; + [ a swap slice3 maj w+ ] bi ; inline : update-H ( T1 T2 H -- ) h g pick exchange @@ -125,33 +178,53 @@ CONSTANT: K-256 : prepare-message-schedule ( seq sha2 -- w-seq ) [ word-size>> [ be> ] map ] - [ block-size>> 0 pad-tail 16 64 [a,b) over '[ _ process-M-256 ] each ] bi ; + [ + block-size>> 0 pad-tail 16 64 [a,b) over + '[ _ process-M-256 ] each + ] bi ; inline :: process-chunk ( M block-size cloned-H sha2 -- ) block-size [ M cloned-H sha2 T1 cloned-H T2 - cloned-H update-H + cloned-H update-H ] each - cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; + cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline -:: byte-array>sha2 ( bytes state -- string ) - bytes pad-initial-bytes - state block-size>> - [ - state prepare-message-schedule - state [ block-size>> ] [ H>> clone ] bi state process-chunk - ] each - state H>> 4 seq>byte-array ; +: sha2-steps ( sliced-groups state -- ) + '[ + _ + [ prepare-message-schedule ] + [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi + ] each ; + +: byte-array>sha2 ( bytes state -- ) + [ [ pad-initial-bytes ] [ block-size>> ] bi* ] + [ sha2-steps ] bi ; PRIVATE> +SINGLETON: sha-224 SINGLETON: sha-256 +SINGLETON: sha-384 +SINGLETON: sha-512 +INSTANCE: sha-224 checksum INSTANCE: sha-256 checksum +INSTANCE: sha-384 checksum +INSTANCE: sha-512 checksum TUPLE: sha2-state K H word-size block-size ; +TUPLE: sha-224-state < sha2-state ; + +: ( -- sha2-state ) + sha-224-state new + K-256 >>K + initial-H-224 >>H + 4 >>word-size + 64 >>block-size ; + TUPLE: sha-256-state < sha2-state ; : ( -- sha2-state ) @@ -161,5 +234,12 @@ TUPLE: sha-256-state < sha2-state ; 4 >>word-size 64 >>block-size ; +M: sha-224 checksum-bytes + drop + [ byte-array>sha2 ] + [ H>> 7 head 4 seq>byte-array ] bi ; + M: sha-256 checksum-bytes - drop byte-array>sha2 ; + drop + [ byte-array>sha2 ] + [ H>> 4 seq>byte-array ] bi ; From 4df3f2056da65802ac62d68e3bb106a350a14a65 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 May 2009 18:47:44 -0500 Subject: [PATCH 130/210] iokit game-input backend improvements: - avoid some needless allocation when dispatching input events - some gamepads claim to be pointers too; only match actual mouses - don't mess with the calibration settings if the axis min/max attributes aren't available also, throw a more helpful error when plist> fails --- basis/cocoa/plists/plists.factor | 11 +++- extra/game-input/iokit/iokit.factor | 82 ++++++++++++++++------------- 2 files changed, 54 insertions(+), 39 deletions(-) diff --git a/basis/cocoa/plists/plists.factor b/basis/cocoa/plists/plists.factor index 31b59a6eac..ceb097bb3a 100644 --- a/basis/cocoa/plists/plists.factor +++ b/basis/cocoa/plists/plists.factor @@ -4,7 +4,7 @@ USING: strings arrays hashtables assocs sequences fry macros cocoa.messages cocoa.classes cocoa.application cocoa kernel namespaces io.backend math cocoa.enumeration byte-arrays -combinators alien.c-types words core-foundation +combinators alien.c-types words core-foundation quotations core-foundation.data core-foundation.utilities ; IN: cocoa.plists @@ -41,10 +41,16 @@ DEFER: plist> *void* [ -> release "read-plist failed" throw ] when* ; MACRO: objc-class-case ( alist -- quot ) - [ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ; + [ + dup callable? + [ first2 [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip 2array ] + unless + ] map '[ _ cond ] ; PRIVATE> +ERROR: invalid-plist-object object ; + : plist> ( plist -- value ) { { NSString [ (plist-NSString>) ] } @@ -53,6 +59,7 @@ PRIVATE> { NSArray [ (plist-NSArray>) ] } { NSDictionary [ (plist-NSDictionary>) ] } { NSObject [ ] } + [ invalid-plist-object ] } objc-class-case ; : read-plist ( path -- assoc ) diff --git a/extra/game-input/iokit/iokit.factor b/extra/game-input/iokit/iokit.factor index de1529f8df..42189a8787 100755 --- a/extra/game-input/iokit/iokit.factor +++ b/extra/game-input/iokit/iokit.factor @@ -8,6 +8,8 @@ IN: game-input.iokit SINGLETON: iokit-game-input-backend +SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ; + iokit-game-input-backend game-input-backend set-global : hid-manager-matching ( matching-seq -- alien ) @@ -23,7 +25,6 @@ iokit-game-input-backend game-input-backend set-global CONSTANT: game-devices-matching-seq { - H{ { "DeviceUsage" 1 } { "DeviceUsagePage" 1 } } ! pointers H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads @@ -88,17 +89,17 @@ CONSTANT: hat-switch-matching-hash game-devices-matching-seq hid-manager-matching ; : device-property ( device key -- value ) - IOHIDDeviceGetProperty plist> ; + IOHIDDeviceGetProperty [ plist> ] [ f ] if* ; : element-property ( element key -- value ) - IOHIDElementGetProperty plist> ; + IOHIDElementGetProperty [ plist> ] [ f ] if* ; : set-element-property ( element key value -- ) [ ] [ >plist ] bi* IOHIDElementSetProperty drop ; : transfer-element-property ( element from-key to-key -- ) - [ dupd element-property ] dip swap set-element-property ; + [ dupd element-property ] dip swap + [ set-element-property ] [ 2drop ] if* ; : mouse-device? ( device -- ? ) { - [ 1 1 IOHIDDeviceConformsTo ] [ 1 2 IOHIDDeviceConformsTo ] } 1|| ; @@ -113,28 +114,31 @@ CONSTANT: hat-switch-matching-hash [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi 2array ; -: button? ( {usage-page,usage} -- ? ) - first 9 = ; inline -: keyboard-key? ( {usage-page,usage} -- ? ) - first 7 = ; inline +: button? ( element -- ? ) + IOHIDElementGetUsagePage 9 = ; inline +: keyboard-key? ( element -- ? ) + IOHIDElementGetUsagePage 7 = ; inline +: axis? ( element -- ? ) + IOHIDElementGetUsagePage 1 = ; inline + : x-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 30 } = ; inline + IOHIDElementGetUsage HEX: 30 = ; inline : y-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 31 } = ; inline + IOHIDElementGetUsage HEX: 31 = ; inline : z-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 32 } = ; inline + IOHIDElementGetUsage HEX: 32 = ; inline : rx-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 33 } = ; inline + IOHIDElementGetUsage HEX: 33 = ; inline : ry-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 34 } = ; inline + IOHIDElementGetUsage HEX: 34 = ; inline : rz-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 35 } = ; inline + IOHIDElementGetUsage HEX: 35 = ; inline : slider? ( {usage-page,usage} -- ? ) - { 1 HEX: 36 } = ; inline + IOHIDElementGetUsage HEX: 36 = ; inline : wheel? ( {usage-page,usage} -- ? ) - { 1 HEX: 38 } = ; inline + IOHIDElementGetUsage HEX: 38 = ; inline : hat-switch? ( {usage-page,usage} -- ? ) - { 1 HEX: 39 } = ; inline + IOHIDElementGetUsage HEX: 39 = ; inline CONSTANT: pov-values { @@ -152,42 +156,46 @@ CONSTANT: pov-values : pov-value ( value -- pov-direction ) IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ; -: record-button ( hid-value usage state -- ) - [ button-value ] [ second 1- ] [ buttons>> ] tri* set-nth ; +: record-button ( hid-value element state -- ) + [ button-value ] [ IOHIDElementGetUsage 1- ] [ buttons>> ] tri* set-nth ; : record-controller ( controller-state value -- ) - dup IOHIDValueGetElement element-usage { + dup IOHIDValueGetElement { { [ dup button? ] [ rot record-button ] } - { [ dup x-axis? ] [ drop axis-value >>x drop ] } - { [ dup y-axis? ] [ drop axis-value >>y drop ] } - { [ dup z-axis? ] [ drop axis-value >>z drop ] } - { [ dup rx-axis? ] [ drop axis-value >>rx drop ] } - { [ dup ry-axis? ] [ drop axis-value >>ry drop ] } - { [ dup rz-axis? ] [ drop axis-value >>rz drop ] } - { [ dup slider? ] [ drop axis-value >>slider drop ] } - { [ dup hat-switch? ] [ drop pov-value >>pov drop ] } + { [ dup axis? ] [ { + { [ dup x-axis? ] [ drop axis-value >>x drop ] } + { [ dup y-axis? ] [ drop axis-value >>y drop ] } + { [ dup z-axis? ] [ drop axis-value >>z drop ] } + { [ dup rx-axis? ] [ drop axis-value >>rx drop ] } + { [ dup ry-axis? ] [ drop axis-value >>ry drop ] } + { [ dup rz-axis? ] [ drop axis-value >>rz drop ] } + { [ dup slider? ] [ drop axis-value >>slider drop ] } + { [ dup hat-switch? ] [ drop pov-value >>pov drop ] } + [ 3drop ] + } cond ] } [ 3drop ] } cond ; -SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ; - : ?set-nth ( value nth seq -- ) 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ; : record-keyboard ( value -- ) - dup IOHIDValueGetElement element-usage keyboard-key? [ + dup IOHIDValueGetElement keyboard-key? [ [ IOHIDValueGetIntegerValue c-bool> ] [ IOHIDValueGetElement IOHIDElementGetUsage ] bi +keyboard-state+ get ?set-nth ] [ drop ] if ; : record-mouse ( value -- ) - dup IOHIDValueGetElement element-usage { + dup IOHIDValueGetElement { { [ dup button? ] [ +mouse-state+ get record-button ] } - { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] } - { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] } - { [ dup wheel? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] } - { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] } + { [ dup axis? ] [ { + { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] } + { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] } + { [ dup wheel? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] } + { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] } + [ 2drop ] + } cond ] } [ 2drop ] } cond ; From a0477acadb98e7534eb12161724ed2004ed19f3f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 19:00:06 -0500 Subject: [PATCH 131/210] implementing sha2 512 --- basis/checksums/common/common.factor | 3 + basis/checksums/sha2/sha2-tests.factor | 6 ++ basis/checksums/sha2/sha2.factor | 93 +++++++++++++++++++------- 3 files changed, 78 insertions(+), 24 deletions(-) diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor index 0ae4328446..01cc2cb739 100644 --- a/basis/checksums/common/common.factor +++ b/basis/checksums/common/common.factor @@ -9,6 +9,9 @@ SYMBOL: bytes-read : calculate-pad-length ( length -- length' ) [ 56 < 55 119 ? ] keep - ; +: calculate-pad-length-long ( length -- length' ) + [ 112 < 111 249 ? ] keep - ; + : pad-last-block ( str big-endian? length -- str ) [ [ % ] 2dip HEX: 80 , diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor index 1476f04e75..f224d497a6 100644 --- a/basis/checksums/sha2/sha2-tests.factor +++ b/basis/checksums/sha2/sha2-tests.factor @@ -34,3 +34,9 @@ IN: checksums.sha2.tests "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 test-checksum ] unit-test + + + + +[ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ] +[ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 6a695b0965..1abed088a3 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -6,9 +6,31 @@ sbufs strings combinators.smart math.ranges fry combinators accessors locals ; IN: checksums.sha2 - first3 ; inline -: pad-initial-bytes ( string -- padded-string ) +GENERIC: pad-initial-bytes ( string sha2 -- padded-string ) + +M: sha2-short pad-initial-bytes ( string sha2 -- padded-string ) + drop dup [ HEX: 80 , length - [ HEX: 3f bitand calculate-pad-length 0 % ] + [ 64 mod calculate-pad-length 0 % ] [ 3 shift 8 >be % ] bi ] "" make append ; +M: sha2-long pad-initial-bytes ( string sha2 -- padded-string ) + drop dup [ + HEX: 80 , + length + [ 128 mod calculate-pad-length-long 0 % ] + [ 3 shift 16 >be % ] bi + ] "" make append ; + : seq>byte-array ( seq n -- string ) '[ _ >be ] map B{ } join ; @@ -179,7 +216,7 @@ ALIAS: K-512 K-384 : prepare-message-schedule ( seq sha2 -- w-seq ) [ word-size>> [ be> ] map ] [ - block-size>> 0 pad-tail 16 64 [a,b) over + block-size>> [ 0 pad-tail 16 ] keep [a,b) over '[ _ process-M-256 ] each ] bi ; inline @@ -199,25 +236,9 @@ ALIAS: K-512 K-384 ] each ; : byte-array>sha2 ( bytes state -- ) - [ [ pad-initial-bytes ] [ block-size>> ] bi* ] + [ [ pad-initial-bytes ] [ nip block-size>> ] 2bi ] [ sha2-steps ] bi ; -PRIVATE> - -SINGLETON: sha-224 -SINGLETON: sha-256 -SINGLETON: sha-384 -SINGLETON: sha-512 - -INSTANCE: sha-224 checksum -INSTANCE: sha-256 checksum -INSTANCE: sha-384 checksum -INSTANCE: sha-512 checksum - -TUPLE: sha2-state K H word-size block-size ; - -TUPLE: sha-224-state < sha2-state ; - : ( -- sha2-state ) sha-224-state new K-256 >>K @@ -225,8 +246,6 @@ TUPLE: sha-224-state < sha2-state ; 4 >>word-size 64 >>block-size ; -TUPLE: sha-256-state < sha2-state ; - : ( -- sha2-state ) sha-256-state new K-256 >>K @@ -234,6 +253,22 @@ TUPLE: sha-256-state < sha2-state ; 4 >>word-size 64 >>block-size ; +: ( -- sha2-state ) + sha-384-state new + K-384 >>K + initial-H-384 >>H + 8 >>word-size + 80 >>block-size ; + +: ( -- sha2-state ) + sha-512-state new + K-512 >>K + initial-H-512 >>H + 8 >>word-size + 80 >>block-size ; + +PRIVATE> + M: sha-224 checksum-bytes drop [ byte-array>sha2 ] @@ -243,3 +278,13 @@ M: sha-256 checksum-bytes drop [ byte-array>sha2 ] [ H>> 4 seq>byte-array ] bi ; + +M: sha-384 checksum-bytes + drop + [ byte-array>sha2 ] + [ H>> 6 head 8 seq>byte-array ] bi ; + +M: sha-512 checksum-bytes + drop + [ byte-array>sha2 ] + [ H>> 8 seq>byte-array ] bi ; From 9e70b11845f1f458107351576c093e68ea7e9720 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 May 2009 19:16:45 -0500 Subject: [PATCH 132/210] a little bit more rice on game-input.iokit --- extra/game-input/iokit/iokit.factor | 50 ++++++++++++++++------------- 1 file changed, 27 insertions(+), 23 deletions(-) diff --git a/extra/game-input/iokit/iokit.factor b/extra/game-input/iokit/iokit.factor index 42189a8787..5f09a054f9 100755 --- a/extra/game-input/iokit/iokit.factor +++ b/extra/game-input/iokit/iokit.factor @@ -1,7 +1,7 @@ USING: cocoa cocoa.plists core-foundation iokit iokit.hid kernel cocoa.enumeration destructors math.parser cocoa.application sequences locals combinators.short-circuit threads -namespaces assocs vectors arrays combinators +namespaces assocs vectors arrays combinators hints alien core-foundation.run-loop accessors sequences.private alien.c-types math parser game-input vectors ; IN: game-input.iokit @@ -99,9 +99,7 @@ CONSTANT: hat-switch-matching-hash [ set-element-property ] [ 2drop ] if* ; : mouse-device? ( device -- ? ) - { - [ 1 2 IOHIDDeviceConformsTo ] - } 1|| ; + 1 2 IOHIDDeviceConformsTo ; : controller-device? ( device -- ? ) { @@ -156,12 +154,12 @@ CONSTANT: pov-values : pov-value ( value -- pov-direction ) IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ; -: record-button ( hid-value element state -- ) - [ button-value ] [ IOHIDElementGetUsage 1- ] [ buttons>> ] tri* set-nth ; +: record-button ( state hid-value element -- ) + [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ; : record-controller ( controller-state value -- ) dup IOHIDValueGetElement { - { [ dup button? ] [ rot record-button ] } + { [ dup button? ] [ record-button ] } { [ dup axis? ] [ { { [ dup x-axis? ] [ drop axis-value >>x drop ] } { [ dup y-axis? ] [ drop axis-value >>y drop ] } @@ -176,29 +174,35 @@ CONSTANT: pov-values [ 3drop ] } cond ; +HINTS: record-controller { controller-state alien } ; + : ?set-nth ( value nth seq -- ) 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ; -: record-keyboard ( value -- ) - dup IOHIDValueGetElement keyboard-key? [ +: record-keyboard ( keyboard-state value -- ) + dup IOHIDValueGetElement dup keyboard-key? [ [ IOHIDValueGetIntegerValue c-bool> ] - [ IOHIDValueGetElement IOHIDElementGetUsage ] bi - +keyboard-state+ get ?set-nth - ] [ drop ] if ; + [ IOHIDElementGetUsage ] bi* + rot ?set-nth + ] [ 3drop ] if ; -: record-mouse ( value -- ) +HINTS: record-keyboard { array alien } ; + +: record-mouse ( mouse-state value -- ) dup IOHIDValueGetElement { - { [ dup button? ] [ +mouse-state+ get record-button ] } + { [ dup button? ] [ record-button ] } { [ dup axis? ] [ { - { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] } - { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] } - { [ dup wheel? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] } - { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] } - [ 2drop ] + { [ dup x-axis? ] [ drop mouse-axis-value [ + ] curry change-dx drop ] } + { [ dup y-axis? ] [ drop mouse-axis-value [ + ] curry change-dy drop ] } + { [ dup wheel? ] [ drop mouse-axis-value [ + ] curry change-scroll-dx drop ] } + { [ dup z-axis? ] [ drop mouse-axis-value [ + ] curry change-scroll-dy drop ] } + [ 3drop ] } cond ] } - [ 2drop ] + [ 3drop ] } cond ; +HINTS: record-mouse { mouse-state alien } ; + M: iokit-game-input-backend read-mouse +mouse-state+ get ; @@ -271,8 +275,8 @@ M: iokit-game-input-backend reset-mouse { [ sender controller-device? ] [ sender +controller-states+ get at value record-controller ] } - { [ sender mouse-device? ] [ value record-mouse ] } - [ value record-keyboard ] + { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] } + [ +keyboard-state+ get value record-keyboard ] } cond ] IOHIDValueCallback ; @@ -297,7 +301,7 @@ M: iokit-game-input-backend (open-game-input) } cleave ; M: iokit-game-input-backend (reset-game-input) - { +hid-manager+ +keyboard-state+ +controller-states+ } + { +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ } [ f swap set-global ] each ; M: iokit-game-input-backend (close-game-input) From 374c742cad58ca01a977080fe42b0a24aae20683 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 21:33:49 -0500 Subject: [PATCH 133/210] mason.report: Remove superfluous text --- extra/mason/report/report.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 0340941449..6e48e7cf04 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -112,8 +112,7 @@ IN: mason.report benchmark-error-vocabs-file benchmark-error-messages-file error-dump - - "Benchmark timings" + benchmarks-file eval-file benchmarks-table ] output>array ] with-report ; From 1e7f809a9818a165f45b802f3bb5eb73b5c9946b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 21:34:28 -0500 Subject: [PATCH 134/210] specialized-arrays: fix tests on PowerPC --- .../specialized-arrays-tests.factor | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index f64542fa00..1e470b699a 100644 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -2,7 +2,8 @@ IN: specialized-arrays.tests USING: tools.test specialized-arrays sequences specialized-arrays.int specialized-arrays.bool specialized-arrays.ushort alien.c-types accessors kernel -specialized-arrays.direct.int specialized-arrays.char arrays ; +specialized-arrays.direct.int specialized-arrays.char +specialized-arrays.uint arrays combinators ; [ t ] [ { 1 2 3 } >int-array int-array? ] unit-test @@ -10,7 +11,13 @@ specialized-arrays.direct.int specialized-arrays.char arrays ; [ 2 ] [ int-array{ 1 2 3 } second ] unit-test -[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >char-array underlying>> = ] unit-test +[ t ] [ + { t f t } >bool-array underlying>> + { 1 0 1 } "bool" heap-size { + { 1 [ >char-array ] } + { 4 [ >uint-array ] } + } case underlying>> = +] unit-test [ ushort-array{ 1234 } ] [ little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array From 8b35e726c01693a0b5cdacc5070f157ca4197f63 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 09:49:31 -0500 Subject: [PATCH 135/210] fp-nan? was defined incorrectly. while i'm here, let's add some more float manipulation words --- core/math/math-docs.factor | 33 +++++++++++++++++++- core/math/math-tests.factor | 17 +++++++++++ core/math/math.factor | 60 +++++++++++++++++++++++++++++-------- 3 files changed, 97 insertions(+), 13 deletions(-) diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index c28bf062c1..75370d6cfd 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -245,10 +245,22 @@ HELP: times { $example "USING: io math ;" "3 [ \"Hi\" print ] times" "Hi\nHi\nHi" } } ; +HELP: fp-special? +{ $values { "x" real } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "x" } " is an IEEE special value (Not-a-Number or Infinity). While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; + HELP: fp-nan? { $values { "x" real } { "?" "a boolean" } } { $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; +HELP: fp-qnan? +{ $values { "x" real } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "x" } " is an IEEE Quiet Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; + +HELP: fp-snan? +{ $values { "x" real } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "x" } " is an IEEE Signaling Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; + HELP: fp-infinity? { $values { "x" real } { "?" "a boolean" } } { $description "Tests if " { $snippet "x" } " is an IEEE Infinity value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } @@ -257,7 +269,26 @@ HELP: fp-infinity? { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" } } ; -{ fp-nan? fp-infinity? } related-words +HELP: fp-nan-payload +{ $values { "x" real } { "bits" integer } } +{ $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ; + +HELP: +{ $values { "payload" integer } { "float" float } } +{ $description "Constructs an IEEE Not-a-Number value with a payload of " { $snippet "payload" } "." } +{ $notes "A " { $snippet "payload" } " of " { $snippet "0" } " will construct an Infinity value." } ; + +{ fp-special? fp-nan? fp-qnan? fp-snan? fp-infinity? fp-nan-payload } related-words + +HELP: next-float +{ $values { "m" float } { "n" float } } +{ $description "Returns the least representable " { $link float } " value greater than " { $snippet "m" } "." } ; + +HELP: prev-float +{ $values { "m" float } { "n" float } } +{ $description "Returns the greatest representable " { $link float } " value less than " { $snippet "m" } "." } ; + +{ next-float prev-float } related-words HELP: real-part { $values { "z" number } { "x" real } } diff --git a/core/math/math-tests.factor b/core/math/math-tests.factor index c2077eb790..b7cc51e669 100644 --- a/core/math/math-tests.factor +++ b/core/math/math-tests.factor @@ -12,7 +12,24 @@ IN: math.tests [ f ] [ 1/0. fp-nan? ] unit-test [ f ] [ -1/0. fp-nan? ] unit-test [ t ] [ -0/0. fp-nan? ] unit-test +[ t ] [ 1 fp-nan? ] unit-test +! [ t ] [ 1 fp-snan? ] unit-test +! [ f ] [ 1 fp-qnan? ] unit-test +[ t ] [ HEX: 8000000000001 fp-nan? ] unit-test +[ f ] [ HEX: 8000000000001 fp-snan? ] unit-test +[ t ] [ HEX: 8000000000001 fp-qnan? ] unit-test [ t ] [ 1/0. fp-infinity? ] unit-test [ t ] [ -1/0. fp-infinity? ] unit-test [ f ] [ -0/0. fp-infinity? ] unit-test + +[ f ] [ 0 fp-nan? ] unit-test +[ t ] [ 0 fp-infinity? ] unit-test + +[ 0.0 ] [ -0.0 next-float ] unit-test +[ t ] [ 1.0 dup next-float < ] unit-test +[ t ] [ -1.0 dup next-float < ] unit-test + +[ -0.0 ] [ 0.0 prev-float ] unit-test +[ t ] [ 1.0 dup prev-float > ] unit-test +[ t ] [ -1.0 dup prev-float > ] unit-test diff --git a/core/math/math.factor b/core/math/math.factor index 8e0000326f..6a087ec909 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -81,26 +81,62 @@ TUPLE: complex { real real read-only } { imaginary real read-only } ; UNION: number real complex ; +GENERIC: fp-special? ( x -- ? ) GENERIC: fp-nan? ( x -- ? ) +GENERIC: fp-qnan? ( x -- ? ) +GENERIC: fp-snan? ( x -- ? ) +GENERIC: fp-infinity? ( x -- ? ) +GENERIC: fp-nan-payload ( x -- bits ) +M: object fp-special? + drop f ; M: object fp-nan? drop f ; - -M: float fp-nan? - double>bits -51 shift HEX: fff [ bitand ] keep = ; - -GENERIC: fp-infinity? ( x -- ? ) - +M: object fp-qnan? + drop f ; +M: object fp-snan? + drop f ; M: object fp-infinity? drop f ; +M: object fp-nan-payload + drop f ; -M: float fp-infinity? ( float -- ? ) +M: float fp-special? + double>bits -52 shift HEX: 7ff [ bitand ] keep = ; + +M: float fp-nan-payload + double>bits HEX: fffffffffffff bitand ; foldable flushable + +M: float fp-nan? + dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; + +M: float fp-qnan? + dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ; + +M: float fp-snan? + dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ; + +M: float fp-infinity? + dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; + +: ( payload -- nan ) + HEX: 7ff0000000000000 bitor bits>double ; foldable flushable + +: next-float ( m -- n ) double>bits - dup -52 shift HEX: 7ff [ bitand ] keep = [ - HEX: fffffffffffff bitand 0 = - ] [ - drop f - ] if ; + dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero + dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero + 1 + bits>double ! positive + ] if + ] if ; foldable flushable + +: prev-float ( m -- n ) + double>bits + dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative + dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero + 1 - bits>double ! positive non-zero + ] if + ] if ; foldable flushable : next-power-of-2 ( m -- n ) dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline From dedb1d753660d719bf9b3924179359b2458765f6 Mon Sep 17 00:00:00 2001 From: Diego Martinelli Date: Sat, 9 May 2009 17:23:41 +0200 Subject: [PATCH 136/210] Main implementation done. Need docs and tests. --- extra/hashcash/authors.txt | 1 + extra/hashcash/hashcash.factor | 90 +++++++++++++++++++++++++++++++++- 2 files changed, 89 insertions(+), 2 deletions(-) diff --git a/extra/hashcash/authors.txt b/extra/hashcash/authors.txt index e69de29bb2..f6e3b59c4c 100755 --- a/extra/hashcash/authors.txt +++ b/extra/hashcash/authors.txt @@ -0,0 +1 @@ +Diego Martinelli diff --git a/extra/hashcash/hashcash.factor b/extra/hashcash/hashcash.factor index fe7cf10bd3..3e75aad94c 100755 --- a/extra/hashcash/hashcash.factor +++ b/extra/hashcash/hashcash.factor @@ -1,4 +1,90 @@ -! Copyright (C) 2009 Your name. +! Copyright (C) 2009 Diego Martinelli. ! See http://factorcode.org/license.txt for BSD license. -USING: ; +USING: accessors byte-arrays calendar calendar.format +checksums checksums.openssl classes.tuple +fry kernel make math math.functions math.parser math.ranges +present random sequences splitting strings syntax ; IN: hashcash + +! Hashcash implementation +! Reference materials listed below: +! +! http://hashcash.org +! http://en.wikipedia.org/wiki/Hashcash +! http://www.ibm.com/developerworks/linux/library/l-hashcash.html?ca=dgr-lnxw01HashCash +! +! And the reference implementation (in python): +! http://www.gnosis.cx/download/gnosis/util/hashcash.py + +> 100 mod pad-00 ] + [ month>> pad-00 ] + [ day>> pad-00 ] tri 3append ; + +! Random salt is formed by ascii characters +! between 33 and 126 +: available-chars ( -- seq ) + 33 126 [a,b] [ CHAR: : = not ] filter ; + +PRIVATE> + +! Generate a 'length' long random salt +: salt ( length -- salted ) + available-chars '[ _ random ] "" replicate-as ; + +TUPLE: hashcash version bits date resource ext salt suffix ; + +: ( -- tuple ) + hashcash new + 1 >>version + 20 >>bits + get-date >>date + 8 salt >>salt ; + +M: hashcash string>> + tuple-slots [ present ] map ":" join ; + +hex >>suffix ; + +: get-bits ( bytes -- str ) + [ >bin 8 CHAR: 0 pad-head ] { } map-as concat ; + +: checksummed-bits ( tuple -- relevant-bits ) + dup string>> sha1-checksum + swap bits>> 8 / ceiling head get-bits ; + +: all-char-zero? ( seq -- ? ) + [ CHAR: 0 = ] all? ; inline + +: valid-guess? ( checksum tuple -- ? ) + bits>> head all-char-zero? ; + +: (mint) ( tuple counter -- tuple ) + 2dup set-suffix checksummed-bits pick + valid-guess? [ drop ] [ 1+ (mint) ] if ; + +PRIVATE> + +: mint* ( tuple -- str ) + 0 (mint) string>> ; + +: mint ( resource -- str ) + + swap >>resource + mint* ; + +! One might wanna add check based on the date, +! passing a 'good-until' duration param +: check-stamp ( stamp -- ? ) + dup ":" split [ sha1-checksum get-bits ] dip + second string>number head all-char-zero? ; + From 89ee4b1f401689a63019e2e68c35abdc447225d5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 11:15:06 -0500 Subject: [PATCH 137/210] gravity, jetpack, collision detection for terrain demo --- extra/terrain/shaders/shaders.factor | 10 +-- extra/terrain/terrain.factor | 114 ++++++++++++++++++--------- 2 files changed, 81 insertions(+), 43 deletions(-) diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor index 2dc793f078..c341545956 100644 --- a/extra/terrain/shaders/shaders.factor +++ b/extra/terrain/shaders/shaders.factor @@ -4,15 +4,14 @@ IN: terrain.shaders STRING: terrain-vertex-shader uniform sampler2D heightmap; +uniform vec4 component_scale; varying vec2 heightcoords; -const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0); - float height(sampler2D map, vec2 coords) { vec4 v = texture2D(map, coords); - return dot(v, COMPONENT_SCALE); + return dot(v, component_scale); } void main() @@ -27,15 +26,14 @@ void main() STRING: terrain-pixel-shader uniform sampler2D heightmap; +uniform vec4 component_scale; varying vec2 heightcoords; -const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0); - float height(sampler2D map, vec2 coords) { vec4 v = texture2D(map, coords); - return dot(v, COMPONENT_SCALE); + return dot(v, component_scale); } void main() diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 6617275784..c6dce2d9c2 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -1,6 +1,6 @@ USING: accessors arrays combinators game-input -game-input.scancodes game-loop kernel literals locals math -math.constants math.functions math.matrices math.order +game-input.scancodes game-loop grouping kernel literals locals +math math.constants math.functions math.matrices math.order math.vectors opengl opengl.capabilities opengl.gl opengl.shaders opengl.textures opengl.textures.private sequences sequences.product specialized-arrays.float @@ -9,19 +9,27 @@ ui.gadgets.worlds ui.pixel-formats ; IN: terrain CONSTANT: FOV $[ 2.0 sqrt 1+ ] -CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ] -CONSTANT: FAR-PLANE 2.0 -CONSTANT: EYE-START { 0.5 0.5 1.2 } +CONSTANT: NEAR-PLANE $[ 1.0 2048.0 / ] +CONSTANT: FAR-PLANE 1.0 +CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 } +CONSTANT: PLAYER-HEIGHT $[ 3.0 1024.0 / ] +CONSTANT: GRAVITY $[ 1.0 4096.0 / ] +CONSTANT: JUMP $[ 1.0 1024.0 / ] CONSTANT: TICK-LENGTH $[ 1000 30 /i ] CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ] -CONSTANT: MOVEMENT-SPEED $[ 1.0 512.0 / ] +CONSTANT: MOVEMENT-SPEED $[ 1.0 16384.0 / ] +CONSTANT: FRICTION 0.95 +CONSTANT: COMPONENT-SCALE { 0.5 0.01 0.002 0.0 } CONSTANT: terrain-vertex-size { 512 512 } CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] } CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ] +TUPLE: player + location yaw pitch velocity ; + TUPLE: terrain-world < world - eye yaw pitch + player terrain terrain-segment terrain-texture terrain-program terrain-vertex-buffer game-loop ; @@ -35,9 +43,10 @@ TUPLE: terrain-world < world GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear GL_MODELVIEW glMatrixMode glLoadIdentity + player>> [ pitch>> 1.0 0.0 0.0 glRotatef ] [ yaw>> 0.0 1.0 0.0 glRotatef ] - [ eye>> vneg first3 glTranslatef ] tri ; + [ location>> vneg first3 glTranslatef ] tri ; : vertex-array-vertex ( x z -- vertex ) [ terrain-vertex-distance first * ] @@ -79,47 +88,77 @@ TUPLE: terrain-world < world p cos :> cosp p sin :> sinp - cosy 0.0 siny neg 3array - siny sinp * cosp cosy sinp * 3array - siny cosp * sinp neg cosy cosp * 3array 3array + cosy 0.0 siny neg 3array + siny sinp * cosp cosy sinp * 3array + siny cosp * sinp neg cosy cosp * 3array 3array v swap v.m ; -: forward-vector ( world -- v ) - [ yaw>> ] [ pitch>> ] bi +: forward-vector ( player -- v ) + yaw>> 0.0 { 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ; -: rightward-vector ( world -- v ) - [ yaw>> ] [ pitch>> ] bi +: rightward-vector ( player -- v ) + yaw>> 0.0 { $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ; -: move-forward ( world -- ) - dup forward-vector [ v+ ] curry change-eye drop ; -: move-backward ( world -- ) - dup forward-vector [ v- ] curry change-eye drop ; -: move-leftward ( world -- ) - dup rightward-vector [ v- ] curry change-eye drop ; -: move-rightward ( world -- ) - dup rightward-vector [ v+ ] curry change-eye drop ; +: walk-forward ( player -- ) + dup forward-vector [ v+ ] curry change-velocity drop ; +: walk-backward ( player -- ) + dup forward-vector [ v- ] curry change-velocity drop ; +: walk-leftward ( player -- ) + dup rightward-vector [ v- ] curry change-velocity drop ; +: walk-rightward ( player -- ) + dup rightward-vector [ v+ ] curry change-velocity drop ; +: jump ( player -- ) + [ { 0.0 $ JUMP 0.0 } v+ ] change-velocity drop ; -: rotate-with-mouse ( world mouse -- ) +: clamp-pitch ( pitch -- pitch' ) + 90.0 min -90.0 max ; + +: rotate-with-mouse ( player mouse -- ) [ dx>> MOUSE-SCALE * [ + ] curry change-yaw ] - [ dy>> MOUSE-SCALE * [ + ] curry change-pitch ] bi + [ dy>> MOUSE-SCALE * [ + clamp-pitch ] curry change-pitch ] bi drop ; :: handle-input ( world -- ) + world player>> :> player read-keyboard keys>> :> keys - key-w keys nth [ world move-forward ] when - key-s keys nth [ world move-backward ] when - key-a keys nth [ world move-leftward ] when - key-d keys nth [ world move-rightward ] when + key-w keys nth [ player walk-forward ] when + key-s keys nth [ player walk-backward ] when + key-a keys nth [ player walk-leftward ] when + key-d keys nth [ player walk-rightward ] when + key-space keys nth [ player jump ] when key-escape keys nth [ world close-window ] when - world read-mouse rotate-with-mouse + player read-mouse rotate-with-mouse reset-mouse ; -M: terrain-world tick* - [ handle-input ] keep - ! [ eye>> ] [ yaw>> ] [ pitch>> ] tri 3array P ! debug +: apply-friction ( velocity -- velocity' ) + FRICTION v*n ; + +: apply-gravity ( velocity -- velocity' ) + 1 over [ GRAVITY - ] change-nth ; + +: pixel ( coords dim -- index ) + [ drop first ] [ [ second ] [ first ] bi* * ] 2bi + ; + +: terrain-height-at ( segment point -- height ) + over dim>> [ v* vfloor ] [ pixel >integer ] bi + swap bitmap>> 4 nth COMPONENT-SCALE v. 255.0 / ; + +: collide ( segment location -- location' ) + [ [ first ] [ third ] bi 2array terrain-height-at PLAYER-HEIGHT + ] + [ [ 1 ] 2dip [ max ] with change-nth ] + [ ] tri ; + +: tick-player ( world player -- ) + [ apply-friction apply-gravity ] change-velocity + dup velocity>> [ v+ [ terrain-segment>> ] dip collide ] curry with change-location + P drop ; +M: terrain-world tick* + [ dup focused?>> [ handle-input ] [ drop ] if ] + [ dup player>> tick-player ] bi ; + M: terrain-world draw* nip draw-world ; @@ -137,9 +176,7 @@ M: terrain-world begin-world GL_TEXTURE_2D glEnable GL_VERTEX_ARRAY glEnableClientState 0.5 0.5 0.5 1.0 glClearColor - EYE-START >>eye - 0.0 >>yaw - 0.0 >>pitch + PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } player boa >>player [ >>terrain ] keep { 0 0 } terrain-segment [ >>terrain-segment ] keep make-texture [ set-heightmap-texture-parameters ] keep >>terrain-texture @@ -169,7 +206,8 @@ M: terrain-world draw-world* [ set-modelview-matrix ] [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ] [ dup terrain-program>> [ - "heightmap" glGetUniformLocation 0 glUniform1i + [ "heightmap" glGetUniformLocation 0 glUniform1i ] + [ "component_scale" glGetUniformLocation COMPONENT-SCALE first4 glUniform4f ] bi terrain-vertex-buffer>> draw-vertex-buffer ] with-gl-program ] tri gl-error ; @@ -190,3 +228,5 @@ M: terrain-world pref-dim* drop { 640 480 } ; { grab-input? t } } open-window ] with-ui ; + +MAIN: terrain-window From e12a0505632337ac5cb00eeb1967f66992f25c56 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 11:36:24 -0500 Subject: [PATCH 138/210] bilerp collision height --- extra/terrain/terrain.factor | 24 ++++++++++++++++++------ 1 file changed, 18 insertions(+), 6 deletions(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index c6dce2d9c2..083b162c01 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -137,12 +137,25 @@ TUPLE: terrain-world < world : apply-gravity ( velocity -- velocity' ) 1 over [ GRAVITY - ] change-nth ; -: pixel ( coords dim -- index ) - [ drop first ] [ [ second ] [ first ] bi* * ] 2bi + ; +:: pixel-indices ( coords dim -- indices ) + coords vfloor [ >integer ] map :> floor-coords + floor-coords first2 dim first * + :> base-index + base-index dim first + :> next-row-index -: terrain-height-at ( segment point -- height ) - over dim>> [ v* vfloor ] [ pixel >integer ] bi - swap bitmap>> 4 nth COMPONENT-SCALE v. 255.0 / ; + base-index + base-index 1 + + next-row-index + next-row-index 1 + 4array ; + +:: terrain-height-at ( segment point -- height ) + segment dim>> :> dim + dim point v* :> pixel + pixel dup vfloor v- :> pixel-mantissa + segment bitmap>> 4 :> pixels + pixel dim pixel-indices :> indices + + indices [ pixels nth COMPONENT-SCALE v. 255.0 / ] map + first4 [ pixel-mantissa first lerp ] 2bi@ pixel-mantissa second lerp ; : collide ( segment location -- location' ) [ [ first ] [ third ] bi 2array terrain-height-at PLAYER-HEIGHT + ] @@ -152,7 +165,6 @@ TUPLE: terrain-world < world : tick-player ( world player -- ) [ apply-friction apply-gravity ] change-velocity dup velocity>> [ v+ [ terrain-segment>> ] dip collide ] curry with change-location - P drop ; M: terrain-world tick* From 1d58b94bf71ccef5ce5aaacec3d8a38cd943a722 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 11:43:04 -0500 Subject: [PATCH 139/210] send bilerp upstream to spawn --- basis/math/vectors/vectors-tests.factor | 2 ++ basis/math/vectors/vectors.factor | 4 ++++ extra/terrain/terrain.factor | 2 +- 3 files changed, 7 insertions(+), 1 deletion(-) diff --git a/basis/math/vectors/vectors-tests.factor b/basis/math/vectors/vectors-tests.factor index b4b12d619b..968af6a3aa 100644 --- a/basis/math/vectors/vectors-tests.factor +++ b/basis/math/vectors/vectors-tests.factor @@ -14,3 +14,5 @@ USING: math.vectors tools.test ; [ { 1.75 1.75 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.5 vnlerp ] unit-test [ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test + +[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index eb203a5f12..17f6c39f04 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -41,6 +41,10 @@ IN: math.vectors : set-axis ( u v axis -- w ) [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; +: bilerp ( aa ba ab bb {t,u} -- a_tu ) + [ first lerp ] [ second lerp ] bi-curry + [ 2bi@ ] [ call ] bi* ; + : vlerp ( a b t -- a_t ) [ lerp ] 3map ; diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 083b162c01..d58aa4ec30 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -155,7 +155,7 @@ TUPLE: terrain-world < world pixel dim pixel-indices :> indices indices [ pixels nth COMPONENT-SCALE v. 255.0 / ] map - first4 [ pixel-mantissa first lerp ] 2bi@ pixel-mantissa second lerp ; + first4 pixel-mantissa bilerp ; : collide ( segment location -- location' ) [ [ first ] [ third ] bi 2array terrain-height-at PLAYER-HEIGHT + ] From 41a4b1fdb807022ca0a5ec7b0f37631fc37d1004 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 12:53:01 -0500 Subject: [PATCH 140/210] factor game-input and game-loop mgmt out to a game-world base object --- extra/game-worlds/game-worlds.factor | 24 ++++++++++++++++++++++++ extra/terrain/terrain.factor | 27 ++++++++++----------------- 2 files changed, 34 insertions(+), 17 deletions(-) create mode 100644 extra/game-worlds/game-worlds.factor diff --git a/extra/game-worlds/game-worlds.factor b/extra/game-worlds/game-worlds.factor new file mode 100644 index 0000000000..864bd28fc1 --- /dev/null +++ b/extra/game-worlds/game-worlds.factor @@ -0,0 +1,24 @@ +USING: accessors game-input game-loop kernel ui.gadgets +ui.gadgets.worlds ui.gestures ; +IN: game-worlds + +TUPLE: game-world < world + game-loop ; + +GENERIC: tick-length ( world -- millis ) + +M: game-world draw* + nip draw-world ; + +M: game-world begin-world + dup [ tick-length ] [ ] bi [ >>game-loop ] keep start-loop + drop + open-game-input ; + +M: game-world end-world + close-game-input + [ [ stop-loop ] when* f ] change-game-loop + drop ; + +M: game-world focusable-child* drop t ; + diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index d58aa4ec30..fe105b2e52 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -1,11 +1,11 @@ -USING: accessors arrays combinators game-input -game-input.scancodes game-loop grouping kernel literals locals +USING: accessors arrays combinators game-input game-loop +game-input.scancodes grouping kernel literals locals math math.constants math.functions math.matrices math.order math.vectors opengl opengl.capabilities opengl.gl opengl.shaders opengl.textures opengl.textures.private sequences sequences.product specialized-arrays.float terrain.generation terrain.shaders ui ui.gadgets -ui.gadgets.worlds ui.pixel-formats ; +ui.gadgets.worlds ui.pixel-formats game-worlds method-chains ; IN: terrain CONSTANT: FOV $[ 2.0 sqrt 1+ ] @@ -15,7 +15,6 @@ CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 } CONSTANT: PLAYER-HEIGHT $[ 3.0 1024.0 / ] CONSTANT: GRAVITY $[ 1.0 4096.0 / ] CONSTANT: JUMP $[ 1.0 1024.0 / ] -CONSTANT: TICK-LENGTH $[ 1000 30 /i ] CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ] CONSTANT: MOVEMENT-SPEED $[ 1.0 16384.0 / ] CONSTANT: FRICTION 0.95 @@ -28,11 +27,13 @@ CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ] TUPLE: player location yaw pitch velocity ; -TUPLE: terrain-world < world +TUPLE: terrain-world < game-world player terrain terrain-segment terrain-texture terrain-program - terrain-vertex-buffer - game-loop ; + terrain-vertex-buffer ; + +M: terrain-world tick-length + drop 1000 30 /i ; : frustum ( dim -- -x x -y y near far ) dup first2 min v/n @@ -171,9 +172,6 @@ M: terrain-world tick* [ dup focused?>> [ handle-input ] [ drop ] if ] [ dup player>> tick-player ] bi ; -M: terrain-world draw* - nip draw-world ; - : set-heightmap-texture-parameters ( texture -- ) GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri @@ -181,7 +179,7 @@ M: terrain-world draw* GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ; -M: terrain-world begin-world +BEFORE: terrain-world begin-world "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" } require-gl-version-or-extensions GL_DEPTH_TEST glEnable @@ -195,14 +193,10 @@ M: terrain-world begin-world terrain-vertex-shader terrain-pixel-shader >>terrain-program vertex-array >vertex-buffer >>terrain-vertex-buffer - TICK-LENGTH over [ >>game-loop ] keep start-loop - open-game-input drop ; -M: terrain-world end-world - close-game-input +AFTER: terrain-world end-world { - [ game-loop>> stop-loop ] [ terrain-vertex-buffer>> delete-gl-buffer ] [ terrain-program>> delete-gl-program ] [ terrain-texture>> delete-texture ] @@ -224,7 +218,6 @@ M: terrain-world draw-world* ] with-gl-program ] tri gl-error ; -M: terrain-world focusable-child* drop t ; M: terrain-world pref-dim* drop { 640 480 } ; : terrain-window ( -- ) From f503775497f4382444f36af5cc765e5bd7d82c0f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 9 May 2009 13:54:18 -0500 Subject: [PATCH 141/210] use bi, call >string on c-strings from tar --- extra/crypto/hmac/hmac.factor | 4 ++-- extra/tar/tar.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor index 6e6229f182..9a668aa23a 100755 --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -31,8 +31,8 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; : init-hmac ( K -- o i ) 64 0 pad-tail - [ opad seq-bitxor ] keep - ipad seq-bitxor ; + [ opad seq-bitxor ] + [ ipad seq-bitxor ] bi ; PRIVATE> diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index e281871252..93554c146a 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -18,7 +18,7 @@ ERROR: checksum-error header ; : trim-string ( seq -- newseq ) [ "\0 " member? ] trim ; : read-c-string ( n -- str/f ) - read [ zero? ] trim-tail [ f ] when-empty ; + read [ zero? ] trim-tail [ f ] when-empty >string ; : read-tar-header ( -- obj ) \ tar-header new From 868e693977f0d0a27c35a162e93ba4e99564f85a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 9 May 2009 13:54:42 -0500 Subject: [PATCH 142/210] 64-bit add/subtract/multiply --- basis/math/bitwise/bitwise.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 73d111f91e..4fe2340643 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -35,6 +35,11 @@ IN: math.bitwise : w- ( int int -- int ) - 32 bits ; inline : w* ( int int -- int ) * 32 bits ; inline +! 64-bit arithmetic +: W+ ( int int -- int ) + 64 bits ; inline +: W- ( int int -- int ) - 64 bits ; inline +: W* ( int int -- int ) * 64 bits ; inline + ! flags MACRO: flags ( values -- ) [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ; From e080be9fa02a6d6402b0418fb448cca983ac7ce2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 14:31:33 -0500 Subject: [PATCH 143/210] save off the tick-slice when draw*-ing a game-world --- extra/game-worlds/game-worlds.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/game-worlds/game-worlds.factor b/extra/game-worlds/game-worlds.factor index 864bd28fc1..fa6b326fa9 100644 --- a/extra/game-worlds/game-worlds.factor +++ b/extra/game-worlds/game-worlds.factor @@ -1,14 +1,15 @@ -USING: accessors game-input game-loop kernel ui.gadgets +USING: accessors game-input game-loop kernel math ui.gadgets ui.gadgets.worlds ui.gestures ; IN: game-worlds TUPLE: game-world < world - game-loop ; + game-loop + { tick-slice float initial: 0.0 } ; GENERIC: tick-length ( world -- millis ) M: game-world draw* - nip draw-world ; + swap >>tick-slice draw-world ; M: game-world begin-world dup [ tick-length ] [ ] bi [ >>game-loop ] keep start-loop From dc3b18b785fe5650155b5e219a870502e780166a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 14:33:17 -0500 Subject: [PATCH 144/210] don't mess with the orphaned nodes when pop-front-ing or pop-back-ing a dlist. add a dlist-filter word that drops off all nodes that don't satisfy a predicate --- basis/dlists/dlists-tests.factor | 5 +++++ basis/dlists/dlists.factor | 7 +++++-- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor index 3689680157..8072c93753 100755 --- a/basis/dlists/dlists-tests.factor +++ b/basis/dlists/dlists-tests.factor @@ -79,3 +79,8 @@ IN: dlists.tests [ V{ f 3 1 f } ] [ 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test [ V{ } ] [ dlist>seq ] unit-test + +[ V{ 0 2 4 } ] [ { 0 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test +[ V{ 2 4 } ] [ { 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test +[ V{ 2 4 } ] [ { 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test +[ V{ 0 2 4 } ] [ { 0 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index 3d7224ed16..89675c6469 100755 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -95,7 +95,7 @@ M: dlist pop-front* ( dlist -- ) [ [ [ empty-dlist ] unless* - [ f ] change-next drop + next>> f over set-prev-when ] change-front drop ] keep @@ -108,7 +108,7 @@ M: dlist pop-back* ( dlist -- ) [ [ [ empty-dlist ] unless* - [ f ] change-prev drop + prev>> f over set-next-when ] change-back drop ] keep @@ -157,6 +157,9 @@ M: dlist clear-deque ( dlist -- ) : 1dlist ( obj -- dlist ) [ push-front ] keep ; +: dlist-filter ( dlist quot -- dlist ) + over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline + M: dlist clone [ '[ _ push-back ] dlist-each ] keep ; From 74b308f873cc261810a80d1d13a55101b8ad2c2d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 May 2009 18:17:30 -0500 Subject: [PATCH 145/210] Fix negative zero smashing with bootstrap --- basis/bootstrap/image/image.factor | 3 +++ core/math/math.factor | 2 ++ 2 files changed, 5 insertions(+) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 55e6a31491..92d75604e0 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -52,6 +52,9 @@ GENERIC: (eql?) ( obj1 obj2 -- ? ) M: integer (eql?) = ; +M: float (eql?) + over float? [ fp-bitwise= ] [ 2drop f ] if ; + M: sequence (eql?) over sequence? [ 2dup [ length ] bi@ = diff --git a/core/math/math.factor b/core/math/math.factor index 6a087ec909..da9bc4d1b5 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -81,6 +81,8 @@ TUPLE: complex { real real read-only } { imaginary real read-only } ; UNION: number real complex ; +: fp-bitwise= ( x y -- ? ) [ double>bits ] bi@ = ; inline + GENERIC: fp-special? ( x -- ? ) GENERIC: fp-nan? ( x -- ? ) GENERIC: fp-qnan? ( x -- ? ) From 5c25001c3dac7a4b65a6752b0a005136a8d210ba Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 20:15:03 -0500 Subject: [PATCH 146/210] docs for dlist-filter --- basis/dlists/dlists-docs.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor index 12e39746c7..e210ad35ce 100755 --- a/basis/dlists/dlists-docs.factor +++ b/basis/dlists/dlists-docs.factor @@ -15,6 +15,7 @@ $nl "Iterating over elements:" { $subsection dlist-each } { $subsection dlist-find } +{ $subsection dlist-filter } { $subsection dlist-any? } "Deleting a node matching a predicate:" { $subsection delete-node-if* } @@ -40,6 +41,11 @@ HELP: dlist-find "This operation is O(n)." } ; +HELP: dlist-filter +{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist" { $link dlist } } } +{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, removing the corresponding nodes if the quotation returns " { $link f } "." } +{ $side-effects { "dlist" } } ; + HELP: dlist-any? { $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } } { $description "Just like " { $link dlist-find } " except it doesn't return the object." } From eac70696c9db4bea251664d03b8ecb9f62ac2753 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 20:15:55 -0500 Subject: [PATCH 147/210] clamp coordinates when doing terrain collision detection past the edge of the segment --- extra/terrain/terrain.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index fe105b2e52..590244ca6a 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -138,8 +138,11 @@ M: terrain-world tick-length : apply-gravity ( velocity -- velocity' ) 1 over [ GRAVITY - ] change-nth ; +: clamp-coords ( coords dim -- coords' ) + [ { 0 0 } vmax ] dip { 2 2 } v- vmin ; + :: pixel-indices ( coords dim -- indices ) - coords vfloor [ >integer ] map :> floor-coords + coords vfloor [ >integer ] map dim clamp-coords :> floor-coords floor-coords first2 dim first * + :> base-index base-index dim first + :> next-row-index From 45f325a7445588f698b88d4465cd0728b8ccd293 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 20:23:56 -0500 Subject: [PATCH 148/210] "math" help-lint --- core/math/math-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 75370d6cfd..e5f68a511c 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -274,7 +274,7 @@ HELP: fp-nan-payload { $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ; HELP: -{ $values { "payload" integer } { "float" float } } +{ $values { "payload" integer } { "nan" float } } { $description "Constructs an IEEE Not-a-Number value with a payload of " { $snippet "payload" } "." } { $notes "A " { $snippet "payload" } " of " { $snippet "0" } " will construct an Infinity value." } ; From b86a419b6efa9be797c70a86cd97118bba64d71f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 May 2009 20:24:17 -0500 Subject: [PATCH 149/210] Eliminate prettyprinter dependency from UI --- basis/math/rectangles/prettyprint/authors.txt | 1 + basis/math/rectangles/prettyprint/prettyprint.factor | 7 +++++++ basis/math/rectangles/rectangles.factor | 9 +++++---- basis/ui/gadgets/gadgets.factor | 10 +++++----- basis/ui/gadgets/prettyprint/authors.txt | 1 + basis/ui/gadgets/prettyprint/prettyprint.factor | 7 +++++++ 6 files changed, 26 insertions(+), 9 deletions(-) create mode 100644 basis/math/rectangles/prettyprint/authors.txt create mode 100644 basis/math/rectangles/prettyprint/prettyprint.factor create mode 100644 basis/ui/gadgets/prettyprint/authors.txt create mode 100644 basis/ui/gadgets/prettyprint/prettyprint.factor diff --git a/basis/math/rectangles/prettyprint/authors.txt b/basis/math/rectangles/prettyprint/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/math/rectangles/prettyprint/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/math/rectangles/prettyprint/prettyprint.factor b/basis/math/rectangles/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..c23be50029 --- /dev/null +++ b/basis/math/rectangles/prettyprint/prettyprint.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors math.rectangles kernel prettyprint.custom prettyprint.backend ; +IN: math.rectangles.prettyprint + +M: rect pprint* + \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ; diff --git a/basis/math/rectangles/rectangles.factor b/basis/math/rectangles/rectangles.factor index 340eafa37d..c8569dfdb9 100644 --- a/basis/math/rectangles/rectangles.factor +++ b/basis/math/rectangles/rectangles.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel arrays sequences math math.vectors accessors -parser prettyprint.custom prettyprint.backend ; +parser ; IN: math.rectangles TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; @@ -10,9 +10,6 @@ TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; SYNTAX: RECT: scan-object scan-object parsed ; -M: rect pprint* - \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ; - : ( -- rect ) rect new ; inline : point>rect ( loc -- rect ) { 0 0 } ; inline @@ -64,3 +61,7 @@ M: rect contains-point? [ [ loc>> ] dip (>>loc) ] [ [ dim>> ] dip (>>dim) ] 2bi ; inline + +USING: vocabs vocabs.loader ; + +"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when \ No newline at end of file diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index f9f397d46f..5dd1710cdd 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -3,8 +3,7 @@ USING: accessors arrays hashtables kernel models math namespaces make sequences quotations math.vectors combinators sorting binary-search vectors dlists deques models threads -concurrency.flags math.order math.rectangles fry locals -prettyprint.backend prettyprint.custom ; +concurrency.flags math.order math.rectangles fry locals ; IN: ui.gadgets ! Values for orientation slot @@ -28,9 +27,6 @@ interior boundary model ; -! Don't print gadgets with RECT: syntax -M: gadget pprint* pprint-tuple ; - M: gadget equal? 2drop f ; M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ; @@ -397,3 +393,7 @@ M: f request-focus-on 2drop ; : focus-path ( gadget -- seq ) [ focus>> ] follow ; + +USING: vocabs vocabs.loader ; + +"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when \ No newline at end of file diff --git a/basis/ui/gadgets/prettyprint/authors.txt b/basis/ui/gadgets/prettyprint/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/ui/gadgets/prettyprint/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/ui/gadgets/prettyprint/prettyprint.factor b/basis/ui/gadgets/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..82a89eda11 --- /dev/null +++ b/basis/ui/gadgets/prettyprint/prettyprint.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: ui.gadgets prettyprint.backend prettyprint.custom ; +IN: ui.gadgets.prettyprint + +! Don't print gadgets with RECT: syntax +M: gadget pprint* pprint-tuple ; \ No newline at end of file From 0b7eee6e61bb23db89c55bc40b77f12ec2369d93 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 May 2009 20:24:32 -0500 Subject: [PATCH 150/210] Slightly more space-efficient dispatch table representation --- core/generic/single/single.factor | 2 +- vm/dispatch.cpp | 11 +++++------ 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 36a76153f9..8d84b21bf7 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -163,7 +163,7 @@ M: hi-tag-dispatch-engine compile-engine : build-fast-hash ( methods -- buckets ) >alist V{ } clone [ hashcode 1array ] distribute-buckets - [ compile-engines* >alist >array ] map ; + [ compile-engines* >alist { } join ] map ; M: echelon-dispatch-engine compile-engine dup n>> 0 = [ diff --git a/vm/dispatch.cpp b/vm/dispatch.cpp index 847a19d738..4a1411733e 100755 --- a/vm/dispatch.cpp +++ b/vm/dispatch.cpp @@ -8,15 +8,14 @@ cell megamorphic_cache_misses; static cell search_lookup_alist(cell table, cell klass) { - array *pairs = untag(table); - fixnum index = array_capacity(pairs) - 1; + array *elements = untag(table); + fixnum index = array_capacity(elements) - 2; while(index >= 0) { - array *pair = untag(array_nth(pairs,index)); - if(array_nth(pair,0) == klass) - return array_nth(pair,1); + if(array_nth(elements,index) == klass) + return array_nth(elements,index + 1); else - index--; + index -= 2; } return F; From ef5c9844e4fe34e207f6795605c44d05746d5e3c Mon Sep 17 00:00:00 2001 From: Diego Martinelli Date: Sun, 10 May 2009 14:20:23 +0200 Subject: [PATCH 151/210] Done with docs and unit tests. --- extra/hashcash/hashcash.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/hashcash/hashcash.factor b/extra/hashcash/hashcash.factor index 3e75aad94c..1eb690b20f 100755 --- a/extra/hashcash/hashcash.factor +++ b/extra/hashcash/hashcash.factor @@ -74,10 +74,10 @@ M: hashcash string>> PRIVATE> -: mint* ( tuple -- str ) +: mint* ( tuple -- stamp ) 0 (mint) string>> ; -: mint ( resource -- str ) +: mint ( resource -- stamp ) swap >>resource mint* ; From 85facc27d6c610fabc142cc1476c44d5f59b2ec0 Mon Sep 17 00:00:00 2001 From: Diego Martinelli Date: Sun, 10 May 2009 14:27:35 +0200 Subject: [PATCH 152/210] Ops. --- extra/hashcash/hashcash-docs.factor | 60 ++++++++++++++++++++++++++++ extra/hashcash/hashcash-tests.factor | 15 +++++++ extra/hashcash/summary.txt | 1 + 3 files changed, 76 insertions(+) create mode 100644 extra/hashcash/hashcash-docs.factor create mode 100644 extra/hashcash/hashcash-tests.factor create mode 100644 extra/hashcash/summary.txt diff --git a/extra/hashcash/hashcash-docs.factor b/extra/hashcash/hashcash-docs.factor new file mode 100644 index 0000000000..2cfe0bb68e --- /dev/null +++ b/extra/hashcash/hashcash-docs.factor @@ -0,0 +1,60 @@ +USING: help.markup help.syntax kernel math ; +IN: hashcash + +ARTICLE: "hashcash" "Hashcash" +"Hashcash is a denial-of-service counter measure tool." +$nl +"A hashcash stamp constitutes a proof-of-work which takes a parameterizable amount of work to compute for the sender. The recipient can verify received hashcash stamps efficiently." +$nl +"More info on hashcash:" +$nl +{ $url "http://www.hashcash.org/" } $nl +{ $url "http://en.wikipedia.org/wiki/Hashcash" } $nl +{ $url "http://www.ibm.com/developerworks/linux/library/l-hashcash.html?ca=dgr-lnxw01HashCash" } $nl +"This library provide basic utilities for hashcash creation and validation." +$nl +"Creating stamps:" +{ $subsection mint } +{ $subsection mint* } +"Validation:" +{ $subsection check-stamp } +"Hashcash tuple and constructor:" +{ $subsection hashcash } +{ $subsection } +"Utilities:" +{ $subsection salt } ; + +{ mint mint* check-stamp salt } related-words + +HELP: mint +{ $values { "resource" "a string" } { "stamp" "generated stamp" } } +{ $description "This word generate a valid stamp with default parameters and the specified resource." } ; + +HELP: mint* +{ $values { "tuple" "a tuple" } { "stamp" "generated stamp" } } +{ $description "As " { $snippet "mint" } " but it takes an hashcash tuple as a parameter." } ; + +HELP: check-stamp +{ $values { "stamp" "a string" } { "?" boolean } } +{ $description "Check for stamp's validity. Only supports hashcash version 1." } ; + +HELP: salt +{ $values { "length" integer } { "salted" "a string" } } +{ $description "It generates a random string of " { $snippet "length" } " characters." } ; + +HELP: +{ $values { "tuple" object } } +{ $description "It fill an hashcash tuple with the default values: 1 as hashcash version, 20 as bits, today's date as date and a random 8 character long salt" } ; + +HELP: hashcash +{ $class-description "An hashcash object. An hashcash have the following slots:" + { $table + { { $slot "version" } "The version number. Only version 1 is supported." } + { { $slot "bits" } "The claimed bit value." } + { { $slot "date" } "The date a stamp was minted." } + { { $slot "resource" } "The resource for which a stamp is minted." } + { { $slot "ext" } "Extensions that a specialized application may want." } + { { $slot "salt" } "A random salt." } + { { $slot "suffix" } "The computed suffix. This is supposed to be manipulated by the library." } + } +} ; diff --git a/extra/hashcash/hashcash-tests.factor b/extra/hashcash/hashcash-tests.factor new file mode 100644 index 0000000000..efef40acfa --- /dev/null +++ b/extra/hashcash/hashcash-tests.factor @@ -0,0 +1,15 @@ +USING: accessors sequences tools.test hashcash ; + +[ t ] [ "foo@bar.com" mint check-stamp ] unit-test + +[ t ] [ + + "foo@bar.com" >>resource + 16 >>bits + mint* check-stamp ] unit-test + +[ t ] [ + "1:20:040927:mertz@gnosis.cx::odVZhQMP:7ca28" check-stamp +] unit-test + +[ 8 ] [ 8 salt length ] unit-test diff --git a/extra/hashcash/summary.txt b/extra/hashcash/summary.txt new file mode 100644 index 0000000000..e5ec1d4064 --- /dev/null +++ b/extra/hashcash/summary.txt @@ -0,0 +1 @@ +Hashcash implementation From 1216ea2fd884b8c18b139c9f01d859c951e5a2bf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 10 May 2009 10:41:50 -0500 Subject: [PATCH 153/210] cut perlin-noise time in half --- .../math/polynomials/polynomials-docs.factor | 10 +- basis/math/polynomials/polynomials.factor | 12 +- basis/math/vectors/vectors.factor | 10 ++ .../affine-transforms.factor | 2 + extra/noise/noise.factor | 105 ++++++++++-------- 5 files changed, 85 insertions(+), 54 deletions(-) diff --git a/basis/math/polynomials/polynomials-docs.factor b/basis/math/polynomials/polynomials-docs.factor index edffa5377d..6617556270 100644 --- a/basis/math/polynomials/polynomials-docs.factor +++ b/basis/math/polynomials/polynomials-docs.factor @@ -93,7 +93,13 @@ HELP: pdiff { $description "Finds the derivative of " { $snippet "p" } "." } ; HELP: polyval -{ $values { "p" "a polynomial" } { "x" number } { "p[x]" number } } +{ $values { "x" number } { "p" "a polynomial" } { "p[x]" number } } { $description "Evaluate " { $snippet "p" } " with the input " { $snippet "x" } "." } -{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } 2 polyval ." "5" } } ; +{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval ." "5" } } ; +HELP: polyval* +{ $values { "p" "a literal polynomial" } } +{ $description "Macro version of " { $link polyval } ". Evaluates the literal polynomial " { $snippet "p" } " at the value off the top of the stack." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval* ." "5" } } ; + +{ polyval polyval* } related-words diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index f65c4ecaaf..fd6eda4a90 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel make math math.order math.vectors sequences - splitting vectors ; + splitting vectors macros combinators ; IN: math.polynomials : pdiff ( p -- p' ) dup length v* { 0 } ?head drop ; -: polyval ( p x -- p[x] ) - [ dup length ] dip powers v. ; +: polyval ( x p -- p[x] ) + [ length swap powers ] [ nip ] 2bi v. ; + +MACRO: polyval* ( p -- ) + reverse + [ 1 tail [ \ * swap \ + [ ] 3sequence ] map ] + [ first \ drop swap [ ] 2sequence ] bi + prefix \ cleave [ ] 2sequence ; diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 17f6c39f04..bad2733bbf 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -41,6 +41,13 @@ IN: math.vectors : set-axis ( u v axis -- w ) [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; +: 2tetra@ ( p q r s t u v w quot -- ) + dup [ [ 2bi@ ] curry 4dip ] dip 2bi@ ; inline + +: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv ) + [ first lerp ] [ second lerp ] [ third lerp ] tri-curry + [ 2tetra@ ] [ 2bi@ ] [ call ] tri* ; + : bilerp ( aa ba ab bb {t,u} -- a_tu ) [ first lerp ] [ second lerp ] bi-curry [ 2bi@ ] [ call ] bi* ; @@ -72,3 +79,6 @@ HINTS: v. { array array } ; HINTS: vlerp { array array array } ; HINTS: vnlerp { array array object } ; + +HINTS: bilerp { object object object object array } ; +HINTS: trilerp { object object object object object object object object array } ; diff --git a/extra/math/affine-transforms/affine-transforms.factor b/extra/math/affine-transforms/affine-transforms.factor index 20b73ba678..d1fd602f72 100644 --- a/extra/math/affine-transforms/affine-transforms.factor +++ b/extra/math/affine-transforms/affine-transforms.factor @@ -17,6 +17,8 @@ CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0 [ drop origin>> ] 2tri v+ v+ ; +: ( -- a ) + { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } ; : ( origin -- a ) [ { 1.0 0.0 } { 0.0 1.0 } ] dip ; : ( theta -- transform ) diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor index c28768283c..46704eed36 100644 --- a/extra/noise/noise.factor +++ b/extra/noise/noise.factor @@ -1,61 +1,60 @@ USING: byte-arrays combinators fry images kernel locals math math.affine-transforms math.functions math.order math.polynomials math.vectors random random.mersenne-twister -sequences sequences.product ; +sequences sequences.product hints arrays sequences.private +combinators.short-circuit math.private ; IN: noise : ( -- table ) - 256 iota >byte-array randomize dup append ; + 256 iota >byte-array randomize dup append ; inline : with-seed ( seed quot -- ) [ ] dip with-random ; inline u hash 12 bitand zero? - [ gradients second ] - [ hash 13 bitand 12 = [ gradients first ] [ gradients third ] if ] if + [ y ] [ hash 13 bitand 12 = [ x ] [ z ] if ] if :> v hash 1 bitand zero? [ u ] [ u neg ] if hash 2 bitand zero? [ v ] [ v neg ] if + ; +HINTS: grad { fixnum float float float } ; + : unit-cube ( point -- cube ) - [ floor >fixnum 256 mod ] map ; + [ floor >fixnum 256 rem ] map ; -:: hashes ( table cube -- aaa baa aba bba aab bab abb bbb ) - cube first :> x - cube second :> y - cube third :> z - x table nth y + :> a - x 1 + table nth y + :> b +:: hashes ( table x y z -- aaa baa aba bba aab bab abb bbb ) + x table nth-unsafe y fixnum+fast :> a + x 1 fixnum+fast table nth-unsafe y fixnum+fast :> b - a table nth z + :> aa - b table nth z + :> ba - a 1 + table nth z + :> ab - b 1 + table nth z + :> bb + a table nth-unsafe z fixnum+fast :> aa + b table nth-unsafe z fixnum+fast :> ba + a 1 fixnum+fast table nth-unsafe z fixnum+fast :> ab + b 1 fixnum+fast table nth-unsafe z fixnum+fast :> bb - aa table nth - ba table nth - ab table nth - bb table nth - aa 1 + table nth - ba 1 + table nth - ab 1 + table nth - bb 1 + table nth ; + aa table nth-unsafe + ba table nth-unsafe + ab table nth-unsafe + bb table nth-unsafe + aa 1 fixnum+fast table nth-unsafe + ba 1 fixnum+fast table nth-unsafe + ab 1 fixnum+fast table nth-unsafe + bb 1 fixnum+fast table nth-unsafe ; inline -:: 2tetra@ ( p q r s t u v w quot -- ) - p q quot call - r s quot call - t u quot call - v w quot call - ; inline +HINTS: hashes { byte-array fixnum fixnum fixnum } ; : >byte-map ( floats -- bytes ) [ 255.0 * >fixnum ] B{ } map-as ; @@ -63,26 +62,33 @@ IN: noise : >image ( bytes dim -- image ) swap [ L f ] dip image boa ; -PRIVATE> - -:: perlin-noise ( table point -- value ) +:: perlin-noise-unsafe ( table point -- value ) point unit-cube :> cube point dup vfloor v- :> gradients gradients fade :> faded - table cube hashes { - [ gradients grad ] - [ gradients { -1.0 0.0 0.0 } v+ grad ] - [ gradients { 0.0 -1.0 0.0 } v+ grad ] - [ gradients { -1.0 -1.0 0.0 } v+ grad ] - [ gradients { 0.0 0.0 -1.0 } v+ grad ] - [ gradients { -1.0 0.0 -1.0 } v+ grad ] - [ gradients { 0.0 -1.0 -1.0 } v+ grad ] - [ gradients { -1.0 -1.0 -1.0 } v+ grad ] + table cube first3 hashes { + [ gradients first3 grad ] + [ gradients first3 [ 1.0 - ] [ ] [ ] tri* grad ] + [ gradients first3 [ ] [ 1.0 - ] [ ] tri* grad ] + [ gradients first3 [ 1.0 - ] [ 1.0 - ] [ ] tri* grad ] + [ gradients first3 [ ] [ ] [ 1.0 - ] tri* grad ] + [ gradients first3 [ 1.0 - ] [ ] [ 1.0 - ] tri* grad ] + [ gradients first3 [ ] [ 1.0 - ] [ 1.0 - ] tri* grad ] + [ gradients first3 [ 1.0 - ] [ 1.0 - ] [ 1.0 - ] tri* grad ] } spread - [ faded first lerp ] 2tetra@ - [ faded second lerp ] 2bi@ - faded third lerp ; + faded trilerp ; + +ERROR: invalid-perlin-noise-table table ; + +: validate-table ( table -- table ) + dup { [ byte-array? ] [ length 512 >= ] } 1&& + [ invalid-perlin-noise-table ] unless ; + +PRIVATE> + +: perlin-noise ( table point -- value ) + [ validate-table ] dip perlin-noise-unsafe ; inline : normalize-0-1 ( sequence -- sequence' ) [ supremum ] [ infimum [ - ] keep ] [ ] tri @@ -92,7 +98,8 @@ PRIVATE> [ 0.0 max 1.0 min ] map ; : perlin-noise-map ( table transform dim -- map ) - [ iota ] map [ a.v 0.0 suffix perlin-noise ] with with product-map ; + [ validate-table ] 2dip + [ iota ] map [ a.v 0.0 suffix perlin-noise-unsafe ] with with product-map ; : perlin-noise-byte-map ( table transform dim -- map ) perlin-noise-map normalize-0-1 >byte-map ; From ad30581e1cfa0fc866f7553b11e5eccb2aac4b42 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 12:18:59 -0500 Subject: [PATCH 154/210] working on sha2 --- basis/checksums/common/common.factor | 2 +- basis/checksums/sha2/sha2-tests.factor | 4 +- basis/checksums/sha2/sha2.factor | 90 +++++++++++++++----------- 3 files changed, 56 insertions(+), 40 deletions(-) diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor index 01cc2cb739..76675f9413 100644 --- a/basis/checksums/common/common.factor +++ b/basis/checksums/common/common.factor @@ -10,7 +10,7 @@ SYMBOL: bytes-read [ 56 < 55 119 ? ] keep - ; : calculate-pad-length-long ( length -- length' ) - [ 112 < 111 249 ? ] keep - ; + [ 120 < 119 247 ? ] keep - ; : pad-last-block ( str big-endian? length -- str ) [ diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor index f224d497a6..c14ea5a98d 100644 --- a/basis/checksums/sha2/sha2-tests.factor +++ b/basis/checksums/sha2/sha2-tests.factor @@ -38,5 +38,5 @@ IN: checksums.sha2.tests -[ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ] -[ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test +! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ] +! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 1abed088a3..12e32f6c69 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -8,13 +8,9 @@ IN: checksums.sha2 SINGLETON: sha-224 SINGLETON: sha-256 -SINGLETON: sha-384 -SINGLETON: sha-512 INSTANCE: sha-224 checksum INSTANCE: sha-256 checksum -INSTANCE: sha-384 checksum -INSTANCE: sha-512 checksum TUPLE: sha2-state K H word-size block-size ; @@ -26,10 +22,6 @@ TUPLE: sha-224-state < sha2-short ; TUPLE: sha-256-state < sha2-short ; -TUPLE: sha-384-state < sha2-long ; - -TUPLE: sha-512-state < sha2-long ; - % ] - [ 3 shift 16 >be % ] bi + [ 3 shift 8 >be % ] bi ] "" make append ; : seq>byte-array ( seq n -- string ) '[ _ >be ] map B{ } join ; -:: T1 ( n M H sha2 -- T1 ) +:: T1-256 ( n M H sha2 -- T1 ) n M nth n sha2 K>> nth + e H slice3 ch w+ e H nth S1-256 w+ h H nth w+ ; inline -: T2 ( H -- T2 ) +: T2-256 ( H -- T2 ) [ a swap nth S0-256 ] [ a swap slice3 maj w+ ] bi ; inline +:: T1-512 ( n M H sha2 -- T1 ) + n M nth + n sha2 K>> nth + + e H slice3 ch w+ + e H nth S1-512 w+ + h H nth w+ ; inline + +: T2-512 ( H -- T2 ) + [ a swap nth S0-512 ] + [ a swap slice3 maj w+ ] bi ; inline + : update-H ( T1 T2 H -- ) h g pick exchange g f pick exchange @@ -222,8 +262,8 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string ) :: process-chunk ( M block-size cloned-H sha2 -- ) block-size [ - M cloned-H sha2 T1 - cloned-H T2 + M cloned-H sha2 T1-256 + cloned-H T2-256 cloned-H update-H ] each cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline @@ -253,20 +293,6 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string ) 4 >>word-size 64 >>block-size ; -: ( -- sha2-state ) - sha-384-state new - K-384 >>K - initial-H-384 >>H - 8 >>word-size - 80 >>block-size ; - -: ( -- sha2-state ) - sha-512-state new - K-512 >>K - initial-H-512 >>H - 8 >>word-size - 80 >>block-size ; - PRIVATE> M: sha-224 checksum-bytes @@ -278,13 +304,3 @@ M: sha-256 checksum-bytes drop [ byte-array>sha2 ] [ H>> 4 seq>byte-array ] bi ; - -M: sha-384 checksum-bytes - drop - [ byte-array>sha2 ] - [ H>> 6 head 8 seq>byte-array ] bi ; - -M: sha-512 checksum-bytes - drop - [ byte-array>sha2 ] - [ H>> 8 seq>byte-array ] bi ; From a09947f042db821f391297b2853acf4600dbe5d4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 12:24:19 -0500 Subject: [PATCH 155/210] move math.miller-rabin to math.primes.miller-rabin --- basis/math/{ => primes}/miller-rabin/authors.txt | 0 basis/math/{ => primes}/miller-rabin/miller-rabin-docs.factor | 0 basis/math/{ => primes}/miller-rabin/miller-rabin-tests.factor | 0 basis/math/{ => primes}/miller-rabin/miller-rabin.factor | 0 basis/math/{ => primes}/miller-rabin/summary.txt | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename basis/math/{ => primes}/miller-rabin/authors.txt (100%) rename basis/math/{ => primes}/miller-rabin/miller-rabin-docs.factor (100%) rename basis/math/{ => primes}/miller-rabin/miller-rabin-tests.factor (100%) rename basis/math/{ => primes}/miller-rabin/miller-rabin.factor (100%) rename basis/math/{ => primes}/miller-rabin/summary.txt (100%) diff --git a/basis/math/miller-rabin/authors.txt b/basis/math/primes/miller-rabin/authors.txt similarity index 100% rename from basis/math/miller-rabin/authors.txt rename to basis/math/primes/miller-rabin/authors.txt diff --git a/basis/math/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor similarity index 100% rename from basis/math/miller-rabin/miller-rabin-docs.factor rename to basis/math/primes/miller-rabin/miller-rabin-docs.factor diff --git a/basis/math/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor similarity index 100% rename from basis/math/miller-rabin/miller-rabin-tests.factor rename to basis/math/primes/miller-rabin/miller-rabin-tests.factor diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor similarity index 100% rename from basis/math/miller-rabin/miller-rabin.factor rename to basis/math/primes/miller-rabin/miller-rabin.factor diff --git a/basis/math/miller-rabin/summary.txt b/basis/math/primes/miller-rabin/summary.txt similarity index 100% rename from basis/math/miller-rabin/summary.txt rename to basis/math/primes/miller-rabin/summary.txt From 99a257a89e9700dc0c093a141fb65f2bcf23b533 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 12:24:43 -0500 Subject: [PATCH 156/210] update usages of miller-rabin --- basis/math/primes/miller-rabin/miller-rabin-docs.factor | 8 ++++---- basis/math/primes/miller-rabin/miller-rabin-tests.factor | 6 +++--- basis/math/primes/miller-rabin/miller-rabin.factor | 2 +- basis/math/primes/primes.factor | 5 +++-- extra/crypto/rsa/rsa.factor | 4 ++-- extra/project-euler/common/common.factor | 2 +- extra/random/blum-blum-shub/blum-blum-shub.factor | 2 +- 7 files changed, 15 insertions(+), 14 deletions(-) diff --git a/basis/math/primes/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor index 4aa318f674..2455dafdd5 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-docs.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel sequences math ; -IN: math.miller-rabin +IN: math.primes.miller-rabin HELP: find-relative-prime { $values @@ -82,8 +82,8 @@ HELP: unique-primes } { $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ; -ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test" -"The " { $vocab-link "math.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl +ARTICLE: "math.primes.miller-rabin" "Miller-Rabin probabilistic primality test" +"The " { $vocab-link "math.primes.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl "The Miller-Rabin probabilistic primality test:" { $subsection miller-rabin } { $subsection miller-rabin* } @@ -97,4 +97,4 @@ ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test" { $subsection next-safe-prime } { $subsection random-safe-prime } ; -ABOUT: "math.miller-rabin" +ABOUT: "math.primes.miller-rabin" diff --git a/basis/math/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor index 9981064ec0..9c635c8f38 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor @@ -1,6 +1,6 @@ -USING: math.miller-rabin tools.test kernel sequences -math.miller-rabin.private math ; -IN: math.miller-rabin.tests +USING: math.primes.miller-rabin tools.test kernel sequences +math.primes.miller-rabin.private math ; +IN: math.primes.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test [ t ] [ 2 miller-rabin ] unit-test diff --git a/basis/math/primes/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor index 991924dfe4..35ee97a897 100755 --- a/basis/math/primes/miller-rabin/miller-rabin.factor +++ b/basis/math/primes/miller-rabin/miller-rabin.factor @@ -3,7 +3,7 @@ USING: combinators kernel locals math math.functions math.ranges random sequences sets combinators.short-circuit math.bitwise math math.order ; -IN: math.miller-rabin +IN: math.primes.miller-rabin : >odd ( n -- int ) 0 set-bit ; foldable diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor index 688fdad713..fa1cd5cb63 100644 --- a/basis/math/primes/primes.factor +++ b/basis/math/primes/primes.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007-2009 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel math math.functions math.miller-rabin -math.order math.primes.erato math.ranges sequences ; +USING: combinators kernel math math.functions +math.primes.miller-rabin math.order math.primes.erato +math.ranges sequences ; IN: math.primes Date: Sun, 10 May 2009 12:59:35 -0500 Subject: [PATCH 157/210] add lucas-lehmer primality test --- basis/math/primes/lucas-lehmer/authors.txt | 1 + .../lucas-lehmer/lucas-lehmer-docs.factor | 25 +++++++++++++++++ .../lucas-lehmer/lucas-lehmer-tests.factor | 13 +++++++++ .../primes/lucas-lehmer/lucas-lehmer.factor | 27 +++++++++++++++++++ 4 files changed, 66 insertions(+) create mode 100644 basis/math/primes/lucas-lehmer/authors.txt create mode 100644 basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor create mode 100644 basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor create mode 100644 basis/math/primes/lucas-lehmer/lucas-lehmer.factor diff --git a/basis/math/primes/lucas-lehmer/authors.txt b/basis/math/primes/lucas-lehmer/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/math/primes/lucas-lehmer/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor b/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor new file mode 100644 index 0000000000..582b59b69a --- /dev/null +++ b/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel ; +IN: math.primes.lucas-lehmer + +HELP: lucas-lehmer +{ $values + { "p" "a prime number" } + { "?" "a boolean" } +} +{ $description "Runs the Lucas-Lehmer test on the prime " { $snippet "p" } " and returns " { $link t } " if " { $snippet "(2 ^ p) - 1" } " is prime." } +{ $examples + { $example "! Test that (2 ^ 61) - 1 is prime:" + "USING: math.primes.lucas-lehmer prettyprint ;" + "61 lucas-lehmer ." + "t" + } +} ; + +ARTICLE: "math.primes.lucas-lehmer" "Lucas-Lehmer Mersenne Primality test" +"The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary tests numbers of the form " { $snippet "(2 ^ p) - 1" } " for primality, where " { $snippet "p" } " is prime." $nl +"Run the Lucas-Lehmer test:" +{ $subsection lucas-lehmer } ; + +ABOUT: "math.primes.lucas-lehmer" diff --git a/basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor b/basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor new file mode 100644 index 0000000000..b114fa8553 --- /dev/null +++ b/basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test math.primes.lucas-lehmer ; +IN: math.primes.lucas-lehmer.tests + +[ t ] [ 2 lucas-lehmer ] unit-test +[ t ] [ 3 lucas-lehmer ] unit-test +[ f ] [ 4 lucas-lehmer ] unit-test +[ t ] [ 5 lucas-lehmer ] unit-test +[ f ] [ 6 lucas-lehmer ] unit-test +[ f ] [ 11 lucas-lehmer ] unit-test +[ t ] [ 13 lucas-lehmer ] unit-test +[ t ] [ 61 lucas-lehmer ] unit-test diff --git a/basis/math/primes/lucas-lehmer/lucas-lehmer.factor b/basis/math/primes/lucas-lehmer/lucas-lehmer.factor new file mode 100644 index 0000000000..a8bf097dbe --- /dev/null +++ b/basis/math/primes/lucas-lehmer/lucas-lehmer.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators fry kernel locals math +math.primes combinators.short-circuit ; +IN: math.primes.lucas-lehmer + +ERROR: invalid-lucas-lehmer-candidate obj ; + + ] } 1&& + [ invalid-lucas-lehmer-candidate ] unless ; + +PRIVATE> + +: lucas-lehmer ( p -- ? ) + lucas-lehmer-guard + { + { [ dup 2 = ] [ drop t ] } + { [ dup prime? ] [ do-lucas-lehmer ] } + [ drop f ] + } cond ; From 9ef65178c916ad1163e52ca062029e1bee8ea8e0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 13:39:08 -0500 Subject: [PATCH 158/210] move random-bits* to random, work on docs --- .../mersenne-twister-tests.factor | 2 +- basis/random/random-docs.factor | 15 +++++++++++++-- basis/random/random-tests.factor | 2 ++ basis/random/random.factor | 5 ++++- 4 files changed, 20 insertions(+), 4 deletions(-) diff --git a/basis/random/mersenne-twister/mersenne-twister-tests.factor b/basis/random/mersenne-twister/mersenne-twister-tests.factor index c35d7488ac..651e43ef5b 100644 --- a/basis/random/mersenne-twister/mersenne-twister-tests.factor +++ b/basis/random/mersenne-twister/mersenne-twister-tests.factor @@ -11,7 +11,7 @@ IN: random.mersenne-twister.tests 100 [ 100 random ] replicate ; : test-rng ( seed quot -- ) - [ ] dip with-random ; inline + [ ] dip with-random ; inline [ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor index c7600a731f..222ecaf935 100755 --- a/basis/random/random-docs.factor +++ b/basis/random/random-docs.factor @@ -40,9 +40,17 @@ HELP: random-bytes } ; HELP: random-bits -{ $values { "n" "an integer" } { "r" "a random integer" } } +{ $values { "numbits" integer } { "r" "a random integer" } } { $description "Outputs an random integer n bits in length." } ; +HELP: random-bits* +{ $values + { "numbits" integer } + { "n" integer } +} +{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ; + + HELP: with-random { $values { "tuple" "a random generator" } { "quot" "a quotation" } } { $description "Calls the quotation with the random generator in a dynamic variable. All random numbers will be generated using this random generator." } ; @@ -93,6 +101,9 @@ $nl "Randomizing a sequence:" { $subsection randomize } "Deleting a random element from a sequence:" -{ $subsection delete-random } ; +{ $subsection delete-random } +"Random numbers with " { $snippet "n" } " bits:" +{ $subsection random-bits } +{ $subsection random-bits* } ; ABOUT: "random" diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index 9607627b3d..2b6ac9b1b8 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -23,3 +23,5 @@ IN: random.tests [ f ] [ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test + +[ 49 ] [ 50 random-bits* log2 ] unit-test diff --git a/basis/random/random.factor b/basis/random/random.factor index 6b02c8a3e8..661e771258 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -45,7 +45,10 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; PRIVATE> -: random-bits ( n -- r ) 2^ random-integer ; +: random-bits ( numbits -- r ) 2^ random-integer ; + +: random-bits* ( numbits -- n ) + 1 - [ random-bits ] keep set-bit ; : random ( seq -- elt ) [ f ] [ From ca0bd17a4bb847a9666aa2bd9c55c7a4ca7d5b7b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 13:42:41 -0500 Subject: [PATCH 159/210] add next-odd etc to math.bitwise --- basis/math/bitwise/bitwise.factor | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 4fe2340643..ff4806348b 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -111,3 +111,10 @@ PRIVATE> : >signed ( x n -- y ) 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ; +: >odd ( n -- int ) 0 set-bit ; foldable + +: >even ( n -- int ) 0 clear-bit ; foldable + +: next-even ( m -- n ) >even 2 + ; foldable + +: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable From 2ab75512b7a7b8a103e1cec1180a54cb984c3c6b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 10 May 2009 13:45:58 -0500 Subject: [PATCH 160/210] purple sky --- extra/terrain/shaders/shaders.factor | 34 +++++++++++++++++ extra/terrain/terrain.factor | 57 +++++++++++++++++++--------- 2 files changed, 74 insertions(+), 17 deletions(-) diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor index c341545956..bfb46b8ba1 100644 --- a/extra/terrain/shaders/shaders.factor +++ b/extra/terrain/shaders/shaders.factor @@ -1,6 +1,40 @@ USING: multiline ; IN: terrain.shaders +STRING: sky-vertex-shader + +uniform float sky_theta; +varying vec3 direction; + +void main() +{ + vec4 v = vec4(gl_Vertex.xy, -1.0, 1.0); + gl_Position = v; + float s = sin(sky_theta), c = cos(sky_theta); + direction = mat3(1, 0, 0, 0, c, s, 0, -s, c) + * (gl_ModelViewMatrixInverse * vec4(v.xyz, 0.0)).xyz; +} + +; + +STRING: sky-pixel-shader + +uniform sampler2D sky; +uniform float sky_gradient, sky_theta; + +const vec4 SKY_COLOR_A = vec4(0.25, 0.0, 0.5, 1.0), + SKY_COLOR_B = vec4(0.6, 0.5, 0.75, 1.0); + +varying vec3 direction; + +void main() +{ + float t = texture2D(sky, normalize(direction.xyz).xy * 0.5 + vec2(0.5)).x + sky_gradient; + gl_FragColor = mix(SKY_COLOR_A, SKY_COLOR_B, sin(6.28*t)); +} + +; + STRING: terrain-vertex-shader uniform sampler2D heightmap; diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 590244ca6a..411d34f44c 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -5,20 +5,23 @@ math.vectors opengl opengl.capabilities opengl.gl opengl.shaders opengl.textures opengl.textures.private sequences sequences.product specialized-arrays.float terrain.generation terrain.shaders ui ui.gadgets -ui.gadgets.worlds ui.pixel-formats game-worlds method-chains ; +ui.gadgets.worlds ui.pixel-formats game-worlds method-chains +math.affine-transforms noise ; IN: terrain CONSTANT: FOV $[ 2.0 sqrt 1+ ] -CONSTANT: NEAR-PLANE $[ 1.0 2048.0 / ] -CONSTANT: FAR-PLANE 1.0 +CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ] +CONSTANT: FAR-PLANE 2.0 CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 } -CONSTANT: PLAYER-HEIGHT $[ 3.0 1024.0 / ] +CONSTANT: PLAYER-HEIGHT $[ 1.0 256.0 / ] CONSTANT: GRAVITY $[ 1.0 4096.0 / ] CONSTANT: JUMP $[ 1.0 1024.0 / ] CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ] CONSTANT: MOVEMENT-SPEED $[ 1.0 16384.0 / ] CONSTANT: FRICTION 0.95 -CONSTANT: COMPONENT-SCALE { 0.5 0.01 0.002 0.0 } +CONSTANT: COMPONENT-SCALE { 0.5 0.01 0.0005 0.0 } +CONSTANT: SKY-PERIOD 1200 +CONSTANT: SKY-SPEED 0.0005 CONSTANT: terrain-vertex-size { 512 512 } CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] } @@ -29,6 +32,7 @@ TUPLE: player TUPLE: terrain-world < game-world player + sky-image sky-texture sky-program terrain terrain-segment terrain-texture terrain-program terrain-vertex-buffer ; @@ -41,7 +45,7 @@ M: terrain-world tick-length NEAR-PLANE FAR-PLANE ; : set-modelview-matrix ( gadget -- ) - GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear + GL_DEPTH_BUFFER_BIT glClear GL_MODELVIEW glMatrixMode glLoadIdentity player>> @@ -175,24 +179,33 @@ M: terrain-world tick* [ dup focused?>> [ handle-input ] [ drop ] if ] [ dup player>> tick-player ] bi ; -: set-heightmap-texture-parameters ( texture -- ) +: set-texture-parameters ( texture -- ) GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ; +: sky-gradient ( world -- t ) + game-loop>> tick-number>> SKY-PERIOD mod SKY-PERIOD /f ; +: sky-theta ( world -- theta ) + game-loop>> tick-number>> SKY-SPEED * ; + BEFORE: terrain-world begin-world "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" } require-gl-version-or-extensions GL_DEPTH_TEST glEnable GL_TEXTURE_2D glEnable GL_VERTEX_ARRAY glEnableClientState - 0.5 0.5 0.5 1.0 glClearColor PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } player boa >>player + 0.01 0.01 { 512 512 } perlin-noise-image + [ >>sky-image ] keep + make-texture [ set-texture-parameters ] keep >>sky-texture [ >>terrain ] keep { 0 0 } terrain-segment [ >>terrain-segment ] keep - make-texture [ set-heightmap-texture-parameters ] keep >>terrain-texture + make-texture [ set-texture-parameters ] keep >>terrain-texture + sky-vertex-shader sky-pixel-shader + >>sky-program terrain-vertex-shader terrain-pixel-shader >>terrain-program vertex-array >vertex-buffer >>terrain-vertex-buffer @@ -203,6 +216,8 @@ AFTER: terrain-world end-world [ terrain-vertex-buffer>> delete-gl-buffer ] [ terrain-program>> delete-gl-program ] [ terrain-texture>> delete-texture ] + [ sky-program>> delete-gl-program ] + [ sky-texture>> delete-texture ] } cleave ; M: terrain-world resize-world @@ -212,14 +227,22 @@ M: terrain-world resize-world [ frustum glFrustum ] bi ; M: terrain-world draw-world* - [ set-modelview-matrix ] - [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ] - [ dup terrain-program>> [ - [ "heightmap" glGetUniformLocation 0 glUniform1i ] - [ "component_scale" glGetUniformLocation COMPONENT-SCALE first4 glUniform4f ] bi - terrain-vertex-buffer>> draw-vertex-buffer - ] with-gl-program ] - tri gl-error ; + { + [ set-modelview-matrix ] + [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ] + [ sky-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ] + [ GL_DEPTH_TEST glDisable dup sky-program>> [ + [ nip "sky" glGetUniformLocation 1 glUniform1i ] + [ "sky_gradient" glGetUniformLocation swap sky-gradient glUniform1f ] + [ "sky_theta" glGetUniformLocation swap sky-theta glUniform1f ] 2tri + { -1.0 -1.0 } { 2.0 2.0 } gl-fill-rect + ] with-gl-program ] + [ GL_DEPTH_TEST glEnable dup terrain-program>> [ + [ "heightmap" glGetUniformLocation 0 glUniform1i ] + [ "component_scale" glGetUniformLocation COMPONENT-SCALE first4 glUniform4f ] bi + terrain-vertex-buffer>> draw-vertex-buffer + ] with-gl-program ] + } cleave gl-error ; M: terrain-world pref-dim* drop { 640 480 } ; From 7dc1bc1fd00e24164d15041132e92fb25880bb81 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 13:47:51 -0500 Subject: [PATCH 161/210] more docs for math.primes, move words out of miller-rabin --- .../miller-rabin/miller-rabin-docs.factor | 74 +---------------- .../miller-rabin/miller-rabin-tests.factor | 5 +- .../primes/miller-rabin/miller-rabin.factor | 83 +------------------ basis/math/primes/primes-docs.factor | 50 ++++++++++- basis/math/primes/primes-tests.factor | 13 ++- basis/math/primes/primes.factor | 43 +++++++++- 6 files changed, 105 insertions(+), 163 deletions(-) diff --git a/basis/math/primes/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor index 2455dafdd5..2d19d51e06 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-docs.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-docs.factor @@ -3,20 +3,6 @@ USING: help.markup help.syntax kernel sequences math ; IN: math.primes.miller-rabin -HELP: find-relative-prime -{ $values - { "n" integer } - { "p" integer } -} -{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ; - -HELP: find-relative-prime* -{ $values - { "n" integer } { "guess" integer } - { "p" integer } -} -{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ; - HELP: miller-rabin { $values { "n" integer } @@ -33,68 +19,10 @@ HELP: miller-rabin* } { $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ; -HELP: next-prime -{ $values - { "n" integer } - { "p" integer } -} -{ $description "Tests consecutive numbers for primality with " { $link miller-rabin } " and returns the next prime." } ; - -HELP: next-safe-prime -{ $values - { "n" integer } - { "q" integer } -} -{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ; - -HELP: random-bits* -{ $values - { "numbits" integer } - { "n" integer } -} -{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ; - -HELP: random-prime -{ $values - { "numbits" integer } - { "p" integer } -} -{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; - -HELP: random-safe-prime -{ $values - { "numbits" integer } - { "p" integer } -} -{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; - -HELP: safe-prime? -{ $values - { "q" integer } - { "?" "a boolean" } -} -{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ; - -HELP: unique-primes -{ $values - { "numbits" integer } { "n" integer } - { "seq" sequence } -} -{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ; - ARTICLE: "math.primes.miller-rabin" "Miller-Rabin probabilistic primality test" "The " { $vocab-link "math.primes.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl "The Miller-Rabin probabilistic primality test:" { $subsection miller-rabin } -{ $subsection miller-rabin* } -"Generating relative prime numbers:" -{ $subsection find-relative-prime } -{ $subsection find-relative-prime* } -"Generating prime numbers:" -{ $subsection next-prime } -{ $subsection random-prime } -"Generating safe prime numbers:" -{ $subsection next-safe-prime } -{ $subsection random-safe-prime } ; +{ $subsection miller-rabin* } ; ABOUT: "math.primes.miller-rabin" diff --git a/basis/math/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor index 9c635c8f38..aeae6cac1b 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor @@ -1,5 +1,6 @@ -USING: math.primes.miller-rabin tools.test kernel sequences -math.primes.miller-rabin.private math ; +USING: kernel math math.primes math.primes.miller-rabin +math.primes.miller-rabin.private math.primes.safe +math.primes.safe.private random sequences tools.test ; IN: math.primes.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test diff --git a/basis/math/primes/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor index 35ee97a897..b0dfc4ed35 100755 --- a/basis/math/primes/miller-rabin/miller-rabin.factor +++ b/basis/math/primes/miller-rabin/miller-rabin.factor @@ -1,18 +1,9 @@ ! Copyright (c) 2008-2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel locals math math.functions math.ranges -random sequences sets combinators.short-circuit math.bitwise -math math.order ; +USING: combinators combinators.short-circuit kernel locals math +math.functions math.ranges random sequences sets ; IN: math.primes.miller-rabin -: >odd ( n -- int ) 0 set-bit ; foldable - -: >even ( n -- int ) 0 clear-bit ; foldable - -: next-even ( m -- n ) >even 2 + ; - -: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; - } cond ; : miller-rabin ( n -- ? ) 10 miller-rabin* ; - -ERROR: prime-range-error n ; - -: next-prime ( n -- p ) - dup 1 < [ prime-range-error ] when - dup 1 = [ - drop 2 - ] [ - next-odd dup miller-rabin [ next-prime ] unless - ] if ; - -: random-bits* ( numbits -- n ) - 1 - [ random-bits ] keep set-bit ; - -: random-prime ( numbits -- p ) - random-bits* next-prime ; - -ERROR: no-relative-prime n ; - - [ 2 + (find-relative-prime) ] [ nip ] if ; - -PRIVATE> - -: find-relative-prime* ( n guess -- p ) - #! find a prime relative to n with initial guess - >odd (find-relative-prime) ; - -: find-relative-prime ( n -- p ) - dup random find-relative-prime* ; - -ERROR: too-few-primes ; - -: unique-primes ( numbits n -- seq ) - #! generate two primes - swap - dup 5 < [ too-few-primes ] when - 2dup [ random-prime ] curry replicate - dup all-unique? [ 2nip ] [ drop unique-primes ] if ; - -! Safe primes are of the form p = 2q + 1, p,q are prime -! See http://en.wikipedia.org/wiki/Safe_prime - - - -: safe-prime? ( q -- ? ) - { - [ 1 - 2 / dup integer? [ miller-rabin ] [ drop f ] if ] - [ miller-rabin ] - } 1&& ; - -: next-safe-prime ( n -- q ) - next-safe-prime-candidate - dup safe-prime? [ next-safe-prime ] unless ; - -: random-safe-prime ( numbits -- p ) - random-bits* next-safe-prime ; diff --git a/basis/math/primes/primes-docs.factor b/basis/math/primes/primes-docs.factor index c7dbc950e8..fa991e800f 100644 --- a/basis/math/primes/primes-docs.factor +++ b/basis/math/primes/primes-docs.factor @@ -1,10 +1,10 @@ -USING: help.markup help.syntax ; +USING: help.markup help.syntax math sequences ; IN: math.primes { next-prime prime? } related-words HELP: next-prime -{ $values { "n" "an integer not smaller than 2" } { "p" "a prime number" } } +{ $values { "n" integer } { "p" "a prime number" } } { $description "Return the next prime number greater than " { $snippet "n" } "." } ; HELP: prime? @@ -20,3 +20,49 @@ HELP: primes-upto HELP: primes-between { $values { "low" "an integer" } { "high" "an integer" } { "seq" "a sequence" } } { $description "Return a sequence containing all the prime numbers between " { $snippet "low" } " and " { $snippet "high" } "." } ; + +HELP: find-relative-prime +{ $values + { "n" integer } + { "p" integer } +} +{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ; + +HELP: find-relative-prime* +{ $values + { "n" integer } { "guess" integer } + { "p" integer } +} +{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ; + +HELP: random-prime +{ $values + { "numbits" integer } + { "p" integer } +} +{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; + +HELP: unique-primes +{ $values + { "numbits" integer } { "n" integer } + { "seq" sequence } +} +{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ; + + +ARTICLE: "math.primes" "Prime numbers" +"The " { $vocab-link "math.primes" } " vocabulary implements words related to prime numbers." $nl +"Testing if a number is prime:" +{ $subsection prime? } +"Generating prime numbers:" +{ $subsection next-prime } +{ $subsection primes-upto } +{ $subsection primes-between } +{ $subsection random-prime } +"Generating relative prime numbers:" +{ $subsection find-relative-prime } +{ $subsection find-relative-prime* } +"Make a sequence of random prime numbers:" +{ $subsection unique-primes } ; + +ABOUT: "math.primes" diff --git a/basis/math/primes/primes-tests.factor b/basis/math/primes/primes-tests.factor index db738399ef..6580f0780e 100644 --- a/basis/math/primes/primes-tests.factor +++ b/basis/math/primes/primes-tests.factor @@ -1,4 +1,6 @@ -USING: arrays math.primes tools.test ; +USING: arrays math math.primes math.primes.miller-rabin +tools.test ; +IN: math.primes.tests { 1237 } [ 1234 next-prime ] unit-test { f t } [ 1234 prime? 1237 prime? ] unit-test @@ -7,3 +9,12 @@ USING: arrays math.primes tools.test ; { { 4999963 4999999 5000011 5000077 5000081 } } [ 4999962 5000082 primes-between >array ] unit-test + +[ 2 ] [ 1 next-prime ] unit-test +[ 3 ] [ 2 next-prime ] unit-test +[ 5 ] [ 3 next-prime ] unit-test +[ 101 ] [ 100 next-prime ] unit-test +[ t ] [ 2135623355842621559 miller-rabin ] unit-test +[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test + +[ 49 ] [ 50 random-prime log2 ] unit-test diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor index fa1cd5cb63..e3985fc600 100644 --- a/basis/math/primes/primes.factor +++ b/basis/math/primes/primes.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007-2009 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel math math.functions -math.primes.miller-rabin math.order math.primes.erato -math.ranges sequences ; +USING: combinators kernel math math.bitwise math.functions +math.order math.primes.erato math.primes.miller-rabin +math.ranges random sequences sets fry ; IN: math.primes } cond ; foldable : next-prime ( n -- p ) - next-odd [ dup really-prime? ] [ 2 + ] until ; foldable + dup 2 < [ + drop 2 + ] [ + next-odd [ dup really-prime? ] [ 2 + ] until + ] if ; foldable : primes-between ( low high -- seq ) [ dup 3 max dup even? [ 1 + ] when ] dip @@ -32,3 +36,34 @@ PRIVATE> : primes-upto ( n -- seq ) 2 swap primes-between ; : coprime? ( a b -- ? ) gcd nip 1 = ; foldable + +: random-prime ( numbits -- p ) + random-bits* next-prime ; + +: estimated-primes ( m -- n ) + dup log / ; foldable + +ERROR: no-relative-prime n ; + + [ 2 + (find-relative-prime) ] [ nip ] if ; + +PRIVATE> + +: find-relative-prime* ( n guess -- p ) + #! find a prime relative to n with initial guess + >odd (find-relative-prime) ; + +: find-relative-prime ( n -- p ) + dup random find-relative-prime* ; + +ERROR: too-few-primes n numbits ; + +: unique-primes ( n numbits -- seq ) + 2dup 2^ estimated-primes > [ too-few-primes ] when + 2dup '[ _ random-prime ] replicate + dup all-unique? [ 2nip ] [ drop unique-primes ] if ; From 93a18a3c269bd42cf51f1a2041bef15c794e0fa4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 13:48:09 -0500 Subject: [PATCH 162/210] update using --- extra/project-euler/046/046.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/project-euler/046/046.factor b/extra/project-euler/046/046.factor index e4b8dcc955..0aa9eafe58 100755 --- a/extra/project-euler/046/046.factor +++ b/extra/project-euler/046/046.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.primes math.ranges sequences project-euler.common ; +USING: kernel math math.functions math.primes math.ranges +sequences project-euler.common math.bitwise ; IN: project-euler.046 ! http://projecteuler.net/index.php?section=problems&id=46 From 880e5bd03e3c6ed4766471e1aaeb0c5bd28efeef Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 13:49:40 -0500 Subject: [PATCH 163/210] make a new vocabulary for safe primes --- basis/math/primes/safe/authors.txt | 1 + basis/math/primes/safe/safe-docs.factor | 38 ++++++++++++++++++++++++ basis/math/primes/safe/safe-tests.factor | 14 +++++++++ basis/math/primes/safe/safe.factor | 29 ++++++++++++++++++ 4 files changed, 82 insertions(+) create mode 100644 basis/math/primes/safe/authors.txt create mode 100644 basis/math/primes/safe/safe-docs.factor create mode 100644 basis/math/primes/safe/safe-tests.factor create mode 100644 basis/math/primes/safe/safe.factor diff --git a/basis/math/primes/safe/authors.txt b/basis/math/primes/safe/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/math/primes/safe/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/math/primes/safe/safe-docs.factor b/basis/math/primes/safe/safe-docs.factor new file mode 100644 index 0000000000..861fc4e4ed --- /dev/null +++ b/basis/math/primes/safe/safe-docs.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.short-circuit help.markup help.syntax kernel +math math.functions math.primes random ; +IN: math.primes.safe + +HELP: next-safe-prime +{ $values + { "n" integer } + { "q" integer } +} +{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ; + +HELP: random-safe-prime +{ $values + { "numbits" integer } + { "p" integer } +} +{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; + +HELP: safe-prime? +{ $values + { "q" integer } + { "?" "a boolean" } +} +{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ; + + +ARTICLE: "math.primes.safe" "Safe prime numbers" +"The " { $vocab-link "math.primes.safe" } " vocabulary implements words to calculate safe prime numbers. Safe primes are of the form p = 2q + 1, where p,q are prime. Safe primes have desirable qualities for cryptographic applications." $nl + +"Testing if a number is a safe prime:" +{ $subsection safe-prime? } +"Generating safe prime numbers:" +{ $subsection next-safe-prime } +{ $subsection random-safe-prime } ; + +ABOUT: "math.primes.safe" diff --git a/basis/math/primes/safe/safe-tests.factor b/basis/math/primes/safe/safe-tests.factor new file mode 100644 index 0000000000..ef9aa9246f --- /dev/null +++ b/basis/math/primes/safe/safe-tests.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: math.primes.safe math.primes.safe.private tools.test ; +IN: math.primes.safe.tests + +[ 863 ] [ 862 next-safe-prime ] unit-test +[ f ] [ 862 safe-prime? ] unit-test +[ t ] [ 7 safe-prime? ] unit-test +[ f ] [ 31 safe-prime? ] unit-test +[ t ] [ 47 safe-prime-candidate? ] unit-test +[ t ] [ 47 safe-prime? ] unit-test +[ t ] [ 863 safe-prime? ] unit-test + +[ 47 ] [ 31 next-safe-prime ] unit-test diff --git a/basis/math/primes/safe/safe.factor b/basis/math/primes/safe/safe.factor new file mode 100644 index 0000000000..a3becb628f --- /dev/null +++ b/basis/math/primes/safe/safe.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.short-circuit kernel math math.functions +math.primes random ; +IN: math.primes.safe + + + +: safe-prime? ( q -- ? ) + { + [ 1 - 2 / dup integer? [ prime? ] [ drop f ] if ] + [ prime? ] + } 1&& ; + +: next-safe-prime ( n -- q ) + next-safe-prime-candidate + dup safe-prime? [ next-safe-prime ] unless ; + +: random-safe-prime ( numbits -- p ) + random-bits* next-safe-prime ; From 7a60ce161ab2ad90ab52e83e7fa10826df6a6faf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 14:01:21 -0500 Subject: [PATCH 164/210] link to prime tests from prime docs --- basis/math/primes/factors/factors.factor | 3 ++- basis/math/primes/primes-docs.factor | 3 +-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor index 278bf70b3d..f5fa468687 100644 --- a/basis/math/primes/factors/factors.factor +++ b/basis/math/primes/factors/factors.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007-2009 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators kernel make math math.functions math.primes sequences ; +USING: arrays combinators kernel make math math.functions +math.primes sequences ; IN: math.primes.factors Date: Sun, 10 May 2009 14:08:03 -0500 Subject: [PATCH 165/210] dont load safe primes in miller rabin tests --- .../miller-rabin/miller-rabin-tests.factor | 21 +------------------ 1 file changed, 1 insertion(+), 20 deletions(-) diff --git a/basis/math/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor index aeae6cac1b..d201abfef8 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor @@ -1,6 +1,4 @@ -USING: kernel math math.primes math.primes.miller-rabin -math.primes.miller-rabin.private math.primes.safe -math.primes.safe.private random sequences tools.test ; +USING: kernel math.primes.miller-rabin sequences tools.test ; IN: math.primes.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test @@ -8,23 +6,6 @@ IN: math.primes.miller-rabin.tests [ t ] [ 3 miller-rabin ] unit-test [ f ] [ 36 miller-rabin ] unit-test [ t ] [ 37 miller-rabin ] unit-test -[ 2 ] [ 1 next-prime ] unit-test -[ 3 ] [ 2 next-prime ] unit-test -[ 5 ] [ 3 next-prime ] unit-test -[ 101 ] [ 100 next-prime ] unit-test [ t ] [ 2135623355842621559 miller-rabin ] unit-test -[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test - -[ 863 ] [ 862 next-safe-prime ] unit-test -[ f ] [ 862 safe-prime? ] unit-test -[ t ] [ 7 safe-prime? ] unit-test -[ f ] [ 31 safe-prime? ] unit-test -[ t ] [ 47 safe-prime-candidate? ] unit-test -[ t ] [ 47 safe-prime? ] unit-test -[ t ] [ 863 safe-prime? ] unit-test [ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test - -[ 47 ] [ 31 next-safe-prime ] unit-test -[ 49 ] [ 50 random-prime log2 ] unit-test -[ 49 ] [ 50 random-bits* log2 ] unit-test From ca9a29ea8591cce9bbb1faae94d056239e5865c3 Mon Sep 17 00:00:00 2001 From: "U-C4\\Administrator" Date: Sun, 10 May 2009 14:24:13 -0500 Subject: [PATCH 166/210] use change-global in a couple of places, formatting --- basis/ui/backend/windows/windows.factor | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index ba4926d97e..2cf4091937 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -616,19 +616,21 @@ M: windows-ui-backend do-events GetDoubleClickTime milliseconds double-click-timeout set-global ; : cleanup-win32-ui ( -- ) - class-name-ptr get-global [ dup f UnregisterClass drop free ] when* - msg-obj get-global [ free ] when* - f class-name-ptr set-global - f msg-obj set-global ; + class-name-ptr [ + [ [ f UnregisterClass drop ] [ free ] bi ] when* f + ] change-global + msg-obj change-global [ [ free ] when* f ] ; -: get-dc ( world -- ) handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ; +: get-dc ( world -- ) + handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ; : get-rc ( world -- ) handle>> dup hDC>> dup wglCreateContext dup win32-error=0/f [ wglMakeCurrent win32-error=0/f ] keep >>hRC drop ; : set-pixel-format ( pixel-format hdc -- ) - swap handle>> "PIXELFORMATDESCRIPTOR" SetPixelFormat win32-error=0/f ; + swap handle>> + "PIXELFORMATDESCRIPTOR" SetPixelFormat win32-error=0/f ; : setup-gl ( world -- ) [ get-dc ] keep @@ -715,6 +717,7 @@ M: windows-ui-backend beep ( -- ) M: windows-ui-backend (grab-input) ( handle -- ) 0 ShowCursor drop hWnd>> client-area>RECT ClipCursor drop ; + M: windows-ui-backend (ungrab-input) ( handle -- ) drop f ClipCursor drop From dfb7514a0222a3a2adba1ffe87925bd08a399d33 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 May 2009 15:28:22 -0500 Subject: [PATCH 167/210] Removing slip usage from basis --- basis/cocoa/application/application.factor | 2 +- basis/compiler/codegen/codegen.factor | 3 +-- basis/stack-checker/known-words/known-words.factor | 14 +------------- basis/xml/xml.factor | 2 +- 4 files changed, 4 insertions(+), 17 deletions(-) diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index 8b33986fc2..66093645c1 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -14,7 +14,7 @@ NSApplicationDelegateReplyCancel NSApplicationDelegateReplyFailure ; : with-autorelease-pool ( quot -- ) - NSAutoreleasePool -> new slip -> release ; inline + NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline : NSApp ( -- app ) NSApplication -> sharedApplication ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 47593878fa..c7b67b72b4 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -444,8 +444,7 @@ TUPLE: callback-context ; : do-callback ( quot token -- ) init-catchstack - dup 2 setenv - slip + [ 2 setenv call ] keep wait-to-return ; inline : callback-return-quot ( ctype -- quot ) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 7603324200..56ef67d2a8 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -95,15 +95,6 @@ M: composed infer-call* M: object infer-call* "literal quotation" literal-expected ; -: infer-nslip ( n -- ) - [ infer->r infer-call ] [ infer-r> ] bi ; - -: infer-slip ( -- ) 1 infer-nslip ; - -: infer-2slip ( -- ) 2 infer-nslip ; - -: infer-3slip ( -- ) 3 infer-nslip ; - : infer-ndip ( word n -- ) [ literals get ] 2dip [ '[ _ def>> infer-quot-here ] ] @@ -180,9 +171,6 @@ M: object infer-call* { \ declare [ infer-declare ] } { \ call [ infer-call ] } { \ (call) [ infer-call ] } - { \ slip [ infer-slip ] } - { \ 2slip [ infer-2slip ] } - { \ 3slip [ infer-3slip ] } { \ dip [ infer-dip ] } { \ 2dip [ infer-2dip ] } { \ 3dip [ infer-3dip ] } @@ -216,7 +204,7 @@ M: object infer-call* "local-word-def" word-prop infer-quot-here ; { - declare call (call) slip 2slip 3slip dip 2dip 3dip curry compose + declare call (call) dip 2dip 3dip curry compose execute (execute) call-effect-unsafe execute-effect-unsafe if dispatch exit load-local load-locals get-local drop-locals do-primitive alien-invoke alien-indirect diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor index fba2eafaba..9df7165e6c 100755 --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -143,7 +143,7 @@ PRIVATE> Date: Fri, 8 May 2009 09:51:57 -0500 Subject: [PATCH 168/210] cleaning up sha2 --- basis/checksums/sha2/sha2.factor | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 3b092a78de..b4b787a2b7 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -2,12 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel splitting grouping math sequences namespaces make io.binary math.bitwise checksums checksums.common -sbufs strings ; +sbufs strings combinators.smart ; IN: checksums.sha2 Date: Fri, 8 May 2009 10:04:31 -0500 Subject: [PATCH 169/210] more refactoring on sha2 --- basis/checksums/sha2/sha2.factor | 40 ++++++++++++++++++-------------- 1 file changed, 22 insertions(+), 18 deletions(-) diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index b4b787a2b7..57a1db5ac1 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel splitting grouping math sequences namespaces make io.binary math.bitwise checksums checksums.common -sbufs strings combinators.smart ; +sbufs strings combinators.smart math.ranges fry combinators ; IN: checksums.sha2 ] map block-size get 0 pad-tail - dup 16 64 dup [ - process-M-256 - ] with each ; + 16 64 [a,b) over '[ _ process-M-256 ] each ; : ch ( x y z -- x' ) [ bitxor bitand ] keep bitxor ; : maj ( x y z -- x' ) - [ [ bitand ] 2keep bitor ] dip bitand bitor ; + [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; : S0-256 ( x -- x' ) - [ -2 bitroll-32 ] keep - [ -13 bitroll-32 ] keep - -22 bitroll-32 bitxor bitxor ; inline + [ + [ -2 bitroll-32 ] + [ -13 bitroll-32 ] + [ -22 bitroll-32 ] tri + ] [ bitxor ] reduce-outputs ; inline : S1-256 ( x -- x' ) - [ -6 bitroll-32 ] keep - [ -11 bitroll-32 ] keep - -25 bitroll-32 bitxor bitxor ; inline + [ + [ -6 bitroll-32 ] + [ -11 bitroll-32 ] + [ -25 bitroll-32 ] tri + ] [ bitxor ] reduce-outputs ; inline : slice3 ( n seq -- a b c ) [ dup 3 + ] dip first3 ; inline @@ -118,7 +122,7 @@ CONSTANT: K-256 ] with each vars get H get [ w+ ] 2map H set ; : seq>byte-array ( n seq -- string ) - [ swap [ >be % ] curry each ] B{ } make ; + [ swap '[ _ >be % ] each ] B{ } make ; : preprocess-plaintext ( string big-endian? -- padded-string ) #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits From a185f8c21952465864a903e162cbb7dca5abc078 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 10:52:25 -0500 Subject: [PATCH 170/210] more refactoring on sha2 --- basis/checksums/sha2/sha2.factor | 114 +++++++++++++++++-------------- 1 file changed, 62 insertions(+), 52 deletions(-) diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 57a1db5ac1..cd67418516 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -2,12 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel splitting grouping math sequences namespaces make io.binary math.bitwise checksums checksums.common -sbufs strings combinators.smart math.ranges fry combinators ; +sbufs strings combinators.smart math.ranges fry combinators +accessors ; IN: checksums.sha2 ] map block-size get 0 pad-tail - 16 64 [a,b) over '[ _ process-M-256 ] each ; - -: ch ( x y z -- x' ) - [ bitxor bitand ] keep bitxor ; - -: maj ( x y z -- x' ) - [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; - : S0-256 ( x -- x' ) [ [ -2 bitroll-32 ] @@ -91,21 +73,42 @@ CONSTANT: K-256 [ -25 bitroll-32 ] tri ] [ bitxor ] reduce-outputs ; inline -: slice3 ( n seq -- a b c ) [ dup 3 + ] dip first3 ; inline +: process-M-256 ( n seq -- ) + { + [ [ 16 - ] dip nth ] + [ [ 15 - ] dip nth s0-256 ] + [ [ 7 - ] dip nth ] + [ [ 2 - ] dip nth s1-256 w+ w+ w+ ] + [ ] + } 2cleave set-nth ; inline -: T1 ( W n -- T1 ) - [ swap nth ] keep - K get nth + - e vars get slice3 ch + - e vars get nth S1-256 + - h vars get nth w+ ; +: ch ( x y z -- x' ) + [ bitxor bitand ] keep bitxor ; -: T2 ( -- T2 ) - a vars get nth S0-256 - a vars get slice3 maj w+ ; +: maj ( x y z -- x' ) + [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; -: update-vars ( T1 T2 -- ) - vars get +: prepare-message-schedule ( seq -- w-seq ) + word-size get [ be> ] map block-size get 0 pad-tail + 16 64 [a,b) over '[ _ process-M-256 ] each ; + +: slice3 ( n seq -- a b c ) + [ dup 3 + ] dip first3 ; inline + +: T1 ( W n H -- T1 ) + [ + [ swap nth ] keep + K-256 nth + + ] dip + [ e swap slice3 ch w+ ] + [ e swap nth S1-256 w+ ] + [ h swap nth w+ ] tri ; + +: T2 ( H -- T2 ) + [ a swap nth S0-256 ] + [ a swap slice3 maj w+ ] bi ; + +: update-H ( T1 T2 H -- ) h g pick exchange g f pick exchange f e pick exchange @@ -115,28 +118,35 @@ CONSTANT: K-256 b a pick exchange [ w+ a ] dip set-nth ; -: process-chunk ( M -- ) - H get clone vars set - prepare-message-schedule block-size get [ - T1 T2 update-vars - ] with each vars get H get [ w+ ] 2map H set ; +: process-chunk ( M block-size H-cloned -- ) + [ + '[ + _ + [ T1 ] + [ T2 ] + [ update-H ] tri + ] with each + ] keep H get [ w+ ] 2map H set ; -: seq>byte-array ( n seq -- string ) - [ swap '[ _ >be % ] each ] B{ } make ; - -: preprocess-plaintext ( string big-endian? -- padded-string ) - #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits - [ >sbuf ] dip over [ +: pad-initial-bytes ( string -- padded-string ) + dup [ HEX: 80 , - dup length HEX: 3f bitand - calculate-pad-length 0 % - length 3 shift 8 rot [ >be ] [ >le ] if % - ] "" make over push-all ; + length + [ HEX: 3f bitand calculate-pad-length 0 % ] + [ 3 shift 8 >be % ] bi + ] "" make append ; + +: seq>byte-array ( seq n -- string ) + '[ _ >be ] map B{ } join ; : byte-array>sha2 ( byte-array -- string ) - t preprocess-plaintext - block-size get group [ process-chunk ] each - 4 H get seq>byte-array ; + pad-initial-bytes + block-size get + [ + prepare-message-schedule + block-size get H get clone process-chunk + ] each + H get 4 seq>byte-array ; PRIVATE> @@ -146,9 +156,9 @@ INSTANCE: sha-256 checksum M: sha-256 checksum-bytes drop [ - K-256 K set initial-H-256 H set 4 word-size set 64 block-size set byte-array>sha2 + ] with-scope ; From b57c92fdc882fcc22e7994eb8d7641537cc645e6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 17:18:43 -0500 Subject: [PATCH 171/210] move sha2 state to a tuple --- basis/checksums/sha2/sha2.factor | 36 +++++++++++++++++++------------- 1 file changed, 22 insertions(+), 14 deletions(-) diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index cd67418516..ff19c4c9a8 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -8,7 +8,7 @@ IN: checksums.sha2 [ be> ] map block-size get 0 pad-tail + sha2 get word-size>> [ be> ] map sha2 get block-size>> 0 pad-tail 16 64 [a,b) over '[ _ process-M-256 ] each ; : slice3 ( n seq -- a b c ) @@ -98,7 +98,7 @@ CONSTANT: K-256 : T1 ( W n H -- T1 ) [ [ swap nth ] keep - K-256 nth + + sha2 get K>> nth + ] dip [ e swap slice3 ch w+ ] [ e swap nth S1-256 w+ ] @@ -126,7 +126,7 @@ CONSTANT: K-256 [ T2 ] [ update-H ] tri ] with each - ] keep H get [ w+ ] 2map H set ; + ] keep sha2 get H>> [ w+ ] 2map sha2 get (>>H) ; : pad-initial-bytes ( string -- padded-string ) dup [ @@ -141,12 +141,12 @@ CONSTANT: K-256 : byte-array>sha2 ( byte-array -- string ) pad-initial-bytes - block-size get + sha2 get block-size>> [ prepare-message-schedule - block-size get H get clone process-chunk + sha2 get [ block-size>> ] [ H>> clone ] bi process-chunk ] each - H get 4 seq>byte-array ; + sha2 get H>> 4 seq>byte-array ; PRIVATE> @@ -154,11 +154,19 @@ SINGLETON: sha-256 INSTANCE: sha-256 checksum -M: sha-256 checksum-bytes - drop [ - initial-H-256 H set - 4 word-size set - 64 block-size set - byte-array>sha2 +TUPLE: sha2-state K H word-size block-size ; - ] with-scope ; +TUPLE: sha-256-state < sha2-state ; + +: ( -- sha2-state ) + sha-256-state new + K-256 >>K + initial-H-256 >>H + 4 >>word-size + 64 >>block-size ; + +M: sha-256 checksum-bytes + drop + sha2 [ + byte-array>sha2 + ] with-variable ; From ef495bd34ce9d9e3ef5c841d91941be9ee207aa5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 17:39:11 -0500 Subject: [PATCH 172/210] remove dynamic variables from sha2 --- basis/checksums/sha2/sha2.factor | 89 +++++++++++++++----------------- 1 file changed, 41 insertions(+), 48 deletions(-) diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index ff19c4c9a8..d019a6913b 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -3,7 +3,7 @@ USING: kernel splitting grouping math sequences namespaces make io.binary math.bitwise checksums checksums.common sbufs strings combinators.smart math.ranges fry combinators -accessors ; +accessors locals ; IN: checksums.sha2 > [ be> ] map sha2 get block-size>> 0 pad-tail - 16 64 [a,b) over '[ _ process-M-256 ] each ; + [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline : slice3 ( n seq -- a b c ) [ dup 3 + ] dip first3 ; inline -: T1 ( W n H -- T1 ) - [ - [ swap nth ] keep - sha2 get K>> nth + - ] dip - [ e swap slice3 ch w+ ] - [ e swap nth S1-256 w+ ] - [ h swap nth w+ ] tri ; +: pad-initial-bytes ( string -- padded-string ) + dup [ + HEX: 80 , + length + [ HEX: 3f bitand calculate-pad-length 0 % ] + [ 3 shift 8 >be % ] bi + ] "" make append ; + +: seq>byte-array ( seq n -- string ) + '[ _ >be ] map B{ } join ; + +:: T1 ( n M H sha2 -- T1 ) + n M nth + n sha2 K>> nth + + e H slice3 ch w+ + e H nth S1-256 w+ + h H nth w+ ; : T2 ( H -- T2 ) [ a swap nth S0-256 ] @@ -116,37 +121,28 @@ CONSTANT: K-256 d c pick exchange c b pick exchange b a pick exchange - [ w+ a ] dip set-nth ; + [ w+ a ] dip set-nth ; inline -: process-chunk ( M block-size H-cloned -- ) - [ - '[ - _ - [ T1 ] - [ T2 ] - [ update-H ] tri - ] with each - ] keep sha2 get H>> [ w+ ] 2map sha2 get (>>H) ; +: prepare-message-schedule ( seq sha2 -- w-seq ) + [ word-size>> [ be> ] map ] + [ block-size>> 0 pad-tail 16 64 [a,b) over '[ _ process-M-256 ] each ] bi ; -: pad-initial-bytes ( string -- padded-string ) - dup [ - HEX: 80 , - length - [ HEX: 3f bitand calculate-pad-length 0 % ] - [ 3 shift 8 >be % ] bi - ] "" make append ; - -: seq>byte-array ( seq n -- string ) - '[ _ >be ] map B{ } join ; - -: byte-array>sha2 ( byte-array -- string ) - pad-initial-bytes - sha2 get block-size>> - [ - prepare-message-schedule - sha2 get [ block-size>> ] [ H>> clone ] bi process-chunk +:: process-chunk ( M block-size cloned-H sha2 -- ) + block-size [ + M cloned-H sha2 T1 + cloned-H T2 + cloned-H update-H ] each - sha2 get H>> 4 seq>byte-array ; + cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; + +:: byte-array>sha2 ( bytes state -- string ) + bytes pad-initial-bytes + state block-size>> + [ + state prepare-message-schedule + state [ block-size>> ] [ H>> clone ] bi state process-chunk + ] each + state H>> 4 seq>byte-array ; PRIVATE> @@ -163,10 +159,7 @@ TUPLE: sha-256-state < sha2-state ; K-256 >>K initial-H-256 >>H 4 >>word-size - 64 >>block-size ; + 64 >>block-size ; M: sha-256 checksum-bytes - drop - sha2 [ - byte-array>sha2 - ] with-variable ; + drop byte-array>sha2 ; From 106da0bce46283b9d33c450987a6b87b2dd91a8b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 18:11:13 -0500 Subject: [PATCH 173/210] support sha-224, add constants for all sha2 --- basis/checksums/sha2/sha2-tests.factor | 43 ++++++++-- basis/checksums/sha2/sha2.factor | 108 +++++++++++++++++++++---- 2 files changed, 130 insertions(+), 21 deletions(-) diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor index 2f4e3c51c4..1476f04e75 100644 --- a/basis/checksums/sha2/sha2-tests.factor +++ b/basis/checksums/sha2/sha2-tests.factor @@ -1,7 +1,36 @@ -USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ; -[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test -[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test -[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test -[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test -[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test -[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test +USING: arrays kernel math namespaces sequences tools.test +checksums.sha2 checksums ; +IN: checksums.sha2.tests + +: test-checksum ( text identifier -- checksum ) + checksum-bytes hex-string ; + +[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ] +[ + "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" + sha-224 test-checksum +] unit-test + +[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] +[ "" sha-256 test-checksum ] unit-test + +[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] +[ "abc" sha-256 test-checksum ] unit-test + +[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] +[ "message digest" sha-256 test-checksum ] unit-test + +[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] +[ "abcdefghijklmnopqrstuvwxyz" sha-256 test-checksum ] unit-test + +[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] +[ + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" + sha-256 test-checksum +] unit-test + +[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] +[ + "12345678901234567890123456789012345678901234567890123456789012345678901234567890" + sha-256 test-checksum +] unit-test diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index d019a6913b..6a695b0965 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -19,12 +19,42 @@ CONSTANT: f 5 CONSTANT: g 6 CONSTANT: h 7 +CONSTANT: initial-H-224 + { + HEX: c1059ed8 HEX: 367cd507 HEX: 3070dd17 HEX: f70e5939 + HEX: ffc00b31 HEX: 68581511 HEX: 64f98fa7 HEX: befa4fa4 + } + CONSTANT: initial-H-256 { HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19 } +CONSTANT: initial-H-384 + { + HEX: cbbb9d5dc1059ed8 + HEX: 629a292a367cd507 + HEX: 9159015a3070dd17 + HEX: 152fecd8f70e5939 + HEX: 67332667ffc00b31 + HEX: 8eb44a8768581511 + HEX: db0c2e0d64f98fa7 + HEX: 47b5481dbefa4fa4 + } + +CONSTANT: initial-H-512 + { + HEX: 6a09e667f3bcc908 + HEX: bb67ae8584caa73b + HEX: 3c6ef372fe94f82b + HEX: a54ff53a5f1d36f1 + HEX: 510e527fade682d1 + HEX: 9b05688c2b3e6c1f + HEX: 1f83d9abfb41bd6b + HEX: 5be0cd19137e2179 + } + CONSTANT: K-256 { HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5 @@ -45,6 +75,29 @@ CONSTANT: K-256 HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2 } +CONSTANT: K-384 + { + HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694 + HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65 + HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5 + HEX: 983e5152ee66dfab HEX: a831c66d2db43210 HEX: b00327c898fb213f HEX: bf597fc7beef0ee4 + HEX: c6e00bf33da88fc2 HEX: d5a79147930aa725 HEX: 06ca6351e003826f HEX: 142929670a0e6e70 + HEX: 27b70a8546d22ffc HEX: 2e1b21385c26c926 HEX: 4d2c6dfc5ac42aed HEX: 53380d139d95b3df + HEX: 650a73548baf63de HEX: 766a0abb3c77b2a8 HEX: 81c2c92e47edaee6 HEX: 92722c851482353b + HEX: a2bfe8a14cf10364 HEX: a81a664bbc423001 HEX: c24b8b70d0f89791 HEX: c76c51a30654be30 + HEX: d192e819d6ef5218 HEX: d69906245565a910 HEX: f40e35855771202a HEX: 106aa07032bbd1b8 + HEX: 19a4c116b8d2d0c8 HEX: 1e376c085141ab53 HEX: 2748774cdf8eeb99 HEX: 34b0bcb5e19b48a8 + HEX: 391c0cb3c5c95a63 HEX: 4ed8aa4ae3418acb HEX: 5b9cca4f7763e373 HEX: 682e6ff3d6b2b8a3 + HEX: 748f82ee5defb2fc HEX: 78a5636f43172f60 HEX: 84c87814a1f0ab72 HEX: 8cc702081a6439ec + HEX: 90befffa23631e28 HEX: a4506cebde82bde9 HEX: bef9a3f7b2c67915 HEX: c67178f2e372532b + HEX: ca273eceea26619c HEX: d186b8c721c0c207 HEX: eada7dd6cde0eb1e HEX: f57d4f7fee6ed178 + HEX: 06f067aa72176fba HEX: 0a637dc5a2c898a6 HEX: 113f9804bef90dae HEX: 1b710b35131c471b + HEX: 28db77f523047d84 HEX: 32caab7b40c72493 HEX: 3c9ebe0a15c9bebc HEX: 431d67c49c100d4c + HEX: 4cc5d4becb3e42b6 HEX: 597f299cfc657e2a HEX: 5fcb6fab3ad6faec HEX: 6c44198c4a475817 + } + +ALIAS: K-512 K-384 + : s0-256 ( x -- x' ) [ [ -7 bitroll-32 ] @@ -107,11 +160,11 @@ CONSTANT: K-256 n sha2 K>> nth + e H slice3 ch w+ e H nth S1-256 w+ - h H nth w+ ; + h H nth w+ ; inline : T2 ( H -- T2 ) [ a swap nth S0-256 ] - [ a swap slice3 maj w+ ] bi ; + [ a swap slice3 maj w+ ] bi ; inline : update-H ( T1 T2 H -- ) h g pick exchange @@ -125,33 +178,53 @@ CONSTANT: K-256 : prepare-message-schedule ( seq sha2 -- w-seq ) [ word-size>> [ be> ] map ] - [ block-size>> 0 pad-tail 16 64 [a,b) over '[ _ process-M-256 ] each ] bi ; + [ + block-size>> 0 pad-tail 16 64 [a,b) over + '[ _ process-M-256 ] each + ] bi ; inline :: process-chunk ( M block-size cloned-H sha2 -- ) block-size [ M cloned-H sha2 T1 cloned-H T2 - cloned-H update-H + cloned-H update-H ] each - cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; + cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline -:: byte-array>sha2 ( bytes state -- string ) - bytes pad-initial-bytes - state block-size>> - [ - state prepare-message-schedule - state [ block-size>> ] [ H>> clone ] bi state process-chunk - ] each - state H>> 4 seq>byte-array ; +: sha2-steps ( sliced-groups state -- ) + '[ + _ + [ prepare-message-schedule ] + [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi + ] each ; + +: byte-array>sha2 ( bytes state -- ) + [ [ pad-initial-bytes ] [ block-size>> ] bi* ] + [ sha2-steps ] bi ; PRIVATE> +SINGLETON: sha-224 SINGLETON: sha-256 +SINGLETON: sha-384 +SINGLETON: sha-512 +INSTANCE: sha-224 checksum INSTANCE: sha-256 checksum +INSTANCE: sha-384 checksum +INSTANCE: sha-512 checksum TUPLE: sha2-state K H word-size block-size ; +TUPLE: sha-224-state < sha2-state ; + +: ( -- sha2-state ) + sha-224-state new + K-256 >>K + initial-H-224 >>H + 4 >>word-size + 64 >>block-size ; + TUPLE: sha-256-state < sha2-state ; : ( -- sha2-state ) @@ -161,5 +234,12 @@ TUPLE: sha-256-state < sha2-state ; 4 >>word-size 64 >>block-size ; +M: sha-224 checksum-bytes + drop + [ byte-array>sha2 ] + [ H>> 7 head 4 seq>byte-array ] bi ; + M: sha-256 checksum-bytes - drop byte-array>sha2 ; + drop + [ byte-array>sha2 ] + [ H>> 4 seq>byte-array ] bi ; From 36bc6d6298fc6f7ae44f9b0039aae9c9ed5271f1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 8 May 2009 19:00:06 -0500 Subject: [PATCH 174/210] implementing sha2 512 --- basis/checksums/common/common.factor | 3 + basis/checksums/sha2/sha2-tests.factor | 6 ++ basis/checksums/sha2/sha2.factor | 93 +++++++++++++++++++------- 3 files changed, 78 insertions(+), 24 deletions(-) diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor index 0ae4328446..01cc2cb739 100644 --- a/basis/checksums/common/common.factor +++ b/basis/checksums/common/common.factor @@ -9,6 +9,9 @@ SYMBOL: bytes-read : calculate-pad-length ( length -- length' ) [ 56 < 55 119 ? ] keep - ; +: calculate-pad-length-long ( length -- length' ) + [ 112 < 111 249 ? ] keep - ; + : pad-last-block ( str big-endian? length -- str ) [ [ % ] 2dip HEX: 80 , diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor index 1476f04e75..f224d497a6 100644 --- a/basis/checksums/sha2/sha2-tests.factor +++ b/basis/checksums/sha2/sha2-tests.factor @@ -34,3 +34,9 @@ IN: checksums.sha2.tests "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 test-checksum ] unit-test + + + + +[ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ] +[ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 6a695b0965..1abed088a3 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -6,9 +6,31 @@ sbufs strings combinators.smart math.ranges fry combinators accessors locals ; IN: checksums.sha2 - first3 ; inline -: pad-initial-bytes ( string -- padded-string ) +GENERIC: pad-initial-bytes ( string sha2 -- padded-string ) + +M: sha2-short pad-initial-bytes ( string sha2 -- padded-string ) + drop dup [ HEX: 80 , length - [ HEX: 3f bitand calculate-pad-length 0 % ] + [ 64 mod calculate-pad-length 0 % ] [ 3 shift 8 >be % ] bi ] "" make append ; +M: sha2-long pad-initial-bytes ( string sha2 -- padded-string ) + drop dup [ + HEX: 80 , + length + [ 128 mod calculate-pad-length-long 0 % ] + [ 3 shift 16 >be % ] bi + ] "" make append ; + : seq>byte-array ( seq n -- string ) '[ _ >be ] map B{ } join ; @@ -179,7 +216,7 @@ ALIAS: K-512 K-384 : prepare-message-schedule ( seq sha2 -- w-seq ) [ word-size>> [ be> ] map ] [ - block-size>> 0 pad-tail 16 64 [a,b) over + block-size>> [ 0 pad-tail 16 ] keep [a,b) over '[ _ process-M-256 ] each ] bi ; inline @@ -199,25 +236,9 @@ ALIAS: K-512 K-384 ] each ; : byte-array>sha2 ( bytes state -- ) - [ [ pad-initial-bytes ] [ block-size>> ] bi* ] + [ [ pad-initial-bytes ] [ nip block-size>> ] 2bi ] [ sha2-steps ] bi ; -PRIVATE> - -SINGLETON: sha-224 -SINGLETON: sha-256 -SINGLETON: sha-384 -SINGLETON: sha-512 - -INSTANCE: sha-224 checksum -INSTANCE: sha-256 checksum -INSTANCE: sha-384 checksum -INSTANCE: sha-512 checksum - -TUPLE: sha2-state K H word-size block-size ; - -TUPLE: sha-224-state < sha2-state ; - : ( -- sha2-state ) sha-224-state new K-256 >>K @@ -225,8 +246,6 @@ TUPLE: sha-224-state < sha2-state ; 4 >>word-size 64 >>block-size ; -TUPLE: sha-256-state < sha2-state ; - : ( -- sha2-state ) sha-256-state new K-256 >>K @@ -234,6 +253,22 @@ TUPLE: sha-256-state < sha2-state ; 4 >>word-size 64 >>block-size ; +: ( -- sha2-state ) + sha-384-state new + K-384 >>K + initial-H-384 >>H + 8 >>word-size + 80 >>block-size ; + +: ( -- sha2-state ) + sha-512-state new + K-512 >>K + initial-H-512 >>H + 8 >>word-size + 80 >>block-size ; + +PRIVATE> + M: sha-224 checksum-bytes drop [ byte-array>sha2 ] @@ -243,3 +278,13 @@ M: sha-256 checksum-bytes drop [ byte-array>sha2 ] [ H>> 4 seq>byte-array ] bi ; + +M: sha-384 checksum-bytes + drop + [ byte-array>sha2 ] + [ H>> 6 head 8 seq>byte-array ] bi ; + +M: sha-512 checksum-bytes + drop + [ byte-array>sha2 ] + [ H>> 8 seq>byte-array ] bi ; From 84ccacd5d2d2c2d781d2de828fbe2a053193db8a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 9 May 2009 13:54:18 -0500 Subject: [PATCH 175/210] use bi, call >string on c-strings from tar --- extra/crypto/hmac/hmac.factor | 4 ++-- extra/tar/tar.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor index 6e6229f182..9a668aa23a 100755 --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -31,8 +31,8 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; : init-hmac ( K -- o i ) 64 0 pad-tail - [ opad seq-bitxor ] keep - ipad seq-bitxor ; + [ opad seq-bitxor ] + [ ipad seq-bitxor ] bi ; PRIVATE> diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index e281871252..93554c146a 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -18,7 +18,7 @@ ERROR: checksum-error header ; : trim-string ( seq -- newseq ) [ "\0 " member? ] trim ; : read-c-string ( n -- str/f ) - read [ zero? ] trim-tail [ f ] when-empty ; + read [ zero? ] trim-tail [ f ] when-empty >string ; : read-tar-header ( -- obj ) \ tar-header new From 194281009d6b453dfe482550c04563f1ee44eb15 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 9 May 2009 13:54:42 -0500 Subject: [PATCH 176/210] 64-bit add/subtract/multiply --- basis/math/bitwise/bitwise.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 73d111f91e..4fe2340643 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -35,6 +35,11 @@ IN: math.bitwise : w- ( int int -- int ) - 32 bits ; inline : w* ( int int -- int ) * 32 bits ; inline +! 64-bit arithmetic +: W+ ( int int -- int ) + 64 bits ; inline +: W- ( int int -- int ) - 64 bits ; inline +: W* ( int int -- int ) * 64 bits ; inline + ! flags MACRO: flags ( values -- ) [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ; From a529a7b7a16ea1cb279efec3a3fe9c529f11de7d Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 7 May 2009 10:32:32 +0200 Subject: [PATCH 177/210] reworked insert, save and update; added save-deep --- extra/mongodb/tuple/tuple.factor | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index 9173957979..e5e4867d71 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -54,14 +54,22 @@ M: mdb-persistent id-selector >upsert update ] assoc-each ; inline PRIVATE> -: save-tuple ( tuple -- ) - tuple>storable [ (save-tuples) ] assoc-each ; +: save-tuple-deep ( tuple -- ) + tuple>storable [ (save-tuples) ] assoc-each ; : update-tuple ( tuple -- ) - save-tuple ; + [ tuple-collection name>> ] + [ id-selector ] + [ tuple>assoc ] tri + update ; + +: save-tuple ( tuple -- ) + update-tuple ; : insert-tuple ( tuple -- ) - save-tuple ; + [ tuple-collection name>> ] + [ tuple>assoc ] bi + save ; : delete-tuple ( tuple -- ) [ tuple-collection name>> ] keep From 6254009af774c2d40341eb2b1ac1b6695d70d9d6 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 7 May 2009 12:01:01 +0200 Subject: [PATCH 178/210] some bug fixes --- extra/mongodb/tuple/collection/collection.factor | 4 +++- extra/mongodb/tuple/tuple.factor | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/extra/mongodb/tuple/collection/collection.factor b/extra/mongodb/tuple/collection/collection.factor index 1bd2d94e69..60b2d25764 100644 --- a/extra/mongodb/tuple/collection/collection.factor +++ b/extra/mongodb/tuple/collection/collection.factor @@ -92,6 +92,8 @@ GENERIC: mdb-index-map ( tuple -- sequence ) [ ] [ name>> ] bi H{ } clone [ set-at ] keep ] [ 2drop H{ } clone ] if ; + + PRIVATE> : MDB_ADDON_SLOTS ( -- slots ) @@ -116,7 +118,7 @@ PRIVATE> [ drop MDB_USER_KEY set-word-prop ] [ 3drop ] if ; inline : set-index-map ( class index-list -- ) - [ [ dup user-defined-key-index ] dip index-list>map ] output>sequence + [ dup user-defined-key-index ] dip index-list>map 2array assoc-combine MDB_INDEX_MAP set-word-prop ; inline M: tuple-class tuple-collection ( tuple -- mdb-collection ) diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index e5e4867d71..8f7504d9bc 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -69,7 +69,7 @@ PRIVATE> : insert-tuple ( tuple -- ) [ tuple-collection name>> ] [ tuple>assoc ] bi - save ; + save ; : delete-tuple ( tuple -- ) [ tuple-collection name>> ] keep From 157a55b113e559b547a779063e11ea16195f45ae Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sun, 10 May 2009 11:54:42 +0200 Subject: [PATCH 179/210] added delete-tuples word --- extra/mongodb/tuple/tuple.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index 8f7504d9bc..1b4b3cd4f1 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -75,6 +75,9 @@ PRIVATE> [ tuple-collection name>> ] keep id-selector delete ; +: delete-tuples ( seq -- ) + [ delete-tuple ] each ; + : tuple>query ( tuple -- query ) [ tuple-collection name>> ] keep tuple>selector ; From 0e660158b0d6dd536c101f3755000e08f33fcf87 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 10 May 2009 10:41:50 -0500 Subject: [PATCH 180/210] cut perlin-noise time in half --- .../math/polynomials/polynomials-docs.factor | 10 +- basis/math/polynomials/polynomials.factor | 12 +- basis/math/vectors/vectors.factor | 10 ++ .../affine-transforms.factor | 2 + extra/noise/noise.factor | 105 ++++++++++-------- 5 files changed, 85 insertions(+), 54 deletions(-) diff --git a/basis/math/polynomials/polynomials-docs.factor b/basis/math/polynomials/polynomials-docs.factor index edffa5377d..6617556270 100644 --- a/basis/math/polynomials/polynomials-docs.factor +++ b/basis/math/polynomials/polynomials-docs.factor @@ -93,7 +93,13 @@ HELP: pdiff { $description "Finds the derivative of " { $snippet "p" } "." } ; HELP: polyval -{ $values { "p" "a polynomial" } { "x" number } { "p[x]" number } } +{ $values { "x" number } { "p" "a polynomial" } { "p[x]" number } } { $description "Evaluate " { $snippet "p" } " with the input " { $snippet "x" } "." } -{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } 2 polyval ." "5" } } ; +{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval ." "5" } } ; +HELP: polyval* +{ $values { "p" "a literal polynomial" } } +{ $description "Macro version of " { $link polyval } ". Evaluates the literal polynomial " { $snippet "p" } " at the value off the top of the stack." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval* ." "5" } } ; + +{ polyval polyval* } related-words diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index f65c4ecaaf..fd6eda4a90 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel make math math.order math.vectors sequences - splitting vectors ; + splitting vectors macros combinators ; IN: math.polynomials : pdiff ( p -- p' ) dup length v* { 0 } ?head drop ; -: polyval ( p x -- p[x] ) - [ dup length ] dip powers v. ; +: polyval ( x p -- p[x] ) + [ length swap powers ] [ nip ] 2bi v. ; + +MACRO: polyval* ( p -- ) + reverse + [ 1 tail [ \ * swap \ + [ ] 3sequence ] map ] + [ first \ drop swap [ ] 2sequence ] bi + prefix \ cleave [ ] 2sequence ; diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 17f6c39f04..bad2733bbf 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -41,6 +41,13 @@ IN: math.vectors : set-axis ( u v axis -- w ) [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; +: 2tetra@ ( p q r s t u v w quot -- ) + dup [ [ 2bi@ ] curry 4dip ] dip 2bi@ ; inline + +: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv ) + [ first lerp ] [ second lerp ] [ third lerp ] tri-curry + [ 2tetra@ ] [ 2bi@ ] [ call ] tri* ; + : bilerp ( aa ba ab bb {t,u} -- a_tu ) [ first lerp ] [ second lerp ] bi-curry [ 2bi@ ] [ call ] bi* ; @@ -72,3 +79,6 @@ HINTS: v. { array array } ; HINTS: vlerp { array array array } ; HINTS: vnlerp { array array object } ; + +HINTS: bilerp { object object object object array } ; +HINTS: trilerp { object object object object object object object object array } ; diff --git a/extra/math/affine-transforms/affine-transforms.factor b/extra/math/affine-transforms/affine-transforms.factor index 20b73ba678..d1fd602f72 100644 --- a/extra/math/affine-transforms/affine-transforms.factor +++ b/extra/math/affine-transforms/affine-transforms.factor @@ -17,6 +17,8 @@ CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0 [ drop origin>> ] 2tri v+ v+ ; +: ( -- a ) + { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } ; : ( origin -- a ) [ { 1.0 0.0 } { 0.0 1.0 } ] dip ; : ( theta -- transform ) diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor index c28768283c..46704eed36 100644 --- a/extra/noise/noise.factor +++ b/extra/noise/noise.factor @@ -1,61 +1,60 @@ USING: byte-arrays combinators fry images kernel locals math math.affine-transforms math.functions math.order math.polynomials math.vectors random random.mersenne-twister -sequences sequences.product ; +sequences sequences.product hints arrays sequences.private +combinators.short-circuit math.private ; IN: noise : ( -- table ) - 256 iota >byte-array randomize dup append ; + 256 iota >byte-array randomize dup append ; inline : with-seed ( seed quot -- ) [ ] dip with-random ; inline u hash 12 bitand zero? - [ gradients second ] - [ hash 13 bitand 12 = [ gradients first ] [ gradients third ] if ] if + [ y ] [ hash 13 bitand 12 = [ x ] [ z ] if ] if :> v hash 1 bitand zero? [ u ] [ u neg ] if hash 2 bitand zero? [ v ] [ v neg ] if + ; +HINTS: grad { fixnum float float float } ; + : unit-cube ( point -- cube ) - [ floor >fixnum 256 mod ] map ; + [ floor >fixnum 256 rem ] map ; -:: hashes ( table cube -- aaa baa aba bba aab bab abb bbb ) - cube first :> x - cube second :> y - cube third :> z - x table nth y + :> a - x 1 + table nth y + :> b +:: hashes ( table x y z -- aaa baa aba bba aab bab abb bbb ) + x table nth-unsafe y fixnum+fast :> a + x 1 fixnum+fast table nth-unsafe y fixnum+fast :> b - a table nth z + :> aa - b table nth z + :> ba - a 1 + table nth z + :> ab - b 1 + table nth z + :> bb + a table nth-unsafe z fixnum+fast :> aa + b table nth-unsafe z fixnum+fast :> ba + a 1 fixnum+fast table nth-unsafe z fixnum+fast :> ab + b 1 fixnum+fast table nth-unsafe z fixnum+fast :> bb - aa table nth - ba table nth - ab table nth - bb table nth - aa 1 + table nth - ba 1 + table nth - ab 1 + table nth - bb 1 + table nth ; + aa table nth-unsafe + ba table nth-unsafe + ab table nth-unsafe + bb table nth-unsafe + aa 1 fixnum+fast table nth-unsafe + ba 1 fixnum+fast table nth-unsafe + ab 1 fixnum+fast table nth-unsafe + bb 1 fixnum+fast table nth-unsafe ; inline -:: 2tetra@ ( p q r s t u v w quot -- ) - p q quot call - r s quot call - t u quot call - v w quot call - ; inline +HINTS: hashes { byte-array fixnum fixnum fixnum } ; : >byte-map ( floats -- bytes ) [ 255.0 * >fixnum ] B{ } map-as ; @@ -63,26 +62,33 @@ IN: noise : >image ( bytes dim -- image ) swap [ L f ] dip image boa ; -PRIVATE> - -:: perlin-noise ( table point -- value ) +:: perlin-noise-unsafe ( table point -- value ) point unit-cube :> cube point dup vfloor v- :> gradients gradients fade :> faded - table cube hashes { - [ gradients grad ] - [ gradients { -1.0 0.0 0.0 } v+ grad ] - [ gradients { 0.0 -1.0 0.0 } v+ grad ] - [ gradients { -1.0 -1.0 0.0 } v+ grad ] - [ gradients { 0.0 0.0 -1.0 } v+ grad ] - [ gradients { -1.0 0.0 -1.0 } v+ grad ] - [ gradients { 0.0 -1.0 -1.0 } v+ grad ] - [ gradients { -1.0 -1.0 -1.0 } v+ grad ] + table cube first3 hashes { + [ gradients first3 grad ] + [ gradients first3 [ 1.0 - ] [ ] [ ] tri* grad ] + [ gradients first3 [ ] [ 1.0 - ] [ ] tri* grad ] + [ gradients first3 [ 1.0 - ] [ 1.0 - ] [ ] tri* grad ] + [ gradients first3 [ ] [ ] [ 1.0 - ] tri* grad ] + [ gradients first3 [ 1.0 - ] [ ] [ 1.0 - ] tri* grad ] + [ gradients first3 [ ] [ 1.0 - ] [ 1.0 - ] tri* grad ] + [ gradients first3 [ 1.0 - ] [ 1.0 - ] [ 1.0 - ] tri* grad ] } spread - [ faded first lerp ] 2tetra@ - [ faded second lerp ] 2bi@ - faded third lerp ; + faded trilerp ; + +ERROR: invalid-perlin-noise-table table ; + +: validate-table ( table -- table ) + dup { [ byte-array? ] [ length 512 >= ] } 1&& + [ invalid-perlin-noise-table ] unless ; + +PRIVATE> + +: perlin-noise ( table point -- value ) + [ validate-table ] dip perlin-noise-unsafe ; inline : normalize-0-1 ( sequence -- sequence' ) [ supremum ] [ infimum [ - ] keep ] [ ] tri @@ -92,7 +98,8 @@ PRIVATE> [ 0.0 max 1.0 min ] map ; : perlin-noise-map ( table transform dim -- map ) - [ iota ] map [ a.v 0.0 suffix perlin-noise ] with with product-map ; + [ validate-table ] 2dip + [ iota ] map [ a.v 0.0 suffix perlin-noise-unsafe ] with with product-map ; : perlin-noise-byte-map ( table transform dim -- map ) perlin-noise-map normalize-0-1 >byte-map ; From 24c0e447f8f8c7016c9a66ab6f3e49ffa2a0c07a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 12:18:59 -0500 Subject: [PATCH 181/210] working on sha2 --- basis/checksums/common/common.factor | 2 +- basis/checksums/sha2/sha2-tests.factor | 4 +- basis/checksums/sha2/sha2.factor | 90 +++++++++++++++----------- 3 files changed, 56 insertions(+), 40 deletions(-) diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor index 01cc2cb739..76675f9413 100644 --- a/basis/checksums/common/common.factor +++ b/basis/checksums/common/common.factor @@ -10,7 +10,7 @@ SYMBOL: bytes-read [ 56 < 55 119 ? ] keep - ; : calculate-pad-length-long ( length -- length' ) - [ 112 < 111 249 ? ] keep - ; + [ 120 < 119 247 ? ] keep - ; : pad-last-block ( str big-endian? length -- str ) [ diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor index f224d497a6..c14ea5a98d 100644 --- a/basis/checksums/sha2/sha2-tests.factor +++ b/basis/checksums/sha2/sha2-tests.factor @@ -38,5 +38,5 @@ IN: checksums.sha2.tests -[ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ] -[ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test +! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ] +! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 1abed088a3..12e32f6c69 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -8,13 +8,9 @@ IN: checksums.sha2 SINGLETON: sha-224 SINGLETON: sha-256 -SINGLETON: sha-384 -SINGLETON: sha-512 INSTANCE: sha-224 checksum INSTANCE: sha-256 checksum -INSTANCE: sha-384 checksum -INSTANCE: sha-512 checksum TUPLE: sha2-state K H word-size block-size ; @@ -26,10 +22,6 @@ TUPLE: sha-224-state < sha2-short ; TUPLE: sha-256-state < sha2-short ; -TUPLE: sha-384-state < sha2-long ; - -TUPLE: sha-512-state < sha2-long ; - % ] - [ 3 shift 16 >be % ] bi + [ 3 shift 8 >be % ] bi ] "" make append ; : seq>byte-array ( seq n -- string ) '[ _ >be ] map B{ } join ; -:: T1 ( n M H sha2 -- T1 ) +:: T1-256 ( n M H sha2 -- T1 ) n M nth n sha2 K>> nth + e H slice3 ch w+ e H nth S1-256 w+ h H nth w+ ; inline -: T2 ( H -- T2 ) +: T2-256 ( H -- T2 ) [ a swap nth S0-256 ] [ a swap slice3 maj w+ ] bi ; inline +:: T1-512 ( n M H sha2 -- T1 ) + n M nth + n sha2 K>> nth + + e H slice3 ch w+ + e H nth S1-512 w+ + h H nth w+ ; inline + +: T2-512 ( H -- T2 ) + [ a swap nth S0-512 ] + [ a swap slice3 maj w+ ] bi ; inline + : update-H ( T1 T2 H -- ) h g pick exchange g f pick exchange @@ -222,8 +262,8 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string ) :: process-chunk ( M block-size cloned-H sha2 -- ) block-size [ - M cloned-H sha2 T1 - cloned-H T2 + M cloned-H sha2 T1-256 + cloned-H T2-256 cloned-H update-H ] each cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline @@ -253,20 +293,6 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string ) 4 >>word-size 64 >>block-size ; -: ( -- sha2-state ) - sha-384-state new - K-384 >>K - initial-H-384 >>H - 8 >>word-size - 80 >>block-size ; - -: ( -- sha2-state ) - sha-512-state new - K-512 >>K - initial-H-512 >>H - 8 >>word-size - 80 >>block-size ; - PRIVATE> M: sha-224 checksum-bytes @@ -278,13 +304,3 @@ M: sha-256 checksum-bytes drop [ byte-array>sha2 ] [ H>> 4 seq>byte-array ] bi ; - -M: sha-384 checksum-bytes - drop - [ byte-array>sha2 ] - [ H>> 6 head 8 seq>byte-array ] bi ; - -M: sha-512 checksum-bytes - drop - [ byte-array>sha2 ] - [ H>> 8 seq>byte-array ] bi ; From ae000b6ea3dd709e600a70ae587785365577d7f1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 12:24:19 -0500 Subject: [PATCH 182/210] move math.miller-rabin to math.primes.miller-rabin --- basis/math/{ => primes}/miller-rabin/authors.txt | 0 basis/math/{ => primes}/miller-rabin/miller-rabin-docs.factor | 0 basis/math/{ => primes}/miller-rabin/miller-rabin-tests.factor | 0 basis/math/{ => primes}/miller-rabin/miller-rabin.factor | 0 basis/math/{ => primes}/miller-rabin/summary.txt | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename basis/math/{ => primes}/miller-rabin/authors.txt (100%) rename basis/math/{ => primes}/miller-rabin/miller-rabin-docs.factor (100%) rename basis/math/{ => primes}/miller-rabin/miller-rabin-tests.factor (100%) rename basis/math/{ => primes}/miller-rabin/miller-rabin.factor (100%) rename basis/math/{ => primes}/miller-rabin/summary.txt (100%) diff --git a/basis/math/miller-rabin/authors.txt b/basis/math/primes/miller-rabin/authors.txt similarity index 100% rename from basis/math/miller-rabin/authors.txt rename to basis/math/primes/miller-rabin/authors.txt diff --git a/basis/math/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor similarity index 100% rename from basis/math/miller-rabin/miller-rabin-docs.factor rename to basis/math/primes/miller-rabin/miller-rabin-docs.factor diff --git a/basis/math/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor similarity index 100% rename from basis/math/miller-rabin/miller-rabin-tests.factor rename to basis/math/primes/miller-rabin/miller-rabin-tests.factor diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor similarity index 100% rename from basis/math/miller-rabin/miller-rabin.factor rename to basis/math/primes/miller-rabin/miller-rabin.factor diff --git a/basis/math/miller-rabin/summary.txt b/basis/math/primes/miller-rabin/summary.txt similarity index 100% rename from basis/math/miller-rabin/summary.txt rename to basis/math/primes/miller-rabin/summary.txt From 8c839638fc515a04bea4cc3c5cd68c153e3d6a44 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 12:24:43 -0500 Subject: [PATCH 183/210] update usages of miller-rabin --- basis/math/primes/miller-rabin/miller-rabin-docs.factor | 8 ++++---- basis/math/primes/miller-rabin/miller-rabin-tests.factor | 6 +++--- basis/math/primes/miller-rabin/miller-rabin.factor | 2 +- basis/math/primes/primes.factor | 5 +++-- extra/crypto/rsa/rsa.factor | 4 ++-- extra/project-euler/common/common.factor | 2 +- extra/random/blum-blum-shub/blum-blum-shub.factor | 2 +- 7 files changed, 15 insertions(+), 14 deletions(-) diff --git a/basis/math/primes/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor index 4aa318f674..2455dafdd5 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-docs.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel sequences math ; -IN: math.miller-rabin +IN: math.primes.miller-rabin HELP: find-relative-prime { $values @@ -82,8 +82,8 @@ HELP: unique-primes } { $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ; -ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test" -"The " { $vocab-link "math.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl +ARTICLE: "math.primes.miller-rabin" "Miller-Rabin probabilistic primality test" +"The " { $vocab-link "math.primes.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl "The Miller-Rabin probabilistic primality test:" { $subsection miller-rabin } { $subsection miller-rabin* } @@ -97,4 +97,4 @@ ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test" { $subsection next-safe-prime } { $subsection random-safe-prime } ; -ABOUT: "math.miller-rabin" +ABOUT: "math.primes.miller-rabin" diff --git a/basis/math/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor index 9981064ec0..9c635c8f38 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor @@ -1,6 +1,6 @@ -USING: math.miller-rabin tools.test kernel sequences -math.miller-rabin.private math ; -IN: math.miller-rabin.tests +USING: math.primes.miller-rabin tools.test kernel sequences +math.primes.miller-rabin.private math ; +IN: math.primes.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test [ t ] [ 2 miller-rabin ] unit-test diff --git a/basis/math/primes/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor index 991924dfe4..35ee97a897 100755 --- a/basis/math/primes/miller-rabin/miller-rabin.factor +++ b/basis/math/primes/miller-rabin/miller-rabin.factor @@ -3,7 +3,7 @@ USING: combinators kernel locals math math.functions math.ranges random sequences sets combinators.short-circuit math.bitwise math math.order ; -IN: math.miller-rabin +IN: math.primes.miller-rabin : >odd ( n -- int ) 0 set-bit ; foldable diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor index 688fdad713..fa1cd5cb63 100644 --- a/basis/math/primes/primes.factor +++ b/basis/math/primes/primes.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007-2009 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel math math.functions math.miller-rabin -math.order math.primes.erato math.ranges sequences ; +USING: combinators kernel math math.functions +math.primes.miller-rabin math.order math.primes.erato +math.ranges sequences ; IN: math.primes Date: Sun, 10 May 2009 12:59:35 -0500 Subject: [PATCH 184/210] add lucas-lehmer primality test --- basis/math/primes/lucas-lehmer/authors.txt | 1 + .../lucas-lehmer/lucas-lehmer-docs.factor | 25 +++++++++++++++++ .../lucas-lehmer/lucas-lehmer-tests.factor | 13 +++++++++ .../primes/lucas-lehmer/lucas-lehmer.factor | 27 +++++++++++++++++++ 4 files changed, 66 insertions(+) create mode 100644 basis/math/primes/lucas-lehmer/authors.txt create mode 100644 basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor create mode 100644 basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor create mode 100644 basis/math/primes/lucas-lehmer/lucas-lehmer.factor diff --git a/basis/math/primes/lucas-lehmer/authors.txt b/basis/math/primes/lucas-lehmer/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/math/primes/lucas-lehmer/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor b/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor new file mode 100644 index 0000000000..582b59b69a --- /dev/null +++ b/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel ; +IN: math.primes.lucas-lehmer + +HELP: lucas-lehmer +{ $values + { "p" "a prime number" } + { "?" "a boolean" } +} +{ $description "Runs the Lucas-Lehmer test on the prime " { $snippet "p" } " and returns " { $link t } " if " { $snippet "(2 ^ p) - 1" } " is prime." } +{ $examples + { $example "! Test that (2 ^ 61) - 1 is prime:" + "USING: math.primes.lucas-lehmer prettyprint ;" + "61 lucas-lehmer ." + "t" + } +} ; + +ARTICLE: "math.primes.lucas-lehmer" "Lucas-Lehmer Mersenne Primality test" +"The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary tests numbers of the form " { $snippet "(2 ^ p) - 1" } " for primality, where " { $snippet "p" } " is prime." $nl +"Run the Lucas-Lehmer test:" +{ $subsection lucas-lehmer } ; + +ABOUT: "math.primes.lucas-lehmer" diff --git a/basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor b/basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor new file mode 100644 index 0000000000..b114fa8553 --- /dev/null +++ b/basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test math.primes.lucas-lehmer ; +IN: math.primes.lucas-lehmer.tests + +[ t ] [ 2 lucas-lehmer ] unit-test +[ t ] [ 3 lucas-lehmer ] unit-test +[ f ] [ 4 lucas-lehmer ] unit-test +[ t ] [ 5 lucas-lehmer ] unit-test +[ f ] [ 6 lucas-lehmer ] unit-test +[ f ] [ 11 lucas-lehmer ] unit-test +[ t ] [ 13 lucas-lehmer ] unit-test +[ t ] [ 61 lucas-lehmer ] unit-test diff --git a/basis/math/primes/lucas-lehmer/lucas-lehmer.factor b/basis/math/primes/lucas-lehmer/lucas-lehmer.factor new file mode 100644 index 0000000000..a8bf097dbe --- /dev/null +++ b/basis/math/primes/lucas-lehmer/lucas-lehmer.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators fry kernel locals math +math.primes combinators.short-circuit ; +IN: math.primes.lucas-lehmer + +ERROR: invalid-lucas-lehmer-candidate obj ; + + ] } 1&& + [ invalid-lucas-lehmer-candidate ] unless ; + +PRIVATE> + +: lucas-lehmer ( p -- ? ) + lucas-lehmer-guard + { + { [ dup 2 = ] [ drop t ] } + { [ dup prime? ] [ do-lucas-lehmer ] } + [ drop f ] + } cond ; From ec9f2943d9997f4a7682997f2727ab3091601af8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 13:39:08 -0500 Subject: [PATCH 185/210] move random-bits* to random, work on docs --- .../mersenne-twister-tests.factor | 2 +- basis/random/random-docs.factor | 15 +++++++++++++-- basis/random/random-tests.factor | 2 ++ basis/random/random.factor | 5 ++++- 4 files changed, 20 insertions(+), 4 deletions(-) diff --git a/basis/random/mersenne-twister/mersenne-twister-tests.factor b/basis/random/mersenne-twister/mersenne-twister-tests.factor index c35d7488ac..651e43ef5b 100644 --- a/basis/random/mersenne-twister/mersenne-twister-tests.factor +++ b/basis/random/mersenne-twister/mersenne-twister-tests.factor @@ -11,7 +11,7 @@ IN: random.mersenne-twister.tests 100 [ 100 random ] replicate ; : test-rng ( seed quot -- ) - [ ] dip with-random ; inline + [ ] dip with-random ; inline [ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor index c7600a731f..222ecaf935 100755 --- a/basis/random/random-docs.factor +++ b/basis/random/random-docs.factor @@ -40,9 +40,17 @@ HELP: random-bytes } ; HELP: random-bits -{ $values { "n" "an integer" } { "r" "a random integer" } } +{ $values { "numbits" integer } { "r" "a random integer" } } { $description "Outputs an random integer n bits in length." } ; +HELP: random-bits* +{ $values + { "numbits" integer } + { "n" integer } +} +{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ; + + HELP: with-random { $values { "tuple" "a random generator" } { "quot" "a quotation" } } { $description "Calls the quotation with the random generator in a dynamic variable. All random numbers will be generated using this random generator." } ; @@ -93,6 +101,9 @@ $nl "Randomizing a sequence:" { $subsection randomize } "Deleting a random element from a sequence:" -{ $subsection delete-random } ; +{ $subsection delete-random } +"Random numbers with " { $snippet "n" } " bits:" +{ $subsection random-bits } +{ $subsection random-bits* } ; ABOUT: "random" diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index 9607627b3d..2b6ac9b1b8 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -23,3 +23,5 @@ IN: random.tests [ f ] [ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test + +[ 49 ] [ 50 random-bits* log2 ] unit-test diff --git a/basis/random/random.factor b/basis/random/random.factor index 6b02c8a3e8..661e771258 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -45,7 +45,10 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; PRIVATE> -: random-bits ( n -- r ) 2^ random-integer ; +: random-bits ( numbits -- r ) 2^ random-integer ; + +: random-bits* ( numbits -- n ) + 1 - [ random-bits ] keep set-bit ; : random ( seq -- elt ) [ f ] [ From 0920567e798e9e6f908e23844870583804a55a27 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 13:42:41 -0500 Subject: [PATCH 186/210] add next-odd etc to math.bitwise --- basis/math/bitwise/bitwise.factor | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 4fe2340643..ff4806348b 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -111,3 +111,10 @@ PRIVATE> : >signed ( x n -- y ) 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ; +: >odd ( n -- int ) 0 set-bit ; foldable + +: >even ( n -- int ) 0 clear-bit ; foldable + +: next-even ( m -- n ) >even 2 + ; foldable + +: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable From c7601defa9690b0df71edc92ae8e4fea12869710 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 10 May 2009 13:45:58 -0500 Subject: [PATCH 187/210] purple sky --- extra/terrain/shaders/shaders.factor | 34 +++++++++++++++++ extra/terrain/terrain.factor | 57 +++++++++++++++++++--------- 2 files changed, 74 insertions(+), 17 deletions(-) diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor index c341545956..bfb46b8ba1 100644 --- a/extra/terrain/shaders/shaders.factor +++ b/extra/terrain/shaders/shaders.factor @@ -1,6 +1,40 @@ USING: multiline ; IN: terrain.shaders +STRING: sky-vertex-shader + +uniform float sky_theta; +varying vec3 direction; + +void main() +{ + vec4 v = vec4(gl_Vertex.xy, -1.0, 1.0); + gl_Position = v; + float s = sin(sky_theta), c = cos(sky_theta); + direction = mat3(1, 0, 0, 0, c, s, 0, -s, c) + * (gl_ModelViewMatrixInverse * vec4(v.xyz, 0.0)).xyz; +} + +; + +STRING: sky-pixel-shader + +uniform sampler2D sky; +uniform float sky_gradient, sky_theta; + +const vec4 SKY_COLOR_A = vec4(0.25, 0.0, 0.5, 1.0), + SKY_COLOR_B = vec4(0.6, 0.5, 0.75, 1.0); + +varying vec3 direction; + +void main() +{ + float t = texture2D(sky, normalize(direction.xyz).xy * 0.5 + vec2(0.5)).x + sky_gradient; + gl_FragColor = mix(SKY_COLOR_A, SKY_COLOR_B, sin(6.28*t)); +} + +; + STRING: terrain-vertex-shader uniform sampler2D heightmap; diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 590244ca6a..411d34f44c 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -5,20 +5,23 @@ math.vectors opengl opengl.capabilities opengl.gl opengl.shaders opengl.textures opengl.textures.private sequences sequences.product specialized-arrays.float terrain.generation terrain.shaders ui ui.gadgets -ui.gadgets.worlds ui.pixel-formats game-worlds method-chains ; +ui.gadgets.worlds ui.pixel-formats game-worlds method-chains +math.affine-transforms noise ; IN: terrain CONSTANT: FOV $[ 2.0 sqrt 1+ ] -CONSTANT: NEAR-PLANE $[ 1.0 2048.0 / ] -CONSTANT: FAR-PLANE 1.0 +CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ] +CONSTANT: FAR-PLANE 2.0 CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 } -CONSTANT: PLAYER-HEIGHT $[ 3.0 1024.0 / ] +CONSTANT: PLAYER-HEIGHT $[ 1.0 256.0 / ] CONSTANT: GRAVITY $[ 1.0 4096.0 / ] CONSTANT: JUMP $[ 1.0 1024.0 / ] CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ] CONSTANT: MOVEMENT-SPEED $[ 1.0 16384.0 / ] CONSTANT: FRICTION 0.95 -CONSTANT: COMPONENT-SCALE { 0.5 0.01 0.002 0.0 } +CONSTANT: COMPONENT-SCALE { 0.5 0.01 0.0005 0.0 } +CONSTANT: SKY-PERIOD 1200 +CONSTANT: SKY-SPEED 0.0005 CONSTANT: terrain-vertex-size { 512 512 } CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] } @@ -29,6 +32,7 @@ TUPLE: player TUPLE: terrain-world < game-world player + sky-image sky-texture sky-program terrain terrain-segment terrain-texture terrain-program terrain-vertex-buffer ; @@ -41,7 +45,7 @@ M: terrain-world tick-length NEAR-PLANE FAR-PLANE ; : set-modelview-matrix ( gadget -- ) - GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear + GL_DEPTH_BUFFER_BIT glClear GL_MODELVIEW glMatrixMode glLoadIdentity player>> @@ -175,24 +179,33 @@ M: terrain-world tick* [ dup focused?>> [ handle-input ] [ drop ] if ] [ dup player>> tick-player ] bi ; -: set-heightmap-texture-parameters ( texture -- ) +: set-texture-parameters ( texture -- ) GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ; +: sky-gradient ( world -- t ) + game-loop>> tick-number>> SKY-PERIOD mod SKY-PERIOD /f ; +: sky-theta ( world -- theta ) + game-loop>> tick-number>> SKY-SPEED * ; + BEFORE: terrain-world begin-world "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" } require-gl-version-or-extensions GL_DEPTH_TEST glEnable GL_TEXTURE_2D glEnable GL_VERTEX_ARRAY glEnableClientState - 0.5 0.5 0.5 1.0 glClearColor PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } player boa >>player + 0.01 0.01 { 512 512 } perlin-noise-image + [ >>sky-image ] keep + make-texture [ set-texture-parameters ] keep >>sky-texture [ >>terrain ] keep { 0 0 } terrain-segment [ >>terrain-segment ] keep - make-texture [ set-heightmap-texture-parameters ] keep >>terrain-texture + make-texture [ set-texture-parameters ] keep >>terrain-texture + sky-vertex-shader sky-pixel-shader + >>sky-program terrain-vertex-shader terrain-pixel-shader >>terrain-program vertex-array >vertex-buffer >>terrain-vertex-buffer @@ -203,6 +216,8 @@ AFTER: terrain-world end-world [ terrain-vertex-buffer>> delete-gl-buffer ] [ terrain-program>> delete-gl-program ] [ terrain-texture>> delete-texture ] + [ sky-program>> delete-gl-program ] + [ sky-texture>> delete-texture ] } cleave ; M: terrain-world resize-world @@ -212,14 +227,22 @@ M: terrain-world resize-world [ frustum glFrustum ] bi ; M: terrain-world draw-world* - [ set-modelview-matrix ] - [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ] - [ dup terrain-program>> [ - [ "heightmap" glGetUniformLocation 0 glUniform1i ] - [ "component_scale" glGetUniformLocation COMPONENT-SCALE first4 glUniform4f ] bi - terrain-vertex-buffer>> draw-vertex-buffer - ] with-gl-program ] - tri gl-error ; + { + [ set-modelview-matrix ] + [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ] + [ sky-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ] + [ GL_DEPTH_TEST glDisable dup sky-program>> [ + [ nip "sky" glGetUniformLocation 1 glUniform1i ] + [ "sky_gradient" glGetUniformLocation swap sky-gradient glUniform1f ] + [ "sky_theta" glGetUniformLocation swap sky-theta glUniform1f ] 2tri + { -1.0 -1.0 } { 2.0 2.0 } gl-fill-rect + ] with-gl-program ] + [ GL_DEPTH_TEST glEnable dup terrain-program>> [ + [ "heightmap" glGetUniformLocation 0 glUniform1i ] + [ "component_scale" glGetUniformLocation COMPONENT-SCALE first4 glUniform4f ] bi + terrain-vertex-buffer>> draw-vertex-buffer + ] with-gl-program ] + } cleave gl-error ; M: terrain-world pref-dim* drop { 640 480 } ; From c723f8ef6dd650a035c26e02a4f3a4674ba299c7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 13:47:51 -0500 Subject: [PATCH 188/210] more docs for math.primes, move words out of miller-rabin --- .../miller-rabin/miller-rabin-docs.factor | 74 +---------------- .../miller-rabin/miller-rabin-tests.factor | 5 +- .../primes/miller-rabin/miller-rabin.factor | 83 +------------------ basis/math/primes/primes-docs.factor | 50 ++++++++++- basis/math/primes/primes-tests.factor | 13 ++- basis/math/primes/primes.factor | 43 +++++++++- 6 files changed, 105 insertions(+), 163 deletions(-) diff --git a/basis/math/primes/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor index 2455dafdd5..2d19d51e06 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-docs.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-docs.factor @@ -3,20 +3,6 @@ USING: help.markup help.syntax kernel sequences math ; IN: math.primes.miller-rabin -HELP: find-relative-prime -{ $values - { "n" integer } - { "p" integer } -} -{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ; - -HELP: find-relative-prime* -{ $values - { "n" integer } { "guess" integer } - { "p" integer } -} -{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ; - HELP: miller-rabin { $values { "n" integer } @@ -33,68 +19,10 @@ HELP: miller-rabin* } { $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ; -HELP: next-prime -{ $values - { "n" integer } - { "p" integer } -} -{ $description "Tests consecutive numbers for primality with " { $link miller-rabin } " and returns the next prime." } ; - -HELP: next-safe-prime -{ $values - { "n" integer } - { "q" integer } -} -{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ; - -HELP: random-bits* -{ $values - { "numbits" integer } - { "n" integer } -} -{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ; - -HELP: random-prime -{ $values - { "numbits" integer } - { "p" integer } -} -{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; - -HELP: random-safe-prime -{ $values - { "numbits" integer } - { "p" integer } -} -{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; - -HELP: safe-prime? -{ $values - { "q" integer } - { "?" "a boolean" } -} -{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ; - -HELP: unique-primes -{ $values - { "numbits" integer } { "n" integer } - { "seq" sequence } -} -{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ; - ARTICLE: "math.primes.miller-rabin" "Miller-Rabin probabilistic primality test" "The " { $vocab-link "math.primes.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl "The Miller-Rabin probabilistic primality test:" { $subsection miller-rabin } -{ $subsection miller-rabin* } -"Generating relative prime numbers:" -{ $subsection find-relative-prime } -{ $subsection find-relative-prime* } -"Generating prime numbers:" -{ $subsection next-prime } -{ $subsection random-prime } -"Generating safe prime numbers:" -{ $subsection next-safe-prime } -{ $subsection random-safe-prime } ; +{ $subsection miller-rabin* } ; ABOUT: "math.primes.miller-rabin" diff --git a/basis/math/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor index 9c635c8f38..aeae6cac1b 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor @@ -1,5 +1,6 @@ -USING: math.primes.miller-rabin tools.test kernel sequences -math.primes.miller-rabin.private math ; +USING: kernel math math.primes math.primes.miller-rabin +math.primes.miller-rabin.private math.primes.safe +math.primes.safe.private random sequences tools.test ; IN: math.primes.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test diff --git a/basis/math/primes/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor index 35ee97a897..b0dfc4ed35 100755 --- a/basis/math/primes/miller-rabin/miller-rabin.factor +++ b/basis/math/primes/miller-rabin/miller-rabin.factor @@ -1,18 +1,9 @@ ! Copyright (c) 2008-2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel locals math math.functions math.ranges -random sequences sets combinators.short-circuit math.bitwise -math math.order ; +USING: combinators combinators.short-circuit kernel locals math +math.functions math.ranges random sequences sets ; IN: math.primes.miller-rabin -: >odd ( n -- int ) 0 set-bit ; foldable - -: >even ( n -- int ) 0 clear-bit ; foldable - -: next-even ( m -- n ) >even 2 + ; - -: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; - } cond ; : miller-rabin ( n -- ? ) 10 miller-rabin* ; - -ERROR: prime-range-error n ; - -: next-prime ( n -- p ) - dup 1 < [ prime-range-error ] when - dup 1 = [ - drop 2 - ] [ - next-odd dup miller-rabin [ next-prime ] unless - ] if ; - -: random-bits* ( numbits -- n ) - 1 - [ random-bits ] keep set-bit ; - -: random-prime ( numbits -- p ) - random-bits* next-prime ; - -ERROR: no-relative-prime n ; - - [ 2 + (find-relative-prime) ] [ nip ] if ; - -PRIVATE> - -: find-relative-prime* ( n guess -- p ) - #! find a prime relative to n with initial guess - >odd (find-relative-prime) ; - -: find-relative-prime ( n -- p ) - dup random find-relative-prime* ; - -ERROR: too-few-primes ; - -: unique-primes ( numbits n -- seq ) - #! generate two primes - swap - dup 5 < [ too-few-primes ] when - 2dup [ random-prime ] curry replicate - dup all-unique? [ 2nip ] [ drop unique-primes ] if ; - -! Safe primes are of the form p = 2q + 1, p,q are prime -! See http://en.wikipedia.org/wiki/Safe_prime - - - -: safe-prime? ( q -- ? ) - { - [ 1 - 2 / dup integer? [ miller-rabin ] [ drop f ] if ] - [ miller-rabin ] - } 1&& ; - -: next-safe-prime ( n -- q ) - next-safe-prime-candidate - dup safe-prime? [ next-safe-prime ] unless ; - -: random-safe-prime ( numbits -- p ) - random-bits* next-safe-prime ; diff --git a/basis/math/primes/primes-docs.factor b/basis/math/primes/primes-docs.factor index c7dbc950e8..fa991e800f 100644 --- a/basis/math/primes/primes-docs.factor +++ b/basis/math/primes/primes-docs.factor @@ -1,10 +1,10 @@ -USING: help.markup help.syntax ; +USING: help.markup help.syntax math sequences ; IN: math.primes { next-prime prime? } related-words HELP: next-prime -{ $values { "n" "an integer not smaller than 2" } { "p" "a prime number" } } +{ $values { "n" integer } { "p" "a prime number" } } { $description "Return the next prime number greater than " { $snippet "n" } "." } ; HELP: prime? @@ -20,3 +20,49 @@ HELP: primes-upto HELP: primes-between { $values { "low" "an integer" } { "high" "an integer" } { "seq" "a sequence" } } { $description "Return a sequence containing all the prime numbers between " { $snippet "low" } " and " { $snippet "high" } "." } ; + +HELP: find-relative-prime +{ $values + { "n" integer } + { "p" integer } +} +{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ; + +HELP: find-relative-prime* +{ $values + { "n" integer } { "guess" integer } + { "p" integer } +} +{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ; + +HELP: random-prime +{ $values + { "numbits" integer } + { "p" integer } +} +{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; + +HELP: unique-primes +{ $values + { "numbits" integer } { "n" integer } + { "seq" sequence } +} +{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ; + + +ARTICLE: "math.primes" "Prime numbers" +"The " { $vocab-link "math.primes" } " vocabulary implements words related to prime numbers." $nl +"Testing if a number is prime:" +{ $subsection prime? } +"Generating prime numbers:" +{ $subsection next-prime } +{ $subsection primes-upto } +{ $subsection primes-between } +{ $subsection random-prime } +"Generating relative prime numbers:" +{ $subsection find-relative-prime } +{ $subsection find-relative-prime* } +"Make a sequence of random prime numbers:" +{ $subsection unique-primes } ; + +ABOUT: "math.primes" diff --git a/basis/math/primes/primes-tests.factor b/basis/math/primes/primes-tests.factor index db738399ef..6580f0780e 100644 --- a/basis/math/primes/primes-tests.factor +++ b/basis/math/primes/primes-tests.factor @@ -1,4 +1,6 @@ -USING: arrays math.primes tools.test ; +USING: arrays math math.primes math.primes.miller-rabin +tools.test ; +IN: math.primes.tests { 1237 } [ 1234 next-prime ] unit-test { f t } [ 1234 prime? 1237 prime? ] unit-test @@ -7,3 +9,12 @@ USING: arrays math.primes tools.test ; { { 4999963 4999999 5000011 5000077 5000081 } } [ 4999962 5000082 primes-between >array ] unit-test + +[ 2 ] [ 1 next-prime ] unit-test +[ 3 ] [ 2 next-prime ] unit-test +[ 5 ] [ 3 next-prime ] unit-test +[ 101 ] [ 100 next-prime ] unit-test +[ t ] [ 2135623355842621559 miller-rabin ] unit-test +[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test + +[ 49 ] [ 50 random-prime log2 ] unit-test diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor index fa1cd5cb63..e3985fc600 100644 --- a/basis/math/primes/primes.factor +++ b/basis/math/primes/primes.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007-2009 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel math math.functions -math.primes.miller-rabin math.order math.primes.erato -math.ranges sequences ; +USING: combinators kernel math math.bitwise math.functions +math.order math.primes.erato math.primes.miller-rabin +math.ranges random sequences sets fry ; IN: math.primes } cond ; foldable : next-prime ( n -- p ) - next-odd [ dup really-prime? ] [ 2 + ] until ; foldable + dup 2 < [ + drop 2 + ] [ + next-odd [ dup really-prime? ] [ 2 + ] until + ] if ; foldable : primes-between ( low high -- seq ) [ dup 3 max dup even? [ 1 + ] when ] dip @@ -32,3 +36,34 @@ PRIVATE> : primes-upto ( n -- seq ) 2 swap primes-between ; : coprime? ( a b -- ? ) gcd nip 1 = ; foldable + +: random-prime ( numbits -- p ) + random-bits* next-prime ; + +: estimated-primes ( m -- n ) + dup log / ; foldable + +ERROR: no-relative-prime n ; + + [ 2 + (find-relative-prime) ] [ nip ] if ; + +PRIVATE> + +: find-relative-prime* ( n guess -- p ) + #! find a prime relative to n with initial guess + >odd (find-relative-prime) ; + +: find-relative-prime ( n -- p ) + dup random find-relative-prime* ; + +ERROR: too-few-primes n numbits ; + +: unique-primes ( n numbits -- seq ) + 2dup 2^ estimated-primes > [ too-few-primes ] when + 2dup '[ _ random-prime ] replicate + dup all-unique? [ 2nip ] [ drop unique-primes ] if ; From 96c9152189b25b01568695968a352d8d48e61e5f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 13:48:09 -0500 Subject: [PATCH 189/210] update using --- extra/project-euler/046/046.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/project-euler/046/046.factor b/extra/project-euler/046/046.factor index e4b8dcc955..0aa9eafe58 100755 --- a/extra/project-euler/046/046.factor +++ b/extra/project-euler/046/046.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.primes math.ranges sequences project-euler.common ; +USING: kernel math math.functions math.primes math.ranges +sequences project-euler.common math.bitwise ; IN: project-euler.046 ! http://projecteuler.net/index.php?section=problems&id=46 From 861765ed523f4cbfdf6a72af657eebd2fe513bc7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 13:49:40 -0500 Subject: [PATCH 190/210] make a new vocabulary for safe primes --- basis/math/primes/safe/authors.txt | 1 + basis/math/primes/safe/safe-docs.factor | 38 ++++++++++++++++++++++++ basis/math/primes/safe/safe-tests.factor | 14 +++++++++ basis/math/primes/safe/safe.factor | 29 ++++++++++++++++++ 4 files changed, 82 insertions(+) create mode 100644 basis/math/primes/safe/authors.txt create mode 100644 basis/math/primes/safe/safe-docs.factor create mode 100644 basis/math/primes/safe/safe-tests.factor create mode 100644 basis/math/primes/safe/safe.factor diff --git a/basis/math/primes/safe/authors.txt b/basis/math/primes/safe/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/math/primes/safe/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/math/primes/safe/safe-docs.factor b/basis/math/primes/safe/safe-docs.factor new file mode 100644 index 0000000000..861fc4e4ed --- /dev/null +++ b/basis/math/primes/safe/safe-docs.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.short-circuit help.markup help.syntax kernel +math math.functions math.primes random ; +IN: math.primes.safe + +HELP: next-safe-prime +{ $values + { "n" integer } + { "q" integer } +} +{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ; + +HELP: random-safe-prime +{ $values + { "numbits" integer } + { "p" integer } +} +{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; + +HELP: safe-prime? +{ $values + { "q" integer } + { "?" "a boolean" } +} +{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ; + + +ARTICLE: "math.primes.safe" "Safe prime numbers" +"The " { $vocab-link "math.primes.safe" } " vocabulary implements words to calculate safe prime numbers. Safe primes are of the form p = 2q + 1, where p,q are prime. Safe primes have desirable qualities for cryptographic applications." $nl + +"Testing if a number is a safe prime:" +{ $subsection safe-prime? } +"Generating safe prime numbers:" +{ $subsection next-safe-prime } +{ $subsection random-safe-prime } ; + +ABOUT: "math.primes.safe" diff --git a/basis/math/primes/safe/safe-tests.factor b/basis/math/primes/safe/safe-tests.factor new file mode 100644 index 0000000000..ef9aa9246f --- /dev/null +++ b/basis/math/primes/safe/safe-tests.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: math.primes.safe math.primes.safe.private tools.test ; +IN: math.primes.safe.tests + +[ 863 ] [ 862 next-safe-prime ] unit-test +[ f ] [ 862 safe-prime? ] unit-test +[ t ] [ 7 safe-prime? ] unit-test +[ f ] [ 31 safe-prime? ] unit-test +[ t ] [ 47 safe-prime-candidate? ] unit-test +[ t ] [ 47 safe-prime? ] unit-test +[ t ] [ 863 safe-prime? ] unit-test + +[ 47 ] [ 31 next-safe-prime ] unit-test diff --git a/basis/math/primes/safe/safe.factor b/basis/math/primes/safe/safe.factor new file mode 100644 index 0000000000..a3becb628f --- /dev/null +++ b/basis/math/primes/safe/safe.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.short-circuit kernel math math.functions +math.primes random ; +IN: math.primes.safe + + + +: safe-prime? ( q -- ? ) + { + [ 1 - 2 / dup integer? [ prime? ] [ drop f ] if ] + [ prime? ] + } 1&& ; + +: next-safe-prime ( n -- q ) + next-safe-prime-candidate + dup safe-prime? [ next-safe-prime ] unless ; + +: random-safe-prime ( numbits -- p ) + random-bits* next-safe-prime ; From 0659fa413f5207fffe640bffdda3da81e0902ad6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 14:01:21 -0500 Subject: [PATCH 191/210] link to prime tests from prime docs --- basis/math/primes/factors/factors.factor | 3 ++- basis/math/primes/primes-docs.factor | 3 +-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor index 278bf70b3d..f5fa468687 100644 --- a/basis/math/primes/factors/factors.factor +++ b/basis/math/primes/factors/factors.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007-2009 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators kernel make math math.functions math.primes sequences ; +USING: arrays combinators kernel make math math.functions +math.primes sequences ; IN: math.primes.factors Date: Sun, 10 May 2009 14:08:03 -0500 Subject: [PATCH 192/210] dont load safe primes in miller rabin tests --- .../miller-rabin/miller-rabin-tests.factor | 21 +------------------ 1 file changed, 1 insertion(+), 20 deletions(-) diff --git a/basis/math/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor index aeae6cac1b..d201abfef8 100644 --- a/basis/math/primes/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor @@ -1,6 +1,4 @@ -USING: kernel math math.primes math.primes.miller-rabin -math.primes.miller-rabin.private math.primes.safe -math.primes.safe.private random sequences tools.test ; +USING: kernel math.primes.miller-rabin sequences tools.test ; IN: math.primes.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test @@ -8,23 +6,6 @@ IN: math.primes.miller-rabin.tests [ t ] [ 3 miller-rabin ] unit-test [ f ] [ 36 miller-rabin ] unit-test [ t ] [ 37 miller-rabin ] unit-test -[ 2 ] [ 1 next-prime ] unit-test -[ 3 ] [ 2 next-prime ] unit-test -[ 5 ] [ 3 next-prime ] unit-test -[ 101 ] [ 100 next-prime ] unit-test [ t ] [ 2135623355842621559 miller-rabin ] unit-test -[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test - -[ 863 ] [ 862 next-safe-prime ] unit-test -[ f ] [ 862 safe-prime? ] unit-test -[ t ] [ 7 safe-prime? ] unit-test -[ f ] [ 31 safe-prime? ] unit-test -[ t ] [ 47 safe-prime-candidate? ] unit-test -[ t ] [ 47 safe-prime? ] unit-test -[ t ] [ 863 safe-prime? ] unit-test [ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test - -[ 47 ] [ 31 next-safe-prime ] unit-test -[ 49 ] [ 50 random-prime log2 ] unit-test -[ 49 ] [ 50 random-bits* log2 ] unit-test From eeafebbd450265c4be14d0dc8a18586b6982ed32 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 16:33:43 -0500 Subject: [PATCH 193/210] fix using --- extra/crypto/rsa/rsa.factor | 4 ++-- extra/random/blum-blum-shub/blum-blum-shub.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor index 1da170d197..50ea84fd39 100644 --- a/extra/crypto/rsa/rsa.factor +++ b/extra/crypto/rsa/rsa.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: math.primes.miller-rabin kernel math math.functions -namespaces sequences accessors ; +USING: math.primes kernel math math.functions namespaces +sequences accessors ; IN: crypto.rsa ! The private key is the only secret. diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor index 4a52a2f79c..8229abca69 100755 --- a/extra/random/blum-blum-shub/blum-blum-shub.factor +++ b/extra/random/blum-blum-shub/blum-blum-shub.factor @@ -1,5 +1,5 @@ -USING: kernel math sequences namespaces -math.primes.miller-rabin math.functions accessors random ; +USING: kernel math sequences namespaces math.primes +math.functions accessors random ; IN: random.blum-blum-shub ! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n From 2887b62cc13e31efce010523dcb782814a5878a0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 May 2009 16:39:17 -0500 Subject: [PATCH 194/210] Removing slip 2slip 3slip nslip --- basis/fry/fry-docs.factor | 1 - .../generalizations-docs.factor | 17 ----------- .../generalizations-tests.factor | 2 -- basis/generalizations/generalizations.factor | 3 -- core/combinators/combinators-docs.factor | 11 ++------ core/kernel/kernel-docs.factor | 12 -------- core/kernel/kernel.factor | 28 ++++--------------- core/quotations/quotations.factor | 2 +- extra/reports/noise/noise.factor | 1 - 9 files changed, 8 insertions(+), 69 deletions(-) diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor index 5d750775e5..32ad856d00 100644 --- a/basis/fry/fry-docs.factor +++ b/basis/fry/fry-docs.factor @@ -57,7 +57,6 @@ $nl "Here are some built-in combinators rewritten in terms of fried quotations:" { $table { { $link literalize } { $snippet ": literalize '[ _ ] ;" } } - { { $link slip } { $snippet ": slip '[ @ _ ] call ;" } } { { $link curry } { $snippet ": curry '[ _ @ ] ;" } } { { $link compose } { $snippet ": compose '[ @ @ ] ;" } } { { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } } diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 3671511194..d6a3aa948a 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -161,22 +161,6 @@ HELP: ndip } } ; -HELP: nslip -{ $values { "n" integer } } -{ $description "A generalization of " { $link slip } " that can work " -"for any stack depth. The first " { $snippet "n" } " items after the quotation will be " -"removed from the stack, the quotation called, and the items restored." -} -{ $examples - { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip 6 narray ." "{ 99 1 2 3 4 5 }" } - "Some core words expressed in terms of " { $link nslip } ":" - { $table - { { $link slip } { $snippet "1 nslip" } } - { { $link 2slip } { $snippet "2 nslip" } } - { { $link 3slip } { $snippet "3 nslip" } } - } -} ; - HELP: nkeep { $values { "quot" quotation } { "n" integer } } { $description "A generalization of " { $link keep } " that can work " @@ -339,7 +323,6 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words" ARTICLE: "combinator-generalizations" "Generalized combinators" { $subsection ndip } -{ $subsection nslip } { $subsection nkeep } { $subsection napply } { $subsection ncleave } diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 7ede271d01..d0f614f9cd 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -26,8 +26,6 @@ IN: generalizations.tests [ [ 1 ] 5 ndip ] must-infer [ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test -[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer -{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 139b7a528a..397166a418 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -60,9 +60,6 @@ MACRO: ntuck ( n -- ) MACRO: ndip ( quot n -- ) [ '[ _ dip ] ] times ; -MACRO: nslip ( n -- ) - '[ [ call ] _ ndip ] ; - MACRO: nkeep ( quot n -- ) tuck '[ _ ndup _ _ ndip ] ; diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 8b301affbd..1a17e8c1fb 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -62,9 +62,6 @@ $nl ": dip [ ] bi* ;" ": 2dip [ ] [ ] tri* ;" "" - ": slip [ call ] [ ] bi* ;" - ": 2slip [ call ] [ ] [ ] tri* ;" - "" ": nip [ drop ] [ ] bi* ;" ": 2nip [ drop ] [ drop ] [ ] tri* ;" "" @@ -121,7 +118,7 @@ $nl { $subsection both? } { $subsection either? } ; -ARTICLE: "slip-keep-combinators" "Retain stack combinators" +ARTICLE: "retainstack-combinators" "Retain stack combinators" "Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators." $nl "The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:" @@ -129,10 +126,6 @@ $nl { $subsection 2dip } { $subsection 3dip } { $subsection 4dip } -"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:" -{ $subsection slip } -{ $subsection 2slip } -{ $subsection 3slip } "The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:" { $subsection keep } { $subsection 2keep } @@ -259,7 +252,7 @@ ARTICLE: "conditionals" "Conditional combinators" ARTICLE: "dataflow-combinators" "Data flow combinators" "Data flow combinators pass values between quotations:" -{ $subsection "slip-keep-combinators" } +{ $subsection "retainstack-combinators" } { $subsection "cleave-combinators" } { $subsection "spread-combinators" } { $subsection "apply-combinators" } diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index e67e2bc0dd..22e0e76451 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -212,18 +212,6 @@ HELP: call-clear ( quot -- ) { $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." } { $notes "Used to implement " { $link "threads" } "." } ; -HELP: slip -{ $values { "quot" quotation } { "x" object } } -{ $description "Calls a quotation while hiding the top of the stack." } ; - -HELP: 2slip -{ $values { "quot" quotation } { "x" object } { "y" object } } -{ $description "Calls a quotation while hiding the top two stack elements." } ; - -HELP: 3slip -{ $values { "quot" quotation } { "x" object } { "y" object } { "z" object } } -{ $description "Calls a quotation while hiding the top three stack elements." } ; - HELP: keep { $values { "quot" { $quotation "( x -- ... )" } } { "x" object } } { $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." } diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 6245080225..d6350e0420 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -58,37 +58,19 @@ DEFER: if : ?if ( default cond true false -- ) pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline -! Slippers and dippers. +! 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 - #! a literal quotation. - [ call ] dip ; +: dip ( x quot -- x ) swap [ call ] dip ; -: 2slip ( quot x y -- x y ) - #! '2slip' and '2dip' can be defined in terms of each other - #! because the JIT special-cases a '2dip' preceeded by - #! a literal quotation. - [ call ] 2dip ; +: 2dip ( x y quot -- x y ) -rot [ call ] 2dip ; -: 3slip ( quot x y z -- x y z ) - #! '3slip' and '3dip' can be defined in terms of each other - #! because the JIT special-cases a '3dip' preceeded by - #! a literal quotation. - [ call ] 3dip ; - -: dip ( x quot -- x ) swap slip ; - -: 2dip ( x y quot -- x y ) -rot 2slip ; - -: 3dip ( x y z quot -- x y z ) -roll 3slip ; +: 3dip ( x y z quot -- x y z ) -roll [ call ] 3dip ; : 4dip ( w x y z quot -- w x y z ) swap [ 3dip ] dip ; inline ! Keepers -: keep ( x quot -- x ) over slip ; inline +: keep ( x quot -- x ) over [ call ] dip ; inline : 2keep ( x y quot -- x y ) [ 2dup ] dip 2dip ; inline diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 3245ac1e20..af3c110d61 100644 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -19,7 +19,7 @@ M: quotation call (call) ; M: curry call uncurry call ; -M: compose call uncompose slip call ; +M: compose call uncompose [ call ] dip call ; M: wrapper equal? over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ; diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 89e00f88c5..51196279ff 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -52,7 +52,6 @@ IN: reports.noise { nkeep 5 } { npick 6 } { nrot 5 } - { nslip 5 } { ntuck 6 } { nwith 4 } { over 2 } From cd648333608bac26e3ad670f1b87daf9522ab4e7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 May 2009 16:39:51 -0500 Subject: [PATCH 195/210] clean up contents and lines words; contents never outputs f now --- basis/io/launcher/unix/unix-tests.factor | 2 +- basis/io/streams/string/string-tests.factor | 2 ++ core/io/io-docs.factor | 8 ++--- core/io/io.factor | 36 ++++++++++++------- .../byte-array/byte-array-tests.factor | 1 + core/sequences/sequences-docs.factor | 8 ++++- core/sequences/sequences.factor | 27 +++++++------- 7 files changed, 54 insertions(+), 30 deletions(-) diff --git a/basis/io/launcher/unix/unix-tests.factor b/basis/io/launcher/unix/unix-tests.factor index 99d45e4fd7..852d8171e4 100644 --- a/basis/io/launcher/unix/unix-tests.factor +++ b/basis/io/launcher/unix/unix-tests.factor @@ -48,7 +48,7 @@ concurrency.promises threads unix.process ; try-process ] unit-test -[ f ] [ +[ "" ] [ "cat" "launcher-test-1" temp-file 2array diff --git a/basis/io/streams/string/string-tests.factor b/basis/io/streams/string/string-tests.factor index 967c0d4613..27971f1431 100644 --- a/basis/io/streams/string/string-tests.factor +++ b/basis/io/streams/string/string-tests.factor @@ -2,6 +2,8 @@ USING: io.streams.string io kernel arrays namespaces make tools.test ; IN: io.streams.string.tests +[ "" ] [ "" [ contents ] with-string-reader ] unit-test + [ "line 1" CHAR: l ] [ "line 1\nline 2\nline 3" diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 97b143e989..ac74e6b11e 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -239,13 +239,13 @@ HELP: each-block { $description "Calls the quotation with successive blocks of data, until the current " { $link input-stream } " is exhausted." } ; HELP: stream-contents -{ $values { "stream" "an input stream" } { "seq" "a string, byte array or " { $link f } } } -{ $description "Reads the entire contents of a stream. If the stream is empty, outputs " { $link f } "." } +{ $values { "stream" "an input stream" } { "seq" { $or string byte-array } } } +{ $description "Reads all elements in the given stream until the stream is exhausted. The type of the sequence depends on the stream's element type." } $io-error ; HELP: contents -{ $values { "seq" "a string, byte array or " { $link f } } } -{ $description "Reads the entire contents of a the stream stored in " { $link input-stream } ". If the stream is empty, outputs " { $link f } "." } +{ $values { "seq" { $or string byte-array } } } +{ $description "Reads all elements in the " { $link input-stream } " until the stream is exhausted. The type of the sequence depends on the stream's element type." } $io-error ; ARTICLE: "stream-protocol" "Stream protocol" diff --git a/core/io/io.factor b/core/io/io.factor index b43098bcd4..669f104a5f 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: hashtables generic kernel math namespaces make sequences -continuations destructors assocs ; +continuations destructors assocs combinators ; IN: io SYMBOLS: +byte+ +character+ ; @@ -20,7 +20,9 @@ GENERIC: stream-flush ( stream -- ) GENERIC: stream-nl ( stream -- ) ERROR: bad-seek-type type ; + SINGLETONS: seek-absolute seek-relative seek-end ; + GENERIC: stream-seek ( n seek-type stream -- ) : stream-print ( str stream -- ) [ stream-write ] keep stream-nl ; @@ -68,29 +70,39 @@ SYMBOL: error-stream : bl ( -- ) " " write ; -: stream-lines ( stream -- seq ) - [ [ readln dup ] [ ] produce nip ] with-input-stream ; - -: lines ( -- seq ) - input-stream get stream-lines ; - : each-line ( quot -- ) [ readln ] each-morsel ; inline -: stream-contents ( stream -- seq ) - [ - [ 65536 read-partial dup ] [ ] produce nip concat f like - ] with-input-stream ; +: lines ( -- seq ) + [ ] accumulator [ each-line ] dip { } like ; + +: stream-lines ( stream -- seq ) + [ lines ] with-input-stream ; : contents ( -- seq ) - input-stream get stream-contents ; + [ 65536 read-partial dup ] [ ] produce nip + element-exemplar concat-as ; + +: stream-contents ( stream -- seq ) + [ contents ] with-input-stream ; : each-block ( quot: ( block -- ) -- ) [ 8192 read-partial ] each-morsel ; inline diff --git a/core/io/streams/byte-array/byte-array-tests.factor b/core/io/streams/byte-array/byte-array-tests.factor index 0cd35dfa21..43a8373232 100644 --- a/core/io/streams/byte-array/byte-array-tests.factor +++ b/core/io/streams/byte-array/byte-array-tests.factor @@ -1,6 +1,7 @@ USING: tools.test io.streams.byte-array io.encodings.binary io.encodings.utf8 io kernel arrays strings namespaces ; +[ B{ } ] [ B{ } binary [ contents ] with-byte-reader ] unit-test [ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test [ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index cfd96789b4..b6cfface12 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -533,12 +533,18 @@ HELP: concat { $description "Concatenates a sequence of sequences together into one sequence. If " { $snippet "seq" } " is empty, outputs " { $snippet "{ }" } ", otherwise the resulting sequence is of the same class as the first element of " { $snippet "seq" } "." } { $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as the first element of " { $snippet "seq" } "." } ; +HELP: concat-as +{ $values { "seq" sequence } { "exemplar" sequence } { "newseq" sequence } } +{ $description "Concatenates a sequence of sequences together into one sequence with the same type as " { $snippet "exemplar" } "." } +{ $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as " { $snippet "exemplar" } "." } ; + HELP: join { $values { "seq" sequence } { "glue" sequence } { "newseq" sequence } } { $description "Concatenates a sequence of sequences together into one sequence, placing a copy of " { $snippet "glue" } " between each pair of sequences. The resulting sequence is of the same class as " { $snippet "glue" } "." } +{ $notes "If the " { $snippet "glue" } " sequence is empty, this word calls " { $link concat-as } "." } { $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as " { $snippet "glue" } "." } ; -{ join concat } related-words +{ join concat concat-as } related-words HELP: peek { $values { "seq" sequence } { "elt" object } } diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index d60602fc71..dd48501fa0 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -704,13 +704,14 @@ PRIVATE> : sum-lengths ( seq -- n ) 0 [ length + ] reduce ; +: concat-as ( seq exemplar -- newseq ) + swap [ { } ] [ + [ sum-lengths over new-resizable ] keep + [ over push-all ] each + ] if-empty swap like ; + : concat ( seq -- newseq ) - [ { } ] [ - [ sum-lengths ] keep - [ first new-resizable ] keep - [ [ over push-all ] each ] keep - first like - ] if-empty ; + [ { } ] [ dup first concat-as ] if-empty ; PRIVATE> : join ( seq glue -- newseq ) - [ - 2dup joined-length over new-resizable [ - [ [ push-all ] 2curry ] [ [ nip push-all ] 2curry ] 2bi - interleave - ] keep - ] keep like ; + dup empty? [ concat-as ] [ + [ + 2dup joined-length over new-resizable [ + [ [ push-all ] 2curry ] [ [ nip push-all ] 2curry ] 2bi + interleave + ] keep + ] keep like + ] if ; : padding ( seq n elt quot -- newseq ) [ From 59c7e881da0465c697854b49c215d57363ba06ff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 May 2009 16:40:19 -0500 Subject: [PATCH 196/210] mason: add retries in another place, and add a type declaration --- extra/mason/common/common.factor | 4 ++-- extra/mason/notify/notify.factor | 12 +++++++----- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index d020c68fc4..b7545a3c9e 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -5,12 +5,12 @@ math.functions make io io.files io.pathnames io.directories io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint combinators.short-circuit parser combinators calendar calendar.format arrays mason.config locals system debugger fry -continuations ; +continuations strings ; IN: mason.common SYMBOL: current-git-id -ERROR: output-process-error output process ; +ERROR: output-process-error { output string } { process process } ; M: output-process-error error. [ "Process:" print process>> . nl ] diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor index 96e31c4a45..c75014e1b0 100644 --- a/extra/mason/notify/notify.factor +++ b/extra/mason/notify/notify.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays accessors io io.sockets io.encodings.utf8 io.files io.launcher kernel make mason.config mason.common mason.email -mason.twitter namespaces sequences prettyprint ; +mason.twitter namespaces sequences prettyprint fry ; IN: mason.notify : status-notify ( input-file args -- ) @@ -14,10 +14,12 @@ IN: mason.notify target-cpu get , target-os get , ] { } make prepend - - swap >>command - swap [ +closed+ ] unless* >>stdin - try-output-process + [ 5 ] 2dip '[ + + _ >>command + _ [ +closed+ ] unless* >>stdin + try-output-process + ] retry ] [ 2drop ] if ; : notify-begin-build ( git-id -- ) From 70deacb900ae04d521b3d471d96a1f93335af60b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 May 2009 17:03:41 -0500 Subject: [PATCH 197/210] Fix unit tests and load errors for slip removal --- basis/compiler/tests/curry.factor | 2 +- .../escape-analysis/escape-analysis-tests.factor | 2 +- .../tree/tuple-unboxing/tuple-unboxing-tests.factor | 2 +- basis/stack-checker/stack-checker-tests.factor | 2 +- basis/windows/com/com.factor | 2 +- basis/windows/com/wrapper/wrapper.factor | 2 +- core/kernel/kernel-tests.factor | 12 ++++-------- extra/crypto/timing/authors.txt | 1 - extra/crypto/timing/timing-tests.factor | 4 ---- extra/crypto/timing/timing.factor | 8 -------- extra/reports/noise/noise.factor | 3 --- extra/spider/unique-deque/unique-deque.factor | 4 ++-- 12 files changed, 12 insertions(+), 32 deletions(-) delete mode 100755 extra/crypto/timing/authors.txt delete mode 100644 extra/crypto/timing/timing-tests.factor delete mode 100644 extra/crypto/timing/timing.factor diff --git a/basis/compiler/tests/curry.factor b/basis/compiler/tests/curry.factor index 32611ba87a..b541e19f34 100644 --- a/basis/compiler/tests/curry.factor +++ b/basis/compiler/tests/curry.factor @@ -33,7 +33,7 @@ IN: compiler.tests.curry ] unit-test : foobar ( quot: ( -- ) -- ) - dup slip swap [ foobar ] [ drop ] if ; inline recursive + [ call ] keep swap [ foobar ] [ drop ] if ; inline recursive [ ] [ [ [ f ] foobar ] compile-call ] unit-test diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index 5f89372ebe..3d9d77ae56 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -302,7 +302,7 @@ C: ro-box [ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test : impeach-node ( quot: ( node -- ) -- ) - dup slip impeach-node ; inline recursive + [ call ] keep impeach-node ; inline recursive : bleach-node ( quot: ( node -- ) -- ) [ bleach-node ] curry [ ] compose impeach-node ; inline recursive diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index 70670648b1..0d5f05fab0 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -39,7 +39,7 @@ TUPLE: empty-tuple ; ! A more complicated example : impeach-node ( quot: ( node -- ) -- ) - dup slip impeach-node ; inline recursive + [ call ] keep impeach-node ; inline recursive : bleach-node ( quot: ( node -- ) -- ) [ bleach-node ] curry [ ] compose impeach-node ; inline recursive diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 919cd098f6..201f3ce30b 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -180,7 +180,7 @@ DEFER: blah4 over [ 2drop ] [ - [ swap slip ] keep swap bad-combinator + [ dip ] keep swap bad-combinator ] if ; inline recursive [ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail diff --git a/basis/windows/com/com.factor b/basis/windows/com/com.factor index af828c9145..d485692a91 100644 --- a/basis/windows/com/com.factor +++ b/basis/windows/com/com.factor @@ -40,6 +40,6 @@ COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046} IUnknown::Release drop ; inline : with-com-interface ( interface quot -- ) - over [ slip ] [ com-release ] [ ] cleanup ; inline + over [ com-release ] curry [ ] cleanup ; inline DESTRUCTOR: com-release diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index e78c987cd4..9d52378da9 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -93,7 +93,7 @@ unless : compile-alien-callback ( word return parameters abi quot -- word ) '[ _ _ _ _ alien-callback ] - [ [ (( -- alien )) define-declared ] pick slip ] + [ [ (( -- alien )) define-declared ] pick [ call ] dip ] with-compilation-unit ; : (callback-word) ( function-name interface-name counter -- word ) diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 5a88db4f9e..c8e0fcd2a9 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -61,20 +61,16 @@ IN: kernel.tests [ 2 ] [ f 2 xor ] unit-test [ f ] [ f f xor ] unit-test -[ slip ] must-fail +[ dip ] must-fail [ ] [ :c ] unit-test -[ 1 slip ] must-fail +[ 1 [ call ] dip ] must-fail [ ] [ :c ] unit-test -[ 1 2 slip ] must-fail +[ 1 2 [ call ] dip ] must-fail [ ] [ :c ] unit-test -[ 1 2 3 slip ] must-fail -[ ] [ :c ] unit-test - - -[ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test +[ 5 ] [ 1 [ 2 2 + ] dip + ] unit-test [ [ ] keep ] must-fail diff --git a/extra/crypto/timing/authors.txt b/extra/crypto/timing/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/extra/crypto/timing/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/crypto/timing/timing-tests.factor b/extra/crypto/timing/timing-tests.factor deleted file mode 100644 index 9afb913724..0000000000 --- a/extra/crypto/timing/timing-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -USING: crypto.timing kernel tools.test system math ; -IN: crypto.timing.tests - -[ t ] [ millis [ ] 1000 with-timing millis swap - 1000 >= ] unit-test diff --git a/extra/crypto/timing/timing.factor b/extra/crypto/timing/timing.factor deleted file mode 100644 index b2a59a1851..0000000000 --- a/extra/crypto/timing/timing.factor +++ /dev/null @@ -1,8 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel math threads system calendar ; -IN: crypto.timing - -: with-timing ( quot n -- ) - #! force the quotation to execute in, at minimum, n milliseconds - millis 2slip millis - + milliseconds sleep ; inline diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 51196279ff..f5c2ea9811 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -19,13 +19,11 @@ IN: reports.noise { 2keep 1 } { 2nip 2 } { 2over 4 } - { 2slip 2 } { 2swap 3 } { 3curry 2 } { 3drop 1 } { 3dup 2 } { 3keep 3 } - { 3slip 3 } { 4drop 2 } { 4dup 3 } { compose 1/2 } @@ -58,7 +56,6 @@ IN: reports.noise { pick 4 } { roll 4 } { rot 3 } - { slip 1 } { spin 3 } { swap 1 } { swapd 3 } diff --git a/extra/spider/unique-deque/unique-deque.factor b/extra/spider/unique-deque/unique-deque.factor index b26797f8d5..b4bbc9fbf8 100644 --- a/extra/spider/unique-deque/unique-deque.factor +++ b/extra/spider/unique-deque/unique-deque.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs deques dlists kernel spider ; +USING: accessors assocs deques dlists kernel ; IN: spider.unique-deque TUPLE: todo-url url depth ; @@ -32,6 +32,6 @@ TUPLE: unique-deque assoc deque ; : slurp-deque-when ( deque quot1 quot2: ( value -- ) -- ) pick deque-empty? [ 3drop ] [ - [ [ pop-front dup ] 2dip slip [ t ] compose [ drop f ] if ] + [ [ pop-front dup ] 2dip [ call ] dip [ t ] compose [ drop f ] if ] [ roll [ slurp-deque-when ] [ 3drop ] if ] 3bi ] if ; inline recursive From 028235b9ffc8972bbf74d41eee1ef970ac01d007 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Sun, 10 May 2009 20:06:28 -0300 Subject: [PATCH 198/210] extra.redis: Vocabulary for communicating with the Redis key-value database --- extra/redis/authors.txt | 1 + extra/redis/command-writer/authors.txt | 1 + .../command-writer-tests.factor | 138 ++++++++++++++++++ .../command-writer/command-writer.factor | 104 +++++++++++++ extra/redis/command-writer/summary.txt | 1 + extra/redis/redis.factor | 74 ++++++++++ extra/redis/response-parser/authors.txt | 1 + .../response-parser-tests.factor | 20 +++ .../response-parser/response-parser.factor | 27 ++++ extra/redis/response-parser/summary.txt | 1 + extra/redis/summary.txt | 1 + 11 files changed, 369 insertions(+) create mode 100644 extra/redis/authors.txt create mode 100644 extra/redis/command-writer/authors.txt create mode 100644 extra/redis/command-writer/command-writer-tests.factor create mode 100644 extra/redis/command-writer/command-writer.factor create mode 100644 extra/redis/command-writer/summary.txt create mode 100644 extra/redis/redis.factor create mode 100644 extra/redis/response-parser/authors.txt create mode 100644 extra/redis/response-parser/response-parser-tests.factor create mode 100644 extra/redis/response-parser/response-parser.factor create mode 100644 extra/redis/response-parser/summary.txt create mode 100644 extra/redis/summary.txt diff --git a/extra/redis/authors.txt b/extra/redis/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/redis/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/redis/command-writer/authors.txt b/extra/redis/command-writer/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/redis/command-writer/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/redis/command-writer/command-writer-tests.factor b/extra/redis/command-writer/command-writer-tests.factor new file mode 100644 index 0000000000..901c4e41f3 --- /dev/null +++ b/extra/redis/command-writer/command-writer-tests.factor @@ -0,0 +1,138 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test redis.command-writer io.streams.string ; +IN: redis.command-writer.tests + +#! Connection +[ "QUIT\r\n" ] [ [ quit ] with-string-writer ] unit-test + +[ "PING\r\n" ] [ [ ping ] with-string-writer ] unit-test + +[ "AUTH password\r\n" ] [ [ "password" auth ] with-string-writer ] unit-test + +#! String values +[ "SET key 3\r\nfoo\r\n" ] [ [ "foo" "key" set ] with-string-writer ] unit-test + +[ "GET key\r\n" ] [ [ "key" get ] with-string-writer ] unit-test + +[ "GETSET key 3\r\nfoo\r\n" ] [ + [ "foo" "key" getset ] with-string-writer +] unit-test + +[ "MGET key1 key2 key3\r\n" ] [ + [ { "key1" "key2" "key3" } mget ] with-string-writer +] unit-test + +[ "SETNX key 3\r\nfoo\r\n" ] [ + [ "foo" "key" setnx ] with-string-writer +] unit-test + +[ "INCR key\r\n" ] [ [ "key" incr ] with-string-writer ] unit-test + +[ "INCRBY key 7\r\n" ] [ [ 7 "key" incrby ] with-string-writer ] unit-test + +[ "DECR key\r\n" ] [ [ "key" decr ] with-string-writer ] unit-test + +[ "DECRBY key 7\r\n" ] [ [ 7 "key" decrby ] with-string-writer ] unit-test + +[ "EXISTS key\r\n" ] [ [ "key" exists ] with-string-writer ] unit-test + +[ "DEL key\r\n" ] [ [ "key" del ] with-string-writer ] unit-test + +[ "TYPE key\r\n" ] [ [ "key" type ] with-string-writer ] unit-test + +#! Key space +[ "KEYS pat*\r\n" ] [ [ "pat*" keys ] with-string-writer ] unit-test + +[ "RANDOMKEY\r\n" ] [ [ randomkey ] with-string-writer ] unit-test + +[ "RENAME key newkey\r\n" ] [ + [ "newkey" "key" rename ] with-string-writer +] unit-test + +[ "RENAMENX key newkey\r\n" ] [ + [ "newkey" "key" renamenx ] with-string-writer +] unit-test + +[ "DBSIZE\r\n" ] [ [ dbsize ] with-string-writer ] unit-test + +[ "EXPIRE key 7\r\n" ] [ [ 7 "key" expire ] with-string-writer ] unit-test + +#! Lists +[ "RPUSH key 3\r\nfoo\r\n" ] [ [ "foo" "key" rpush ] with-string-writer ] unit-test + +[ "LPUSH key 3\r\nfoo\r\n" ] [ [ "foo" "key" lpush ] with-string-writer ] unit-test + +[ "LLEN key\r\n" ] [ [ "key" llen ] with-string-writer ] unit-test + +[ "LRANGE key 5 9\r\n" ] [ [ 5 9 "key" lrange ] with-string-writer ] unit-test + +[ "LTRIM key 5 9\r\n" ] [ [ 5 9 "key" ltrim ] with-string-writer ] unit-test + +[ "LINDEX key 7\r\n" ] [ [ 7 "key" lindex ] with-string-writer ] unit-test + +[ "LSET key 0 3\r\nfoo\r\n" ] [ [ "foo" 0 "key" lset ] with-string-writer ] unit-test + +[ "LREM key 1 3\r\nfoo\r\n" ] [ [ "foo" 1 "key" lrem ] with-string-writer ] unit-test + +[ "LPOP key\r\n" ] [ [ "key" lpop ] with-string-writer ] unit-test + +[ "RPOP key\r\n" ] [ [ "key" rpop ] with-string-writer ] unit-test + +#! Sets +[ "SADD key 3\r\nfoo\r\n" ] [ [ "foo" "key" sadd ] with-string-writer ] unit-test + +[ "SREM key 3\r\nfoo\r\n" ] [ [ "foo" "key" srem ] with-string-writer ] unit-test + +[ "SMOVE srckey dstkey 3\r\nfoo\r\n" ] [ + [ "foo" "dstkey" "srckey" smove ] with-string-writer +] unit-test + +[ "SCARD key\r\n" ] [ [ "key" scard ] with-string-writer ] unit-test + +[ "SISMEMBER key 3\r\nfoo\r\n" ] [ + [ "foo" "key" sismember ] with-string-writer +] unit-test + +[ "SINTER key1 key2 key3\r\n" ] [ + [ { "key1" "key2" "key3" } sinter ] with-string-writer +] unit-test + +[ "SINTERSTORE dstkey key1 key2 key3\r\n" ] [ + [ { "key1" "key2" "key3" } "dstkey" sinterstore ] with-string-writer +] unit-test + +[ "SUNION key1 key2 key3\r\n" ] [ + [ { "key1" "key2" "key3" } sunion ] with-string-writer +] unit-test + +[ "SUNIONSTORE dstkey key1 key2 key3\r\n" ] [ + [ { "key1" "key2" "key3" } "dstkey" sunionstore ] with-string-writer +] unit-test + +[ "SMEMBERS key\r\n" ] [ [ "key" smembers ] with-string-writer ] unit-test + +#! Multiple db +[ "SELECT 2\r\n" ] [ [ 2 select ] with-string-writer ] unit-test + +[ "MOVE key 2\r\n" ] [ [ 2 "key" move ] with-string-writer ] unit-test + +[ "FLUSHDB\r\n" ] [ [ flushdb ] with-string-writer ] unit-test + +[ "FLUSHALL\r\n" ] [ [ flushall ] with-string-writer ] unit-test + +#! Sorting + +#! Persistence control +[ "SAVE\r\n" ] [ [ save ] with-string-writer ] unit-test + +[ "BGSAVE\r\n" ] [ [ bgsave ] with-string-writer ] unit-test + +[ "LASTSAVE\r\n" ] [ [ lastsave ] with-string-writer ] unit-test + +[ "SHUTDOWN\r\n" ] [ [ shutdown ] with-string-writer ] unit-test + +#! Remote server control +[ "INFO\r\n" ] [ [ info ] with-string-writer ] unit-test + +[ "MONITOR\r\n" ] [ [ monitor ] with-string-writer ] unit-test diff --git a/extra/redis/command-writer/command-writer.factor b/extra/redis/command-writer/command-writer.factor new file mode 100644 index 0000000000..e5e635f457 --- /dev/null +++ b/extra/redis/command-writer/command-writer.factor @@ -0,0 +1,104 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: io io.crlf kernel math.parser sequences strings interpolate locals ; +IN: redis.command-writer + +string write crlf ] + [ write ] bi ; + +: space ( -- ) CHAR: space write1 ; + +: write-key/value ( value key -- ) + write space + write-value-with-length ; + +: write-key/integer ( integer key -- ) + write space + number>string write ; + +PRIVATE> + +#! Connection +: quit ( -- ) "QUIT" write crlf ; +: ping ( -- ) "PING" write crlf ; +: auth ( password -- ) "AUTH " write write crlf ; + +#! String values +: set ( value key -- ) "SET " write write-key/value crlf ; +: get ( key -- ) "GET " write write crlf ; +: getset ( value key -- ) "GETSET " write write-key/value crlf ; +: mget ( keys -- ) "MGET " write " " join write crlf ; +: setnx ( value key -- ) "SETNX " write write-key/value crlf ; +: incr ( key -- ) "INCR " write write crlf ; +: incrby ( integer key -- ) "INCRBY " write write-key/integer crlf ; +: decr ( key -- ) "DECR " write write crlf ; +: decrby ( integer key -- ) "DECRBY " write write-key/integer crlf ; +: exists ( key -- ) "EXISTS " write write crlf ; +: del ( key -- ) "DEL " write write crlf ; +: type ( key -- ) "TYPE " write write crlf ; + +#! Key space +: keys ( pattern -- ) "KEYS " write write crlf ; +: randomkey ( -- ) "RANDOMKEY" write crlf ; +: rename ( newkey key -- ) "RENAME " write write space write crlf ; +: renamenx ( newkey key -- ) "RENAMENX " write write space write crlf ; +: dbsize ( -- ) "DBSIZE" write crlf ; +: expire ( integer key -- ) "EXPIRE " write write-key/integer crlf ; + +#! Lists +: rpush ( value key -- ) "RPUSH " write write-key/value crlf ; +: lpush ( value key -- ) "LPUSH " write write-key/value crlf ; +: llen ( key -- ) "LLEN " write write crlf ; +: lrange ( start end key -- ) + "LRANGE " write write [ space number>string write ] bi@ crlf ; +: ltrim ( start end key -- ) + "LTRIM " write write [ space number>string write ] bi@ crlf ; +: lindex ( integer key -- ) "LINDEX " write write-key/integer crlf ; +: lset ( value index key -- ) + "LSET " write write-key/integer space write-value-with-length crlf ; +: lrem ( value amount key -- ) + "LREM " write write-key/integer space write-value-with-length crlf ; +: lpop ( key -- ) "LPOP " write write crlf ; +: rpop ( key -- ) "RPOP " write write crlf ; + +#! Sets +: sadd ( member key -- ) + "SADD " write write space write-value-with-length crlf ; +: srem ( member key -- ) + "SREM " write write space write-value-with-length crlf ; +: smove ( member newkey key -- ) + "SMOVE " write write space write space write-value-with-length crlf ; +: scard ( key -- ) "SCARD " write write crlf ; +: sismember ( member key -- ) + "SISMEMBER " write write space write-value-with-length crlf ; +: sinter ( keys -- ) "SINTER " write " " join write crlf ; +: sinterstore ( keys destkey -- ) + "SINTERSTORE " write write space " " join write crlf ; +: sunion ( keys -- ) "SUNION " write " " join write crlf ; +: sunionstore ( keys destkey -- ) + "SUNIONSTORE " write write " " join space write crlf ; +: smembers ( key -- ) "SMEMBERS " write write crlf ; + +#! Multiple db +: select ( integer -- ) "SELECT " write number>string write crlf ; +: move ( integer key -- ) "MOVE " write write-key/integer crlf ; +: flushdb ( -- ) "FLUSHDB" write crlf ; +: flushall ( -- ) "FLUSHALL" write crlf ; + +#! Sorting +! sort + +#! Persistence control +: save ( -- ) "SAVE" write crlf ; +: bgsave ( -- ) "BGSAVE" write crlf ; +: lastsave ( -- ) "LASTSAVE" write crlf ; +: shutdown ( -- ) "SHUTDOWN" write crlf ; + +#! Remote server control +: info ( -- ) "INFO" write crlf ; +: monitor ( -- ) "MONITOR" write crlf ; diff --git a/extra/redis/command-writer/summary.txt b/extra/redis/command-writer/summary.txt new file mode 100644 index 0000000000..917b915546 --- /dev/null +++ b/extra/redis/command-writer/summary.txt @@ -0,0 +1 @@ +Definitions of messages sent to Redis diff --git a/extra/redis/redis.factor b/extra/redis/redis.factor new file mode 100644 index 0000000000..1f6d732407 --- /dev/null +++ b/extra/redis/redis.factor @@ -0,0 +1,74 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: io redis.response-parser redis.command-writer ; +IN: redis + +#! Connection +: redis-quit ( -- ) quit flush ; +: redis-ping ( -- response ) ping flush read-response ; +: redis-auth ( password -- response ) auth flush read-response ; + +#! String values +: redis-set ( value key -- response ) set flush read-response ; +: redis-get ( key -- response ) get flush read-response ; +: redis-getset ( value key -- response ) getset flush read-response ; +: redis-mget ( keys -- response ) mget flush read-response ; +: redis-setnx ( value key -- response ) setnx flush read-response ; +: redis-incr ( key -- response ) incr flush read-response ; +: redis-incrby ( integer key -- response ) incrby flush read-response ; +: redis-decr ( key -- response ) decr flush read-response ; +: redis-decrby ( integer key -- response ) decrby flush read-response ; +: redis-exists ( key -- response ) exists flush read-response ; +: redis-del ( key -- response ) del flush read-response ; +: redis-type ( key -- response ) type flush read-response ; + +#! Key space +: redis-keys ( pattern -- response ) keys flush read-response ; +: redis-randomkey ( -- response ) randomkey flush read-response ; +: redis-rename ( newkey key -- response ) rename flush read-response ; +: redis-renamenx ( newkey key -- response ) renamenx flush read-response ; +: redis-dbsize ( -- response ) dbsize flush read-response ; +: redis-expire ( integer key -- response ) expire flush read-response ; + +#! Lists +: redis-rpush ( value key -- response ) rpush flush read-response ; +: redis-lpush ( value key -- response ) lpush flush read-response ; +: redis-llen ( key -- response ) llen flush read-response ; +: redis-lrange ( start end key -- response ) lrange flush read-response ; +: redis-ltrim ( start end key -- response ) ltrim flush read-response ; +: redis-lindex ( integer key -- response ) lindex flush read-response ; +: redis-lset ( value index key -- response ) lset flush read-response ; +: redis-lrem ( value amount key -- response ) lrem flush read-response ; +: redis-lpop ( key -- response ) lpop flush read-response ; +: redis-rpop ( key -- response ) rpop flush read-response ; + +#! Sets +: redis-sadd ( member key -- response ) sadd flush read-response ; +: redis-srem ( member key -- response ) srem flush read-response ; +: redis-smove ( member newkey key -- response ) smove flush read-response ; +: redis-scard ( key -- response ) scard flush read-response ; +: redis-sismember ( member key -- response ) sismember flush read-response ; +: redis-sinter ( keys -- response ) sinter flush read-response ; +: redis-sinterstore ( keys destkey -- response ) sinterstore flush read-response ; +: redis-sunion ( keys -- response ) sunion flush read-response ; +: redis-sunionstore ( keys destkey -- response ) sunionstore flush read-response ; +: redis-smembers ( key -- response ) smembers flush read-response ; + +#! Multiple db +: redis-select ( integer -- response ) select flush read-response ; +: redis-move ( integer key -- response ) move flush read-response ; +: redis-flushdb ( -- response ) flushdb flush read-response ; +: redis-flushall ( -- response ) flushall flush read-response ; + +#! Sorting +! sort + +#! Persistence control +: redis-save ( -- response ) save flush read-response ; +: redis-bgsave ( -- response ) bgsave flush read-response ; +: redis-lastsave ( -- response ) lastsave flush read-response ; +: redis-shutdown ( -- response ) shutdown flush read-response ; + +#! Remote server control +: redis-info ( -- response ) info flush read-response ; +: redis-monitor ( -- response ) monitor flush read-response ; diff --git a/extra/redis/response-parser/authors.txt b/extra/redis/response-parser/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/redis/response-parser/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/redis/response-parser/response-parser-tests.factor b/extra/redis/response-parser/response-parser-tests.factor new file mode 100644 index 0000000000..bde36114c3 --- /dev/null +++ b/extra/redis/response-parser/response-parser-tests.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test redis.response-parser io.streams.string ; +IN: redis.response-parser.tests + +[ 1 ] [ ":1\r\n" [ read-response ] with-string-reader ] unit-test + +[ "hello" ] [ "$5\r\nhello\r\n" [ read-response ] with-string-reader ] unit-test + +[ f ] [ "$-1\r\n" [ read-response ] with-string-reader ] unit-test + +[ { "hello" "world!" } ] [ + "*2\r\n$5\r\nhello\r\n$6\r\nworld!\r\n" [ read-response ] with-string-reader +] unit-test + +[ { "hello" f "world!" } ] [ + "*3\r\n$5\r\nhello\r\n$-1\r\n$6\r\nworld!\r\n" [ + read-response + ] with-string-reader +] unit-test diff --git a/extra/redis/response-parser/response-parser.factor b/extra/redis/response-parser/response-parser.factor new file mode 100644 index 0000000000..3d92d553b0 --- /dev/null +++ b/extra/redis/response-parser/response-parser.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2009 Bruno Deferrari +! See http://factorcode.org/license.txt for BSD license. +USING: combinators io kernel math math.parser sequences ; +IN: redis.response-parser + +number read-bulk ; +: read-multi-bulk ( n -- seq/f ) + dup 0 < [ drop f ] [ + iota [ drop (read-multi-bulk) ] map + ] if ; + +: handle-response ( string -- string ) ; ! TODO +: handle-error ( string -- string ) ; ! TODO + +PRIVATE> + +: read-response ( -- response ) + readln unclip { + { CHAR: : [ string>number ] } + { CHAR: + [ handle-response ] } + { CHAR: $ [ string>number read-bulk ] } + { CHAR: * [ string>number read-multi-bulk ] } + { CHAR: - [ handle-error ] } + } case ; diff --git a/extra/redis/response-parser/summary.txt b/extra/redis/response-parser/summary.txt new file mode 100644 index 0000000000..b89407c7b4 --- /dev/null +++ b/extra/redis/response-parser/summary.txt @@ -0,0 +1 @@ +Parser for responses sent by the Redis server diff --git a/extra/redis/summary.txt b/extra/redis/summary.txt new file mode 100644 index 0000000000..0cd6e69e38 --- /dev/null +++ b/extra/redis/summary.txt @@ -0,0 +1 @@ +Words for communicating with the Redis key-value database From 956ae3a2beae2ade96f54456e102d01296ed2ca4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 18:20:19 -0500 Subject: [PATCH 199/210] fix rsa tests --- extra/crypto/rsa/rsa.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor index 50ea84fd39..f4ef4687b5 100644 --- a/extra/crypto/rsa/rsa.factor +++ b/extra/crypto/rsa/rsa.factor @@ -21,7 +21,7 @@ C: rsa CONSTANT: public-key 65537 : rsa-primes ( numbits -- p q ) - 2/ 2 unique-primes first2 ; + 2/ 2 swap unique-primes first2 ; : modulus-phi ( numbits -- n phi ) #! Loop until phi is not divisible by the public key. From 57621dc7388953bf9f71648386f1ea7544df4e26 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 May 2009 18:54:56 -0500 Subject: [PATCH 200/210] Fix unit test failures caused by change to 'contents' word --- basis/base64/base64-tests.factor | 2 +- basis/urls/encoding/encoding-tests.factor | 4 ++-- basis/urls/urls.factor | 14 ++++++++------ 3 files changed, 11 insertions(+), 9 deletions(-) diff --git a/basis/base64/base64-tests.factor b/basis/base64/base64-tests.factor index 9094286575..e962fa7e59 100644 --- a/basis/base64/base64-tests.factor +++ b/basis/base64/base64-tests.factor @@ -4,7 +4,7 @@ IN: base64.tests [ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" ascii encode >base64 base64> ascii decode ] unit-test -[ f ] [ "" ascii encode >base64 base64> ascii decode ] unit-test +[ "" ] [ "" ascii encode >base64 base64> ascii decode ] unit-test [ "a" ] [ "a" ascii encode >base64 base64> ascii decode ] unit-test [ "ab" ] [ "ab" ascii encode >base64 base64> ascii decode ] unit-test [ "abc" ] [ "abc" ascii encode >base64 base64> ascii decode ] unit-test diff --git a/basis/urls/encoding/encoding-tests.factor b/basis/urls/encoding/encoding-tests.factor index 78e31a764d..f3e0497588 100644 --- a/basis/urls/encoding/encoding-tests.factor +++ b/basis/urls/encoding/encoding-tests.factor @@ -2,8 +2,8 @@ IN: urls.encoding.tests USING: urls.encoding tools.test arrays kernel assocs present accessors ; [ "~hello world" ] [ "%7ehello world" url-decode ] unit-test -[ f ] [ "%XX%XX%XX" url-decode ] unit-test -[ f ] [ "%XX%XX%X" url-decode ] unit-test +[ "" ] [ "%XX%XX%XX" url-decode ] unit-test +[ "" ] [ "%XX%XX%X" url-decode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test [ " ! " ] [ "%20%21%20" url-decode ] unit-test diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor index 1e886ae3e2..a72fac567a 100644 --- a/basis/urls/urls.factor +++ b/basis/urls/urls.factor @@ -25,12 +25,14 @@ TUPLE: url protocol username password host port path query anchor ; ] if ; : parse-host ( string -- host port ) - ":" split1 [ url-decode ] [ - dup [ - string>number - dup [ "Invalid port" throw ] unless - ] when - ] bi* ; + [ + ":" split1 [ url-decode ] [ + dup [ + string>number + dup [ "Invalid port" throw ] unless + ] when + ] bi* + ] [ f f ] if* ; GENERIC: >url ( obj -- url ) From 9b491d1442ab71effd4e07fbc4b199a030e21b35 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 May 2009 19:01:38 -0500 Subject: [PATCH 201/210] Fix bool type on PowerPC --- basis/alien/c-types/c-types.factor | 9 +++++---- basis/cpu/ppc/ppc.factor | 8 +++++++- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 6067c90f2d..df5a5bbba8 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -259,8 +259,9 @@ M: long-long-type box-return ( type -- ) [ dup c-setter '[ _ [ 0 @ ] keep ] ] bi (( value -- c-ptr )) define-inline ; -: c-bool> ( int -- ? ) - 0 = not ; inline +: >c-bool ( ? -- int ) 1 0 ? ; inline + +: c-bool> ( int -- ? ) 0 = not ; inline : define-primitive-type ( type name -- ) [ typedef ] @@ -409,8 +410,8 @@ CONSTANT: primitive-types "uchar" define-primitive-type - [ alien-unsigned-1 zero? not ] >>getter - [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter + [ alien-unsigned-1 c-bool> ] >>getter + [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter 1 >>size 1 >>align "box_boolean" >>boxer diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 442dd8e7ea..314ea830f8 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -713,4 +713,10 @@ USE: vocabs.loader } cond "complex-double" c-type t >>return-in-registers? drop -"bool" c-type 4 >>size 4 >>align drop \ No newline at end of file + +"bool" c-type +4 >>size +4 >>align +[ alien-unsigned-1 c-bool> ] >>getter +[ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter +drop \ No newline at end of file From 3e7269731b97f6399b6ec9f8c7a61d74067904bd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 May 2009 19:10:20 -0500 Subject: [PATCH 202/210] cpu.ppc: really fix bool type --- basis/cpu/ppc/ppc.factor | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 314ea830f8..dc7108b3a1 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -2,11 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs sequences kernel combinators make math math.order math.ranges system namespaces locals layouts words -alien alien.c-types literals cpu.architecture cpu.ppc.assembler -cpu.ppc.assembler.backend literals compiler.cfg.registers +alien alien.accessors alien.c-types literals cpu.architecture +cpu.ppc.assembler cpu.ppc.assembler.backend literals compiler.cfg.registers compiler.cfg.instructions compiler.constants compiler.codegen compiler.codegen.fixup compiler.cfg.intrinsics -compiler.cfg.stack-frame ; +compiler.cfg.stack-frame compiler.units ; IN: cpu.ppc ! PowerPC register assignments: @@ -714,9 +714,13 @@ USE: vocabs.loader "complex-double" c-type t >>return-in-registers? drop -"bool" c-type -4 >>size -4 >>align -[ alien-unsigned-1 c-bool> ] >>getter -[ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter -drop \ No newline at end of file +[ + + [ alien-unsigned-4 c-bool> ] >>getter + [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter + 4 >>size + 4 >>align + "box_boolean" >>boxer + "to_boolean" >>unboxer + "bool" define-primitive-type +] with-compilation-unit From be41611667c2da002e54ae71a96ce0e25e5fc3da Mon Sep 17 00:00:00 2001 From: "U-C4\\Administrator" Date: Sun, 10 May 2009 19:20:04 -0500 Subject: [PATCH 203/210] add a find-by-extensions word --- .../io/directories/search/search-docs.factor | 35 +++++++++++++++++-- basis/io/directories/search/search.factor | 9 ++++- extra/id3/id3.factor | 3 +- 3 files changed, 41 insertions(+), 6 deletions(-) diff --git a/basis/io/directories/search/search-docs.factor b/basis/io/directories/search/search-docs.factor index a6c82a1bff..6bfaa07227 100644 --- a/basis/io/directories/search/search-docs.factor +++ b/basis/io/directories/search/search-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel quotations ; +USING: help.markup help.syntax kernel quotations sequences ; IN: io.directories.search HELP: each-file @@ -57,6 +57,32 @@ HELP: find-all-in-directories } { $description "Finds all files in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ; +HELP: find-by-extension +{ $values + { "path" "a pathname string" } { "extension" "a file extension" } + { "seq" sequence } +} +{ $description "Searches a directory for all files with the given extension. File extension and filenames are converted to lower-case and compared using the " { $link tail? } " word. The file extension should contain the period." } +{ $examples + { $unchecked-example + "USING: io.directories.search ;" + "\"/\" \".mp3\" find-by-extension" + } +} ; + +HELP: find-by-extensions +{ $values + { "path" "a pathname string" } { "extensions" "a sequence of file extensions" } + { "seq" sequence } +} +{ $description "Searches a directory for all files in the given list of extensions. File extensions and filenames are converted to lower-case and compared using the " { $link tail? } " word. File extensions should contain the period." } +{ $examples + { $unchecked-example + "USING: io.directories.search ;" + "\"/\" { \".jpg\" \".gif\" \".tiff\" \".png\" \".bmp\" } find-by-extensions" + } +} ; + { find-file find-all-files find-in-directories find-all-in-directories } related-words ARTICLE: "io.directories.search" "Searching directories" @@ -65,10 +91,13 @@ ARTICLE: "io.directories.search" "Searching directories" { $subsection recursive-directory-files } { $subsection recursive-directory-entries } { $subsection each-file } -"Finding files:" +"Finding files by name:" { $subsection find-file } { $subsection find-all-files } { $subsection find-in-directories } -{ $subsection find-all-in-directories } ; +{ $subsection find-all-in-directories } +"Finding files by extension:" +{ $subsection find-by-extension } +{ $subsection find-by-extensions } ; ABOUT: "io.directories.search" diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index f7d18306f8..3fbf09a3c3 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -3,7 +3,7 @@ USING: accessors arrays continuations deques dlists fry io.directories io.files io.files.info io.pathnames kernel sequences system vocabs.loader locals math namespaces -sorting assocs calendar threads io math.parser ; +sorting assocs calendar threads io math.parser unicode.case ; IN: io.directories.search : qualified-directory-entries ( path -- seq ) @@ -106,4 +106,11 @@ ERROR: file-not-found path bfs? quot ; ] { } map>assoc ] with-qualified-directory-entries sort-values ; +: find-by-extensions ( path extensions -- seq ) + [ >lower ] map + '[ >lower _ [ tail? ] with any? ] find-all-files ; + +: find-by-extension ( path extension -- seq ) + 1array find-by-extensions ; + os windows? [ "io.directories.search.windows" require ] when diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 79df00ff5e..6acace8582 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -233,8 +233,7 @@ PRIVATE> : genre ( id3 -- string/f ) "TCON" find-id3-frame parse-genre ; -: find-mp3s ( path -- seq ) - [ >lower ".mp3" tail? ] find-all-files ; +: find-mp3s ( path -- seq ) ".mp3" find-by-extension ; ERROR: id3-parse-error path error ; From 64a9585dd0b580de672789ea55242f0b6794b879 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 May 2009 21:33:13 -0500 Subject: [PATCH 204/210] Fix deployment of UI apps and implement various tricks to make deployed images smaller --- basis/cocoa/messages/messages.factor | 2 +- basis/tools/deploy/deploy-docs.factor | 2 + basis/tools/deploy/deploy-tests.factor | 4 ++ basis/tools/deploy/shaker/shaker.factor | 68 +++++++++++--------- basis/tools/deploy/shaker/strip-cocoa.factor | 9 ++- basis/ui/gadgets/worlds/worlds.factor | 2 +- basis/ui/gestures/gestures.factor | 12 ++-- basis/ui/pixel-formats/pixel-formats.factor | 4 +- extra/spheres/deploy.factor | 19 +++--- extra/terrain/deploy.factor | 15 +++++ 10 files changed, 87 insertions(+), 50 deletions(-) create mode 100644 extra/terrain/deploy.factor diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 65bb2c02ef..fdd4ba81d7 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -68,7 +68,7 @@ MACRO: (send) ( selector super? -- quot ) [ dup lookup-method ] dip [ make-prepare-send ] 2keep super-message-senders message-senders ? get at - '[ _ call _ execute ] ; + 1quotation append ; : send ( receiver args... selector -- return... ) f (send) ; inline diff --git a/basis/tools/deploy/deploy-docs.factor b/basis/tools/deploy/deploy-docs.factor index 4c03047eb8..71701b6a56 100644 --- a/basis/tools/deploy/deploy-docs.factor +++ b/basis/tools/deploy/deploy-docs.factor @@ -29,6 +29,8 @@ ARTICLE: "tools.deploy.caveats" "Deploy tool caveats" "In deployed applications, the " { $link boa } " word does not verify that the parameters on the stack satisfy the tuple's slot declarations, if any. This reduces deploy image size but can make bugs harder to track down. Make sure your program is fully debugged before deployment." { $heading "Behavior of " { $link POSTPONE: execute( } } "Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-effect-unsafe } "." +{ $heading "Behavior of " { $link POSTPONE: call-next-method } } +"The " { $link POSTPONE: call-next-method } " word does not check if the input is of the right type in deployed applications." { $heading "Error reporting" } "If the " { $link deploy-reflection } " level in the configuration is low enough, the debugger is stripped out, and error messages can be rather cryptic. Increase the reflection level to get readable error messages." { $heading "Choosing the right deploy flags" } diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 3bebf7236d..1c12e8b781 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -20,6 +20,10 @@ io.directories tools.deploy.test ; [ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test +[ t ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test + +[ t ] [ "terrain" shake-and-bake 1600000 small-enough? ] unit-test + [ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test os macosx? [ diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 816dbb7979..7bbc726d30 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -1,13 +1,11 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors io.backend io.streams.c init fry -namespaces make assocs kernel parser lexer strings.parser vocabs -sequences words memory kernel.private -continuations io vocabs.loader system strings sets -vectors quotations byte-arrays sorting compiler.units -definitions generic generic.standard tools.deploy.config ; +USING: arrays accessors io.backend io.streams.c init fry namespaces +make assocs kernel parser lexer strings.parser vocabs sequences words +memory kernel.private continuations io vocabs.loader system strings +sets vectors quotations byte-arrays sorting compiler.units definitions +generic generic.standard tools.deploy.config combinators classes ; QUALIFIED: bootstrap.stage2 -QUALIFIED: classes QUALIFIED: command-line QUALIFIED: compiler.errors QUALIFIED: continuations @@ -193,6 +191,11 @@ IN: tools.deploy.shaker strip-word-names? [ dup strip-word-names ] when 2drop ; +: strip-compiler-classes ( -- ) + "Stripping compiler classes" show + "compiler" child-vocabs [ words ] map concat [ class? ] filter + [ dup implementors [ "methods" word-prop delete-at ] with each ] each ; + : strip-default-methods ( -- ) strip-debugger? [ "Stripping default methods" show @@ -255,14 +258,14 @@ IN: tools.deploy.shaker { gensym name>char-hook - classes:next-method-quot-cache - classes:class-and-cache - classes:class-not-cache - classes:class-or-cache - classes:class<=-cache - classes:classes-intersect-cache - classes:implementors-map - classes:update-map + next-method-quot-cache + class-and-cache + class-not-cache + class-or-cache + class<=-cache + classes-intersect-cache + implementors-map + update-map command-line:main-vocab-hook compiled-crossref compiled-generic-crossref @@ -334,8 +337,16 @@ IN: tools.deploy.shaker [ instances dup H{ } clone [ [ ] cache ] curry map ] dip call become ; inline -: compress-byte-arrays ( -- ) - [ byte-array? ] [ ] "byte arrays" compress ; +: compress-objects ( -- ) + [ + { + [ dup array? [ empty? ] [ drop f ] if ] + [ byte-array? ] + [ string? ] + [ wrapper? ] + } cleave + or or or + ] [ ] "objects" compress ; : remain-compiled ( old new -- old new ) #! Quotations which were formerly compiled must remain @@ -349,12 +360,6 @@ IN: tools.deploy.shaker [ quotation? ] [ remain-compiled ] "quotations" compress [ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ; -: compress-strings ( -- ) - [ string? ] [ ] "strings" compress ; - -: compress-wrappers ( -- ) - [ wrapper? ] [ ] "wrappers" compress ; - SYMBOL: deploy-vocab : [:c] ( -- word ) ":c" "debugger" lookup ; @@ -385,18 +390,23 @@ SYMBOL: deploy-vocab t "quiet" set-global f output-stream set-global ; +: unsafe-next-method-quot ( method -- quot ) + [ "method-class" word-prop ] + [ "method-generic" word-prop ] bi + next-method 1quotation ; + : compute-next-methods ( -- ) [ standard-generic? ] instances [ "methods" word-prop [ - nip - dup next-method-quot "next-method-quot" set-word-prop + nip dup + unsafe-next-method-quot + "next-method-quot" set-word-prop ] assoc-each ] each "vocab:tools/deploy/shaker/next-methods.factor" run-file ; : strip ( -- ) init-stripper - strip-default-methods strip-libc strip-call strip-cocoa @@ -404,14 +414,14 @@ SYMBOL: deploy-vocab compute-next-methods strip-init-hooks strip-c-io + strip-compiler-classes + strip-default-methods f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore deploy-vocab get vocab-main deploy-boot-quot stripped-word-props stripped-globals strip-globals - compress-byte-arrays + compress-objects compress-quotations - compress-strings - compress-wrappers strip-words ; : deploy-error-handler ( quot -- ) diff --git a/basis/tools/deploy/shaker/strip-cocoa.factor b/basis/tools/deploy/shaker/strip-cocoa.factor index df64443b7b..133308b732 100644 --- a/basis/tools/deploy/shaker/strip-cocoa.factor +++ b/basis/tools/deploy/shaker/strip-cocoa.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007, 2008 Slava Pestov +! Copyright (C) 2007, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs namespaces kernel kernel.private words compiler.units sequences -init vocabs ; +init vocabs memoize accessors ; IN: tools.deploy.shaker.cocoa : pool ( obj -- obj' ) \ pool get [ ] cache ; @@ -42,3 +42,8 @@ H{ } clone \ pool [ [ get values compile ] each ] bind ] with-variable + +\ make-prepare-send reset-memoized +\ reset-memoized + +\ (send) def>> second clear-assoc \ No newline at end of file diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index eec5666f0e..2e7b84ef6e 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -4,7 +4,7 @@ USING: accessors arrays assocs continuations kernel math models namespaces opengl opengl.textures sequences io combinators combinators.short-circuit fry math.vectors math.rectangles cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks -ui.commands ui.pixel-formats destructors literals ; +ui.pixel-formats destructors literals ; IN: ui.gadgets.worlds CONSTANT: default-world-pixel-format-attributes diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index 7e038ef2e0..073b2d5e26 100644 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -3,8 +3,8 @@ USING: accessors arrays assocs kernel math math.order models namespaces make sequences words strings system hashtables math.parser math.vectors classes.tuple classes boxes calendar alarms combinators -sets columns fry deques ui.gadgets ui.gadgets.private unicode.case -unicode.categories combinators.short-circuit ; +sets columns fry deques ui.gadgets ui.gadgets.private ascii +combinators.short-circuit ; IN: ui.gestures GENERIC: handle-gesture ( gesture gadget -- ? ) @@ -296,10 +296,10 @@ HOOK: modifiers>string os ( modifiers -- string ) M: macosx modifiers>string [ { - { A+ [ "\u{place-of-interest-sign}" ] } - { M+ [ "\u{option-key}" ] } - { S+ [ "\u{upwards-white-arrow}" ] } - { C+ [ "\u{up-arrowhead}" ] } + { A+ [ "\u002318" ] } + { M+ [ "\u002325" ] } + { S+ [ "\u0021e7" ] } + { C+ [ "\u002303" ] } } case ] map "" join ; diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index 52abf44362..a280ab0666 100644 --- a/basis/ui/pixel-formats/pixel-formats.factor +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -1,6 +1,6 @@ USING: accessors assocs classes destructors functors kernel lexer math parser sequences specialized-arrays.int ui.backend -words.symbol ; +words ; IN: ui.pixel-formats SYMBOLS: @@ -71,7 +71,7 @@ GENERIC: >PFA ( attribute -- pfas ) M: object >PFA drop { } ; -M: symbol >PFA +M: word >PFA TABLE at [ { } ] unless* ; M: pixel-format-attribute >PFA dup class TABLE at diff --git a/extra/spheres/deploy.factor b/extra/spheres/deploy.factor index d6591a1a26..22c5de0963 100644 --- a/extra/spheres/deploy.factor +++ b/extra/spheres/deploy.factor @@ -1,14 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-reflection 1 } - { deploy-word-defs? f } - { deploy-word-props? f } - { deploy-name "Spheres" } - { deploy-compiler? t } - { deploy-math? t } - { deploy-io 1 } - { deploy-threads? t } - { "stop-after-last-window?" t } { deploy-ui? t } + { deploy-reflection 1 } + { deploy-unicode? f } + { deploy-math? t } + { deploy-io 2 } { deploy-c-types? f } + { deploy-name "Spheres" } + { deploy-word-props? f } + { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-compiler? t } + { deploy-threads? t } } diff --git a/extra/terrain/deploy.factor b/extra/terrain/deploy.factor new file mode 100644 index 0000000000..e51f8d13e6 --- /dev/null +++ b/extra/terrain/deploy.factor @@ -0,0 +1,15 @@ +USING: tools.deploy.config ; +H{ + { deploy-ui? t } + { deploy-reflection 1 } + { deploy-unicode? f } + { deploy-math? t } + { deploy-io 2 } + { deploy-c-types? f } + { deploy-name "Terrain" } + { deploy-word-props? f } + { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-compiler? t } + { deploy-threads? t } +} From 0f6b2f69faef36914c818e43a523d532b21fafa7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 May 2009 00:32:22 -0500 Subject: [PATCH 205/210] Deploy tool always uses optimizing compiler now --- basis/none/deploy.factor | 1 - basis/tools/deploy/backend/backend.factor | 16 ++++++++-------- basis/tools/deploy/config/config-docs.factor | 6 ------ basis/tools/deploy/config/config.factor | 2 -- basis/tools/deploy/deploy-tests.factor | 3 +-- basis/tools/deploy/shaker/shaker.factor | 19 ++++++++++--------- basis/tools/deploy/test/1/deploy.factor | 1 - basis/tools/deploy/test/10/deploy.factor | 1 - basis/tools/deploy/test/11/deploy.factor | 1 - basis/tools/deploy/test/12/deploy.factor | 1 - basis/tools/deploy/test/13/deploy.factor | 1 - basis/tools/deploy/test/2/deploy.factor | 1 - basis/tools/deploy/test/3/deploy.factor | 1 - basis/tools/deploy/test/4/deploy.factor | 1 - basis/tools/deploy/test/5/deploy.factor | 1 - basis/tools/deploy/test/6/deploy.factor | 1 - basis/tools/deploy/test/7/deploy.factor | 1 - basis/tools/deploy/test/8/8.factor | 11 ----------- basis/tools/deploy/test/8/deploy.factor | 15 --------------- basis/tools/deploy/test/9/deploy.factor | 1 - basis/ui/tools/deploy/deploy.factor | 1 - extra/4DNav/deploy.factor | 1 - extra/benchmark/fib6/deploy.factor | 1 - extra/benchmark/regex-dna/deploy.factor | 1 - extra/bunny/deploy.factor | 1 - extra/chicago-talk/deploy.factor | 1 - extra/color-picker/deploy.factor | 1 - extra/drills/deployed/deploy.factor | 1 - extra/gesture-logger/deploy.factor | 1 - extra/hello-ui/deploy.factor | 18 +++++++++--------- extra/hello-unicode/deploy.factor | 1 - extra/hello-world/deploy.factor | 1 - extra/jamshred/deploy.factor | 1 - extra/joystick-demo/deploy.factor | 1 - extra/maze/deploy.factor | 18 +++++++++--------- extra/merger/deploy.factor | 1 - extra/minneapolis-talk/deploy.factor | 1 - extra/nehe/deploy.factor | 1 - extra/spheres/deploy.factor | 1 - extra/sudoku/deploy.factor | 1 - extra/terrain/deploy.factor | 1 - extra/tetris/deploy.factor | 1 - extra/webkit-demo/deploy.factor | 1 - 43 files changed, 37 insertions(+), 105 deletions(-) delete mode 100644 basis/tools/deploy/test/8/8.factor delete mode 100644 basis/tools/deploy/test/8/deploy.factor diff --git a/basis/none/deploy.factor b/basis/none/deploy.factor index f604beab3f..06cc8c6a20 100644 --- a/basis/none/deploy.factor +++ b/basis/none/deploy.factor @@ -6,7 +6,6 @@ H{ { deploy-name "none" } { "stop-after-last-window?" t } { deploy-c-types? f } - { deploy-compiler? f } { deploy-io 1 } { deploy-ui? f } { deploy-reflection 1 } diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index b74548a65f..ba82276927 100755 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -43,14 +43,14 @@ CONSTANT: theme-path "basis/ui/gadgets/theme/" [ my-arch make-image ] unless ; : bootstrap-profile ( -- profile ) - { - { "math" deploy-math? } - { "compiler" deploy-compiler? } - { "threads" deploy-threads? } - { "ui" deploy-ui? } - { "unicode" deploy-unicode? } - } [ nip get ] assoc-filter keys - native-io? [ "io" suffix ] when ; + [ + deploy-math? get [ "math" , ] when + deploy-threads? get [ "threads" , ] when + "compiler" , + deploy-ui? get [ "ui" , ] when + deploy-unicode? get [ "unicode" , ] when + native-io? [ "io" , ] when + ] { } make ; : staging-image-name ( profile -- name ) "staging." diff --git a/basis/tools/deploy/config/config-docs.factor b/basis/tools/deploy/config/config-docs.factor index c8249e4e41..bd612c644a 100644 --- a/basis/tools/deploy/config/config-docs.factor +++ b/basis/tools/deploy/config/config-docs.factor @@ -5,7 +5,6 @@ IN: tools.deploy.config ARTICLE: "deploy-flags" "Deployment flags" "There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:" { $subsection deploy-math? } -{ $subsection deploy-compiler? } { $subsection deploy-unicode? } { $subsection deploy-threads? } { $subsection deploy-ui? } @@ -53,11 +52,6 @@ HELP: deploy-math? $nl "On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ; -HELP: deploy-compiler? -{ $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible." -$nl -"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ; - HELP: deploy-unicode? { $description "Deploy flag. If set, full Unicode " { $link POSTPONE: CHAR: } " syntax is included." $nl diff --git a/basis/tools/deploy/config/config.factor b/basis/tools/deploy/config/config.factor index 63c8393b51..89d1fe3821 100644 --- a/basis/tools/deploy/config/config.factor +++ b/basis/tools/deploy/config/config.factor @@ -7,7 +7,6 @@ IN: tools.deploy.config SYMBOL: deploy-name SYMBOL: deploy-ui? -SYMBOL: deploy-compiler? SYMBOL: deploy-math? SYMBOL: deploy-unicode? SYMBOL: deploy-threads? @@ -55,7 +54,6 @@ SYMBOL: deploy-image { deploy-ui? f } { deploy-io 2 } { deploy-reflection 1 } - { deploy-compiler? t } { deploy-threads? t } { deploy-unicode? f } { deploy-math? t } diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 1c12e8b781..842faba640 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -11,7 +11,7 @@ io.directories tools.deploy.test ; [ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test -[ "staging.math-compiler-threads-ui-strip.image" ] [ +[ "staging.math-threads-compiler-ui-strip.image" ] [ "hello-ui" deploy-config [ bootstrap-profile staging-image-name file-name ] bind ] unit-test @@ -88,7 +88,6 @@ M: quit-responder call-responder* { "tools.deploy.test.6" "tools.deploy.test.7" - "tools.deploy.test.8" "tools.deploy.test.9" "tools.deploy.test.10" "tools.deploy.test.11" diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 7bbc726d30..d79326ddc4 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -337,16 +337,17 @@ IN: tools.deploy.shaker [ instances dup H{ } clone [ [ ] cache ] curry map ] dip call become ; inline +: compress-object? ( obj -- ? ) + { + { [ dup array? ] [ empty? ] } + { [ dup byte-array? ] [ drop t ] } + { [ dup string? ] [ drop t ] } + { [ dup wrapper? ] [ drop t ] } + [ drop f ] + } cond ; + : compress-objects ( -- ) - [ - { - [ dup array? [ empty? ] [ drop f ] if ] - [ byte-array? ] - [ string? ] - [ wrapper? ] - } cleave - or or or - ] [ ] "objects" compress ; + [ compress-object? ] [ ] "objects" compress ; : remain-compiled ( old new -- old new ) #! Quotations which were formerly compiled must remain diff --git a/basis/tools/deploy/test/1/deploy.factor b/basis/tools/deploy/test/1/deploy.factor index 6d6a1c1bd3..509024a5c3 100644 --- a/basis/tools/deploy/test/1/deploy.factor +++ b/basis/tools/deploy/test/1/deploy.factor @@ -8,7 +8,6 @@ H{ { deploy-math? t } { deploy-io 2 } { deploy-name "tools.deploy.test.1" } - { deploy-compiler? t } { deploy-reflection 1 } { "stop-after-last-window?" t } } diff --git a/basis/tools/deploy/test/10/deploy.factor b/basis/tools/deploy/test/10/deploy.factor index 3f5940651d..c42063f644 100644 --- a/basis/tools/deploy/test/10/deploy.factor +++ b/basis/tools/deploy/test/10/deploy.factor @@ -4,7 +4,6 @@ H{ { deploy-unicode? f } { deploy-io 2 } { deploy-word-props? f } - { deploy-compiler? f } { deploy-threads? f } { deploy-word-defs? f } { "stop-after-last-window?" t } diff --git a/basis/tools/deploy/test/11/deploy.factor b/basis/tools/deploy/test/11/deploy.factor index 42f707b332..4828f70d90 100644 --- a/basis/tools/deploy/test/11/deploy.factor +++ b/basis/tools/deploy/test/11/deploy.factor @@ -9,7 +9,6 @@ H{ { deploy-math? f } { deploy-unicode? f } { deploy-threads? f } - { deploy-compiler? f } { deploy-io 2 } { deploy-ui? f } } diff --git a/basis/tools/deploy/test/12/deploy.factor b/basis/tools/deploy/test/12/deploy.factor index 638e1ca000..a3aaa3bca2 100644 --- a/basis/tools/deploy/test/12/deploy.factor +++ b/basis/tools/deploy/test/12/deploy.factor @@ -9,7 +9,6 @@ H{ { deploy-io 2 } { deploy-ui? f } { deploy-name "tools.deploy.test.12" } - { deploy-compiler? f } { deploy-word-defs? f } { deploy-threads? f } } diff --git a/basis/tools/deploy/test/13/deploy.factor b/basis/tools/deploy/test/13/deploy.factor index 9513192311..d175075c14 100644 --- a/basis/tools/deploy/test/13/deploy.factor +++ b/basis/tools/deploy/test/13/deploy.factor @@ -1,7 +1,6 @@ USING: tools.deploy.config ; H{ { deploy-threads? t } - { deploy-compiler? t } { deploy-math? t } { deploy-io 2 } { "stop-after-last-window?" t } diff --git a/basis/tools/deploy/test/2/deploy.factor b/basis/tools/deploy/test/2/deploy.factor index 1457769ce1..10cd7a85d9 100644 --- a/basis/tools/deploy/test/2/deploy.factor +++ b/basis/tools/deploy/test/2/deploy.factor @@ -8,7 +8,6 @@ H{ { deploy-math? t } { deploy-io 2 } { deploy-name "tools.deploy.test.2" } - { deploy-compiler? t } { deploy-reflection 1 } { "stop-after-last-window?" t } } diff --git a/basis/tools/deploy/test/3/deploy.factor b/basis/tools/deploy/test/3/deploy.factor index f3131237bf..b72b00d1e4 100644 --- a/basis/tools/deploy/test/3/deploy.factor +++ b/basis/tools/deploy/test/3/deploy.factor @@ -6,7 +6,6 @@ H{ { "stop-after-last-window?" t } { deploy-word-defs? f } { deploy-reflection 1 } - { deploy-compiler? t } { deploy-threads? t } { deploy-io 3 } { deploy-math? t } diff --git a/basis/tools/deploy/test/4/deploy.factor b/basis/tools/deploy/test/4/deploy.factor index 981bbcf982..b2f22055c4 100644 --- a/basis/tools/deploy/test/4/deploy.factor +++ b/basis/tools/deploy/test/4/deploy.factor @@ -8,7 +8,6 @@ H{ { deploy-math? t } { deploy-io 2 } { deploy-name "tools.deploy.test.4" } - { deploy-compiler? t } { deploy-reflection 1 } { "stop-after-last-window?" t } } diff --git a/basis/tools/deploy/test/5/deploy.factor b/basis/tools/deploy/test/5/deploy.factor index 22f5021497..3f9b7f1599 100644 --- a/basis/tools/deploy/test/5/deploy.factor +++ b/basis/tools/deploy/test/5/deploy.factor @@ -8,7 +8,6 @@ H{ { deploy-math? t } { deploy-io 3 } { deploy-name "tools.deploy.test.5" } - { deploy-compiler? t } { deploy-reflection 1 } { "stop-after-last-window?" t } } diff --git a/basis/tools/deploy/test/6/deploy.factor b/basis/tools/deploy/test/6/deploy.factor index c474fcdadf..b86bfdb31a 100644 --- a/basis/tools/deploy/test/6/deploy.factor +++ b/basis/tools/deploy/test/6/deploy.factor @@ -5,7 +5,6 @@ H{ { deploy-io 1 } { deploy-name "tools.deploy.test.6" } { deploy-math? t } - { deploy-compiler? t } { deploy-ui? f } { deploy-c-types? f } { deploy-word-defs? f } diff --git a/basis/tools/deploy/test/7/deploy.factor b/basis/tools/deploy/test/7/deploy.factor index bc374f1088..d1e93fc7c2 100644 --- a/basis/tools/deploy/test/7/deploy.factor +++ b/basis/tools/deploy/test/7/deploy.factor @@ -6,7 +6,6 @@ H{ { deploy-io 2 } { deploy-math? t } { "stop-after-last-window?" t } - { deploy-compiler? t } { deploy-unicode? f } { deploy-c-types? f } { deploy-reflection 1 } diff --git a/basis/tools/deploy/test/8/8.factor b/basis/tools/deploy/test/8/8.factor deleted file mode 100644 index c495928bf2..0000000000 --- a/basis/tools/deploy/test/8/8.factor +++ /dev/null @@ -1,11 +0,0 @@ -USING: kernel ; -IN: tools.deploy.test.8 - -: literal-merge-test-1 ( -- x ) H{ { "lil" "wayne" } } ; -: literal-merge-test-2 ( -- x ) H{ { "lil" "wayne" } } ; - -: literal-merge-test ( -- ) - literal-merge-test-1 - literal-merge-test-2 eq? t assert= ; - -MAIN: literal-merge-test diff --git a/basis/tools/deploy/test/8/deploy.factor b/basis/tools/deploy/test/8/deploy.factor deleted file mode 100644 index 3bea1edfc7..0000000000 --- a/basis/tools/deploy/test/8/deploy.factor +++ /dev/null @@ -1,15 +0,0 @@ -USING: tools.deploy.config ; -H{ - { deploy-name "tools.deploy.test.8" } - { deploy-c-types? f } - { deploy-word-props? f } - { deploy-ui? f } - { deploy-reflection 1 } - { deploy-compiler? f } - { deploy-unicode? f } - { deploy-io 1 } - { deploy-word-defs? f } - { deploy-threads? f } - { "stop-after-last-window?" t } - { deploy-math? f } -} diff --git a/basis/tools/deploy/test/9/deploy.factor b/basis/tools/deploy/test/9/deploy.factor index 91b1da5697..caddbe36d0 100644 --- a/basis/tools/deploy/test/9/deploy.factor +++ b/basis/tools/deploy/test/9/deploy.factor @@ -6,7 +6,6 @@ H{ { "stop-after-last-window?" t } { deploy-word-defs? f } { deploy-reflection 1 } - { deploy-compiler? t } { deploy-threads? f } { deploy-io 1 } { deploy-math? t } diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor index 6a8322ac02..d3c1278bf5 100644 --- a/basis/ui/tools/deploy/deploy.factor +++ b/basis/ui/tools/deploy/deploy.factor @@ -29,7 +29,6 @@ TUPLE: deploy-gadget < pack vocab settings ; : advanced-settings ( parent -- parent ) "Advanced:"