From e490e9b636dc045d53935c1ac86346af68650ae8 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 01:48:29 -0500 Subject: [PATCH 1/5] refactor hardware-info a bit --- extra/hardware-info/backend/backend.factor | 3 +-- extra/hardware-info/hardware-info.factor | 15 ++++++++---- extra/hardware-info/macosx/macosx.factor | 28 ++++++++++++---------- extra/hardware-info/windows/ce/ce.factor | 19 +++++++-------- extra/hardware-info/windows/nt/nt.factor | 21 +++++++--------- 5 files changed, 44 insertions(+), 42 deletions(-) diff --git a/extra/hardware-info/backend/backend.factor b/extra/hardware-info/backend/backend.factor index 17794c196d..95a56da2d2 100644 --- a/extra/hardware-info/backend/backend.factor +++ b/extra/hardware-info/backend/backend.factor @@ -1,8 +1,7 @@ +USING: system ; IN: hardware-info.backend -SYMBOL: os HOOK: cpus os ( -- n ) - HOOK: memory-load os ( -- n ) HOOK: physical-mem os ( -- n ) HOOK: available-mem os ( -- n ) diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor index ecdcc42cb5..6d27cf5252 100755 --- a/extra/hardware-info/hardware-info.factor +++ b/extra/hardware-info/hardware-info.factor @@ -1,10 +1,13 @@ -USING: alien.syntax kernel math prettyprint +USING: alien.syntax kernel math prettyprint io math.parser combinators vocabs.loader hardware-info.backend system ; IN: hardware-info -: kb. ( x -- ) 10 2^ /f . ; -: megs. ( x -- ) 20 2^ /f . ; -: gigs. ( x -- ) 30 2^ /f . ; +: write-unit ( x n str -- ) + [ 2^ /i number>string write bl ] [ write ] bi* ; + +: kb ( x -- ) 10 "kB" write-unit ; +: megs ( x -- ) 20 "MB" write-unit ; +: gigs ( x -- ) 30 "GB" write-unit ; << { { [ os windows? ] [ "hardware-info.windows" ] } @@ -12,3 +15,7 @@ IN: hardware-info { [ os macosx? ] [ "hardware-info.macosx" ] } { [ t ] [ f ] } } cond [ require ] when* >> + +: hardware-report. ( -- ) + "CPUs: " write cpus number>string write nl + "Physical RAM: " write physical-mem megs nl ; diff --git a/extra/hardware-info/macosx/macosx.factor b/extra/hardware-info/macosx/macosx.factor index c246a95186..dac052a1de 100644 --- a/extra/hardware-info/macosx/macosx.factor +++ b/extra/hardware-info/macosx/macosx.factor @@ -1,10 +1,8 @@ USING: alien alien.c-types alien.syntax byte-arrays kernel -namespaces sequences unix hardware-info.backend ; +namespaces sequences unix hardware-info.backend system +io.unix.backend ; IN: hardware-info.macosx -TUPLE: macosx ; -T{ macosx } os set-global - ! See /usr/include/sys/sysctl.h for constants LIBRARY: libc @@ -14,14 +12,11 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi [ ] map concat ; : (sysctl-query) ( name namelen oldp oldlenp -- oldp error/f ) - over >r - f 0 sysctl -1 = [ err_no strerror ] [ f ] if - r> swap ; + over >r f 0 sysctl io-error r> ; : sysctl-query ( seq n -- byte-array ) - >r [ make-int-array ] keep length r> - [ ] keep - (sysctl-query) [ throw ] when* ; + >r [ make-int-array ] [ length ] bi r> + [ ] [ ] bi (sysctl-query) ; : sysctl-query-string ( seq -- n ) 4096 sysctl-query alien>char-string ; @@ -36,8 +31,15 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi : model ( -- str ) { 6 2 } sysctl-query-string ; M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ; : byte-order ( -- n ) { 6 4 } sysctl-query-uint ; -: user-mem ( -- n ) { 6 4 } sysctl-query-uint ; +M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ; +: user-mem ( -- n ) { 6 6 } sysctl-query-uint ; : page-size ( -- n ) { 6 7 } sysctl-query-uint ; +: disknames ( -- n ) { 6 8 } 8 sysctl-query ; +: diskstats ( -- n ) { 6 9 } 8 sysctl-query ; +: epoch ( -- n ) { 6 10 } sysctl-query-uint ; +: floating-point ( -- n ) { 6 11 } sysctl-query-uint ; +: machine-arch ( -- n ) { 6 12 } sysctl-query-string ; +: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ; : bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ; : cpu-frequency ( -- n ) { 6 15 } sysctl-query-uint ; : cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ; @@ -47,7 +49,7 @@ M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ; : l2-cache-size ( -- n ) { 6 20 } sysctl-query-uint ; : l3-cache-settings ( -- n ) { 6 21 } sysctl-query-uint ; : l3-cache-size ( -- n ) { 6 22 } sysctl-query-uint ; -: bus-frequency2 ( -- n ) { 6 23 } sysctl-query-uint ; -M: macosx physical-mem ( -- n ) { 6 24 } sysctl-query-ulonglong ; +: tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ; +: mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ; : available-cpus ( -- n ) { 6 25 } sysctl-query-uint ; diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor index f671ea9426..55c2ac6c0d 100755 --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/hardware-info/windows/ce/ce.factor @@ -2,33 +2,30 @@ USING: alien.c-types hardware-info kernel math namespaces windows windows.kernel32 hardware-info.backend ; IN: hardware-info.windows.ce -TUPLE: wince-os ; -T{ wince-os } os set-global - : memory-status ( -- MEMORYSTATUS ) "MEMORYSTATUS" "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength [ GlobalMemoryStatus ] keep ; -M: wince-os cpus ( -- n ) 1 ; +M: wince cpus ( -- n ) 1 ; -M: wince-os memory-load ( -- n ) +M: wince memory-load ( -- n ) memory-status MEMORYSTATUS-dwMemoryLoad ; -M: wince-os physical-mem ( -- n ) +M: wince physical-mem ( -- n ) memory-status MEMORYSTATUS-dwTotalPhys ; -M: wince-os available-mem ( -- n ) +M: wince available-mem ( -- n ) memory-status MEMORYSTATUS-dwAvailPhys ; -M: wince-os total-page-file ( -- n ) +M: wince total-page-file ( -- n ) memory-status MEMORYSTATUS-dwTotalPageFile ; -M: wince-os available-page-file ( -- n ) +M: wince available-page-file ( -- n ) memory-status MEMORYSTATUS-dwAvailPageFile ; -M: wince-os total-virtual-mem ( -- n ) +M: wince total-virtual-mem ( -- n ) memory-status MEMORYSTATUS-dwTotalVirtual ; -M: wince-os available-virtual-mem ( -- n ) +M: wince available-virtual-mem ( -- n ) memory-status MEMORYSTATUS-dwAvailVirtual ; diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor index 8bdb75fe6a..ba9c1d74b5 100755 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -1,15 +1,12 @@ USING: alien alien.c-types kernel libc math namespaces hardware-info.backend -windows windows.advapi32 windows.kernel32 ; +windows windows.advapi32 windows.kernel32 system ; IN: hardware-info.windows.nt -TUPLE: winnt-os ; -T{ winnt-os } os set-global - : system-info ( -- SYSTEM_INFO ) "SYSTEM_INFO" [ GetSystemInfo ] keep ; -M: winnt-os cpus ( -- n ) +M: winnt cpus ( -- n ) system-info SYSTEM_INFO-dwNumberOfProcessors ; : memory-status ( -- MEMORYSTATUSEX ) @@ -17,25 +14,25 @@ M: winnt-os cpus ( -- n ) "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength [ GlobalMemoryStatusEx ] keep swap zero? [ win32-error ] when ; -M: winnt-os memory-load ( -- n ) +M: winnt memory-load ( -- n ) memory-status MEMORYSTATUSEX-dwMemoryLoad ; -M: winnt-os physical-mem ( -- n ) +M: winnt physical-mem ( -- n ) memory-status MEMORYSTATUSEX-ullTotalPhys ; -M: winnt-os available-mem ( -- n ) +M: winnt available-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailPhys ; -M: winnt-os total-page-file ( -- n ) +M: winnt total-page-file ( -- n ) memory-status MEMORYSTATUSEX-ullTotalPageFile ; -M: winnt-os available-page-file ( -- n ) +M: winnt available-page-file ( -- n ) memory-status MEMORYSTATUSEX-ullAvailPageFile ; -M: winnt-os total-virtual-mem ( -- n ) +M: winnt total-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullTotalVirtual ; -M: winnt-os available-virtual-mem ( -- n ) +M: winnt available-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailVirtual ; : computer-name ( -- string ) From d642347f341e3820a3167e1c9c7e489d42928858 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 11:55:08 -0500 Subject: [PATCH 2/5] move bit twiddling words to math.bitfields.lib use 32-bit in mersenne-twister --- extra/crypto/common/common-docs.factor | 17 ------------- extra/crypto/common/common.factor | 24 ++----------------- extra/crypto/sha1/sha1.factor | 4 ++-- extra/crypto/sha2/sha2.factor | 20 ++++++++-------- extra/math/functions/functions.factor | 9 ------- .../mersenne-twister/mersenne-twister.factor | 13 ++++------ 6 files changed, 19 insertions(+), 68 deletions(-) diff --git a/extra/crypto/common/common-docs.factor b/extra/crypto/common/common-docs.factor index b53ecaac3c..559c7934d0 100644 --- a/extra/crypto/common/common-docs.factor +++ b/extra/crypto/common/common-docs.factor @@ -2,23 +2,6 @@ USING: help.markup help.syntax kernel math sequences quotations math.private ; IN: crypto.common -HELP: >32-bit -{ $values { "x" integer } { "y" integer } } -{ $description "Used to implement 32-bit integer overflow." } ; - -HELP: >64-bit -{ $values { "x" integer } { "y" integer } } -{ $description "Used to implement 64-bit integer overflow." } ; - -HELP: bitroll -{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } } -{ $description "Roll n by s bits to the left, wrapping around after w bits." } -{ $examples - { $example "USING: crypto.common prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" } - { $example "USING: crypto.common prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" } -} ; - - HELP: hex-string { $values { "seq" "a sequence" } { "str" "a string" } } { $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." } diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor index 3ac551d114..f0129772b0 100644 --- a/extra/crypto/common/common.factor +++ b/extra/crypto/common/common.factor @@ -1,11 +1,8 @@ USING: arrays kernel io io.binary sbufs splitting strings sequences -namespaces math math.parser parser hints ; +namespaces math math.parser parser hints math.bitfields.lib ; IN: crypto.common -: >32-bit ( x -- y ) HEX: ffffffff bitand ; inline -: >64-bit ( x -- y ) HEX: ffffffffffffffff bitand ; inline - -: w+ ( int int -- int ) + >32-bit ; inline +: w+ ( int int -- int ) + 32-bit ; inline : (nth-int) ( string n -- int ) 2 shift dup 4 + rot ; inline @@ -39,26 +36,9 @@ SYMBOL: big-endian? 3 shift 8 rot [ >be ] [ >le ] if % ] "" make 64 group ; -: shift-mod ( n s w -- n ) - >r shift r> 2^ 1- bitand ; inline - : update-old-new ( old new -- ) [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline -: bitroll ( x s w -- y ) - [ 1 - bitand ] keep - over 0 < [ [ + ] keep ] when - [ shift-mod ] 3keep - [ - ] keep shift-mod bitor ; inline - -: bitroll-32 ( n s -- n' ) 32 bitroll ; - -HINTS: bitroll-32 bignum fixnum ; - -: bitroll-64 ( n s -- n' ) 64 bitroll ; - -HINTS: bitroll-64 bignum fixnum ; - : hex-string ( seq -- str ) [ [ >hex 2 48 pad-left % ] each ] "" make ; diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index 8f3d3e6ecc..7e8677a117 100755 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -1,7 +1,7 @@ USING: arrays combinators crypto.common kernel io io.encodings.binary io.files io.streams.byte-array math.vectors strings sequences namespaces math parser sequences vectors -io.binary hashtables symbols ; +io.binary hashtables symbols math.bitfields.lib ; IN: crypto.sha1 ! Implemented according to RFC 3174. @@ -66,7 +66,7 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; K get nth , A get 5 bitroll-32 , E get , - ] { } make sum >32-bit ; inline + ] { } make sum 32-bit ; inline : set-vars ( temp -- ) ! E = D; D = C; C = S^30(B); B = A; A = TEMP; diff --git a/extra/crypto/sha2/sha2.factor b/extra/crypto/sha2/sha2.factor index daba6d29ff..f555de8b08 100755 --- a/extra/crypto/sha2/sha2.factor +++ b/extra/crypto/sha2/sha2.factor @@ -1,19 +1,19 @@ USING: crypto.common kernel splitting math sequences namespaces -io.binary symbols ; +io.binary symbols math.bitfields.lib ; IN: crypto.sha2 word ; -: a 0 ; -: b 1 ; -: c 2 ; -: d 3 ; -: e 4 ; -: f 5 ; -: g 6 ; -: h 7 ; +: a 0 ; inline +: b 1 ; inline +: c 2 ; inline +: d 3 ; inline +: e 4 ; inline +: f 5 ; inline +: g 6 ; inline +: h 7 ; inline : initial-H-256 ( -- seq ) { @@ -124,7 +124,7 @@ PRIVATE> initial-H-256 H set 4 word-size set 64 block-size set - \ >32-bit >word set + \ 32-bit >word set byte-array>sha2 ] with-scope ; diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor index dcbccb4316..77c7d9247d 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -30,15 +30,6 @@ M: real sqrt 2dup >r >r >r odd? r> call r> 2/ r> each-bit ] if ; inline -: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable -: set-bit ( x n -- y ) 2^ bitor ; foldable -: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable -: bit-set? ( x n -- ? ) bit-clear? not ; foldable -: unmask ( x n -- ? ) bitnot bitand ; foldable -: unmask? ( x n -- ? ) unmask 0 > ; foldable -: mask ( x n -- ? ) bitand ; foldable -: mask? ( x n -- ? ) mask 0 > ; foldable - GENERIC: (^) ( x y -- z ) foldable : ^n ( z w -- z^w ) diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index 77054ea377..2aa6f45897 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -4,7 +4,7 @@ ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c USING: arrays kernel math namespaces sequences system init -accessors math.ranges random circular ; +accessors math.ranges random circular math.bitfields.lib ; IN: random.mersenne-twister r mt-n r> seq>> [ [ (mt-generate) ] keep set-generated ] curry each ] [ 0 >>i drop ] bi ; -: init-mt-first ( seed -- seq ) - >r mt-n 0 r> - HEX: ffffffff bitand 0 pick set-nth ; - : init-mt-formula ( seq i -- f(seq[i]) ) tuck swap nth dup -30 shift bitxor 1812433253 * + - 1+ HEX: ffffffff bitand ; + 1+ 32-bit ; : init-mt-rest ( seq -- ) - mt-n 1- [0,b) [ + mt-n 1- [ dupd [ init-mt-formula ] keep 1+ rot set-nth ] with each ; : init-mt-seq ( seed -- seq ) - init-mt-first dup init-mt-rest ; + 32-bit mt-n 0 + [ set-first ] [ init-mt-rest ] [ ] tri ; : mt-temper ( y -- yt ) dup -11 shift bitxor From 5c2b2b024e1c0b6a4332d752d68f119048b56d4a Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 13:04:24 -0500 Subject: [PATCH 3/5] more cleanup of mersenne-twister -- you can actually understand it now :) --- .../mersenne-twister/mersenne-twister.factor | 55 ++++++++++--------- 1 file changed, 29 insertions(+), 26 deletions(-) diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index 2aa6f45897..d3a5fad4ca 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. ! mersenne twister based on ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c - USING: arrays kernel math namespaces sequences system init -accessors math.ranges random circular math.bitfields.lib ; +accessors math.ranges random circular math.bitfields.lib +combinators ; IN: random.mersenne-twister r >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi - r> bitxor bitxor r> r> set-nth ; inline : calculate-y ( y1 y2 mt -- y ) - tuck [ nth mt-hi ] [ nth mt-lo ] 2bi* bitor ; inline + tuck + [ nth 32 mask-bit ] + [ nth 31 bits ] 2bi* bitor ; inline -: (mt-generate) ( n mt-seq -- y to from-elt ) - [ >r dup 1+ r> calculate-y ] - [ >r mt-m + r> nth ] - [ drop ] 2tri ; +: (mt-generate) ( n mt-seq -- next-mt ) + [ + [ dup 1+ ] [ calculate-y ] bi* + [ 2/ ] [ odd? mt-a 0 ? ] bi bitxor + ] [ + [ mt-m + ] [ nth ] bi* + ] 2bi bitxor ; : mt-generate ( mt -- ) - [ >r mt-n r> seq>> [ [ (mt-generate) ] keep set-generated ] curry each ] - [ 0 >>i drop ] bi ; + [ + mt-n swap seq>> [ + [ (mt-generate) ] [ set-nth ] 2bi + ] curry each + ] [ 0 >>i drop ] bi ; -: init-mt-formula ( seq i -- f(seq[i]) ) - tuck swap nth dup -30 shift bitxor 1812433253 * + - 1+ 32-bit ; +: init-mt-formula ( i seq -- f(seq[i]) ) + dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; : init-mt-rest ( seq -- ) - mt-n 1- [ - dupd [ init-mt-formula ] keep 1+ rot set-nth - ] with each ; + mt-n 1- swap [ + [ init-mt-formula ] [ >r 1+ r> set-nth ] 2bi + ] curry each ; : init-mt-seq ( seed -- seq ) - 32-bit mt-n 0 + 32 bits mt-n 0 [ set-first ] [ init-mt-rest ] [ ] tri ; : mt-temper ( y -- yt ) @@ -52,6 +53,9 @@ TUPLE: mersenne-twister seq i ; dup 15 shift HEX: efc60000 bitand bitxor dup -18 shift bitxor ; inline +: next-index ( mt -- i ) + dup i>> dup mt-n < [ nip ] [ drop mt-generate 0 ] if ; + PRIVATE> : ( seed -- obj ) @@ -62,7 +66,6 @@ M: mersenne-twister seed-random ( mt seed -- ) init-mt-seq >>seq drop ; M: mersenne-twister random-32* ( mt -- r ) - dup [ i>> ] [ seq>> ] bi - over mt-n < [ nip >r dup mt-generate 0 r> ] unless - nth mt-temper - swap [ 1+ ] change-i drop ; + [ next-index ] + [ seq>> nth mt-temper ] + [ [ 1+ ] change-i drop ] tri ; From 0b90458cca9e82e2e1174edc81324f6e6e29c519 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 13:27:10 -0500 Subject: [PATCH 4/5] simplify bitroll --- extra/crypto/common/common.factor | 2 +- extra/crypto/sha1/sha1.factor | 2 +- extra/crypto/sha2/sha2.factor | 3 +-- extra/math/bitfields/lib/lib-docs.factor | 16 ++++++++++++ extra/math/bitfields/lib/lib-tests.factor | 14 ++++++++++ extra/math/bitfields/lib/lib.factor | 31 +++++++++++++++++++++++ 6 files changed, 64 insertions(+), 4 deletions(-) create mode 100644 extra/math/bitfields/lib/lib-docs.factor create mode 100644 extra/math/bitfields/lib/lib-tests.factor create mode 100644 extra/math/bitfields/lib/lib.factor diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor index f0129772b0..b9f1d43784 100644 --- a/extra/crypto/common/common.factor +++ b/extra/crypto/common/common.factor @@ -2,7 +2,7 @@ USING: arrays kernel io io.binary sbufs splitting strings sequences namespaces math math.parser parser hints math.bitfields.lib ; IN: crypto.common -: w+ ( int int -- int ) + 32-bit ; inline +: w+ ( int int -- int ) + 32 bits ; inline : (nth-int) ( string n -- int ) 2 shift dup 4 + rot ; inline diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index 7e8677a117..d054eda31b 100755 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -66,7 +66,7 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; K get nth , A get 5 bitroll-32 , E get , - ] { } make sum 32-bit ; inline + ] { } make sum 32 bits ; inline : set-vars ( temp -- ) ! E = D; D = C; C = S^30(B); B = A; A = TEMP; diff --git a/extra/crypto/sha2/sha2.factor b/extra/crypto/sha2/sha2.factor index f555de8b08..0acc5c1388 100755 --- a/extra/crypto/sha2/sha2.factor +++ b/extra/crypto/sha2/sha2.factor @@ -4,7 +4,7 @@ IN: crypto.sha2 word ; +SYMBOLS: vars M K H S0 S1 process-M word-size block-size ; : a 0 ; inline : b 1 ; inline @@ -124,7 +124,6 @@ PRIVATE> initial-H-256 H set 4 word-size set 64 block-size set - \ 32-bit >word set byte-array>sha2 ] with-scope ; diff --git a/extra/math/bitfields/lib/lib-docs.factor b/extra/math/bitfields/lib/lib-docs.factor new file mode 100644 index 0000000000..bfbe9eaded --- /dev/null +++ b/extra/math/bitfields/lib/lib-docs.factor @@ -0,0 +1,16 @@ +USING: help.markup help.syntax kernel math sequences ; +IN: math.bitfields.lib + +HELP: bits +{ $values { "m" integer } { "n" integer } { "m'" integer } } +{ $description "Keep only n bits from the integer m." } +{ $example "USING: math.bitfields.lib prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ; + +HELP: bitroll +{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } } +{ $description "Roll n by s bits to the left, wrapping around after w bits." } +{ $examples + { $example "USING: math.bitfields.lib prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" } + { $example "USING: math.bitfields.lib prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" } +} ; + diff --git a/extra/math/bitfields/lib/lib-tests.factor b/extra/math/bitfields/lib/lib-tests.factor new file mode 100644 index 0000000000..c002240e69 --- /dev/null +++ b/extra/math/bitfields/lib/lib-tests.factor @@ -0,0 +1,14 @@ +USING: math.bitfields.lib tools.test ; +IN: math.bitfields.lib.test + +[ 0 ] [ 1 0 0 bitroll ] unit-test +[ 1 ] [ 1 0 1 bitroll ] unit-test +[ 1 ] [ 1 1 1 bitroll ] unit-test +[ 1 ] [ 1 0 2 bitroll ] unit-test +[ 1 ] [ 1 0 1 bitroll ] unit-test +[ 1 ] [ 1 20 2 bitroll ] unit-test +[ 1 ] [ 1 8 8 bitroll ] unit-test +[ 1 ] [ 1 -8 8 bitroll ] unit-test +[ 1 ] [ 1 -32 8 bitroll ] unit-test +[ 128 ] [ 1 -1 8 bitroll ] unit-test +[ 8 ] [ 1 3 32 bitroll ] unit-test diff --git a/extra/math/bitfields/lib/lib.factor b/extra/math/bitfields/lib/lib.factor new file mode 100644 index 0000000000..4a8f3835ca --- /dev/null +++ b/extra/math/bitfields/lib/lib.factor @@ -0,0 +1,31 @@ +USING: hints kernel math ; +IN: math.bitfields.lib + +: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable +: set-bit ( x n -- y ) 2^ bitor ; foldable +: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable +: bit-set? ( x n -- ? ) bit-clear? not ; foldable +: unmask ( x n -- ? ) bitnot bitand ; foldable +: unmask? ( x n -- ? ) unmask 0 > ; foldable +: mask ( x n -- ? ) bitand ; foldable +: mask? ( x n -- ? ) mask 0 > ; foldable +: wrap ( m n -- m' ) 1- bitand ; foldable +: bits ( m n -- m' ) 2^ wrap ; inline +: mask-bit ( m n -- m' ) 1- 2^ mask ; inline + +: shift-mod ( n s w -- n ) + >r shift r> 2^ wrap ; inline + +: bitroll ( x s w -- y ) + [ wrap ] keep + [ shift-mod ] 3keep + [ - ] keep shift-mod bitor ; inline + +: bitroll-32 ( n s -- n' ) 32 bitroll ; + +HINTS: bitroll-32 bignum fixnum ; + +: bitroll-64 ( n s -- n' ) 64 bitroll ; + +HINTS: bitroll-64 bignum fixnum ; + From 53d21c6c7a8c69351147b4ce73ba4a869b086ed0 Mon Sep 17 00:00:00 2001 From: erg Date: Thu, 3 Apr 2008 13:57:33 -0500 Subject: [PATCH 5/5] cleanup in aisle crypto --- extra/crypto/barrett/barrett.factor | 8 +++++++- extra/crypto/common/common.factor | 3 +-- extra/crypto/hmac/hmac-tests.factor | 1 - extra/crypto/hmac/hmac.factor | 1 - extra/crypto/md5/md5.factor | 6 +++--- extra/crypto/rsa/rsa.factor | 6 +++--- extra/crypto/test/common.factor | 15 --------------- extra/crypto/timing/timing.factor | 5 ++--- extra/crypto/xor/xor.factor | 6 +++--- 9 files changed, 19 insertions(+), 32 deletions(-) delete mode 100644 extra/crypto/test/common.factor diff --git a/extra/crypto/barrett/barrett.factor b/extra/crypto/barrett/barrett.factor index 55da97202f..4a070190e3 100644 --- a/extra/crypto/barrett/barrett.factor +++ b/extra/crypto/barrett/barrett.factor @@ -4,5 +4,11 @@ IN: crypto.barrett : barrett-mu ( n size -- mu ) #! Calculates Barrett's reduction parameter mu #! size = word size in bits (8, 16, 32, 64, ...) - over log2 1+ over / 2 * >r 2 swap ^ r> ^ swap / floor ; + ! over log2 1+ over / 2 * >r 2 swap ^ r> ^ swap / floor ; + [ + [ log2 1+ ] [ / 2 * ] bi* + ] [ + 2^ rot ^ swap /i + ] 2bi ; + diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor index b9f1d43784..a714727ad9 100644 --- a/extra/crypto/common/common.factor +++ b/extra/crypto/common/common.factor @@ -50,9 +50,8 @@ SYMBOL: big-endian? : 2seq>seq ( seq1 seq2 -- seq ) #! { aceg } { bdfh } -> { abcdefgh } - swap ! error? [ 2array flip concat ] keep like ; : mod-nth ( n seq -- elt ) #! 5 "abcd" -> b - [ length mod ] keep nth ; + [ length mod ] [ nth ] bi ; diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor index fa0cbef4c7..eff95bbcd6 100755 --- a/extra/crypto/hmac/hmac-tests.factor +++ b/extra/crypto/hmac/hmac-tests.factor @@ -9,4 +9,3 @@ IN: crypto.hmac.tests [ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test [ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test [ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa 50 HEX: dd >byte-array byte-array>sha1-hmac >string ] unit-test - diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor index 3dad01fe3a..91d404aead 100755 --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -37,7 +37,6 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; : byte-array>sha1-hmac ( K string -- hmac ) binary stream>sha1-hmac ; - : stream>md5-hmac ( K stream -- hmac ) [ init-hmac md5-hmac ] with-stream ; diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor index 7ecbd767b9..45e10da74d 100755 --- a/extra/crypto/md5/md5.factor +++ b/extra/crypto/md5/md5.factor @@ -3,7 +3,7 @@ USING: kernel io io.binary io.files io.streams.byte-array math math.functions math.parser namespaces splitting strings sequences crypto.common byte-arrays locals sequences.private -io.encodings.binary symbols ; +io.encodings.binary symbols math.bitfields.lib ; IN: crypto.md5 r bitand r> bitor ; + pick bitnot bitand [ bitand ] [ bitor ] bi* ; : G ( X Y Z -- GXYZ ) #! G(X,Y,Z) = XZ v Y not(Z) - dup bitnot rot bitand >r bitand r> bitor ; + dup bitnot rot bitand [ bitand ] [ bitor ] bi* ; : H ( X Y Z -- HXYZ ) #! H(X,Y,Z) = X xor Y xor Z diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor index ccf17da4e8..5d3228db10 100644 --- a/extra/crypto/rsa/rsa.factor +++ b/extra/crypto/rsa/rsa.factor @@ -1,5 +1,5 @@ USING: math.miller-rabin kernel math math.functions namespaces -sequences ; +sequences accessors ; IN: crypto.rsa ! The private key is the only secret. @@ -39,7 +39,7 @@ PRIVATE> public-key ; : rsa-encrypt ( message rsa -- encrypted ) - [ rsa-public-key ] keep rsa-modulus ^mod ; + [ public-key>> ] [ modulus>> ] bi ^mod ; : rsa-decrypt ( encrypted rsa -- message ) - [ rsa-private-key ] keep rsa-modulus ^mod ; \ No newline at end of file + [ private-key>> ] [ modulus>> ] bi ^mod ; diff --git a/extra/crypto/test/common.factor b/extra/crypto/test/common.factor deleted file mode 100644 index 6050454402..0000000000 --- a/extra/crypto/test/common.factor +++ /dev/null @@ -1,15 +0,0 @@ -USING: kernel math test namespaces crypto ; - -[ 0 ] [ 1 0 0 bitroll ] unit-test -[ 1 ] [ 1 0 1 bitroll ] unit-test -[ 1 ] [ 1 1 1 bitroll ] unit-test -[ 1 ] [ 1 0 2 bitroll ] unit-test -[ 1 ] [ 1 0 1 bitroll ] unit-test -[ 1 ] [ 1 20 2 bitroll ] unit-test -[ 1 ] [ 1 8 8 bitroll ] unit-test -[ 1 ] [ 1 -8 8 bitroll ] unit-test -[ 1 ] [ 1 -32 8 bitroll ] unit-test -[ 128 ] [ 1 -1 8 bitroll ] unit-test -[ 8 ] [ 1 3 32 bitroll ] unit-test - - diff --git a/extra/crypto/timing/timing.factor b/extra/crypto/timing/timing.factor index da2603d92c..a17d65d90b 100644 --- a/extra/crypto/timing/timing.factor +++ b/extra/crypto/timing/timing.factor @@ -1,7 +1,6 @@ USING: kernel math threads system ; IN: crypto.timing -: with-timing ( ... quot n -- ) +: with-timing ( quot n -- ) #! force the quotation to execute in, at minimum, n milliseconds - millis 2slip millis - + sleep ; - + millis 2slip millis - + sleep ; inline diff --git a/extra/crypto/xor/xor.factor b/extra/crypto/xor/xor.factor index 0713e19843..247387ebdf 100644 --- a/extra/crypto/xor/xor.factor +++ b/extra/crypto/xor/xor.factor @@ -1,8 +1,8 @@ USING: crypto.common kernel math sequences ; IN: crypto.xor -TUPLE: no-xor-key ; +ERROR: no-xor-key ; -: xor-crypt ( key seq -- seq ) - over empty? [ no-xor-key construct-empty throw ] when +: xor-crypt ( key seq -- seq' ) + over empty? [ no-xor-key ] when dup length rot [ mod-nth bitxor ] curry 2map ;