Merge branch 'master' of git://factorcode.org/git/factor
commit
8175d6fe2b
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: byte-arrays arrays assocs kernel kernel.private libc math
|
||||
namespaces make parser sequences strings words assocs splitting
|
||||
math.parser cpu.architecture alien alien.accessors alien.strings
|
||||
quotations layouts system compiler.units io io.files
|
||||
io.encodings.binary io.streams.memory accessors combinators effects
|
||||
continuations fry classes ;
|
||||
namespaces make parser sequences strings words splitting math.parser
|
||||
cpu.architecture alien alien.accessors alien.strings quotations
|
||||
layouts system compiler.units io io.files io.encodings.binary
|
||||
io.streams.memory accessors combinators effects continuations fry
|
||||
classes ;
|
||||
IN: alien.c-types
|
||||
|
||||
DEFER: <int>
|
||||
|
|
|
@ -23,7 +23,7 @@ WHERE
|
|||
: *T ( alien -- z )
|
||||
[ T-real ] [ T-imaginary ] bi rect> ; inline
|
||||
|
||||
T in get
|
||||
T current-vocab
|
||||
{ { N "real" } { N "imaginary" } }
|
||||
define-struct
|
||||
|
||||
|
|
|
@ -421,7 +421,7 @@ PRIVATE>
|
|||
: define-fortran-record ( name vocab fields -- )
|
||||
[ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
|
||||
|
||||
SYNTAX: RECORD: scan in get parse-definition define-fortran-record ;
|
||||
SYNTAX: RECORD: scan current-vocab parse-definition define-fortran-record ;
|
||||
|
||||
: set-fortran-abi ( library -- )
|
||||
library-fortran-abis get-global at fortran-abi set ;
|
||||
|
|
|
@ -1,6 +1,5 @@
|
|||
USING: accessors alien.c-types strings help.markup help.syntax
|
||||
alien.syntax sequences io arrays kernel words assocs namespaces
|
||||
accessors ;
|
||||
USING: alien.c-types strings help.markup help.syntax alien.syntax
|
||||
sequences io arrays kernel words assocs namespaces ;
|
||||
IN: alien.structs
|
||||
|
||||
ARTICLE: "c-structs" "C structure types"
|
||||
|
|
|
@ -22,7 +22,7 @@ SYNTAX: TYPEDEF:
|
|||
scan scan typedef ;
|
||||
|
||||
SYNTAX: C-STRUCT:
|
||||
scan in get parse-definition define-struct ;
|
||||
scan current-vocab parse-definition define-struct ;
|
||||
|
||||
SYNTAX: C-UNION:
|
||||
scan parse-definition define-union ;
|
||||
|
|
|
@ -5,23 +5,51 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary
|
|||
io.streams.byte-array ;
|
||||
IN: bitstreams.tests
|
||||
|
||||
[ 1 t ]
|
||||
[ B{ 254 } binary <byte-reader> <bitstream-reader> read-bit ] unit-test
|
||||
|
||||
[ 254 8 t ]
|
||||
[ B{ 254 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
|
||||
|
||||
[ 4095 12 t ]
|
||||
[ B{ 255 255 } binary <byte-reader> <bitstream-reader> 12 swap read-bits ] unit-test
|
||||
|
||||
[ B{ 254 } ]
|
||||
[ BIN: 1111111111 ]
|
||||
[
|
||||
binary <byte-writer> <bitstream-writer> 254 8 rot
|
||||
[ write-bits ] keep stream>> >byte-array
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
10 swap peek
|
||||
] unit-test
|
||||
|
||||
[ 255 8 t ]
|
||||
[ B{ 255 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
|
||||
[ BIN: 111111111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
9 swap peek
|
||||
] unit-test
|
||||
|
||||
[ 255 8 f ]
|
||||
[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test
|
||||
[ BIN: 11111111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
8 swap peek
|
||||
] unit-test
|
||||
|
||||
[ BIN: 1111111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
7 swap peek
|
||||
] unit-test
|
||||
|
||||
[ BIN: 111111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
6 swap peek
|
||||
] unit-test
|
||||
|
||||
[ BIN: 11111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
5 swap peek
|
||||
] unit-test
|
||||
|
||||
[ B{ } <msb0-bit-reader> 5 swap peek ] must-fail
|
||||
[ B{ } <msb0-bit-reader> 1 swap peek ] must-fail
|
||||
[ B{ } <msb0-bit-reader> 8 swap peek ] must-fail
|
||||
|
||||
[ 0 ] [ B{ } <msb0-bit-reader> 0 swap peek ] unit-test
|
||||
|
|
|
@ -1,96 +1,160 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors byte-arrays destructors fry io kernel locals
|
||||
math sequences ;
|
||||
USING: accessors alien.accessors assocs byte-arrays combinators
|
||||
constructors destructors fry io io.binary io.encodings.binary
|
||||
io.streams.byte-array kernel locals macros math math.ranges
|
||||
multiline sequences sequences.private vectors byte-vectors
|
||||
combinators.short-circuit math.bitwise ;
|
||||
IN: bitstreams
|
||||
|
||||
TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ;
|
||||
TUPLE: bitstream-reader < bitstream ;
|
||||
TUPLE: widthed { bits integer read-only } { #bits integer read-only } ;
|
||||
|
||||
: reset-bitstream ( stream -- stream )
|
||||
0 >>#bits 0 >>current-bits ; inline
|
||||
ERROR: invalid-widthed bits #bits ;
|
||||
|
||||
: new-bitstream ( stream class -- bitstream )
|
||||
: check-widthed ( bits #bits -- bits #bits )
|
||||
dup 0 < [ invalid-widthed ] when
|
||||
2dup { [ nip 0 = ] [ drop 0 = not ] } 2&& [ invalid-widthed ] when
|
||||
over 0 = [
|
||||
2dup [ dup 0 < [ neg ] when log2 1 + ] dip > [ invalid-widthed ] when
|
||||
] unless ;
|
||||
|
||||
: <widthed> ( bits #bits -- widthed )
|
||||
check-widthed
|
||||
widthed boa ;
|
||||
|
||||
: zero-widthed ( -- widthed ) 0 0 <widthed> ;
|
||||
: zero-widthed? ( widthed -- ? ) zero-widthed = ;
|
||||
|
||||
TUPLE: bit-reader
|
||||
{ bytes byte-array }
|
||||
{ byte-pos array-capacity initial: 0 }
|
||||
{ bit-pos array-capacity initial: 0 } ;
|
||||
|
||||
TUPLE: bit-writer
|
||||
{ bytes byte-vector }
|
||||
{ widthed widthed } ;
|
||||
|
||||
TUPLE: msb0-bit-reader < bit-reader ;
|
||||
TUPLE: lsb0-bit-reader < bit-reader ;
|
||||
CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ;
|
||||
CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ;
|
||||
|
||||
TUPLE: msb0-bit-writer < bit-writer ;
|
||||
TUPLE: lsb0-bit-writer < bit-writer ;
|
||||
|
||||
: new-bit-writer ( class -- bs )
|
||||
new
|
||||
swap >>stream
|
||||
reset-bitstream ; inline
|
||||
BV{ } clone >>bytes
|
||||
0 0 <widthed> >>widthed ; inline
|
||||
|
||||
M: bitstream-reader dispose ( stream -- )
|
||||
stream>> dispose ;
|
||||
: <msb0-bit-writer> ( -- bs )
|
||||
msb0-bit-writer new-bit-writer ;
|
||||
|
||||
: <bitstream-reader> ( stream -- bitstream )
|
||||
bitstream-reader new-bitstream ; inline
|
||||
: <lsb0-bit-writer> ( -- bs )
|
||||
lsb0-bit-writer new-bit-writer ;
|
||||
|
||||
: read-next-byte ( bitstream -- bitstream )
|
||||
dup stream>> stream-read1 [
|
||||
>>current-bits 8 >>#bits
|
||||
GENERIC: peek ( n bitstream -- value )
|
||||
GENERIC: poke ( value n bitstream -- )
|
||||
|
||||
: seek ( n bitstream -- )
|
||||
{
|
||||
[ byte-pos>> 8 * ]
|
||||
[ bit-pos>> + + 8 /mod ]
|
||||
[ (>>bit-pos) ]
|
||||
[ (>>byte-pos) ]
|
||||
} cleave ; inline
|
||||
|
||||
: read ( n bitstream -- value )
|
||||
[ peek ] [ seek ] 2bi ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
ERROR: not-enough-bits widthed n ;
|
||||
|
||||
: widthed-bits ( widthed n -- bits )
|
||||
dup 0 < [ not-enough-bits ] when
|
||||
2dup [ #bits>> ] dip < [ not-enough-bits ] when
|
||||
[ [ bits>> ] [ #bits>> ] bi ] dip
|
||||
[ - neg shift ] keep <widthed> ;
|
||||
|
||||
: split-widthed ( widthed n -- widthed1 widthed2 )
|
||||
2dup [ #bits>> ] dip < [
|
||||
drop zero-widthed
|
||||
] [
|
||||
0 >>#bits
|
||||
t >>end-of-stream?
|
||||
] if* ;
|
||||
|
||||
: maybe-read-next-byte ( bitstream -- bitstream )
|
||||
dup #bits>> 0 = [ read-next-byte ] when ; inline
|
||||
|
||||
: shift-one-bit ( bitstream -- n )
|
||||
[ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline
|
||||
|
||||
: next-bit ( bitstream -- n/f ? )
|
||||
maybe-read-next-byte
|
||||
dup end-of-stream?>> [
|
||||
drop f
|
||||
] [
|
||||
[ shift-one-bit ]
|
||||
[ [ 1- ] change-#bits maybe-read-next-byte drop ] bi
|
||||
] if dup >boolean ;
|
||||
|
||||
: read-bit ( bitstream -- n ? )
|
||||
dup #bits>> 1 = [
|
||||
[ current-bits>> 1 bitand ]
|
||||
[ read-next-byte drop ] bi t
|
||||
] [
|
||||
next-bit
|
||||
] if ; inline
|
||||
|
||||
: bits>integer ( seq -- n )
|
||||
0 [ [ 1 shift ] dip bitor ] reduce ; inline
|
||||
|
||||
: read-bits ( width bitstream -- n width ? )
|
||||
[
|
||||
'[ _ read-bit drop ] replicate
|
||||
[ f = ] trim-tail
|
||||
[ bits>integer ] [ length ] bi
|
||||
] 2keep drop over = ;
|
||||
|
||||
TUPLE: bitstream-writer < bitstream ;
|
||||
|
||||
: <bitstream-writer> ( stream -- bitstream )
|
||||
bitstream-writer new-bitstream ; inline
|
||||
|
||||
: write-bit ( n bitstream -- )
|
||||
[ 1 shift bitor ] change-current-bits
|
||||
[ 1+ ] change-#bits
|
||||
dup #bits>> 8 = [
|
||||
[ [ current-bits>> ] [ stream>> stream-write1 ] bi ]
|
||||
[ reset-bitstream drop ] bi
|
||||
] [
|
||||
drop
|
||||
] if ; inline
|
||||
|
||||
ERROR: invalid-bit-width n ;
|
||||
|
||||
:: write-bits ( n width bitstream -- )
|
||||
n 0 < [ n invalid-bit-width ] when
|
||||
n 0 = [
|
||||
width [ 0 bitstream write-bit ] times
|
||||
] [
|
||||
width n log2 1+ dup :> n-length - [ 0 bitstream write-bit ] times
|
||||
n-length [
|
||||
n-length swap - 1- neg n swap shift 1 bitand
|
||||
bitstream write-bit
|
||||
] each
|
||||
[ widthed-bits ]
|
||||
[ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep <widthed> ] 2bi
|
||||
] if ;
|
||||
|
||||
: flush-bits ( bitstream -- ) stream>> stream-flush ;
|
||||
: widthed>bytes ( widthed -- bytes widthed )
|
||||
[ 8 split-widthed dup zero-widthed? not ]
|
||||
[ swap bits>> ] B{ } produce-as nip swap ;
|
||||
|
||||
: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ;
|
||||
:: |widthed ( widthed1 widthed2 -- widthed3 )
|
||||
widthed1 bits>> :> bits1
|
||||
widthed1 #bits>> :> #bits1
|
||||
widthed2 bits>> :> bits2
|
||||
widthed2 #bits>> :> #bits2
|
||||
bits1 #bits2 shift bits2 bitor
|
||||
#bits1 #bits2 + <widthed> ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M:: lsb0-bit-writer poke ( value n bs -- )
|
||||
value n <widthed> :> widthed
|
||||
widthed
|
||||
bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
|
||||
byte bs widthed>> |widthed :> new-byte
|
||||
new-byte #bits>> 8 = [
|
||||
new-byte bits>> bs bytes>> push
|
||||
zero-widthed bs (>>widthed)
|
||||
remainder widthed>bytes
|
||||
[ bs bytes>> push-all ] [ bs (>>widthed) ] bi*
|
||||
] [
|
||||
byte bs (>>widthed)
|
||||
] if ;
|
||||
|
||||
: enough-bits? ( n bs -- ? )
|
||||
[ bytes>> length ]
|
||||
[ byte-pos>> - 8 * ]
|
||||
[ bit-pos>> - ] tri <= ;
|
||||
|
||||
ERROR: not-enough-bits n bit-reader ;
|
||||
|
||||
: #bits>#bytes ( #bits -- #bytes )
|
||||
8 /mod 0 = [ 1 + ] unless ; inline
|
||||
|
||||
:: subseq>bits-le ( bignum n bs -- bits )
|
||||
bignum bs bit-pos>> neg shift n bits ;
|
||||
|
||||
:: subseq>bits-be ( bignum n bs -- bits )
|
||||
bignum
|
||||
8 bs bit-pos>> - n - 8 mod dup 0 < [ 8 + ] when
|
||||
neg shift n bits ;
|
||||
|
||||
:: adjust-bits ( n bs -- )
|
||||
n 8 /mod :> #bits :> #bytes
|
||||
bs [ #bytes + ] change-byte-pos
|
||||
bit-pos>> #bits + dup 8 >= [
|
||||
8 - bs (>>bit-pos)
|
||||
bs [ 1 + ] change-byte-pos drop
|
||||
] [
|
||||
bs (>>bit-pos)
|
||||
] if ;
|
||||
|
||||
:: (peek) ( n bs endian> subseq-endian -- bits )
|
||||
n bs enough-bits? [ n bs not-enough-bits ] unless
|
||||
bs [ byte-pos>> ] [ bit-pos>> n + ] bi #bits>#bytes dupd +
|
||||
bs bytes>> subseq endian> execute( seq -- x ) :> bignum
|
||||
bignum n bs subseq-endian execute( bignum n bs -- bits ) ;
|
||||
|
||||
M: lsb0-bit-reader peek ( n bs -- bits ) \ le> \ subseq>bits-le (peek) ;
|
||||
|
||||
M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ;
|
||||
|
||||
:: bit-writer-bytes ( writer -- bytes )
|
||||
writer widthed>> #bits>> :> n
|
||||
n 0 = [
|
||||
writer widthed>> bits>> 8 n - shift
|
||||
writer bytes>> swap push
|
||||
] unless
|
||||
writer bytes>> ;
|
||||
|
|
|
@ -1,13 +1,14 @@
|
|||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors compiler cpu.architecture vocabs.loader system
|
||||
USING: accessors cpu.architecture vocabs.loader system
|
||||
sequences namespaces parser kernel kernel.private classes
|
||||
classes.private arrays hashtables vectors classes.tuple sbufs
|
||||
hashtables.private sequences.private math classes.tuple.private
|
||||
growable namespaces.private assocs words command-line vocabs io
|
||||
io.encodings.string libc splitting math.parser memory
|
||||
compiler.units math.order compiler.tree.builder
|
||||
compiler.tree.optimizer compiler.cfg.optimizer ;
|
||||
io.encodings.string libc splitting math.parser memory compiler.units
|
||||
math.order compiler.tree.builder compiler.tree.optimizer
|
||||
compiler.cfg.optimizer ;
|
||||
FROM: compiler => enable-optimizer compile-word ;
|
||||
IN: bootstrap.compiler
|
||||
|
||||
! Don't bring this in when deploying, since it will store a
|
||||
|
|
|
@ -1,15 +1,14 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien arrays byte-arrays generic assocs hashtables assocs
|
||||
hashtables.private io io.binary io.files io.encodings.binary
|
||||
io.pathnames kernel kernel.private math namespaces make parser
|
||||
prettyprint sequences sequences.private strings sbufs vectors words
|
||||
quotations assocs system layouts splitting grouping growable classes
|
||||
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 bootstrap.image.syntax ;
|
||||
USING: alien arrays byte-arrays generic hashtables hashtables.private
|
||||
io io.binary io.files io.encodings.binary io.pathnames kernel
|
||||
kernel.private math namespaces make parser prettyprint sequences
|
||||
strings sbufs vectors words quotations assocs system layouts splitting
|
||||
grouping growable classes classes.builtin classes.tuple
|
||||
classes.tuple.private vocabs vocabs.loader source-files definitions
|
||||
debugger quotations.private combinators math.order math.private
|
||||
accessors slots.private generic.single.private compiler.units
|
||||
compiler.constants fry bootstrap.image.syntax ;
|
||||
IN: bootstrap.image
|
||||
|
||||
: arch ( os cpu -- arch )
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math math.order math.parser math.functions kernel
|
||||
sequences io accessors arrays io.streams.string splitting
|
||||
combinators accessors calendar calendar.format.macros present ;
|
||||
combinators calendar calendar.format.macros present ;
|
||||
IN: calendar.format
|
||||
|
||||
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
!
|
||||
! Channels - based on ideas from newsqueak
|
||||
USING: kernel sequences threads continuations
|
||||
random math accessors random ;
|
||||
random math accessors ;
|
||||
IN: channels
|
||||
|
||||
TUPLE: channel receivers senders ;
|
||||
|
|
|
@ -10,6 +10,6 @@ CONSTANT: adler-32-modulus 65521
|
|||
|
||||
M: adler-32 checksum-bytes ( bytes checksum -- value )
|
||||
drop
|
||||
[ sum 1+ ]
|
||||
[ sum 1 + ]
|
||||
[ [ dup length [1,b] <reversed> v. ] [ length ] bi + ] bi
|
||||
[ adler-32-modulus mod ] bi@ 16 shift bitor ;
|
||||
|
|
|
@ -0,0 +1,48 @@
|
|||
USING: kernel io strings byte-arrays sequences namespaces math
|
||||
parser checksums.hmac tools.test checksums.md5 checksums.sha
|
||||
checksums ;
|
||||
IN: checksums.hmac.tests
|
||||
|
||||
[
|
||||
"\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d"
|
||||
] [
|
||||
16 11 <string> "Hi There" md5 hmac-bytes >string ] unit-test
|
||||
|
||||
[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ]
|
||||
[ "Jefe" "what do ya want for nothing?" md5 hmac-bytes >string ] unit-test
|
||||
|
||||
[
|
||||
"V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6"
|
||||
]
|
||||
[
|
||||
16 HEX: aa <string>
|
||||
50 HEX: dd <repetition> md5 hmac-bytes >string
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9"
|
||||
] [
|
||||
16 11 <string> "Hi There" sha1 hmac-bytes >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?" sha1 hmac-bytes >string
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb"
|
||||
] [
|
||||
16 HEX: aa <string>
|
||||
50 HEX: dd <repetition> sha1 hmac-bytes >string
|
||||
] unit-test
|
||||
|
||||
[ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ]
|
||||
[ 20 HEX: b <string> "Hi There" sha-256 hmac-bytes hex-string ] unit-test
|
||||
|
||||
[ "167f928588c5cc2eef8e3093caa0e87c9ff566a14794aa61648d81621a2a40c6" ]
|
||||
[
|
||||
"JefeJefeJefeJefeJefeJefeJefeJefe"
|
||||
"what do ya want for nothing?" sha-256 hmac-bytes hex-string
|
||||
] unit-test
|
|
@ -0,0 +1,39 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays checksums combinators fry io io.binary
|
||||
io.encodings.binary io.files io.streams.byte-array kernel
|
||||
locals math math.vectors memoize sequences ;
|
||||
IN: checksums.hmac
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: seq-bitxor ( seq seq -- seq ) [ bitxor ] 2map ;
|
||||
|
||||
: opad ( checksum-state -- seq ) block-size>> HEX: 5c <array> ;
|
||||
|
||||
: ipad ( checksum-state -- seq ) block-size>> HEX: 36 <array> ;
|
||||
|
||||
:: init-K ( K checksum checksum-state -- o i )
|
||||
checksum-state block-size>> K length <
|
||||
[ K checksum checksum-bytes ] [ K ] if
|
||||
checksum-state block-size>> 0 pad-tail
|
||||
[ checksum-state opad seq-bitxor ]
|
||||
[ checksum-state ipad seq-bitxor ] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
:: hmac-stream ( K stream checksum -- value )
|
||||
K checksum dup initialize-checksum-state
|
||||
dup :> checksum-state
|
||||
init-K :> Ki :> Ko
|
||||
checksum-state Ki add-checksum-bytes
|
||||
stream add-checksum-stream get-checksum
|
||||
checksum initialize-checksum-state
|
||||
Ko add-checksum-bytes swap add-checksum-bytes
|
||||
get-checksum ;
|
||||
|
||||
: hmac-file ( K path checksum -- value )
|
||||
[ binary <file-reader> ] dip hmac-stream ;
|
||||
|
||||
: hmac-bytes ( K seq checksum -- value )
|
||||
[ binary <byte-reader> ] dip hmac-stream ;
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -0,0 +1,19 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test checksums.interleave checksums.sha ;
|
||||
IN: checksums.interleave.tests
|
||||
|
||||
[
|
||||
B{
|
||||
59 155 253 205 75 163 94 115 208 42 227 92 181 19 60 232
|
||||
119 65 178 131 210 48 241 230 204 216 30 156 4 215 80 84 93
|
||||
206 44 1 18 128 150 153
|
||||
}
|
||||
] [
|
||||
B{
|
||||
102 83 241 12 26 250 181 76 97 200 37 117 168 74 254 48 216
|
||||
170 26 58 150 150 179 24 153 146 191 225 203 127 166 167
|
||||
}
|
||||
sha1 interleaved-checksum
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs checksums grouping kernel locals math sequences ;
|
||||
IN: checksums.interleave
|
||||
|
||||
: seq>2seq ( seq -- seq1 seq2 )
|
||||
#! { abcdefgh } -> { aceg } { bdfh }
|
||||
2 group flip [ { } { } ] [ first2 ] if-empty ;
|
||||
|
||||
: 2seq>seq ( seq1 seq2 -- seq )
|
||||
#! { aceg } { bdfh } -> { abcdefgh }
|
||||
[ zip concat ] keep like ;
|
||||
|
||||
:: interleaved-checksum ( bytes checksum -- seq )
|
||||
bytes [ zero? ] trim-head
|
||||
dup length odd? [ rest-slice ] when
|
||||
seq>2seq [ checksum checksum-bytes ] bi@ 2seq>seq ;
|
|
@ -1,4 +1,6 @@
|
|||
USING: kernel math namespaces checksums checksums.md5 tools.test byte-arrays ;
|
||||
USING: byte-arrays checksums checksums.md5 io.encodings.binary
|
||||
io.streams.byte-array kernel math namespaces tools.test ;
|
||||
|
||||
|
||||
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
|
||||
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test
|
||||
|
@ -8,3 +10,24 @@ USING: kernel math namespaces checksums checksums.md5 tools.test byte-arrays ;
|
|||
[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array md5 checksum-bytes hex-string ] unit-test
|
||||
[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array md5 checksum-bytes hex-string ] unit-test
|
||||
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<md5-state> "asdf" add-checksum-bytes
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<md5-state> "" add-checksum-bytes
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<md5-state> "asdf" binary <byte-reader> add-checksum-stream
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
|
|
@ -3,57 +3,53 @@
|
|||
USING: kernel io io.binary io.files io.streams.byte-array math
|
||||
math.functions math.parser namespaces splitting grouping strings
|
||||
sequences byte-arrays locals sequences.private macros fry
|
||||
io.encodings.binary math.bitwise checksums
|
||||
checksums.common checksums.stream combinators ;
|
||||
io.encodings.binary math.bitwise checksums accessors
|
||||
checksums.common checksums.stream combinators combinators.smart
|
||||
specialized-arrays.uint literals ;
|
||||
IN: checksums.md5
|
||||
|
||||
! See http://www.faqs.org/rfcs/rfc1321.html
|
||||
SINGLETON: md5
|
||||
|
||||
INSTANCE: md5 stream-checksum
|
||||
|
||||
TUPLE: md5-state < checksum-state state old-state ;
|
||||
|
||||
: <md5-state> ( -- md5 )
|
||||
md5-state new-checksum-state
|
||||
64 >>block-size
|
||||
uint-array{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 }
|
||||
[ clone >>state ] [ >>old-state ] bi ;
|
||||
|
||||
M: md5 initialize-checksum-state drop <md5-state> ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOLS: a b c d old-a old-b old-c old-d ;
|
||||
: v-w+ ( v1 v2 -- v3 ) [ w+ ] 2map ;
|
||||
|
||||
: T ( N -- Y )
|
||||
sin abs 32 2^ * >integer ; foldable
|
||||
: update-md5 ( md5 -- )
|
||||
[ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
|
||||
[ (>>old-state) ] [ (>>state) ] bi ; inline
|
||||
|
||||
: initialize-md5 ( -- )
|
||||
0 bytes-read set
|
||||
HEX: 67452301 dup a set old-a set
|
||||
HEX: efcdab89 dup b set old-b set
|
||||
HEX: 98badcfe dup c set old-c set
|
||||
HEX: 10325476 dup d set old-d set ;
|
||||
CONSTANT: T
|
||||
$[
|
||||
80 iota [ sin abs 32 2^ * >integer ] uint-array{ } map-as
|
||||
]
|
||||
|
||||
: update-md ( -- )
|
||||
old-a a update-old-new
|
||||
old-b b update-old-new
|
||||
old-c c update-old-new
|
||||
old-d d update-old-new ;
|
||||
|
||||
:: (ABCD) ( x a b c d k s i func -- )
|
||||
#! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
|
||||
a [
|
||||
b get c get d get func call w+
|
||||
k x nth-unsafe w+
|
||||
i T w+
|
||||
s bitroll-32
|
||||
b get w+
|
||||
] change ; inline
|
||||
|
||||
: F ( X Y Z -- FXYZ )
|
||||
:: F ( X Y Z -- FXYZ )
|
||||
#! F(X,Y,Z) = XY v not(X) Z
|
||||
pick bitnot bitand [ bitand ] [ bitor ] bi* ;
|
||||
X Y bitand X bitnot Z bitand bitor ; inline
|
||||
|
||||
: G ( X Y Z -- GXYZ )
|
||||
:: G ( X Y Z -- GXYZ )
|
||||
#! G(X,Y,Z) = XZ v Y not(Z)
|
||||
dup bitnot rot bitand [ bitand ] [ bitor ] bi* ;
|
||||
X Z bitand Y Z bitnot bitand bitor ; inline
|
||||
|
||||
: H ( X Y Z -- HXYZ )
|
||||
#! H(X,Y,Z) = X xor Y xor Z
|
||||
bitxor bitxor ;
|
||||
bitxor bitxor ; inline
|
||||
|
||||
: I ( X Y Z -- IXYZ )
|
||||
:: I ( X Y Z -- IXYZ )
|
||||
#! I(X,Y,Z) = Y xor (X v not(Z))
|
||||
rot swap bitnot bitor bitxor ;
|
||||
Z bitnot X bitor Y bitxor ; inline
|
||||
|
||||
CONSTANT: S11 7
|
||||
CONSTANT: S12 12
|
||||
|
@ -72,10 +68,27 @@ CONSTANT: S42 10
|
|||
CONSTANT: S43 15
|
||||
CONSTANT: S44 21
|
||||
|
||||
MACRO: with-md5-round ( ops func -- )
|
||||
'[ [ _ (ABCD) ] compose ] map '[ _ cleave ] ;
|
||||
CONSTANT: a 0
|
||||
CONSTANT: b 1
|
||||
CONSTANT: c 2
|
||||
CONSTANT: d 3
|
||||
|
||||
: (process-md5-block-F) ( block -- )
|
||||
:: (ABCD) ( x state a b c d k s i quot -- )
|
||||
#! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
|
||||
a state [
|
||||
b state nth-unsafe
|
||||
c state nth-unsafe
|
||||
d state nth-unsafe quot call w+
|
||||
k x nth-unsafe w+
|
||||
i T nth-unsafe w+
|
||||
s bitroll-32
|
||||
b state nth-unsafe w+ 32 bits
|
||||
] change-nth-unsafe ; inline
|
||||
|
||||
MACRO: with-md5-round ( ops quot -- )
|
||||
'[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ;
|
||||
|
||||
: (process-md5-block-F) ( block state -- )
|
||||
{
|
||||
[ a b c d 0 S11 1 ]
|
||||
[ d a b c 1 S12 2 ]
|
||||
|
@ -93,9 +106,9 @@ MACRO: with-md5-round ( ops func -- )
|
|||
[ d a b c 13 S12 14 ]
|
||||
[ c d a b 14 S13 15 ]
|
||||
[ b c d a 15 S14 16 ]
|
||||
} [ F ] with-md5-round ;
|
||||
} [ F ] with-md5-round ; inline
|
||||
|
||||
: (process-md5-block-G) ( block -- )
|
||||
: (process-md5-block-G) ( block state -- )
|
||||
{
|
||||
[ a b c d 1 S21 17 ]
|
||||
[ d a b c 6 S22 18 ]
|
||||
|
@ -113,9 +126,9 @@ MACRO: with-md5-round ( ops func -- )
|
|||
[ d a b c 2 S22 30 ]
|
||||
[ c d a b 7 S23 31 ]
|
||||
[ b c d a 12 S24 32 ]
|
||||
} [ G ] with-md5-round ;
|
||||
} [ G ] with-md5-round ; inline
|
||||
|
||||
: (process-md5-block-H) ( block -- )
|
||||
: (process-md5-block-H) ( block state -- )
|
||||
{
|
||||
[ a b c d 5 S31 33 ]
|
||||
[ d a b c 8 S32 34 ]
|
||||
|
@ -133,9 +146,9 @@ MACRO: with-md5-round ( ops func -- )
|
|||
[ d a b c 12 S32 46 ]
|
||||
[ c d a b 15 S33 47 ]
|
||||
[ b c d a 2 S34 48 ]
|
||||
} [ H ] with-md5-round ;
|
||||
} [ H ] with-md5-round ; inline
|
||||
|
||||
: (process-md5-block-I) ( block -- )
|
||||
: (process-md5-block-I) ( block state -- )
|
||||
{
|
||||
[ a b c d 0 S41 49 ]
|
||||
[ d a b c 7 S42 50 ]
|
||||
|
@ -153,38 +166,33 @@ MACRO: with-md5-round ( ops func -- )
|
|||
[ d a b c 11 S42 62 ]
|
||||
[ c d a b 2 S43 63 ]
|
||||
[ b c d a 9 S44 64 ]
|
||||
} [ I ] with-md5-round ;
|
||||
} [ I ] with-md5-round ; inline
|
||||
|
||||
: (process-md5-block) ( block -- )
|
||||
4 <groups> [ le> ] map {
|
||||
[ (process-md5-block-F) ]
|
||||
[ (process-md5-block-G) ]
|
||||
[ (process-md5-block-H) ]
|
||||
[ (process-md5-block-I) ]
|
||||
} cleave
|
||||
|
||||
update-md ;
|
||||
|
||||
: process-md5-block ( str -- )
|
||||
dup length [ bytes-read [ + ] change ] keep 64 = [
|
||||
(process-md5-block)
|
||||
M: md5-state checksum-block ( block state -- )
|
||||
[
|
||||
[ byte-array>uint-array ] [ state>> ] bi* {
|
||||
[ (process-md5-block-F) ]
|
||||
[ (process-md5-block-G) ]
|
||||
[ (process-md5-block-H) ]
|
||||
[ (process-md5-block-I) ]
|
||||
} 2cleave
|
||||
] [
|
||||
f bytes-read get pad-last-block
|
||||
[ (process-md5-block) ] each
|
||||
] if ;
|
||||
|
||||
: stream>md5 ( -- )
|
||||
64 read [ process-md5-block ] keep
|
||||
length 64 = [ stream>md5 ] when ;
|
||||
nip update-md5
|
||||
] 2bi ;
|
||||
|
||||
: get-md5 ( -- str )
|
||||
[ a b c d ] [ get 4 >le ] map concat >byte-array ;
|
||||
: md5>checksum ( md5 -- bytes ) state>> underlying>> ;
|
||||
|
||||
M: md5-state clone ( md5 -- new-md5 )
|
||||
call-next-method
|
||||
[ clone ] change-state
|
||||
[ clone ] change-old-state ;
|
||||
|
||||
M: md5-state get-checksum ( md5 -- bytes )
|
||||
clone [ bytes>> f ] [ bytes-read>> pad-last-block ] [ ] tri
|
||||
[ [ checksum-block ] curry each ] [ md5>checksum ] bi ;
|
||||
|
||||
M: md5 checksum-stream ( stream checksum -- byte-array )
|
||||
drop
|
||||
[ <md5-state> ] dip add-checksum-stream get-checksum ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SINGLETON: md5
|
||||
|
||||
INSTANCE: md5 stream-checksum
|
||||
|
||||
M: md5 checksum-stream ( stream -- byte-array )
|
||||
drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ;
|
||||
|
|
|
@ -30,8 +30,8 @@ ARTICLE: "checksums.openssl" "OpenSSL checksums"
|
|||
"An error thrown if the digest name is unrecognized:"
|
||||
{ $subsection unknown-digest }
|
||||
"An example where we compute the SHA1 checksum of a string using the OpenSSL implementation of SHA1:"
|
||||
{ $example "USING: byte-arrays checksums checksums.openssl prettyprint ;" "\"hello world\" >byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" }
|
||||
{ $example "USING: byte-arrays checksums checksums.openssl ;" "\"hello world\" >byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" }
|
||||
"If we use the Factor implementation, we get the same result, just slightly slower:"
|
||||
{ $example "USING: byte-arrays checksums checksums.sha1 prettyprint ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ;
|
||||
{ $example "USING: byte-arrays checksums checksums.sha ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ;
|
||||
|
||||
ABOUT: "checksums.openssl"
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
USING: accessors byte-arrays checksums checksums.openssl
|
||||
combinators.short-circuit kernel system tools.test ;
|
||||
IN: checksums.openssl.tests
|
||||
USING: byte-arrays checksums.openssl checksums tools.test
|
||||
accessors kernel system ;
|
||||
|
||||
[
|
||||
B{ 201 238 222 100 92 200 182 188 138 255 129 163 115 88 240 136 }
|
||||
|
@ -22,7 +22,7 @@ accessors kernel system ;
|
|||
"Bad checksum test" >byte-array
|
||||
"no such checksum" <openssl-checksum>
|
||||
checksum-bytes
|
||||
] [ [ unknown-digest? ] [ name>> "no such checksum" = ] bi and ]
|
||||
] [ { [ unknown-digest? ] [ name>> "no such checksum" = ] } 1&& ]
|
||||
must-fail-with
|
||||
|
||||
[ ] [ image openssl-sha1 checksum-file drop ] unit-test
|
||||
|
|
|
@ -0,0 +1,18 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: checksums.sha
|
||||
|
||||
HELP: sha-224
|
||||
{ $class-description "SHA-224 checksum algorithm." } ;
|
||||
|
||||
HELP: sha-256
|
||||
{ $class-description "SHA-256 checksum algorithm." } ;
|
||||
|
||||
ARTICLE: "checksums.sha" "SHA-2 checksum"
|
||||
"The SHA family of checksum algorithms are one-way hashes useful for checksumming data. SHA-1 is considered insecure, while SHA-2 It is generally considered to be pretty strong." $nl
|
||||
"SHA-2 checksums:"
|
||||
{ $subsection sha-224 }
|
||||
{ $subsection sha-256 }
|
||||
"SHA-1 checksum:"
|
||||
{ $subsection sha1 } ;
|
||||
|
||||
ABOUT: "checksums.sha"
|
|
@ -1,10 +1,18 @@
|
|||
USING: arrays kernel math namespaces sequences tools.test
|
||||
checksums.sha2 checksums ;
|
||||
IN: checksums.sha2.tests
|
||||
USING: arrays checksums checksums.sha checksums.sha.private
|
||||
io.encodings.binary io.streams.byte-array kernel math
|
||||
namespaces sequences tools.test ;
|
||||
IN: checksums.sha.tests
|
||||
|
||||
: test-checksum ( text identifier -- checksum )
|
||||
checksum-bytes hex-string ;
|
||||
|
||||
[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test
|
||||
[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test
|
||||
! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
|
||||
[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567"
|
||||
10 swap <array> concat sha1 checksum-bytes hex-string ] unit-test
|
||||
|
||||
|
||||
[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ]
|
||||
[
|
||||
"abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
|
||||
|
@ -36,7 +44,27 @@ IN: checksums.sha2.tests
|
|||
] unit-test
|
||||
|
||||
|
||||
|
||||
|
||||
! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ]
|
||||
! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<sha1-state> "asdf" binary <byte-reader> add-checksum-stream
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<sha-256-state> "asdf" binary <byte-reader> add-checksum-stream
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<sha-224-state> "asdf" binary <byte-reader> add-checksum-stream
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
|
@ -3,16 +3,40 @@
|
|||
USING: kernel splitting grouping math sequences namespaces make
|
||||
io.binary math.bitwise checksums checksums.common
|
||||
sbufs strings combinators.smart math.ranges fry combinators
|
||||
accessors locals ;
|
||||
IN: checksums.sha2
|
||||
accessors locals checksums.stream multiline literals
|
||||
generalizations ;
|
||||
IN: checksums.sha
|
||||
|
||||
SINGLETON: sha1
|
||||
INSTANCE: sha1 stream-checksum
|
||||
|
||||
SINGLETON: sha-224
|
||||
SINGLETON: sha-256
|
||||
|
||||
INSTANCE: sha-224 checksum
|
||||
INSTANCE: sha-256 checksum
|
||||
INSTANCE: sha-224 stream-checksum
|
||||
INSTANCE: sha-256 stream-checksum
|
||||
|
||||
TUPLE: sha2-state K H word-size block-size ;
|
||||
TUPLE: sha1-state < checksum-state K H W word-size ;
|
||||
|
||||
CONSTANT: initial-H-sha1
|
||||
{
|
||||
HEX: 67452301
|
||||
HEX: efcdab89
|
||||
HEX: 98badcfe
|
||||
HEX: 10325476
|
||||
HEX: c3d2e1f0
|
||||
}
|
||||
|
||||
CONSTANT: K-sha1
|
||||
$[
|
||||
20 HEX: 5a827999 <repetition>
|
||||
20 HEX: 6ed9eba1 <repetition>
|
||||
20 HEX: 8f1bbcdc <repetition>
|
||||
20 HEX: ca62c1d6 <repetition>
|
||||
4 { } nappend-as
|
||||
]
|
||||
|
||||
TUPLE: sha2-state < checksum-state K H word-size ;
|
||||
|
||||
TUPLE: sha2-short < sha2-state ;
|
||||
|
||||
|
@ -22,6 +46,11 @@ TUPLE: sha-224-state < sha2-short ;
|
|||
|
||||
TUPLE: sha-256-state < sha2-short ;
|
||||
|
||||
M: sha2-state clone
|
||||
call-next-method
|
||||
[ clone ] change-H
|
||||
[ clone ] change-K ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTANT: a 0
|
||||
|
@ -116,6 +145,33 @@ CONSTANT: K-384
|
|||
|
||||
ALIAS: K-512 K-384
|
||||
|
||||
: <sha1-state> ( -- sha1-state )
|
||||
sha1-state new-checksum-state
|
||||
64 >>block-size
|
||||
K-sha1 >>K
|
||||
initial-H-sha1 >>H
|
||||
4 >>word-size ;
|
||||
|
||||
: <sha-224-state> ( -- sha2-state )
|
||||
sha-224-state new-checksum-state
|
||||
64 >>block-size
|
||||
K-256 >>K
|
||||
initial-H-224 >>H
|
||||
4 >>word-size ;
|
||||
|
||||
: <sha-256-state> ( -- sha2-state )
|
||||
sha-256-state new-checksum-state
|
||||
64 >>block-size
|
||||
K-256 >>K
|
||||
initial-H-256 >>H
|
||||
4 >>word-size ;
|
||||
|
||||
M: sha1 initialize-checksum-state drop <sha1-state> ;
|
||||
|
||||
M: sha-224 initialize-checksum-state drop <sha-224-state> ;
|
||||
|
||||
M: sha-256 initialize-checksum-state drop <sha-256-state> ;
|
||||
|
||||
: s0-256 ( x -- x' )
|
||||
[
|
||||
[ -7 bitroll-32 ]
|
||||
|
@ -172,7 +228,7 @@ ALIAS: K-512 K-384
|
|||
[ -41 bitroll-64 ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: process-M-256 ( n seq -- )
|
||||
: prepare-M-256 ( n seq -- )
|
||||
{
|
||||
[ [ 16 - ] dip nth ]
|
||||
[ [ 15 - ] dip nth s0-256 ]
|
||||
|
@ -181,7 +237,7 @@ ALIAS: K-512 K-384
|
|||
[ ]
|
||||
} 2cleave set-nth ; inline
|
||||
|
||||
: process-M-512 ( n seq -- )
|
||||
: prepare-M-512 ( n seq -- )
|
||||
{
|
||||
[ [ 16 - ] dip nth ]
|
||||
[ [ 15 - ] dip nth s0-512 ]
|
||||
|
@ -201,26 +257,6 @@ ALIAS: K-512 K-384
|
|||
|
||||
GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
|
||||
|
||||
M: sha2-short pad-initial-bytes ( string sha2 -- padded-string )
|
||||
drop
|
||||
dup [
|
||||
HEX: 80 ,
|
||||
length
|
||||
[ 64 mod calculate-pad-length 0 <string> % ]
|
||||
[ 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 <string> % ]
|
||||
[ 3 shift 8 >be % ] bi
|
||||
] "" make append ;
|
||||
|
||||
: seq>byte-array ( seq n -- string )
|
||||
'[ _ >be ] map B{ } join ;
|
||||
|
||||
:: T1-256 ( n M H sha2 -- T1 )
|
||||
n M nth
|
||||
n sha2 K>> nth +
|
||||
|
@ -257,7 +293,7 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
|
|||
[ word-size>> <sliced-groups> [ be> ] map ]
|
||||
[
|
||||
block-size>> [ 0 pad-tail 16 ] keep [a,b) over
|
||||
'[ _ process-M-256 ] each
|
||||
'[ _ prepare-M-256 ] each
|
||||
] bi ; inline
|
||||
|
||||
:: process-chunk ( M block-size cloned-H sha2 -- )
|
||||
|
@ -266,41 +302,110 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
|
|||
cloned-H T2-256
|
||||
cloned-H update-H
|
||||
] each
|
||||
cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline
|
||||
sha2 [ cloned-H [ w+ ] 2map ] change-H drop ; inline
|
||||
|
||||
: sha2-steps ( sliced-groups state -- )
|
||||
'[
|
||||
_
|
||||
[ prepare-message-schedule ]
|
||||
[ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi
|
||||
] each ;
|
||||
M: sha2-short checksum-block
|
||||
[ prepare-message-schedule ]
|
||||
[ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
|
||||
|
||||
: byte-array>sha2 ( bytes state -- )
|
||||
[ [ pad-initial-bytes ] [ nip block-size>> ] 2bi <sliced-groups> ]
|
||||
[ sha2-steps ] bi ;
|
||||
: seq>byte-array ( seq n -- string )
|
||||
'[ _ >be ] map B{ } join ;
|
||||
|
||||
: <sha-224-state> ( -- sha2-state )
|
||||
sha-224-state new
|
||||
K-256 >>K
|
||||
initial-H-224 >>H
|
||||
4 >>word-size
|
||||
64 >>block-size ;
|
||||
: sha1>checksum ( sha2 -- bytes )
|
||||
H>> 4 seq>byte-array ;
|
||||
|
||||
: <sha-256-state> ( -- sha2-state )
|
||||
sha-256-state new
|
||||
K-256 >>K
|
||||
initial-H-256 >>H
|
||||
4 >>word-size
|
||||
64 >>block-size ;
|
||||
: sha-224>checksum ( sha2 -- bytes )
|
||||
H>> 7 head 4 seq>byte-array ;
|
||||
|
||||
: sha-256>checksum ( sha2 -- bytes )
|
||||
H>> 4 seq>byte-array ;
|
||||
|
||||
: pad-last-short-block ( state -- )
|
||||
[ bytes>> t ] [ bytes-read>> pad-last-block ] [ ] tri
|
||||
[ checksum-block ] curry each ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: sha-224 checksum-bytes
|
||||
drop <sha-224-state>
|
||||
[ byte-array>sha2 ]
|
||||
[ H>> 7 head 4 seq>byte-array ] bi ;
|
||||
M: sha-224-state get-checksum
|
||||
clone
|
||||
[ pad-last-short-block ] [ sha-224>checksum ] bi ;
|
||||
|
||||
M: sha-256 checksum-bytes
|
||||
drop <sha-256-state>
|
||||
[ byte-array>sha2 ]
|
||||
[ H>> 4 seq>byte-array ] bi ;
|
||||
M: sha-256-state get-checksum
|
||||
clone
|
||||
[ pad-last-short-block ] [ sha-256>checksum ] bi ;
|
||||
|
||||
M: sha-224 checksum-stream ( stream checksum -- byte-array )
|
||||
drop
|
||||
[ <sha-224-state> ] dip add-checksum-stream get-checksum ;
|
||||
|
||||
M: sha-256 checksum-stream ( stream checksum -- byte-array )
|
||||
drop
|
||||
[ <sha-256-state> ] dip add-checksum-stream get-checksum ;
|
||||
|
||||
|
||||
|
||||
: sha1-W ( t seq -- )
|
||||
{
|
||||
[ [ 3 - ] dip nth ]
|
||||
[ [ 8 - ] dip nth bitxor ]
|
||||
[ [ 14 - ] dip nth bitxor ]
|
||||
[ [ 16 - ] dip nth bitxor 1 bitroll-32 ]
|
||||
[ ]
|
||||
} 2cleave set-nth ;
|
||||
|
||||
: prepare-sha1-message-schedule ( seq -- w-seq )
|
||||
4 <sliced-groups> [ be> ] map
|
||||
80 0 pad-tail 16 80 [a,b) over
|
||||
'[ _ sha1-W ] each ; inline
|
||||
|
||||
: sha1-f ( B C D n -- f_nbcd )
|
||||
20 /i
|
||||
{
|
||||
{ 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] }
|
||||
{ 1 [ bitxor bitxor ] }
|
||||
{ 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] }
|
||||
{ 3 [ bitxor bitxor ] }
|
||||
} case ;
|
||||
|
||||
:: inner-loop ( n H W K -- temp )
|
||||
a H nth :> A
|
||||
b H nth :> B
|
||||
c H nth :> C
|
||||
d H nth :> D
|
||||
e H nth :> E
|
||||
[
|
||||
A 5 bitroll-32
|
||||
|
||||
B C D n sha1-f
|
||||
|
||||
E
|
||||
|
||||
n K nth
|
||||
|
||||
n W nth
|
||||
] sum-outputs 32 bits ;
|
||||
|
||||
:: process-sha1-chunk ( bytes H W K state -- )
|
||||
80 [
|
||||
H W K inner-loop
|
||||
d H nth e H set-nth
|
||||
c H nth d H set-nth
|
||||
b H nth 30 bitroll-32 c H set-nth
|
||||
a H nth b H set-nth
|
||||
a H set-nth
|
||||
] each
|
||||
state [ H [ w+ ] 2map ] change-H drop ; inline
|
||||
|
||||
M:: sha1-state checksum-block ( bytes state -- )
|
||||
bytes prepare-sha1-message-schedule state (>>W)
|
||||
|
||||
bytes
|
||||
state [ H>> clone ] [ W>> ] [ K>> ] tri state process-sha1-chunk ;
|
||||
|
||||
M: sha1-state get-checksum
|
||||
clone
|
||||
[ pad-last-short-block ] [ sha-256>checksum ] bi ;
|
||||
|
||||
M: sha1 checksum-stream ( stream checksum -- byte-array )
|
||||
drop
|
||||
[ <sha1-state> ] dip add-checksum-stream get-checksum ;
|
|
@ -0,0 +1 @@
|
|||
SHA checksum algorithms
|
|
@ -1,11 +0,0 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: checksums.sha1
|
||||
|
||||
HELP: sha1
|
||||
{ $class-description "SHA1 checksum algorithm." } ;
|
||||
|
||||
ARTICLE: "checksums.sha1" "SHA1 checksum"
|
||||
"The SHA1 checksum algorithm implements a one-way hash function. It is generally considered to be stronger than MD5, however there is a known algorithm for finding collisions more effectively than a brute-force search (" { $url "http://www.schneier.com/blog/archives/2005/02/sha1_broken.html" } ")."
|
||||
{ $subsection sha1 } ;
|
||||
|
||||
ABOUT: "checksums.sha1"
|
|
@ -1,14 +0,0 @@
|
|||
USING: arrays kernel math namespaces sequences tools.test checksums checksums.sha1 ;
|
||||
|
||||
[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test
|
||||
[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test
|
||||
! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
|
||||
[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567"
|
||||
10 swap <array> concat sha1 checksum-bytes hex-string ] unit-test
|
||||
|
||||
[
|
||||
";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099"
|
||||
] [
|
||||
"\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7"
|
||||
sha1-interleave
|
||||
] unit-test
|
|
@ -1,134 +0,0 @@
|
|||
! 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
|
||||
make math parser sequences assocs grouping vectors io.binary
|
||||
hashtables math.bitwise checksums checksums.common
|
||||
checksums.stream ;
|
||||
IN: checksums.sha1
|
||||
|
||||
! Implemented according to RFC 3174.
|
||||
|
||||
SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
|
||||
|
||||
: get-wth ( n -- wth ) w get nth ; inline
|
||||
: shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline
|
||||
|
||||
: initialize-sha1 ( -- )
|
||||
0 bytes-read set
|
||||
HEX: 67452301 dup h0 set A set
|
||||
HEX: efcdab89 dup h1 set B set
|
||||
HEX: 98badcfe dup h2 set C set
|
||||
HEX: 10325476 dup h3 set D set
|
||||
HEX: c3d2e1f0 dup h4 set E set
|
||||
[
|
||||
20 HEX: 5a827999 <array> %
|
||||
20 HEX: 6ed9eba1 <array> %
|
||||
20 HEX: 8f1bbcdc <array> %
|
||||
20 HEX: ca62c1d6 <array> %
|
||||
] { } make K set ;
|
||||
|
||||
! W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16))
|
||||
: sha1-W ( t -- W_t )
|
||||
dup 3 - get-wth
|
||||
over 8 - get-wth bitxor
|
||||
over 14 - get-wth bitxor
|
||||
swap 16 - get-wth bitxor 1 bitroll-32 ;
|
||||
|
||||
! f(t;B,C,D) = (B AND C) OR ((NOT B) AND D) ( 0 <= t <= 19)
|
||||
! f(t;B,C,D) = B XOR C XOR D (20 <= t <= 39)
|
||||
! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D) (40 <= t <= 59)
|
||||
! f(t;B,C,D) = B XOR C XOR D (60 <= t <= 79)
|
||||
: sha1-f ( B C D t -- f_tbcd )
|
||||
20 /i
|
||||
{
|
||||
{ 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] }
|
||||
{ 1 [ bitxor bitxor ] }
|
||||
{ 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] }
|
||||
{ 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
|
||||
16 80 dup <slice> [ sha1-W w get push ] each ;
|
||||
|
||||
: init-letters ( -- )
|
||||
! step c of RFC 3174, section 6.1
|
||||
h0 get A set
|
||||
h1 get B set
|
||||
h2 get C set
|
||||
h3 get D set
|
||||
h4 get E set ;
|
||||
|
||||
: inner-loop ( n -- temp )
|
||||
! TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t);
|
||||
[
|
||||
[ B get C get D get ] keep sha1-f ,
|
||||
dup get-wth ,
|
||||
K get nth ,
|
||||
A get 5 bitroll-32 ,
|
||||
E get ,
|
||||
] { } make sum 32 bits ; inline
|
||||
|
||||
: set-vars ( temp -- )
|
||||
! E = D; D = C; C = S^30(B); B = A; A = TEMP;
|
||||
D get E set
|
||||
C get D set
|
||||
B get 30 bitroll-32 C set
|
||||
A get B set
|
||||
A set ;
|
||||
|
||||
: calculate-letters ( -- )
|
||||
! step d of RFC 3174, section 6.1
|
||||
80 [ inner-loop set-vars ] each ;
|
||||
|
||||
: update-hs ( -- )
|
||||
! step e of RFC 3174, section 6.1
|
||||
A h0 update-old-new
|
||||
B h1 update-old-new
|
||||
C h2 update-old-new
|
||||
D h3 update-old-new
|
||||
E h4 update-old-new ;
|
||||
|
||||
: (process-sha1-block) ( str -- )
|
||||
80 <vector> w set make-w init-letters calculate-letters update-hs ;
|
||||
|
||||
: process-sha1-block ( str -- )
|
||||
dup length [ bytes-read [ + ] change ] keep 64 = [
|
||||
(process-sha1-block)
|
||||
] [
|
||||
t bytes-read get pad-last-block
|
||||
[ (process-sha1-block) ] each
|
||||
] if ;
|
||||
|
||||
: stream>sha1 ( -- )
|
||||
64 read [ process-sha1-block ] keep
|
||||
length 64 = [ stream>sha1 ] when ;
|
||||
|
||||
: get-sha1 ( -- str )
|
||||
[ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
|
||||
|
||||
SINGLETON: sha1
|
||||
|
||||
INSTANCE: sha1 stream-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 [ { } { } ] [ first2 ] if-empty ;
|
||||
|
||||
: 2seq>seq ( seq1 seq2 -- seq )
|
||||
#! { aceg } { bdfh } -> { abcdefgh }
|
||||
[ zip concat ] keep like ;
|
||||
|
||||
: sha1-interleave ( string -- seq )
|
||||
[ zero? ] trim-head
|
||||
dup length odd? [ rest ] when
|
||||
seq>2seq [ sha1 checksum-bytes ] bi@
|
||||
2seq>seq ;
|
|
@ -1 +0,0 @@
|
|||
SHA1 checksum algorithm
|
|
@ -1,11 +0,0 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: checksums.sha2
|
||||
|
||||
HELP: sha-256
|
||||
{ $class-description "SHA-256 checksum algorithm." } ;
|
||||
|
||||
ARTICLE: "checksums.sha2" "SHA2 checksum"
|
||||
"The SHA2 checksum algorithm implements a one-way hash function. It is generally considered to be pretty strong."
|
||||
{ $subsection sha-256 } ;
|
||||
|
||||
ABOUT: "checksums.sha2"
|
|
@ -1 +0,0 @@
|
|||
SHA2 checksum algorithm
|
|
@ -2,9 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types alien.strings arrays assocs
|
||||
continuations combinators compiler compiler.alien stack-checker kernel
|
||||
math namespaces make parser quotations sequences strings words
|
||||
math namespaces make quotations sequences strings words
|
||||
cocoa.runtime io macros memoize io.encodings.utf8 effects libc
|
||||
libc.private parser lexer init core-foundation fry generalizations
|
||||
libc.private lexer init core-foundation fry generalizations
|
||||
specialized-arrays.direct.alien ;
|
||||
IN: cocoa.messages
|
||||
|
||||
|
|
|
@ -69,6 +69,4 @@ SYMBOL: main-vocab-hook
|
|||
: ignore-cli-args? ( -- ? )
|
||||
os macosx? "run" get "ui" = and ;
|
||||
|
||||
: script-mode ( -- ) ;
|
||||
|
||||
[ default-cli-args ] "command-line" add-init-hook
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors namespaces make math sequences sets
|
||||
assocs fry compiler.cfg.instructions ;
|
||||
assocs fry compiler.cfg compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.rpo
|
||||
|
||||
SYMBOL: visited
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces arrays sequences io words fry
|
||||
continuations vocabs assocs dlists definitions math graphs generic
|
||||
generic.single combinators deques search-deques macros io
|
||||
generic.single combinators deques search-deques macros
|
||||
source-files.errors stack-checker stack-checker.state
|
||||
stack-checker.inlining stack-checker.errors combinators.short-circuit
|
||||
compiler.errors compiler.units compiler.tree.builder
|
||||
|
|
|
@ -1,9 +1,8 @@
|
|||
USING: alien alien.c-types alien.syntax compiler kernel
|
||||
namespaces namespaces tools.test sequences stack-checker
|
||||
stack-checker.errors words arrays parser quotations
|
||||
continuations effects namespaces.private io io.streams.string
|
||||
memory system threads tools.test math accessors combinators
|
||||
specialized-arrays.float alien.libraries io.pathnames
|
||||
USING: alien alien.c-types alien.syntax compiler kernel namespaces
|
||||
sequences stack-checker stack-checker.errors words arrays parser
|
||||
quotations continuations effects namespaces.private io
|
||||
io.streams.string memory system threads tools.test math accessors
|
||||
combinators specialized-arrays.float alien.libraries io.pathnames
|
||||
io.backend ;
|
||||
IN: compiler.tests.alien
|
||||
|
||||
|
|
|
@ -1,9 +1,9 @@
|
|||
USING: generalizations accessors arrays compiler kernel
|
||||
kernel.private math hashtables.private math.private namespaces
|
||||
sequences sequences.private tools.test namespaces.private
|
||||
slots.private sequences.private byte-arrays alien
|
||||
USING: generalizations accessors arrays compiler kernel kernel.private
|
||||
math hashtables.private math.private namespaces sequences tools.test
|
||||
namespaces.private slots.private sequences.private byte-arrays alien
|
||||
alien.accessors layouts words definitions compiler.units io
|
||||
combinators vectors grouping make ;
|
||||
QUALIFIED: namespaces.private
|
||||
IN: compiler.tests.codegen
|
||||
|
||||
! Originally, this file did black box testing of templating
|
||||
|
@ -48,7 +48,7 @@ unit-test
|
|||
[ 3 ]
|
||||
[
|
||||
global [ 3 \ foo set ] bind
|
||||
\ foo [ global >n get ndrop ] compile-call
|
||||
\ foo [ global >n get namespaces.private:ndrop ] compile-call
|
||||
] unit-test
|
||||
|
||||
: blech ( x -- ) drop ;
|
||||
|
@ -62,7 +62,7 @@ unit-test
|
|||
[ 3 ]
|
||||
[
|
||||
global [ 3 \ foo set ] bind
|
||||
\ foo [ global [ get ] swap >n call ndrop ] compile-call
|
||||
\ foo [ global [ get ] swap >n call namespaces.private:ndrop ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ 3 ]
|
||||
|
|
|
@ -1,10 +1,10 @@
|
|||
USING: accessors arrays compiler.units kernel kernel.private math
|
||||
math.constants math.private sequences strings tools.test words
|
||||
continuations sequences.private hashtables.private byte-arrays
|
||||
strings.private system random layouts vectors
|
||||
system random layouts vectors
|
||||
sbufs strings.private slots.private alien math.order
|
||||
alien.accessors alien.c-types alien.syntax alien.strings
|
||||
namespaces libc sequences.private io.encodings.ascii
|
||||
namespaces libc io.encodings.ascii
|
||||
classes compiler ;
|
||||
IN: compiler.tests.intrinsics
|
||||
|
||||
|
|
|
@ -16,6 +16,7 @@ compiler.tree.builder
|
|||
compiler.tree.optimizer
|
||||
compiler.tree.combinators
|
||||
compiler.tree.checker ;
|
||||
FROM: fry => _ ;
|
||||
RENAME: _ match => __
|
||||
IN: compiler.tree.debugger
|
||||
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays namespaces assocs sequences kernel generic assocs
|
||||
USING: arrays namespaces sequences kernel generic assocs
|
||||
classes vectors accessors combinators sets
|
||||
stack-checker.state
|
||||
stack-checker.branches
|
||||
|
|
|
@ -322,3 +322,9 @@ C: <ro-box> ro-box
|
|||
[ 0 ] [
|
||||
[ { null } declare [ 1 ] [ 2 ] if ] count-unboxed-allocations
|
||||
] unit-test
|
||||
|
||||
! Doug found a regression
|
||||
|
||||
TUPLE: empty-tuple ;
|
||||
|
||||
[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
|
|
@ -49,14 +49,10 @@ M: #push escape-analysis*
|
|||
|
||||
: slot-offset ( #call -- n/f )
|
||||
dup in-d>>
|
||||
[ first node-value-info class>> ]
|
||||
[ second node-value-info literal>> ] 2bi
|
||||
dup fixnum? [
|
||||
{
|
||||
{ [ over tuple class<= ] [ 2 - ] }
|
||||
{ [ over complex class<= ] [ 1 - ] }
|
||||
[ drop f ]
|
||||
} cond nip
|
||||
[ second node-value-info literal>> ]
|
||||
[ first node-value-info class>> ] 2bi
|
||||
2dup [ fixnum? ] [ tuple class<= ] bi* and [
|
||||
over 2 >= [ drop 2 - ] [ 2drop f ] if
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
: record-slot-call ( #call -- )
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry namespaces sequences math math.order accessors kernel arrays
|
||||
combinators compiler.utilities assocs
|
||||
combinators assocs
|
||||
stack-checker.backend
|
||||
stack-checker.branches
|
||||
stack-checker.inlining
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: accessors math math.intervals sequences classes.algebra
|
||||
math kernel tools.test compiler.tree.propagation.info arrays ;
|
||||
kernel tools.test compiler.tree.propagation.info arrays ;
|
||||
IN: compiler.tree.propagation.info.tests
|
||||
|
||||
[ f ] [ 0.0 -0.0 eql? ] unit-test
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences accessors kernel assocs sequences
|
||||
USING: sequences accessors kernel assocs
|
||||
compiler.tree
|
||||
compiler.tree.propagation.copy
|
||||
compiler.tree.propagation.info ;
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
IN: compiler.tree.tuple-unboxing.tests
|
||||
USING: tools.test compiler.tree.tuple-unboxing compiler.tree
|
||||
USING: tools.test compiler.tree
|
||||
compiler.tree.builder compiler.tree.recursive
|
||||
compiler.tree.normalization compiler.tree.propagation
|
||||
compiler.tree.cleanup compiler.tree.escape-analysis
|
||||
|
|
|
@ -0,0 +1,88 @@
|
|||
! Copyright (C) 2009 Marc Fauconneau.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs constructors fry
|
||||
hashtables io kernel locals math math.order math.parser
|
||||
math.ranges multiline sequences ;
|
||||
IN: compression.huffman
|
||||
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! huffman codes
|
||||
|
||||
TUPLE: huffman-code
|
||||
{ value }
|
||||
{ size }
|
||||
{ code } ;
|
||||
|
||||
: <huffman-code> ( -- code ) 0 0 0 huffman-code boa ;
|
||||
: next-size ( code -- ) [ 1+ ] change-size [ 2 * ] change-code drop ;
|
||||
: next-code ( code -- ) [ 1+ ] change-code drop ;
|
||||
|
||||
:: all-patterns ( huff n -- seq )
|
||||
n log2 huff size>> - :> free-bits
|
||||
free-bits 0 >
|
||||
[ free-bits 2^ [0,b) [ huff code>> free-bits 2^ * + ] map ]
|
||||
[ huff code>> free-bits neg 2^ /i 1array ] if ;
|
||||
|
||||
:: huffman-each ( tdesc quot: ( huff -- ) -- )
|
||||
<huffman-code> :> code
|
||||
tdesc
|
||||
[
|
||||
code next-size
|
||||
[ code (>>value) code clone quot call code next-code ] each
|
||||
] each ; inline
|
||||
|
||||
: update-reverse-table ( huff n table -- )
|
||||
[ drop all-patterns ]
|
||||
[ nip '[ _ swap _ set-at ] each ] 3bi ;
|
||||
|
||||
:: reverse-table ( tdesc n -- rtable )
|
||||
n f <array> <enum> :> table
|
||||
tdesc [ n table update-reverse-table ] huffman-each
|
||||
table seq>> ;
|
||||
|
||||
:: huffman-table ( tdesc max -- table )
|
||||
max f <array> :> table
|
||||
tdesc [ [ ] [ value>> ] bi table set-nth ] huffman-each
|
||||
table ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! decoder
|
||||
|
||||
TUPLE: huffman-decoder
|
||||
{ bs }
|
||||
{ tdesc }
|
||||
{ rtable }
|
||||
{ bits/level } ;
|
||||
|
||||
CONSTRUCTOR: huffman-decoder ( bs tdesc -- decoder )
|
||||
16 >>bits/level
|
||||
[ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ;
|
||||
|
||||
: read1-huff ( decoder -- elt )
|
||||
16 over [ bs>> bs:peek ] [ rtable>> nth ] bi ! first/last
|
||||
[ size>> swap bs>> bs:seek ] [ value>> ] bi ;
|
||||
|
||||
! %remove
|
||||
: reverse-bits ( value bits -- value' )
|
||||
[ >bin ] [ CHAR: 0 pad-head <reversed> bin> ] bi* ;
|
||||
|
||||
: read1-huff2 ( decoder -- elt )
|
||||
16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi ! first/last
|
||||
[ size>> swap bs>> bs:seek ] [ value>> ] bi ;
|
||||
|
||||
/*
|
||||
: huff>string ( code -- str )
|
||||
[ value>> number>string ]
|
||||
[ [ code>> ] [ size>> bits>string ] bi ] bi
|
||||
" = " glue ;
|
||||
|
||||
: huff. ( code -- ) huff>string print ;
|
||||
|
||||
:: rtable. ( rtable -- )
|
||||
rtable length>> log2 :> n
|
||||
rtable <enum> [ swap n bits. [ huff. ] each ] assoc-each ;
|
||||
*/
|
|
@ -0,0 +1,212 @@
|
|||
! Copyright (C) 2009 Marc Fauconneau.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs byte-arrays
|
||||
byte-vectors combinators constructors fry grouping hashtables
|
||||
compression.huffman images io.binary kernel locals
|
||||
math math.bitwise math.order math.ranges multiline sequences
|
||||
sorting ;
|
||||
IN: compression.inflate
|
||||
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: enum>seq ( assoc -- seq )
|
||||
dup keys [ ] [ max ] map-reduce 1 + f <array>
|
||||
[ '[ swap _ set-nth ] assoc-each ] keep ;
|
||||
|
||||
ERROR: zlib-unimplemented ;
|
||||
ERROR: bad-zlib-data ;
|
||||
ERROR: bad-zlib-header ;
|
||||
|
||||
:: check-zlib-header ( data -- )
|
||||
16 data bs:peek 2 >le be> 31 mod ! checksum
|
||||
0 assert=
|
||||
4 data bs:read 8 assert= ! compression method: deflate
|
||||
4 data bs:read ! log2(max length)-8, 32K max
|
||||
7 <= [ bad-zlib-header ] unless
|
||||
5 data bs:seek ! drop check bits
|
||||
1 data bs:read 0 assert= ! dictionnary - not allowed in png
|
||||
2 data bs:seek ! compression level; ignore
|
||||
;
|
||||
|
||||
:: default-table ( -- table )
|
||||
0 <hashtable> :> table
|
||||
0 143 [a,b] 280 287 [a,b] append 8 table set-at
|
||||
144 255 [a,b] >array 9 table set-at
|
||||
256 279 [a,b] >array 7 table set-at
|
||||
table enum>seq 1 tail ;
|
||||
|
||||
CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
|
||||
|
||||
: get-table ( values size -- table )
|
||||
16 f <array> clone <enum>
|
||||
[ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;
|
||||
|
||||
:: decode-huffman-tables ( bitstream -- tables )
|
||||
5 bitstream bs:read 257 +
|
||||
5 bitstream bs:read 1 +
|
||||
4 bitstream bs:read 4 +
|
||||
clen-shuffle swap head
|
||||
dup [ drop 3 bitstream bs:read ] map
|
||||
get-table
|
||||
bitstream swap <huffman-decoder>
|
||||
[ 2dup + ] dip swap :> k!
|
||||
'[
|
||||
_ read1-huff2
|
||||
{
|
||||
{ [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
|
||||
{ [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
|
||||
{ [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
|
||||
[ ]
|
||||
} cond
|
||||
dup array? [ dup second ] [ 1 ] if
|
||||
k swap - dup k! 0 >
|
||||
]
|
||||
[ ] produce swap suffix
|
||||
{ } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce
|
||||
[ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
|
||||
nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
|
||||
|
||||
CONSTANT: length-table
|
||||
{
|
||||
3 4 5 6 7 8 9 10
|
||||
11 13 15 17
|
||||
19 23 27 31
|
||||
35 43 51 59
|
||||
67 83 99 115
|
||||
131 163 195 227 258
|
||||
}
|
||||
|
||||
CONSTANT: dist-table
|
||||
{
|
||||
1 2 3 4
|
||||
5 7 9 13
|
||||
17 25 33 49
|
||||
65 97 129 193
|
||||
257 385 513 769
|
||||
1025 1537 2049 3073
|
||||
4097 6145 8193 12289
|
||||
16385 24577
|
||||
}
|
||||
|
||||
: nth* ( n seq -- elt )
|
||||
[ length 1- swap - ] [ nth ] bi ;
|
||||
|
||||
:: inflate-lz77 ( seq -- bytes )
|
||||
1000 <byte-vector> :> bytes
|
||||
seq
|
||||
[
|
||||
dup array?
|
||||
[ first2 '[ _ 1- bytes nth* bytes push ] times ]
|
||||
[ bytes push ] if
|
||||
] each
|
||||
bytes ;
|
||||
|
||||
:: inflate-dynamic ( bitstream -- bytes )
|
||||
bitstream decode-huffman-tables
|
||||
bitstream '[ _ swap <huffman-decoder> ] map :> tables
|
||||
[
|
||||
tables first read1-huff2
|
||||
dup 256 >
|
||||
[
|
||||
dup 285 =
|
||||
[ ]
|
||||
[
|
||||
dup 264 >
|
||||
[
|
||||
dup 261 - 4 /i dup 5 >
|
||||
[ bad-zlib-data ] when
|
||||
bitstream bs:read 2array
|
||||
]
|
||||
when
|
||||
] if
|
||||
! 5 bitstream read-bits ! distance
|
||||
tables second read1-huff2
|
||||
dup 3 >
|
||||
[
|
||||
dup 2 - 2 /i dup 13 >
|
||||
[ bad-zlib-data ] when
|
||||
bitstream bs:read 2array
|
||||
]
|
||||
when
|
||||
2array
|
||||
]
|
||||
when
|
||||
dup 256 = not
|
||||
]
|
||||
[ ] produce nip
|
||||
[
|
||||
dup array? [
|
||||
first2
|
||||
[
|
||||
dup array? [ first2 ] [ 0 ] if
|
||||
[ 257 - length-table nth ] [ + ] bi*
|
||||
]
|
||||
[
|
||||
dup array? [ first2 ] [ 0 ] if
|
||||
[ dist-table nth ] [ + ] bi*
|
||||
] bi*
|
||||
2array
|
||||
] when
|
||||
] map ;
|
||||
|
||||
: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ;
|
||||
: inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
|
||||
|
||||
:: inflate-loop ( bitstream -- bytes )
|
||||
[ 1 bitstream bs:read 0 = ]
|
||||
[
|
||||
bitstream
|
||||
2 bitstream bs:read
|
||||
{
|
||||
{ 0 [ inflate-raw ] }
|
||||
{ 1 [ inflate-static ] }
|
||||
{ 2 [ inflate-dynamic ] }
|
||||
{ 3 [ bad-zlib-data f ] }
|
||||
}
|
||||
case
|
||||
]
|
||||
[ produce ] keep call suffix concat ;
|
||||
|
||||
! [ produce ] keep dip swap suffix
|
||||
|
||||
:: paeth ( a b c -- p )
|
||||
a b + c - { a b c } [ [ - abs ] keep 2array ] with map
|
||||
sort-keys first second ;
|
||||
|
||||
:: png-unfilter-line ( prev curr filter -- curr' )
|
||||
prev :> c
|
||||
prev 3 tail-slice :> b
|
||||
curr :> a
|
||||
curr 3 tail-slice :> x
|
||||
x length [0,b)
|
||||
filter
|
||||
{
|
||||
{ 0 [ drop ] }
|
||||
{ 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
|
||||
{ 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
|
||||
{ 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
|
||||
{ 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
|
||||
|
||||
} case
|
||||
curr 3 tail ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! for debug -- shows residual values
|
||||
: reverse-png-filter' ( lines -- filtered )
|
||||
[ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
|
||||
concat [ 128 + 256 wrap ] map ;
|
||||
|
||||
: reverse-png-filter ( lines -- filtered )
|
||||
dup first [ 0 ] replicate prefix
|
||||
[ { 0 0 } prepend ] map
|
||||
2 clump [
|
||||
first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
|
||||
] map concat ;
|
||||
|
||||
: zlib-inflate ( bytes -- bytes )
|
||||
bs:<lsb0-bit-reader>
|
||||
[ check-zlib-header ] [ inflate-loop ] bi
|
||||
inflate-lz77 ;
|
|
@ -1,20 +1,19 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs bitstreams byte-vectors combinators io
|
||||
USING: accessors alien.accessors assocs byte-arrays combinators
|
||||
io.encodings.binary io.streams.byte-array kernel math sequences
|
||||
vectors ;
|
||||
IN: compression.lzw
|
||||
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
|
||||
CONSTANT: clear-code 256
|
||||
CONSTANT: end-of-information 257
|
||||
|
||||
TUPLE: lzw input output end-of-input? table count k omega omega-k #bits
|
||||
code old-code ;
|
||||
TUPLE: lzw input output table code old-code ;
|
||||
|
||||
SYMBOL: table-full
|
||||
|
||||
ERROR: index-too-big n ;
|
||||
|
||||
: lzw-bit-width ( n -- n' )
|
||||
{
|
||||
{ [ dup 510 <= ] [ drop 9 ] }
|
||||
|
@ -24,36 +23,14 @@ ERROR: index-too-big n ;
|
|||
[ drop table-full ]
|
||||
} cond ;
|
||||
|
||||
: lzw-bit-width-compress ( lzw -- n )
|
||||
count>> lzw-bit-width ;
|
||||
|
||||
: lzw-bit-width-uncompress ( lzw -- n )
|
||||
table>> length lzw-bit-width ;
|
||||
|
||||
: initial-compress-table ( -- assoc )
|
||||
258 iota [ [ 1vector ] keep ] H{ } map>assoc ;
|
||||
|
||||
: initial-uncompress-table ( -- seq )
|
||||
258 iota [ 1vector ] V{ } map-as ;
|
||||
|
||||
: reset-lzw ( lzw -- lzw )
|
||||
257 >>count
|
||||
V{ } clone >>omega
|
||||
V{ } clone >>omega-k
|
||||
9 >>#bits ;
|
||||
|
||||
: reset-lzw-compress ( lzw -- lzw )
|
||||
f >>k
|
||||
initial-compress-table >>table reset-lzw ;
|
||||
|
||||
: reset-lzw-uncompress ( lzw -- lzw )
|
||||
initial-uncompress-table >>table reset-lzw ;
|
||||
|
||||
: <lzw-compress> ( input -- obj )
|
||||
lzw new
|
||||
swap >>input
|
||||
binary <byte-writer> <bitstream-writer> >>output
|
||||
reset-lzw-compress ;
|
||||
initial-uncompress-table >>table ;
|
||||
|
||||
: <lzw-uncompress> ( input -- obj )
|
||||
lzw new
|
||||
|
@ -61,79 +38,8 @@ ERROR: index-too-big n ;
|
|||
BV{ } clone >>output
|
||||
reset-lzw-uncompress ;
|
||||
|
||||
: push-k ( lzw -- lzw )
|
||||
[ ]
|
||||
[ k>> ]
|
||||
[ omega>> clone [ push ] keep ] tri >>omega-k ;
|
||||
|
||||
: omega-k-in-table? ( lzw -- ? )
|
||||
[ omega-k>> ] [ table>> ] bi key? ;
|
||||
|
||||
ERROR: not-in-table value ;
|
||||
|
||||
: write-output ( lzw -- )
|
||||
[
|
||||
[ omega>> ] [ table>> ] bi ?at [ not-in-table ] unless
|
||||
] [
|
||||
[ lzw-bit-width-compress ]
|
||||
[ output>> write-bits ] bi
|
||||
] bi ;
|
||||
|
||||
: omega-k>omega ( lzw -- lzw )
|
||||
dup omega-k>> clone >>omega ;
|
||||
|
||||
: k>omega ( lzw -- lzw )
|
||||
dup k>> 1vector >>omega ;
|
||||
|
||||
: add-omega-k ( lzw -- )
|
||||
[ [ 1+ ] change-count count>> ]
|
||||
[ omega-k>> clone ]
|
||||
[ table>> ] tri set-at ;
|
||||
|
||||
: lzw-compress-char ( lzw k -- )
|
||||
>>k push-k dup omega-k-in-table? [
|
||||
omega-k>omega drop
|
||||
] [
|
||||
[ write-output ]
|
||||
[ add-omega-k ]
|
||||
[ k>omega drop ] tri
|
||||
] if ;
|
||||
|
||||
: (lzw-compress-chars) ( lzw -- )
|
||||
dup lzw-bit-width-compress table-full = [
|
||||
drop
|
||||
] [
|
||||
dup input>> stream-read1
|
||||
[ [ lzw-compress-char ] [ drop (lzw-compress-chars) ] 2bi ]
|
||||
[ t >>end-of-input? drop ] if*
|
||||
] if ;
|
||||
|
||||
: lzw-compress-chars ( lzw -- )
|
||||
{
|
||||
! [ [ clear-code lzw-compress-char ] [ drop ] bi ] ! reset-lzw-compress drop ] bi ]
|
||||
[
|
||||
[ clear-code ] dip
|
||||
[ lzw-bit-width-compress ]
|
||||
[ output>> write-bits ] bi
|
||||
]
|
||||
[ (lzw-compress-chars) ]
|
||||
[
|
||||
[ k>> ]
|
||||
[ lzw-bit-width-compress ]
|
||||
[ output>> write-bits ] tri
|
||||
]
|
||||
[
|
||||
[ end-of-information ] dip
|
||||
[ lzw-bit-width-compress ]
|
||||
[ output>> write-bits ] bi
|
||||
]
|
||||
[ ]
|
||||
} cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ;
|
||||
|
||||
: lzw-compress ( byte-array -- seq )
|
||||
binary <byte-reader> <lzw-compress>
|
||||
[ lzw-compress-chars ] [ output>> stream>> ] bi ;
|
||||
|
||||
: lookup-old-code ( lzw -- vector )
|
||||
[ old-code>> ] [ table>> ] bi nth ;
|
||||
|
||||
|
@ -152,7 +58,7 @@ ERROR: not-in-table value ;
|
|||
: add-to-table ( seq lzw -- ) table>> push ;
|
||||
|
||||
: lzw-read ( lzw -- lzw n )
|
||||
[ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ;
|
||||
[ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:read ;
|
||||
|
||||
DEFER: lzw-uncompress-char
|
||||
: handle-clear-code ( lzw -- )
|
||||
|
@ -200,5 +106,6 @@ DEFER: lzw-uncompress-char
|
|||
] if* ;
|
||||
|
||||
: lzw-uncompress ( seq -- byte-array )
|
||||
binary <byte-reader> <bitstream-reader>
|
||||
<lzw-uncompress> [ lzw-uncompress-char ] [ output>> ] bi ;
|
||||
bs:<msb0-bit-reader>
|
||||
<lzw-uncompress>
|
||||
[ lzw-uncompress-char ] [ output>> ] bi ;
|
||||
|
|
|
@ -3,6 +3,7 @@ USING: tools.test concurrency.distributed kernel io.files
|
|||
io.files.temp io.directories arrays io.sockets system
|
||||
combinators threads math sequences concurrency.messaging
|
||||
continuations accessors prettyprint ;
|
||||
FROM: concurrency.messaging => receive send ;
|
||||
|
||||
: test-node ( -- addrspec )
|
||||
{
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
IN: concurrency.exchangers.tests
|
||||
USING: sequences tools.test concurrency.exchangers
|
||||
USING: tools.test concurrency.exchangers
|
||||
concurrency.count-downs concurrency.promises locals kernel
|
||||
threads ;
|
||||
FROM: sequences => 3append ;
|
||||
|
||||
:: exchanger-test ( -- string )
|
||||
[let |
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.syntax help.markup concurrency.messaging.private
|
||||
threads kernel arrays quotations threads strings ;
|
||||
threads kernel arrays quotations strings ;
|
||||
IN: concurrency.messaging
|
||||
|
||||
HELP: send
|
||||
|
@ -53,7 +53,7 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
|
|||
{ $subsection reply-synchronous }
|
||||
"An example:"
|
||||
{ $example
|
||||
"USING: concurrency.messaging kernel prettyprint threads ;"
|
||||
"USING: concurrency.messaging threads ;"
|
||||
"IN: scratchpad"
|
||||
": pong-server ( -- )"
|
||||
" receive [ \"pong\" ] dip reply-synchronous ;"
|
||||
|
|
|
@ -1,7 +1,6 @@
|
|||
! Copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types alien.syntax core-foundation.numbers kernel math
|
||||
sequences core-foundation.numbers ;
|
||||
USING: alien.c-types alien.syntax kernel math sequences ;
|
||||
IN: core-foundation.data
|
||||
|
||||
TYPEDEF: void* CFDataRef
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
IN: cpu.ppc.assembler.tests
|
||||
USING: cpu.ppc.assembler tools.test arrays kernel namespaces
|
||||
make vocabs sequences ;
|
||||
FROM: cpu.ppc.assembler => B ;
|
||||
|
||||
: test-assembler ( expected quot -- )
|
||||
[ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
|
||||
|
|
|
@ -4,6 +4,7 @@ USING: bootstrap.image.private kernel kernel.private namespaces
|
|||
system cpu.ppc.assembler compiler.codegen.fixup compiler.units
|
||||
compiler.constants math math.private layouts words
|
||||
vocabs slots.private locals.backend ;
|
||||
FROM: cpu.ppc.assembler => B ;
|
||||
IN: bootstrap.ppc
|
||||
|
||||
4 \ cell set
|
||||
|
|
|
@ -7,6 +7,7 @@ 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.units ;
|
||||
FROM: cpu.ppc.assembler => B ;
|
||||
IN: cpu.ppc
|
||||
|
||||
! PowerPC register assignments:
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel math namespaces make sequences
|
||||
system layouts alien alien.c-types alien.accessors alien.structs
|
||||
slots splitting assocs combinators make locals cpu.x86.assembler
|
||||
slots splitting assocs combinators locals cpu.x86.assembler
|
||||
cpu.x86 cpu.architecture compiler.constants
|
||||
compiler.codegen compiler.codegen.fixup
|
||||
compiler.cfg.instructions compiler.cfg.builder
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel db.errors peg.ebnf strings sequences math
|
||||
combinators.short-circuit accessors math.parser quoting ;
|
||||
combinators.short-circuit accessors math.parser quoting
|
||||
locals ;
|
||||
IN: db.errors.postgresql
|
||||
|
||||
EBNF: parse-postgresql-sql-error
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: concurrency.combinators db.pools db.sqlite db.tuples
|
||||
db.types kernel math random threads tools.test db sequences
|
||||
io prettyprint db.postgresql db.sqlite accessors io.files.temp
|
||||
io prettyprint db.postgresql accessors io.files.temp
|
||||
namespaces fry system math.parser ;
|
||||
IN: db.tester
|
||||
|
||||
|
|
|
@ -1,11 +1,12 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.files io.files.temp kernel tools.test db db.tuples classes
|
||||
db.types continuations namespaces math math.ranges
|
||||
db.types continuations namespaces math
|
||||
prettyprint calendar sequences db.sqlite math.intervals
|
||||
db.postgresql accessors random math.bitwise system
|
||||
math.ranges strings urls fry db.tuples.private db.private
|
||||
db.tester ;
|
||||
FROM: math.ranges => [a,b] ;
|
||||
IN: db.tuples.tests
|
||||
|
||||
TUPLE: person the-id the-name the-number the-real
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs classes db kernel namespaces
|
||||
classes.tuple words sequences slots math accessors
|
||||
math.parser io prettyprint db.types continuations
|
||||
math.parser io prettyprint continuations
|
||||
destructors mirrors sets db.types db.private fry
|
||||
combinators.short-circuit db.errors ;
|
||||
IN: db.tuples
|
||||
|
|
|
@ -251,8 +251,15 @@ M: already-disposed summary drop "Attempting to operate on disposed object" ;
|
|||
M: no-current-vocab summary
|
||||
drop "Not in a vocabulary; IN: form required" ;
|
||||
|
||||
M: no-word-error error.
|
||||
"No word named ``" write name>> write "'' found in current vocabulary search path" print ;
|
||||
M: no-word-error summary
|
||||
name>> "No word named ``" "'' found in current vocabulary search path" surround ;
|
||||
|
||||
M: no-word-error error. summary print ;
|
||||
|
||||
M: ambiguous-use-error summary
|
||||
words>> first name>> "More than one vocabulary defines a word named ``" "''" surround ;
|
||||
|
||||
M: ambiguous-use-error error. summary print ;
|
||||
|
||||
M: staging-violation summary
|
||||
drop
|
||||
|
|
|
@ -3,6 +3,7 @@
|
|||
USING: accessors arrays io kernel math models namespaces make
|
||||
sequences strings splitting combinators unicode.categories
|
||||
math.order math.ranges fry locals ;
|
||||
FROM: models => change-model ;
|
||||
IN: documents
|
||||
|
||||
: +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: parser lexer kernel namespaces sequences definitions
|
|||
io.files io.backend io.pathnames io summary continuations
|
||||
tools.crossref vocabs.hierarchy prettyprint source-files
|
||||
source-files.errors assocs vocabs vocabs.loader splitting
|
||||
accessors debugger prettyprint help.topics ;
|
||||
accessors debugger help.topics ;
|
||||
IN: editors
|
||||
|
||||
TUPLE: no-edit-hook ;
|
||||
|
|
|
@ -11,7 +11,10 @@ SINGLETON: gvim
|
|||
HOOK: gvim-path io-backend ( -- path )
|
||||
|
||||
M: gvim vim-command ( file line -- string )
|
||||
[ gvim-path , "+" swap number>string append , , ] { } make ;
|
||||
[
|
||||
gvim-path ,
|
||||
number>string "+" prepend , ,
|
||||
] { } make ;
|
||||
|
||||
gvim vim-editor set-global
|
||||
|
||||
|
|
|
@ -3,11 +3,9 @@ namespaces prettyprint editors make ;
|
|||
|
||||
IN: editors.macvim
|
||||
|
||||
: macvim-location ( file line -- )
|
||||
: macvim ( file line -- )
|
||||
drop
|
||||
[ "open" , "-a" , "MacVim", , ] { } make
|
||||
try-process ;
|
||||
|
||||
[ macvim-location ] edit-hook set-global
|
||||
|
||||
run-detached drop ;
|
||||
|
||||
[ macvim ] edit-hook set-global
|
||||
|
|
|
@ -25,7 +25,7 @@ IN: editors.scite
|
|||
number>string "-goto:" prepend ,
|
||||
] { } make ;
|
||||
|
||||
: scite-location ( file line -- )
|
||||
: scite ( file line -- )
|
||||
scite-command run-detached drop ;
|
||||
|
||||
[ scite-location ] edit-hook set-global
|
||||
[ scite ] edit-hook set-global
|
||||
|
|
|
@ -2,9 +2,9 @@ USING: definitions io.launcher kernel math math.parser parser
|
|||
namespaces prettyprint editors make ;
|
||||
IN: editors.textedit
|
||||
|
||||
: textedit-location ( file line -- )
|
||||
: textedit ( file line -- )
|
||||
drop
|
||||
[ "open" , "-a" , "TextEdit", , ] { } make
|
||||
try-process ;
|
||||
run-detached drop ;
|
||||
|
||||
[ textedit-location ] edit-hook set-global
|
||||
[ textedit ] edit-hook set-global
|
||||
|
|
|
@ -1,10 +1,9 @@
|
|||
USING: definitions io.launcher kernel math math.parser parser
|
||||
namespaces prettyprint editors make ;
|
||||
|
||||
IN: editors.textmate
|
||||
|
||||
: textmate-location ( file line -- )
|
||||
: textmate ( file line -- )
|
||||
[ "mate" , "-a" , "-l" , number>string , , ] { } make
|
||||
try-process ;
|
||||
run-detached drop ;
|
||||
|
||||
[ textmate-location ] edit-hook set-global
|
||||
[ textmate ] edit-hook set-global
|
||||
|
|
|
@ -3,7 +3,7 @@ USING: definitions editors help help.markup help.syntax io io.files
|
|||
IN: editors.vim
|
||||
|
||||
ARTICLE: { "vim" "vim" } "Vim support"
|
||||
"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim-location } ". The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "."
|
||||
"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim } ". The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "."
|
||||
$nl
|
||||
"If you intend to use this module regularly, it helps to have it load during stage 2 bootstrap. On Windows, place the following example " { $snippet ".factor-boot-rc" } " in the directory returned by " { $link home } ":"
|
||||
{ $code
|
||||
|
|
|
@ -4,7 +4,6 @@ make ;
|
|||
IN: editors.vim
|
||||
|
||||
SYMBOL: vim-path
|
||||
|
||||
SYMBOL: vim-editor
|
||||
HOOK: vim-command vim-editor ( file line -- array )
|
||||
|
||||
|
@ -12,12 +11,13 @@ SINGLETON: vim
|
|||
|
||||
M: vim vim-command
|
||||
[
|
||||
vim-path get , swap , "+" swap number>string append ,
|
||||
vim-path get ,
|
||||
[ , ] [ number>string "+" prepend , ] bi*
|
||||
] { } make ;
|
||||
|
||||
: vim-location ( file line -- )
|
||||
vim-command try-process ;
|
||||
: vim ( file line -- )
|
||||
vim-command run-detached drop ;
|
||||
|
||||
"vim" vim-path set-global
|
||||
[ vim-location ] edit-hook set-global
|
||||
vim vim-editor set-global
|
||||
[ vim ] edit-hook set-global
|
||||
\ vim vim-editor set-global
|
||||
|
|
|
@ -2,8 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.strings alien.syntax kernel
|
||||
layouts sequences system unix environment io.encodings.utf8
|
||||
unix.utilities vocabs.loader combinators alien.accessors
|
||||
alien.syntax ;
|
||||
unix.utilities vocabs.loader combinators alien.accessors ;
|
||||
IN: environment.unix
|
||||
|
||||
HOOK: environ os ( -- void* )
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: splitting parser compiler.units kernel namespaces
|
||||
USING: splitting parser parser.notes compiler.units kernel namespaces
|
||||
debugger io.streams.string fry combinators effects.parser ;
|
||||
IN: eval
|
||||
|
||||
|
|
|
@ -96,7 +96,7 @@ link-no-follow? off
|
|||
[ "<pre><span class=\"KEYWORD3\">int</span> <span class=\"FUNCTION\">main</span><span class=\"OPERATOR\">(</span><span class=\"OPERATOR\">)</span></pre>" ]
|
||||
[ "[c{int main()}]" convert-farkup ] unit-test
|
||||
|
||||
[ "<p><img src=\"lol.jpg\" alt=\"image:lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
|
||||
[ "<p><img src=\"lol.jpg\" alt=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
|
||||
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
|
||||
[ "<p><a href=\"http://lol.com\">http://lol.com</a></p>" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
|
||||
[ "<p><a href=\"http://lol.com\">haha</a></p>" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
|
||||
|
@ -207,3 +207,5 @@ link-no-follow? off
|
|||
[ convert-farkup drop t ] [ drop print f ] recover
|
||||
] all?
|
||||
] unit-test
|
||||
|
||||
[ "<p><a href=\"http://foo.com/~foo\">http://foo.com/~foo</a></p>" ] [ "[[http://foo.com/~foo]]" convert-farkup ] unit-test
|
||||
|
|
|
@ -70,11 +70,15 @@ DEFER: (parse-paragraph)
|
|||
{ CHAR: % inline-code }
|
||||
} at ;
|
||||
|
||||
: or-simple-title ( url title/f quot: ( title -- title' ) -- url title' )
|
||||
[ "" like dup simple-link-title ] if* ; inline
|
||||
|
||||
: parse-link ( string -- paragraph-list )
|
||||
rest-slice "]]" split1-slice [
|
||||
"|" split1
|
||||
[ "" like dup simple-link-title ] unless*
|
||||
[ "image:" ?head ] dip swap [ image boa ] [ parse-paragraph link boa ] if
|
||||
[ "image:" ?head ] dip swap
|
||||
[ [ ] or-simple-title image boa ]
|
||||
[ [ parse-paragraph ] or-simple-title link boa ] if
|
||||
] dip [ (parse-paragraph) cons ] [ 1list ] if* ;
|
||||
|
||||
: ?first ( seq -- elt ) 0 swap ?nth ;
|
||||
|
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2008 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: accessors arrays ascii assocs calendar combinators fry kernel
|
||||
generalizations io io.encodings.ascii io.files io.streams.string
|
||||
macros math math.functions math.parser peg.ebnf quotations
|
||||
sequences splitting strings unicode.case vectors combinators.smart ;
|
||||
USING: accessors arrays assocs calendar combinators fry kernel
|
||||
generalizations io io.streams.string macros math math.functions
|
||||
math.parser peg.ebnf quotations sequences splitting strings
|
||||
unicode.categories unicode.case vectors combinators.smart ;
|
||||
|
||||
IN: formatting
|
||||
|
||||
|
|
|
@ -2,6 +2,7 @@ USING: calendar ftp.server io.encodings.ascii io.files
|
|||
io.files.unique namespaces threads tools.test kernel
|
||||
io.servers.connection ftp.client accessors urls
|
||||
io.pathnames io.directories sequences fry ;
|
||||
FROM: ftp.client => ftp-get ;
|
||||
IN: ftp.server.tests
|
||||
|
||||
: test-file-contents ( -- string )
|
||||
|
|
|
@ -146,10 +146,10 @@ DEFER: ;FUNCTOR delimiter
|
|||
} ;
|
||||
|
||||
: push-functor-words ( -- )
|
||||
functor-words use get push ;
|
||||
functor-words use-words ;
|
||||
|
||||
: pop-functor-words ( -- )
|
||||
functor-words use get delq ;
|
||||
functor-words unuse-words ;
|
||||
|
||||
: parse-functor-body ( -- form )
|
||||
push-functor-words
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
USING: assocs classes help.markup help.syntax kernel
|
||||
quotations strings words words.symbol furnace.auth.providers.db
|
||||
checksums.sha2 furnace.auth.providers math byte-arrays
|
||||
checksums.sha furnace.auth.providers math byte-arrays
|
||||
http multiline ;
|
||||
IN: furnace.auth
|
||||
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors assocs namespaces kernel sequences sets
|
||||
destructors combinators fry logging
|
||||
io.encodings.utf8 io.encodings.string io.binary random
|
||||
checksums checksums.sha2 urls
|
||||
checksums checksums.sha urls
|
||||
html.forms
|
||||
http.server
|
||||
http.server.filters
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax io.streams.string quotations
|
||||
strings calendar serialize kernel furnace.db words words.symbol
|
||||
strings calendar serialize furnace.db words words.symbol
|
||||
kernel ;
|
||||
IN: furnace.sessions
|
||||
|
||||
|
|
|
@ -1,9 +1,9 @@
|
|||
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 hints alien
|
||||
namespaces assocs arrays combinators hints alien
|
||||
core-foundation.run-loop accessors sequences.private
|
||||
alien.c-types math parser game-input vectors ;
|
||||
alien.c-types math parser game-input vectors bit-arrays ;
|
||||
IN: game-input.iokit
|
||||
|
||||
SINGLETON: iokit-game-input-backend
|
||||
|
@ -12,10 +12,11 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
|
|||
|
||||
iokit-game-input-backend game-input-backend set-global
|
||||
|
||||
: hid-manager-matching ( matching-seq -- alien )
|
||||
f 0 IOHIDManagerCreate
|
||||
[ swap >plist IOHIDManagerSetDeviceMatchingMultiple ]
|
||||
keep ;
|
||||
: make-hid-manager ( -- alien )
|
||||
f 0 IOHIDManagerCreate ;
|
||||
|
||||
: set-hid-manager-matching ( alien matching-seq -- )
|
||||
>plist IOHIDManagerSetDeviceMatchingMultiple ;
|
||||
|
||||
: devices-from-hid-manager ( manager -- vector )
|
||||
[
|
||||
|
@ -85,9 +86,6 @@ CONSTANT: hat-switch-matching-hash
|
|||
: ?hat-switch ( device -- ? )
|
||||
hat-switch-matching-hash ?axis ;
|
||||
|
||||
: hid-manager-matching-game-devices ( -- alien )
|
||||
game-devices-matching-seq hid-manager-matching ;
|
||||
|
||||
: device-property ( device key -- value )
|
||||
<NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
|
||||
: element-property ( element key -- value )
|
||||
|
@ -186,7 +184,7 @@ HINTS: record-controller { controller-state alien } ;
|
|||
rot ?set-nth
|
||||
] [ 3drop ] if ;
|
||||
|
||||
HINTS: record-keyboard { array alien } ;
|
||||
HINTS: record-keyboard { bit-array alien } ;
|
||||
|
||||
: record-mouse ( mouse-state value -- )
|
||||
dup IOHIDValueGetElement {
|
||||
|
@ -285,15 +283,16 @@ M: iokit-game-input-backend reset-mouse
|
|||
4 <vector> +controller-states+ set-global
|
||||
0 0 0 0 2 <vector> mouse-state boa
|
||||
+mouse-state+ set-global
|
||||
256 f <array> +keyboard-state+ set-global ;
|
||||
256 <bit-array> +keyboard-state+ set-global ;
|
||||
|
||||
M: iokit-game-input-backend (open-game-input)
|
||||
hid-manager-matching-game-devices {
|
||||
make-hid-manager {
|
||||
[ initialize-variables ]
|
||||
[ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
|
||||
[ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
|
||||
[ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
|
||||
[ 0 IOHIDManagerOpen mach-error ]
|
||||
[ game-devices-matching-seq set-hid-manager-matching ]
|
||||
[
|
||||
CFRunLoopGetMain CFRunLoopDefaultMode
|
||||
IOHIDManagerScheduleWithRunLoop
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: help.markup help.syntax io kernel math namespaces parser
|
||||
USING: help.markup help.syntax io kernel math parser
|
||||
prettyprint sequences vocabs.loader namespaces stack-checker
|
||||
help command-line multiline see ;
|
||||
IN: help.cookbook
|
||||
|
@ -136,7 +136,7 @@ ARTICLE: "cookbook-variables" "Dynamic variables cookbook"
|
|||
} ;
|
||||
|
||||
ARTICLE: "cookbook-vocabs" "Vocabularies cookbook"
|
||||
"Rather than being in one flat list, words belong to vocabularies; every word is contained in exactly one. When parsing a word name, the parser searches the " { $emphasis "vocabulary search path" } ". When working at the listener, a useful set of vocabularies is already available. In a source file, all used vocabularies must be imported."
|
||||
"Rather than being in one flat list, words belong to vocabularies; every word is contained in exactly one. When parsing a word name, the parser searches through vocabularies. When working at the listener, a useful set of vocabularies is already available. In a source file, all used vocabularies must be imported."
|
||||
$nl
|
||||
"For example, a source file containing the following code will print a parse error if you try loading it:"
|
||||
{ $code "\"Hello world\" print" }
|
||||
|
@ -161,7 +161,7 @@ $nl
|
|||
"You would have to place the first definition after the two others for the parser to accept the file."
|
||||
{ $references
|
||||
{ }
|
||||
"vocabulary-search"
|
||||
"word-search"
|
||||
"words"
|
||||
"parser"
|
||||
} ;
|
||||
|
@ -286,7 +286,6 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
|
|||
{ $list
|
||||
"Factor only makes use of one native thread, and Factor threads are scheduled co-operatively. C library calls block the entire VM."
|
||||
"Factor does not hide anything from the programmer, all internals are exposed. It is your responsibility to avoid writing fragile code which depends too much on implementation detail."
|
||||
{ "When a source file uses two vocabularies which define words with the same name, the order of the vocabularies in the " { $link POSTPONE: USE: } " or " { $link POSTPONE: USING: } " forms is important. The " { $link POSTPONE: QUALIFIED: } " word implements qualified naming, which can be used to resolve ambiguities." }
|
||||
{ "If a literal object appears in a word definition, the object itself is pushed on the stack when the word executes, not a copy. If you intend to mutate this object, you must " { $link clone } " it first. See " { $link "syntax-literals" } "." }
|
||||
{ "For a discussion of potential issues surrounding the " { $link f } " object, see " { $link "booleans" } "." }
|
||||
{ "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by “multiple inheritance” in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." }
|
||||
|
|
|
@ -248,14 +248,14 @@ ARTICLE: "handbook-language-reference" "The language"
|
|||
{ $subsection "namespaces-global" }
|
||||
{ $subsection "values" }
|
||||
{ $heading "Abstractions" }
|
||||
{ $subsection "errors" }
|
||||
{ $subsection "fry" }
|
||||
{ $subsection "objects" }
|
||||
{ $subsection "errors" }
|
||||
{ $subsection "destructors" }
|
||||
{ $subsection "continuations" }
|
||||
{ $subsection "memoize" }
|
||||
{ $subsection "parsing-words" }
|
||||
{ $subsection "macros" }
|
||||
{ $subsection "fry" }
|
||||
{ $subsection "continuations" }
|
||||
{ $heading "Program organization" }
|
||||
{ $subsection "vocabs.loader" }
|
||||
"Vocabularies tagged " { $link T{ vocab-tag { name "extensions" } } } " implement various additional language abstractions." ;
|
||||
|
|
|
@ -2,3 +2,5 @@ IN: help.html.tests
|
|||
USING: help.html tools.test help.topics kernel ;
|
||||
|
||||
[ ] [ "xml" >link help>html drop ] unit-test
|
||||
|
||||
[ "article-foobar.html" ] [ "foobar" >link topic>filename ] unit-test
|
|
@ -1,11 +1,13 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
|
||||
USING: io.encodings.utf8 io.encodings.binary
|
||||
io.files io.files.temp io.directories html.streams help kernel
|
||||
assocs sequences make words accessors arrays help.topics vocabs
|
||||
vocabs.hierarchy help.vocabs namespaces prettyprint io
|
||||
vocabs.loader serialize fry memoize ascii unicode.case math.order
|
||||
vocabs.loader serialize fry memoize unicode.case math.order
|
||||
sorting debugger html xml.syntax xml.writer math.parser ;
|
||||
FROM: io.encodings.ascii => ascii ;
|
||||
FROM: ascii => ascii? ;
|
||||
IN: help.html
|
||||
|
||||
: escape-char ( ch -- )
|
||||
|
|
|
@ -66,11 +66,12 @@ PRIVATE>
|
|||
] check-something ;
|
||||
|
||||
: check-about ( vocab -- )
|
||||
dup '[ _ vocab-help [ article drop ] when* ] check-something ;
|
||||
vocab-link boa dup
|
||||
'[ _ vocab-help [ article drop ] when* ] check-something ;
|
||||
|
||||
: check-vocab ( vocab -- )
|
||||
"Checking " write dup write "..." print
|
||||
[ vocab check-about ]
|
||||
[ check-about ]
|
||||
[ words [ check-word ] each ]
|
||||
[ vocab-articles get at [ check-article ] each ]
|
||||
tri ;
|
||||
|
|
|
@ -5,6 +5,7 @@ hashtables namespaces make parser prettyprint sequences strings
|
|||
io.styles vectors words math sorting splitting classes slots fry
|
||||
sets vocabs help.stylesheet help.topics vocabs.loader quotations
|
||||
combinators see present ;
|
||||
FROM: prettyprint.sections => with-pprint ;
|
||||
IN: help.markup
|
||||
|
||||
PREDICATE: simple-element < array
|
||||
|
@ -348,8 +349,6 @@ M: f ($instance)
|
|||
drop
|
||||
"Throws an error if the I/O operation fails." $errors ;
|
||||
|
||||
FROM: prettyprint.private => with-pprint ;
|
||||
|
||||
: $prettyprinting-note ( children -- )
|
||||
drop {
|
||||
"This word should only be called from inside the "
|
||||
|
|
|
@ -16,4 +16,4 @@ SYNTAX: ARTICLE:
|
|||
] dip remember-definition ;
|
||||
|
||||
SYNTAX: ABOUT:
|
||||
in get vocab scan-object >>help changed-definition ;
|
||||
current-vocab scan-object >>help changed-definition ;
|
||||
|
|
|
@ -38,7 +38,7 @@ $nl
|
|||
$nl
|
||||
"Now we have changed the source file, we must reload it into Factor so that we can test the new definition. To do this, simply go to the Factor listener and press " { $command tool "common" refresh-all } ". This will find any previously-loaded source files which have changed on disk, and reload them."
|
||||
$nl
|
||||
"When you do this, you will get an error about the " { $link dup } " word not being found. This is because this word is part of the " { $vocab-link "kernel" } " vocabulary, but this vocabulary is not part of the source file's " { $link "vocabulary-search" } ". You must explicitly list dependencies in source files. This allows Factor to automatically load required vocabularies and makes larger programs easier to maintain."
|
||||
"When you do this, you will get an error about the " { $link dup } " word not being found. This is because this word is part of the " { $vocab-link "kernel" } " vocabulary, but this vocabulary is not part of the source file's " { $link "word-search" } ". You must explicitly list dependencies in source files. This allows Factor to automatically load required vocabularies and makes larger programs easier to maintain."
|
||||
$nl
|
||||
"To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary. Enter " { $snippet "dup" } " in the listener's input area, and press " { $operation com-browse } ". This will open the documentation browser tool, viewing the help for the " { $link dup } " word. One of the subheadings in the help article will mention the word's vocabulary."
|
||||
$nl
|
||||
|
|
|
@ -3,6 +3,7 @@ USING: tools.test kernel io.streams.string
|
|||
io.streams.null accessors inspector html.streams
|
||||
html.components html.forms namespaces
|
||||
xml.writer ;
|
||||
FROM: html.components => inspector ;
|
||||
|
||||
[ ] [ begin-form ] unit-test
|
||||
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
IN: html.forms.tests
|
||||
USING: kernel sequences tools.test assocs html.forms validators accessors
|
||||
namespaces ;
|
||||
FROM: html.forms => values ;
|
||||
|
||||
: with-validation ( quot -- messages )
|
||||
[
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
USING: html.streams html.streams.private accessors io
|
||||
io.streams.string io.styles kernel namespaces tools.test
|
||||
xml.writer sbufs sequences inspector colors xml.writer
|
||||
sbufs sequences inspector colors xml.writer
|
||||
classes.predicate prettyprint ;
|
||||
IN: html.streams.tests
|
||||
|
||||
|
|
|
@ -1,8 +1,9 @@
|
|||
IN: html.templates.chloe
|
||||
USING: xml.data help.markup help.syntax html.components html.forms
|
||||
USING: help.markup help.syntax html.components html.forms
|
||||
html.templates html.templates.chloe.syntax
|
||||
html.templates.chloe.compiler html.templates.chloe.components
|
||||
math strings quotations namespaces ;
|
||||
FROM: xml.data => tag ;
|
||||
|
||||
HELP: <chloe>
|
||||
{ $values { "path" "a pathname string without the trailing " { $snippet ".xml" } " extension" } { "chloe" chloe } }
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
USING: html.templates html.templates.chloe
|
||||
tools.test io.streams.string kernel sequences ascii boxes
|
||||
namespaces xml html.components html.forms
|
||||
splitting unicode.categories furnace accessors
|
||||
splitting furnace accessors
|
||||
html.templates.chloe.compiler ;
|
||||
IN: html.templates.chloe.tests
|
||||
|
||||
|
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences combinators kernel fry
|
||||
USING: accessors kernel sequences combinators fry
|
||||
namespaces make classes.tuple assocs splitting words arrays io
|
||||
io.files io.files.info io.encodings.utf8 io.streams.string
|
||||
unicode.case mirrors math urls present multiline quotations xml
|
||||
logging
|
||||
xml.data xml.writer xml.syntax strings
|
||||
xml.writer xml.syntax strings
|
||||
html.forms
|
||||
html
|
||||
html.components
|
||||
|
|
|
@ -1,13 +1,11 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: html.templates.chloe.syntax
|
||||
USING: accessors kernel sequences combinators kernel namespaces
|
||||
classes.tuple assocs splitting words arrays memoize parser lexer
|
||||
io io.files io.encodings.utf8 io.streams.string
|
||||
unicode.case mirrors fry math urls
|
||||
multiline xml xml.data xml.writer xml.syntax
|
||||
html.components
|
||||
USING: accessors sequences combinators kernel namespaces classes.tuple
|
||||
assocs splitting words arrays memoize parser lexer io io.files
|
||||
io.encodings.utf8 io.streams.string unicode.case mirrors fry math urls
|
||||
multiline xml xml.data xml.writer xml.syntax html.components
|
||||
html.templates ;
|
||||
IN: html.templates.chloe.syntax
|
||||
|
||||
SYMBOL: tags
|
||||
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: continuations sequences kernel namespaces debugger
|
||||
combinators math quotations generic strings splitting accessors
|
||||
assocs fry vocabs.parser parser lexer io io.files
|
||||
assocs fry vocabs.parser parser parser.notes lexer io io.files
|
||||
io.streams.string io.encodings.utf8 html.templates ;
|
||||
IN: html.templates.fhtml
|
||||
|
||||
|
@ -60,7 +60,7 @@ SYNTAX: %> lexer get parse-%> ;
|
|||
[
|
||||
"quiet" on
|
||||
parser-notes off
|
||||
"html.templates.fhtml" use+
|
||||
"html.templates.fhtml" use-vocab
|
||||
string-lines parse-template-lines
|
||||
] with-file-vocabs ;
|
||||
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue