steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Daniel Ehrenberg 2009-02-04 11:30:57 -06:00
parent babe9bb2fd 489019acd0
commit 354830e983
14 changed files with 77 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
basis/http/server/server-tests.factor
View File

@ -1,6 +1,21 @@
USING: http http.server math sequences continuations tools.test ;
USING: http http.server math sequences continuations tools.test
io.encodings.utf8 io.encodings.binary accessors ;
IN: http.server.tests
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
\ make-http-error must-infer
[ "text/plain; charset=UTF-8" ] [
<response>
"text/plain" >>content-type
utf8 >>content-charset
unparse-content-type
] unit-test
[ "text/xml" ] [
<response>
"text/xml" >>content-type
binary >>content-charset
unparse-content-type
] unit-test

6
basis/http/server/server.factor
View File

@ -97,10 +97,8 @@ GENERIC: write-full-response ( request response -- )
tri ;
: unparse-content-type ( request -- content-type )
[ content-type>> "application/octet-stream" or ]
[ content-charset>> encoding>name ]
bi
[ "; charset=" glue ] when* ;
[ content-type>> "application/octet-stream" or ] [ content-charset>> ] bi
dup binary eq? [ drop ] [ encoding>name "; charset=" glue ] if ;
: ensure-domain ( cookie -- cookie )
[

46
basis/io/encodings/chinese/chinese.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: xml xml.data kernel io io.encodings interval-maps splitting fry
math.parser sequences combinators assocs locals accessors math
arrays values io.encodings.ascii ascii io.files biassocs math.order
combinators.short-circuit io.binary io.encodings.iana ;
math.parser sequences combinators assocs locals accessors math arrays
byte-arrays values io.encodings.ascii ascii io.files biassocs
math.order combinators.short-circuit io.binary io.encodings.iana ;
IN: io.encodings.chinese
SINGLETON: gb18030
@ -17,6 +17,14 @@ gb18030 "GB18030" register-encoding
! Resource file from:
! http://source.icu-project.org/repos/icu/data/trunk/charset/data/xml/gb-18030-2000.xml
! Algorithms from:
! http://www-128.ibm.com/developerworks/library/u-china.html
: linear ( bytes -- num )
! This hard-codes bMin and bMax
reverse first4
10 * + 126 * + 10 * + ; foldable
TUPLE: range ufirst ulast bfirst blast ;
: b>byte-array ( string -- byte-array )
@ -27,8 +35,8 @@ TUPLE: range ufirst ulast bfirst blast ;
{
[ "uFirst" attr hex> ]
[ "uLast" attr hex> ]
[ "bFirst" attr b>byte-array ]
[ "bLast" attr b>byte-array ]
[ "bFirst" attr b>byte-array linear ]
[ "bLast" attr b>byte-array linear ]
} cleave range boa
] dip push ;
@ -51,21 +59,13 @@ TUPLE: range ufirst ulast bfirst blast ;
] each-element mapping ranges
] ;
! Algorithms from:
! http://www-128.ibm.com/developerworks/library/u-china.html
: linear ( bytes -- num )
! This hard-codes bMin and bMax
reverse first4
10 * + 126 * + 10 * + ;
: unlinear ( num -- bytes )
B{ HEX: 81 HEX: 30 HEX: 81 HEX: 30 } linear -
10 /mod swap [ HEX: 30 + ] dip
126 /mod swap [ HEX: 81 + ] dip
10 /mod swap [ HEX: 30 + ] dip
10 /mod HEX: 30 + swap
126 /mod HEX: 81 + swap
10 /mod HEX: 30 + swap
HEX: 81 +
B{ } 4sequence reverse ;
4byte-array dup reverse-here ;
: >interval-map-by ( start-quot end-quot value-quot seq -- interval-map )
'[ _ [ @ 2array ] _ tri ] { } map>assoc <interval-map> ; inline
@ -74,7 +74,7 @@ TUPLE: range ufirst ulast bfirst blast ;
[ ufirst>> ] [ ulast>> ] [ ] >interval-map-by ;
: ranges-gb>u ( ranges -- interval-map )
[ bfirst>> linear ] [ blast>> linear ] [ ] >interval-map-by ;
[ bfirst>> ] [ blast>> ] [ ] >interval-map-by ;
VALUE: gb>u
VALUE: u>gb
@ -87,7 +87,7 @@ ascii <file-reader> xml>gb-data
: lookup-range ( char -- byte-array )
dup u>gb interval-at [
[ ufirst>> - ] [ bfirst>> linear ] bi + unlinear
[ ufirst>> - ] [ bfirst>> ] bi + unlinear
] [ encode-error ] if* ;
M: gb18030 encode-char ( char stream encoding -- )
@ -109,19 +109,19 @@ M: gb18030 encode-char ( char stream encoding -- )
: decode-quad ( byte-array -- char )
dup mapping value-at [ ] [
linear dup gb>u interval-at [
[ bfirst>> linear - ] [ ufirst>> ] bi +
[ bfirst>> - ] [ ufirst>> ] bi +
] [ drop replacement-char ] if*
] ?if ;
: four-byte ( stream byte1 byte2 -- char )
rot 2 swap stream-read dup last-bytes?
[ first2 B{ } 4sequence decode-quad ]
[ first2 4byte-array decode-quad ]
[ 3drop replacement-char ] if ;
: two-byte ( stream byte -- char )
over stream-read1 {
{ [ dup not ] [ 3drop replacement-char ] }
{ [ dup second-byte? ] [ B{ } 2sequence mapping value-at nip ] }
{ [ dup second-byte? ] [ 2byte-array mapping value-at nip ] }
{ [ dup quad-2/4? ] [ four-byte ] }
[ 3drop replacement-char ]
} cond ;
@ -129,7 +129,7 @@ M: gb18030 encode-char ( char stream encoding -- )
M: gb18030 decode-char ( stream encoding -- char )
drop dup stream-read1 {
{ [ dup not ] [ 2drop f ] }
{ [ dup ascii? ] [ nip 1array B{ } like mapping value-at ] }
{ [ dup ascii? ] [ nip 1byte-array mapping value-at ] }
{ [ dup quad-1/3? ] [ two-byte ] }
[ 2drop replacement-char ]
} cond ;

8
basis/io/encodings/japanese/japanese.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel io io.files combinators.short-circuit
math.order values assocs io.encodings io.binary fry strings
math io.encodings.ascii arrays accessors splitting math.parser
biassocs io.encodings.iana ;
math.order values assocs io.encodings io.binary fry strings math
io.encodings.ascii arrays byte-arrays accessors splitting
math.parser biassocs io.encodings.iana ;
IN: io.encodings.japanese
SINGLETON: shift-jis
@ -55,7 +55,7 @@ make-jis to: shift-jis-table
{ [ 0 HEX: 7F between? ] [ HEX: A1 HEX: DF between? ] } 1|| ;
: write-halfword ( stream halfword -- )
h>b/b swap B{ } 2sequence swap stream-write ;
h>b/b swap 2byte-array swap stream-write ;
M: jis encode-char
swapd ch>jis

2
basis/stack-checker/transforms/transforms.factor
View File

@ -70,7 +70,7 @@ IN: stack-checker.transforms
[
[ no-case ]
] [
dup peek quotation? [
dup peek callable? [
dup peek swap but-last
] [
[ no-case ] swap

2
core/byte-arrays/byte-arrays-tests.factor
View File

@ -9,3 +9,5 @@ USING: tools.test byte-arrays sequences kernel ;
[ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test
[ -10 B{ } resize-byte-array ] must-fail
[ B{ 123 } ] [ 123 1byte-array ] unit-test

4
core/byte-arrays/byte-arrays.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private alien.accessors sequences
sequences.private math ;
@ -19,7 +19,7 @@ M: byte-array resize
INSTANCE: byte-array sequence
: 1byte-array ( x -- byte-array ) 1 <byte-array> [ set-first ] keep ; inline
: 1byte-array ( x -- byte-array ) B{ } 1sequence ; inline
: 2byte-array ( x y -- byte-array ) B{ } 2sequence ; inline

12
core/combinators/combinators-tests.factor
View File

@ -1,6 +1,6 @@
USING: alien strings kernel math tools.test io prettyprint
namespaces combinators words classes sequences accessors
math.functions ;
math.functions arrays ;
IN: combinators.tests
! Compiled
@ -314,3 +314,13 @@ IN: combinators.tests
\ test-case-7 must-infer
[ "plus" ] [ \ + test-case-7 ] unit-test
! Some corner cases (no pun intended)
DEFER: corner-case-1
<< \ corner-case-1 2 [ + ] curry 1array [ case ] curry (( a -- b )) define-declared >>
[ t ] [ \ corner-case-1 optimized>> ] unit-test
[ 4 ] [ 2 corner-case-1 ] unit-test
[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test

4
core/combinators/combinators.factor
View File

@ -59,13 +59,13 @@ ERROR: no-case ;
] [
dup wrapper? [ wrapped>> ] when
] if =
] [ quotation? ] if
] [ callable? ] if
] find nip ;
: case ( obj assoc -- )
case-find {
{ [ dup array? ] [ nip second call ] }
{ [ dup quotation? ] [ call ] }
{ [ dup callable? ] [ call ] }
{ [ dup not ] [ no-case ] }
} cond ;

4
core/sequences/sequences-docs.factor
View File

@ -207,6 +207,10 @@ HELP: first4-unsafe
{ $values { "seq" sequence } { "first" "the first element" } { "second" "the second element" } { "third" "the third element" } { "fourth" "the fourth element" } }
{ $contract "Unsafe variant of " { $link first4 } " that does not perform bounds checks." } ;
HELP: 1sequence
{ $values { "obj" object } { "exemplar" sequence } { "seq" sequence } }
{ $description "Creates a one-element sequence of the same type as " { $snippet "exemplar" } "." } ;
HELP: 2sequence
{ $values { "obj1" object } { "obj2" object } { "exemplar" sequence } { "seq" sequence } }
{ $description "Creates a two-element sequence of the same type as " { $snippet "exemplar" } "." } ;

8
core/sequences/sequences.factor
View File

@ -137,9 +137,12 @@ INSTANCE: iota immutable-sequence
: from-end ( seq n -- seq n' ) [ dup length ] dip - ; inline
: (1sequence) ( obj seq -- seq )
[ 0 swap set-nth-unsafe ] keep ; inline
: (2sequence) ( obj1 obj2 seq -- seq )
[ 1 swap set-nth-unsafe ] keep
[ 0 swap set-nth-unsafe ] keep ; inline
(1sequence) ; inline
: (3sequence) ( obj1 obj2 obj3 seq -- seq )
[ 2 swap set-nth-unsafe ] keep
@ -151,6 +154,9 @@ INSTANCE: iota immutable-sequence
PRIVATE>
: 1sequence ( obj exemplar -- seq )
1 swap [ (1sequence) ] new-like ; inline
: 2sequence ( obj1 obj2 exemplar -- seq )
2 swap [ (2sequence) ] new-like ; inline

2
core/vectors/vectors-tests.factor
View File

@ -97,3 +97,5 @@ IN: vectors.tests
[ fixnum ] [ 1 >bignum V{ } new-sequence length class ] unit-test
[ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test
[ V{ "lulz" } ] [ "lulz" 1vector ] unit-test

2
core/vectors/vectors.factor
View File

@ -40,7 +40,7 @@ M: sequence new-resizable drop <vector> ;
INSTANCE: vector growable
: 1vector ( x -- vector ) 1array >vector ;
: 1vector ( x -- vector ) V{ } 1sequence ;
: ?push ( elt seq/f -- seq )
[ 1 <vector> ] unless* [ push ] keep ;

1
extra/reports/noise/noise.factor
View File

@ -53,7 +53,6 @@ IN: reports.noise
{ nipd 3 }
{ nkeep 5 }
{ npick 6 }
{ nrev 5 }
{ nrot 5 }
{ nslip 5 }
{ ntuck 6 }