Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2009-05-18 11:35:21 -05:00
commit 8175d6fe2b
319 changed files with 2993 additions and 1710 deletions

View File

@ -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>

View File

@ -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

View File

@ -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 ;

View File

@ -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"

View File

@ -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 ;

View File

@ -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

View File

@ -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>> ;

View File

@ -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

View File

@ -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 )

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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"

View File

@ -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

View File

@ -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"

View File

@ -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

View File

@ -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 ;

View File

@ -0,0 +1 @@
SHA checksum algorithms

View File

@ -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"

View File

@ -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

View File

@ -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 ;

View File

@ -1 +0,0 @@
SHA1 checksum algorithm

View File

@ -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"

View File

@ -1 +0,0 @@
SHA2 checksum algorithm

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ]

View File

@ -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

View File

@ -16,6 +16,7 @@ compiler.tree.builder
compiler.tree.optimizer
compiler.tree.combinators
compiler.tree.checker ;
FROM: fry => _ ;
RENAME: _ match => __
IN: compiler.tree.debugger

View File

@ -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

View File

@ -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

View File

@ -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 -- )

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;
*/

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 )
{

View File

@ -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 |

View File

@ -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 ;"

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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:

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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* )

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 )

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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." }

View File

@ -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." ;

View File

@ -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

View File

@ -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 -- )

View File

@ -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 ;

View File

@ -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 "

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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 )
[

View File

@ -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

View File

@ -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 } }

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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