Fixing basis -> extra dependencies

db4
Slava Pestov 2008-09-05 19:29:14 -05:00
parent dc88d45762
commit aea0fed14c
154 changed files with 448 additions and 452 deletions

View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
!
! Channels - based on ideas from newsqueak
USING: kernel sequences sequences.lib threads continuations
random math accessors ;
USING: kernel sequences threads continuations
random math accessors random ;
IN: channels
TUPLE: channel receivers senders ;

View File

@ -0,0 +1,21 @@
! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.bitwise strings io.binary namespaces
grouping ;
IN: checksums.common
SYMBOL: bytes-read
: calculate-pad-length ( length -- pad-length )
dup 56 < 55 119 ? swap - ;
: pad-last-block ( str big-endian? length -- str )
[
rot %
HEX: 80 ,
dup HEX: 3f bitand calculate-pad-length 0 <string> %
3 shift 8 rot [ >be ] [ >le ] if %
] "" make 64 group ;
: update-old-new ( old new -- )
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline

View File

@ -0,0 +1 @@
Some code shared by MD5, SHA1 and SHA2 implementations

View File

@ -1,11 +1,14 @@
! See http://www.faqs.org/rfcs/rfc1321.html
! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting grouping strings
sequences crypto.common byte-arrays locals sequences.private
io.encodings.binary symbols math.bitfields.lib checksums ;
sequences byte-arrays locals sequences.private
io.encodings.binary symbols math.bitwise checksums
checksums.common ;
IN: checksums.md5
! See http://www.faqs.org/rfcs/rfc1321.html
<PRIVATE
SYMBOLS: a b c d old-a old-b old-c old-d ;

View File

@ -1,7 +1,9 @@
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 math.bitfields.lib checksums ;
! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel io io.encodings.binary io.files
io.streams.byte-array math.vectors strings sequences namespaces
math parser sequences assocs grouping vectors io.binary hashtables
symbols math.bitwise checksums checksums.common ;
IN: checksums.sha1
! Implemented according to RFC 3174.
@ -45,6 +47,9 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
{ 3 [ bitxor bitxor ] }
} case ;
: nth-int-be ( string n -- int )
4 * dup 4 + rot <slice> be> ; inline
: make-w ( str -- )
#! compute w, steps a-b of RFC 3174, section 6.1
16 [ nth-int-be w get push ] with each
@ -113,6 +118,14 @@ INSTANCE: sha1 checksum
M: sha1 checksum-stream ( stream -- sha1 )
drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;
: seq>2seq ( seq -- seq1 seq2 )
#! { abcdefgh } -> { aceg } { bdfh }
2 group flip dup empty? [ drop { } { } ] [ first2 ] if ;
: 2seq>seq ( seq1 seq2 -- seq )
#! { aceg } { bdfh } -> { abcdefgh }
[ zip concat ] keep like ;
: sha1-interleave ( string -- seq )
[ zero? ] left-trim
dup length odd? [ rest ] when

View File

@ -1,6 +1,8 @@
USING: crypto.common kernel splitting grouping
math sequences namespaces io.binary symbols
math.bitfields.lib checksums ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel splitting grouping math sequences namespaces
io.binary symbols math.bitwise checksums checksums.common
sbufs strings ;
IN: checksums.sha2
<PRIVATE
@ -81,6 +83,8 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
[ -11 bitroll-32 ] keep
-25 bitroll-32 bitxor bitxor ; inline
: slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ; inline
: T1 ( W n -- T1 )
[ swap nth ] keep
K get nth +
@ -112,6 +116,15 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
: seq>byte-array ( n seq -- string )
[ swap [ >be % ] curry each ] B{ } make ;
: preprocess-plaintext ( string big-endian? -- padded-string )
#! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
>r >sbuf r> over [
HEX: 80 ,
dup length HEX: 3f bitand
calculate-pad-length 0 <string> %
length 3 shift 8 rot [ >be ] [ >le ] if %
] "" make over push-all ;
: byte-array>sha2 ( byte-array -- string )
t preprocess-plaintext
block-size get group [ process-chunk ] each

View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math cocoa cocoa.messages cocoa.classes
sequences math.bitfields ;
sequences math.bitwise ;
IN: cocoa.windows
: NSBorderlessWindowMask 0 ; inline

View File

@ -3,7 +3,7 @@
USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces sequences words
quotations strings alien.accessors alien.strings layouts system
combinators math.bitfields words.private cpu.architecture
combinators math.bitwise words.private cpu.architecture
math.order accessors growable ;
IN: compiler.generator.fixup

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.generator.fixup kernel namespaces sequences
words math math.bitfields io.binary parser lexer ;
words math math.bitwise io.binary parser lexer ;
IN: cpu.ppc.assembler.backend
: insn ( operand opcode -- ) { 26 0 } bitfield , ;

View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations destructors kernel math
namespaces sequences sequences.lib classes.tuple words strings
tools.walker accessors combinators.lib combinators ;
namespaces sequences classes.tuple words strings
tools.walker accessors combinators ;
IN: db
TUPLE: db

View File

@ -4,8 +4,8 @@ USING: arrays assocs alien alien.syntax continuations io
kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators sequences.lib classes locals words tools.walker
namespaces.lib accessors random db.queries destructors ;
combinators classes locals words tools.walker
nmake accessors random db.queries destructors ;
USE: tools.walker
IN: db.postgresql

View File

@ -1,9 +1,8 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math namespaces sequences random
strings math.parser math.intervals combinators
math.bitfields.lib namespaces.lib db db.tuples db.types
sequences.lib db.sql classes words shuffle arrays ;
USING: accessors kernel math namespaces sequences random strings
math.parser math.intervals combinators math.bitwise nmake db
db.tuples db.types db.sql classes words shuffle arrays ;
IN: db.queries
GENERIC: where ( specs obj -- )
@ -142,8 +141,8 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
: make-query ( tuple query -- tuple' )
dupd
{
[ group>> [ do-group ] [ drop ] if-seq ]
[ order>> [ do-order ] [ drop ] if-seq ]
[ group>> [ drop ] [ do-group ] if-empty ]
[ order>> [ drop ] [ do-order ] if-empty ]
[ limit>> [ do-limit ] [ drop ] if* ]
[ offset>> [ do-offset ] [ drop ] if* ]
} 2cleave ;

View File

@ -1,6 +1,6 @@
USING: kernel parser quotations classes.tuple words math.order
namespaces.lib namespaces sequences arrays combinators
prettyprint strings math.parser sequences.lib math symbols ;
nmake namespaces sequences arrays combinators
prettyprint strings math.parser math symbols ;
IN: db.sql
SYMBOLS: insert update delete select distinct columns from as

View File

@ -1,13 +1,11 @@
! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays assocs classes compiler db
hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators math.intervals
io namespaces.lib accessors vectors math.ranges random
math.bitfields.lib db.queries destructors ;
USE: tools.walker
USING: alien arrays assocs classes compiler db hashtables
io.files kernel math math.parser namespaces prettyprint
sequences strings classes.tuple alien.c-types continuations
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
math.intervals io nmake accessors vectors math.ranges random
math.bitwise db.queries destructors ;
IN: db.sqlite
TUPLE: sqlite-db < db path ;

View File

@ -3,8 +3,8 @@
USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitfields.lib
math.ranges strings sequences.lib urls fry ;
db.postgresql accessors random math.bitwise
math.ranges strings urls fry ;
IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real

View File

@ -3,7 +3,7 @@
USING: arrays assocs classes db kernel namespaces
classes.tuple words sequences slots math accessors
math.parser io prettyprint db.types continuations
destructors mirrors sequences.lib combinators.lib ;
destructors mirrors ;
IN: db.tuples
: define-persistent ( class table columns -- )
@ -71,13 +71,14 @@ SINGLETON: retryable
] 2map >>bind-params ;
M: retryable execute-statement* ( statement type -- )
drop [
drop [ retries>> ] [
[
nip
[ query-results dispose t ]
[ ]
[ regenerate-params bind-statement* f ] cleanup
] curry
] [ retries>> ] bi retry drop ;
] bi attempt-all drop ;
: resulting-tuple ( class row out-params -- tuple )
rot class new [
@ -159,7 +160,8 @@ M: retryable execute-statement* ( statement type -- )
dup dup class <select-by-slots-statement> do-select ;
: select-tuple ( tuple -- tuple/f )
dup dup class \ query new 1 >>limit <query> do-select ?first ;
dup dup class \ query new 1 >>limit <query> do-select
[ f ] [ first ] if-empty ;
: do-count ( exemplar-tuple statement -- tuples )
[

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep sequences.lib
sequences continuations sequences.deep
words namespaces slots slots.private classes mirrors
classes.tuple combinators calendar.format symbols
classes.singleton accessors quotations random ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors strings namespaces assocs hashtables
mirrors math fry sequences sequences.lib words continuations ;
mirrors math fry sequences words continuations ;
IN: html.forms
TUPLE: form errors values validation-failed ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel combinators math namespaces
assocs assocs.lib sequences splitting sorting sets debugger
assocs sequences splitting sorting sets debugger
strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format present
@ -27,9 +27,12 @@ IN: http
: (read-header) ( -- alist )
[ read-crlf dup f like ] [ parse-header-line ] [ drop ] produce ;
: collect-headers ( assoc -- assoc' )
H{ } clone [ '[ , push-at ] assoc-each ] keep ;
: process-header ( alist -- assoc )
f swap [ [ swap or dup ] dip swap ] assoc-map nip
[ ?push ] histogram [ "; " join ] assoc-map
collect-headers [ "; " join ] assoc-map
>hashtable ;
: read-header ( -- assoc )

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.ports io.unix.backend io.files io
unix unix.stat unix.time kernel math continuations
math.bitfields byte-arrays alien combinators calendar
math.bitwise byte-arrays alien combinators calendar
io.encodings.binary accessors sequences strings system
io.files.private destructors ;

View File

@ -1,4 +1,4 @@
USING: kernel io.ports io.unix.backend math.bitfields
USING: kernel io.ports io.unix.backend math.bitwise
unix io.files.unique.backend system ;
IN: io.unix.files.unique

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel math math.bitfields namespaces
USING: alien.c-types kernel math math.bitwise namespaces
locals accessors combinators threads vectors hashtables
sequences assocs continuations sets
unix unix.time unix.kqueue unix.process

View File

@ -4,7 +4,7 @@ USING: kernel io.backend io.monitors io.monitors.recursive
io.files io.buffers io.monitors io.ports io.timeouts
io.unix.backend io.unix.select io.encodings.utf8
unix.linux.inotify assocs namespaces threads continuations init
math math.bitfields sets alien alien.strings alien.c-types
math math.bitwise sets alien alien.strings alien.c-types
vocabs.loader accessors system hashtables destructors unix ;
IN: io.unix.linux.monitors

View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien io io.files kernel math math.bitfields system unix
USING: alien io io.files kernel math math.bitwise system unix
io.unix.backend io.ports io.mmap destructors locals accessors ;
IN: io.unix.mmap

View File

@ -4,8 +4,7 @@ USING: alien.c-types io.binary io.backend io.files io.buffers
io.windows kernel math splitting
windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces words symbols system
io.ports destructors accessors
math.bitfields math.bitfields.lib ;
io.ports destructors accessors math.bitwise ;
IN: io.windows.files
: open-file ( path access-mode create-mode flags -- handle )

View File

@ -1,6 +1,6 @@
USING: alien alien.c-types arrays destructors generic io.mmap
io.ports io.windows io.windows.files io.windows.privileges
kernel libc math math.bitfields namespaces quotations sequences
kernel libc math math.bitwise namespaces quotations sequences
windows windows.advapi32 windows.kernel32 io.backend system
accessors locals ;
IN: io.windows.mmap

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types libc destructors locals
kernel math assocs namespaces continuations sequences hashtables
sorting arrays combinators math.bitfields strings system
sorting arrays combinators math.bitwise strings system
accessors threads splitting
io.backend io.windows io.windows.nt.backend io.windows.nt.files
io.monitors io.ports io.buffers io.files io.timeouts io

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays destructors io io.windows libc
windows.types math.bitfields windows.kernel32 windows namespaces
windows.types math.bitwise windows.kernel32 windows namespaces
kernel sequences windows.errors assocs math.parser system random
combinators accessors io.pipes io.ports ;
IN: io.windows.nt.pipes

View File

@ -1,6 +1,6 @@
USING: alien alien.c-types alien.syntax arrays continuations
destructors generic io.mmap io.ports io.windows io.windows.files
kernel libc math math.bitfields namespaces quotations sequences windows
kernel libc math math.bitwise namespaces quotations sequences windows
windows.advapi32 windows.kernel32 io.backend system accessors
io.windows.privileges ;
IN: io.windows.nt.privileges

View File

@ -5,7 +5,7 @@ io.buffers io.files io.ports io.sockets io.binary
io.sockets io.timeouts windows.errors strings
kernel math namespaces sequences windows windows.kernel32
windows.shell32 windows.types windows.winsock splitting
continuations math.bitfields system accessors ;
continuations math.bitwise system accessors ;
IN: io.windows
: set-inherit ( handle ? -- )

View File

@ -1,6 +1,5 @@
USING: sequences kernel math locals math.order math.ranges
accessors combinators.lib arrays namespaces combinators
combinators.short-circuit ;
accessors arrays namespaces combinators combinators.short-circuit ;
IN: lcs
<PRIVATE

View File

@ -2,8 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors peg peg.parsers memoize kernel sequences
logging arrays words strings vectors io io.files io.encodings.utf8
namespaces combinators combinators.lib logging.server
calendar calendar.format ;
namespaces combinators logging.server calendar calendar.format ;
IN: logging.parser
TUPLE: log-entry date level word-name message ;

View File

@ -1,27 +0,0 @@
USING: accessors math math.bitfields tools.test kernel words ;
IN: math.bitfields.tests
[ 0 ] [ { } bitfield ] unit-test
[ 256 ] [ 1 { 8 } bitfield ] unit-test
[ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test
[ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test
[ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test
: a 1 ; inline
: b 2 ; inline
: foo ( -- flags ) { a b } flags ;
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
\ foo must-infer
[ 0 ] [ { } bitfield-quot call ] unit-test
[ 256 ] [ 1 { 8 } bitfield-quot call ] unit-test
[ 268 ] [ 3 1 { 8 2 } bitfield-quot call ] unit-test
[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test

View File

@ -1,37 +0,0 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math sequences words
namespaces stack-checker.transforms ;
IN: math.bitfields
GENERIC: (bitfield) ( value accum shift -- newaccum )
M: integer (bitfield) ( value accum shift -- newaccum )
swapd shift bitor ;
M: pair (bitfield) ( value accum pair -- newaccum )
first2 >r dup word? [ swapd execute ] when r> shift bitor ;
: bitfield ( values... bitspec -- n )
0 [ (bitfield) ] reduce ;
: flags ( values -- n )
0 [ dup word? [ execute ] when bitor ] reduce ;
GENERIC: (bitfield-quot) ( spec -- quot )
M: integer (bitfield-quot) ( spec -- quot )
[ swapd shift bitor ] curry ;
M: pair (bitfield-quot) ( spec -- quot )
first2 over word? [ >r swapd execute r> ] [ ] ?
[ shift bitor ] append 2curry ;
: bitfield-quot ( spec -- quot )
[ (bitfield-quot) ] map [ 0 ] prefix concat ;
\ bitfield [ bitfield-quot ] 1 define-transform
\ flags [
[ 0 , [ , \ bitor , ] each ] [ ] make
] 1 define-transform

View File

@ -1 +0,0 @@
Domain-specific language for constructing integers

View File

@ -1 +1,2 @@
Slava Pestov
Doug Coleman

View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax math ;
IN: math.bitfields
IN: math.bitwise
ARTICLE: "math-bitfields" "Constructing bit fields"
"Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:"
@ -35,3 +35,16 @@ HELP: bitfield
" } ;"
}
} ;
HELP: bits
{ $values { "m" integer } { "n" integer } { "m'" integer } }
{ $description "Keep only n bits from the integer m." }
{ $example "USING: math.bitwise 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.bitwise prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
{ $example "USING: math.bitwise prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
} ;

View File

@ -0,0 +1,29 @@
USING: accessors math math.bitwise tools.test kernel words ;
IN: math.bitwise.tests
[ 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
[ 0 ] [ { } bitfield ] unit-test
[ 256 ] [ 1 { 8 } bitfield ] unit-test
[ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test
[ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test
[ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test
: a 1 ; inline
: b 2 ; inline
: foo ( -- flags ) { a b } flags ;
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
\ foo must-infer

View File

@ -0,0 +1,94 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.functions sequences
sequences.private words namespaces macros hints
combinators fry ;
IN: math.bitwise
! utilities
: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
: set-bit ( x n -- y ) 2^ bitor ; inline
: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline
: unmask ( x n -- ? ) bitnot bitand ; inline
: unmask? ( x n -- ? ) unmask 0 > ; inline
: mask ( x n -- ? ) bitand ; inline
: mask? ( x n -- ? ) mask 0 > ; inline
: wrap ( m n -- m' ) 1- bitand ; inline
: 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 ]
[ [ - ] keep shift-mod ] 3bi 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 ;
! 32-bit arithmetic
: w+ ( int int -- int ) + 32 bits ; inline
: w- ( int int -- int ) - 32 bits ; inline
: w* ( int int -- int ) * 32 bits ; inline
! flags
MACRO: flags ( values -- )
[ 0 ] [ [ execute bitor ] curry compose ] reduce ;
! bitfield
<PRIVATE
GENERIC: (bitfield-quot) ( spec -- quot )
M: integer (bitfield-quot) ( spec -- quot )
[ swapd shift bitor ] curry ;
M: pair (bitfield-quot) ( spec -- quot )
first2 over word? [ >r swapd execute r> ] [ ] ?
[ shift bitor ] append 2curry ;
PRIVATE>
MACRO: bitfield ( bitspec -- )
[ 0 ] [ (bitfield-quot) compose ] reduce ;
! bit-count
<PRIVATE
DEFER: byte-bit-count
<<
\ byte-bit-count
256 [
0 swap [ [ 1+ ] when ] each-bit
] B{ } map-as '[ HEX: ff bitand , nth-unsafe ] define-inline
>>
GENERIC: (bit-count) ( x -- n )
M: fixnum (bit-count)
{
[ byte-bit-count ]
[ -8 shift byte-bit-count ]
[ -16 shift byte-bit-count ]
[ -24 shift byte-bit-count ]
} cleave + + + ;
M: bignum (bit-count)
dup 0 = [ drop 0 ] [
[ byte-bit-count ] [ -8 shift (bit-count) ] bi +
] if ;
PRIVATE>
: bit-count ( x -- n )
dup 0 >= [ (bit-count) ] [ bitnot (bit-count) ] if ; inline

View File

@ -0,0 +1 @@
Bitwise arithmetic utilities

View File

@ -0,0 +1,8 @@
IN: nmake.tests
USING: nmake kernel tools.test ;
[ ] [ [ ] { } nmake ] unit-test
[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test
[ [ ] [ call ] curry { { } } nmake ] must-infer

44
basis/nmake/nmake.factor Normal file
View File

@ -0,0 +1,44 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences math.parser kernel macros
generalizations locals ;
IN: nmake
SYMBOL: building-seq
: get-building-seq ( n -- seq )
building-seq get nth ;
: n, ( obj n -- ) get-building-seq push ;
: n% ( seq n -- ) get-building-seq push-all ;
: n# ( num n -- ) >r number>string r> n% ;
: 0, ( obj -- ) 0 n, ;
: 0% ( seq -- ) 0 n% ;
: 0# ( num -- ) 0 n# ;
: 1, ( obj -- ) 1 n, ;
: 1% ( seq -- ) 1 n% ;
: 1# ( num -- ) 1 n# ;
: 2, ( obj -- ) 2 n, ;
: 2% ( seq -- ) 2 n% ;
: 2# ( num -- ) 2 n# ;
: 3, ( obj -- ) 3 n, ;
: 3% ( seq -- ) 3 n% ;
: 3# ( num -- ) 3 n# ;
: 4, ( obj -- ) 4 n, ;
: 4% ( seq -- ) 4 n% ;
: 4# ( num -- ) 4 n# ;
MACRO: finish-nmake ( exemplars -- )
length [ firstn ] curry ;
:: nmake ( quot exemplars -- )
[
exemplars
[ 0 swap new-resizable ] map
building-seq set
quot call
building-seq get
exemplars [ [ like ] 2map ] [ finish-nmake ] bi
] with-scope ; inline

View File

@ -2,7 +2,7 @@
! Portions copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax combinators kernel system namespaces
assocs parser lexer sequences words quotations math.bitfields ;
assocs parser lexer sequences words quotations math.bitwise ;
IN: openssl.libssl

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel compiler.units words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
peg.parsers unicode.categories multiline combinators.lib
peg.parsers unicode.categories multiline
splitting accessors effects sequences.deep peg.search
combinators.short-circuit lexer io.streams.string
stack-checker io prettyprint combinators parser ;

View File

@ -1,7 +1,7 @@
! Based on Clojure's PersistentHashMap by Rich Hickey.
USING: math math.bit-count arrays kernel accessors locals sequences
sequences.private sequences.lib
USING: math math.bitwise arrays kernel accessors locals sequences
sequences.private
persistent.sequences
persistent.hashtables.config
persistent.hashtables.nodes ;

View File

@ -1,6 +1,6 @@
! Based on Clojure's PersistentHashMap by Rich Hickey.
USING: kernel accessors math arrays fry sequences sequences.lib
USING: kernel accessors math arrays fry sequences
locals persistent.sequences
persistent.hashtables.config
persistent.hashtables.nodes

View File

@ -1,7 +1,7 @@
! Based on Clojure's PersistentHashMap by Rich Hickey.
USING: math accessors kernel arrays sequences sequences.private
locals sequences.lib
locals
persistent.sequences
persistent.hashtables.config
persistent.hashtables.nodes ;

View File

@ -1,6 +1,6 @@
! Based on Clojure's PersistentHashMap by Rich Hickey.
USING: math arrays kernel sequences sequences.lib
USING: math arrays kernel sequences
accessors locals persistent.hashtables.config ;
IN: persistent.hashtables.nodes

View File

@ -3,7 +3,7 @@
! 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.bitwise
combinators ;
IN: random.mersenne-twister

View File

@ -1,4 +1,4 @@
USING: random sequences tools.test ;
USING: random sequences tools.test kernel ;
IN: random.tests
[ 4 ] [ 4 random-bytes length ] unit-test
@ -6,3 +6,6 @@ IN: random.tests
[ 4 ] [ [ 4 random-bytes length ] with-secure-random ] unit-test
[ 7 ] [ [ 7 random-bytes length ] with-secure-random ] unit-test
[ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test
[ V{ } [ delete-random drop ] keep length ] must-fail

View File

@ -43,6 +43,9 @@ M: f random-32* ( obj -- * ) no-random-number-generator ;
] keep nth
] if ;
: delete-random ( seq -- elt )
[ length random ] keep [ nth ] 2keep delete-nth ;
: random-bits ( n -- r ) 2^ random ;
: with-random ( tuple quot -- )

View File

@ -1,8 +1,8 @@
! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
! Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays namespaces io io.timeouts kernel logging io.sockets
sequences combinators sequences.lib splitting assocs strings
USING: arrays namespaces io io.timeouts kernel logging
io.sockets sequences combinators splitting assocs strings
math.parser random system calendar io.encodings.ascii summary
calendar.format accessors sets hashtables ;
IN: smtp
@ -112,7 +112,7 @@ ERROR: smtp-transaction-failed < smtp-error ;
} cond ;
: multiline? ( response -- boolean )
?fourth CHAR: - = ;
3 swap ?nth CHAR: - = ;
: process-multiline ( multiline -- response )
>r readln r> 2dup " " append head? [
@ -184,21 +184,3 @@ PRIVATE>
: send-email ( email -- )
[ email>headers ] keep (send-email) ;
! Dirk's old AUTH CRAM-MD5 code. I don't know anything about
! CRAM MD5, and the old code didn't work properly either, so here
! it is in case anyone wants to fix it later.
!
! check-response used to have this clause:
! { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] }
!
! and the rest of the code was as follows:
! : (cram-md5-auth) ( -- response )
! swap challenge get
! string>md5-hmac hex-string
! " " prepend append
! >base64 ;
!
! : cram-md5-auth ( key login -- )
! "AUTH CRAM-MD5\r\n" get-ok
! (cram-md5-auth) "\r\n" append get-ok ;

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io io.streams.string kernel math namespaces sequences
strings circular prettyprint debugger ascii sbufs fry summary
accessors sequences.lib ;
accessors ;
IN: state-parser
! * Basic underlying words
@ -120,7 +120,7 @@ M: not-enough-characters summary ( obj -- str )
: take ( n -- string )
[ 1- ] [ <sbuf> ] bi [
'[ drop get-char [ next , push f ] [ t ] if* ] attempt-each drop
'[ drop get-char [ next , push f ] [ t ] if* ] contains? drop
] keep get-char [ over push ] when* >string ;
: pass-blank ( -- )

View File

@ -3,8 +3,8 @@
USING: assocs io.files hashtables kernel namespaces sequences
vocabs.loader io combinators io.encodings.utf8 calendar accessors
math.parser io.streams.string ui.tools.operations quotations
strings arrays prettyprint words vocabs sorting sets cords
classes sequences.lib combinators.lib ;
strings arrays prettyprint words vocabs sorting sets
classes ;
IN: tools.scaffold
SYMBOL: developer-name
@ -160,16 +160,18 @@ ERROR: no-vocab vocab ;
: help-file-string ( str1 -- str2 )
[
[ "IN: " write print nl ]
[ interesting-words. ]
[ "ARTICLE: " write unparse dup write bl print ";" print nl ]
[ "ABOUT: " write unparse print ] quad
{
[ "IN: " write print nl ]
[ interesting-words. ]
[ "ARTICLE: " write unparse dup write bl print ";" print nl ]
[ "ABOUT: " write unparse print ]
} cleave
] with-string-writer ;
: write-using ( -- )
"USING:" write
using get keys
{ "help.markup" "help.syntax" } cord-append natural-sort
{ "help.markup" "help.syntax" } append natural-sort
[ bl write ] each
" ;" print ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.lib
USING: ui.backend ui.gadgets ui.gadgets.theme
ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces
classes.tuple colors accessors ;
IN: ui.gadgets.canvas

View File

@ -1,8 +0,0 @@
USING: accessors kernel ui.backend ui.gadgets.worlds ;
IN: ui.gadgets.lib
ERROR: no-world-found ;
: find-gl-context ( gadget -- )
find-world dup [ handle>> select-gl-context ] [ no-world-found ] if ;

View File

@ -1 +0,0 @@
Eduardo Cavazos

View File

@ -22,6 +22,12 @@ window-loc ;
: hide-status ( gadget -- ) f swap show-status ;
ERROR: no-world-found ;
: find-gl-context ( gadget -- )
find-world dup
[ handle>> select-gl-context ] [ no-world-found ] if ;
: (request-focus) ( child world ? -- )
pick parent>> pick eq? [
>r >r dup parent>> dup r> r>

View File

@ -8,7 +8,7 @@ sequences strings vectors words windows.kernel32 windows.gdi32
windows.user32 windows.opengl32 windows.messages windows.types
windows.nt windows threads libc combinators continuations
command-line shuffle opengl ui.render unicode.case ascii
math.bitfields locals symbols accessors math.geometry.rect ;
math.bitwise locals symbols accessors math.geometry.rect ;
IN: ui.windows
SINGLETON: windows-ui-backend

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax math math.bitfields ;
USING: alien.syntax math math.bitwise ;
IN: unix.linux.inotify
C-STRUCT: inotify-event

View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences sequences.lib math
USING: kernel continuations sequences math
namespaces sets math.parser math.ranges assocs regexp
unicode.categories arrays hashtables words
classes quotations xmode.catalog ;

View File

@ -1,4 +1,4 @@
USING: alias alien.syntax kernel math windows.types math.bitfields ;
USING: alias alien.syntax kernel math windows.types math.bitwise ;
IN: windows.advapi32
LIBRARY: advapi32

View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax parser namespaces kernel
math math.bitfields windows.types windows.types init assocs
math math.bitwise windows.types windows.types init assocs
sequences libc ;
IN: windows.opengl32

View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax parser namespaces kernel math
windows.types generalizations math.bitfields alias ;
windows.types generalizations math.bitwise alias ;
IN: windows.user32
! HKL for ActivateKeyboardLayout

View File

@ -2,7 +2,7 @@
USING: alien alien.c-types alien.strings alien.syntax arrays
byte-arrays kernel math sequences windows.types windows.kernel32
windows.errors structs windows math.bitfields alias ;
windows.errors structs windows math.bitwise alias ;
IN: windows.winsock
USE: libc

View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types hashtables kernel math math.vectors math.bitfields
namespaces sequences x11.xlib x11.constants x11.glx ;
USING: alien alien.c-types hashtables kernel math math.vectors
math.bitwise namespaces sequences x11.xlib x11.constants x11.glx ;
IN: x11.windows
: create-window-mask ( -- n )

View File

@ -12,7 +12,7 @@
! and note the section.
USING: kernel arrays alien alien.c-types alien.strings
alien.syntax math math.bitfields words sequences namespaces
alien.syntax math math.bitwise words sequences namespaces
continuations io.encodings.ascii ;
IN: x11.xlib

View File

@ -1,7 +1,6 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel xml.data xml.utilities assocs splitting
sequences parser lexer quotations sequences.lib xml.utilities ;
USING: namespaces kernel xml.data xml.utilities assocs sequences ;
IN: xml.generator
: comment, ( string -- ) <comment> , ;
@ -24,56 +23,3 @@ IN: xml.generator
(tag,) build-xml ; inline
: make-xml ( name quot -- xml )
f swap make-xml* ; inline
! Word-based XML literal syntax
: parsed-name ( accum -- accum )
scan ":" split1 [ f <name> ] [ <simple-name> ] if* parsed ;
: run-combinator ( accum quot1 quot2 -- accum )
>r [ ] like parsed r> [ parsed ] each ;
: parse-tag-contents ( accum contained? -- accum )
[ \ contained*, parsed ] [
scan-word \ [ =
[ POSTPONE: [ \ tag*, parsed ]
[ "Expected [ missing" throw ] if
] if ;
DEFER: >>
: attributes-parsed ( accum quot -- accum )
dup empty? [ drop f parsed ] [
>r \ >r parsed r> parsed
[ H{ } make-assoc r> swap ] [ parsed ] each
] if ;
: <<
parsed-name [
\ >> parse-until >quotation
attributes-parsed \ contained? get
] with-scope parse-tag-contents ; parsing
: ==
\ call parsed parsed-name \ set parsed ; parsing
: //
\ contained? on ; parsing
: parse-special ( accum end-token word -- accum )
>r parse-tokens " " join parsed r> parsed ;
: <!-- "-->" \ comment, parse-special ; parsing
: <! ">" \ directive, parse-special ; parsing
: <? "?>" \ instruction, parse-special ; parsing
: >xml-document ( seq -- xml )
dup first prolog? [ unclip-slice ] [ standard-prolog ] if swap
[ tag? ] split-around <xml> ;
DEFER: XML>
: <XML
\ XML> [ >quotation ] parse-literal
{ } parsed \ make parsed \ >xml-document parsed ; parsing

View File

@ -1,7 +1,7 @@
IN: xmode.marker
USING: kernel namespaces xmode.rules xmode.tokens
xmode.marker.state xmode.marker.context xmode.utilities
xmode.catalog sequences math assocs combinators combinators.lib
xmode.catalog sequences math assocs combinators
strings regexp splitting parser-combinators ascii unicode.case
combinators.short-circuit accessors ;

View File

@ -315,6 +315,15 @@ HELP: empty?
{ $values { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests if the sequence has zero length." } ;
HELP: if-empty
{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } }
{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and " { $snippet "quot1" } " is called. Otherwise, if the sequence has any elements, " { $snippet "quot2" } " is called on it." }
{ $example
"USING: kernel prettyprint sequences sequences.lib ;"
"{ 1 2 3 } [ \"empty sequence\" ] [ sum ] if-empty ."
"6"
} ;
HELP: delete-all
{ $values { "seq" "a resizable sequence" } }
{ $description "Resizes the sequence to zero length, removing all elements. Not all sequences are resizable." }

View File

@ -3,6 +3,9 @@ sequences.private strings sbufs tools.test vectors
generic vocabs.loader ;
IN: sequences.tests
[ "empty" ] [ { } [ "empty" ] [ "not empty" ] if-empty ] unit-test
[ { 1 } "not empty" ] [ { 1 } [ "empty" ] [ "not empty" ] if-empty ] unit-test
[ V{ 1 2 3 4 } ] [ 1 5 dup <slice> >vector ] unit-test
[ 3 ] [ 1 4 dup <slice> length ] unit-test
[ 2 ] [ 1 3 { 1 2 3 4 } <slice> length ] unit-test

View File

@ -28,6 +28,14 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
: empty? ( seq -- ? ) length zero? ; inline
: if-empty ( seq quot1 quot2 -- )
[ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
: when-empty ( seq quot1 -- ) [ ] if-empty ; inline
: unless-empty ( seq quot1 -- ) [ ] swap if-empty ; inline
: delete-all ( seq -- ) 0 swap set-length ;
: first ( seq -- first ) 0 swap nth ; inline
@ -582,6 +590,9 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
[ >r >r dup pick length + r> - over r> open-slice ] keep
copy ;
: remove-nth ( n seq -- seq' )
[ swap head-slice ] [ swap 1+ tail-slice ] 2bi append ;
: pop ( seq -- elt )
[ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
@ -659,6 +670,9 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: cut-slice ( seq n -- before after )
[ head-slice ] [ tail-slice ] 2bi ;
: insert-nth ( elt n seq -- seq' )
swap cut-slice [ swap suffix ] dip append ;
: midpoint@ ( seq -- n ) length 2/ ; inline
: halves ( seq -- first second )

View File

@ -1,55 +1,17 @@
USING: arrays kernel io io.binary sbufs splitting grouping
strings sequences namespaces math math.parser parser
hints math.bitfields.lib assocs ;
hints math.bitwise assocs ;
IN: crypto.common
: w+ ( int int -- int ) + 32 bits ; inline
: (nth-int) ( string n -- int )
2 shift dup 4 + rot <slice> ; inline
: nth-int ( string n -- int ) (nth-int) le> ; inline
: nth-int-be ( string n -- int ) (nth-int) be> ; inline
: update ( num var -- ) [ w+ ] change ; inline
: calculate-pad-length ( length -- pad-length )
dup 56 < 55 119 ? swap - ;
: preprocess-plaintext ( string big-endian? -- padded-string )
#! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
>r >sbuf r> over [
HEX: 80 ,
dup length HEX: 3f bitand
calculate-pad-length 0 <string> %
length 3 shift 8 rot [ >be ] [ >le ] if %
] "" make over push-all ;
SYMBOL: bytes-read
SYMBOL: big-endian?
: pad-last-block ( str big-endian? length -- str )
[
rot %
HEX: 80 ,
dup HEX: 3f bitand calculate-pad-length 0 <string> %
3 shift 8 rot [ >be ] [ >le ] if %
] "" make 64 group ;
: update-old-new ( old new -- )
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
: slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ;
: seq>2seq ( seq -- seq1 seq2 )
#! { abcdefgh } -> { aceg } { bdfh }
2 group flip dup empty? [ drop { } { } ] [ first2 ] if ;
: 2seq>seq ( seq1 seq2 -- seq )
#! { aceg } { bdfh } -> { abcdefgh }
[ zip concat ] keep like ;
: mod-nth ( n seq -- elt )
#! 5 "abcd" -> b
[ length mod ] [ nth ] bi ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.bitfields combinators.lib math.parser
USING: kernel math math.bitwise combinators.lib math.parser
random sequences sequences.lib continuations namespaces
io.files io arrays io.files.unique.backend system
combinators vocabs.loader ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types assocs combinators destructors
kernel math math.bitfields math.parser sequences summary system
kernel math math.bitwise math.parser sequences summary system
vocabs.loader ;
IN: io.serial

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel math.bitfields sequences system io.serial ;
USING: alien.syntax kernel math.bitwise sequences system io.serial ;
IN: io.serial.unix
M: bsd lookup-baud ( m -- n )

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math.bitfields serial serial.unix ;
USING: accessors kernel math.bitwise serial serial.unix ;
IN: io.serial.unix
: serial-obj ( -- obj )

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.syntax combinators io.ports
io.streams.duplex io.unix.backend system kernel math math.bitfields
io.streams.duplex io.unix.backend system kernel math math.bitwise
vocabs.loader unix io.serial io.serial.unix.termios ;
IN: io.serial.unix

View File

@ -1,38 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions quotations words sequences
sequences.private combinators fry ;
IN: math.bit-count
<PRIVATE
DEFER: byte-bit-count
<<
\ byte-bit-count
256 [
0 swap [ [ 1+ ] when ] each-bit
] B{ } map-as '[ HEX: ff bitand , nth-unsafe ] define-inline
>>
GENERIC: (bit-count) ( x -- n )
M: fixnum (bit-count)
{
[ byte-bit-count ]
[ -8 shift byte-bit-count ]
[ -16 shift byte-bit-count ]
[ -24 shift byte-bit-count ]
} cleave + + + ;
M: bignum (bit-count)
dup 0 = [ drop 0 ] [
[ byte-bit-count ] [ -8 shift (bit-count) ] bi +
] if ;
PRIVATE>
: bit-count ( x -- n )
dup 0 >= [ (bit-count) ] [ bitnot (bit-count) ] if ; inline

View File

@ -1,16 +0,0 @@
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" }
} ;

View File

@ -1,14 +0,0 @@
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

View File

@ -1,30 +0,0 @@
USING: hints kernel math ;
IN: math.bitfields.lib
: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
: set-bit ( x n -- y ) 2^ bitor ; inline
: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline
: unmask ( x n -- ? ) bitnot bitand ; inline
: unmask? ( x n -- ? ) unmask 0 > ; inline
: mask ( x n -- ? ) bitand ; inline
: mask? ( x n -- ? ) mask 0 > ; inline
: wrap ( m n -- m' ) 1- bitand ; inline
: 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 ]
[ [ - ] keep shift-mod ] 3bi 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 ;

View File

@ -1,8 +1 @@
IN: namespaces.lib.tests
USING: namespaces.lib kernel tools.test ;
[ ] [ [ ] { } nmake ] unit-test
[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test
[ [ ] [ call ] curry { { } } nmake ] must-infer

Some files were not shown because too many files have changed in this diff Show More