From 80389d23ff7ed39d6cb508282516cc5904435448 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 3 Feb 2009 23:00:34 -0600 Subject: [PATCH 1/6] remove nrev from reports.noise --- extra/reports/noise/noise.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 1ce7f9c726..3e47adac0b 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -53,7 +53,6 @@ IN: reports.noise { nipd 3 } { nkeep 5 } { npick 6 } - { nrev 5 } { nrot 5 } { nslip 5 } { ntuck 6 } From cd77ecfab3c0a1407d93cc98c381ea05b529b058 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 4 Feb 2009 02:41:30 -0600 Subject: [PATCH 2/6] 'case' didn't work if the default was a non-quotation callable, like a curry; this could come up with macro expansion. Bug reported by Dan --- basis/stack-checker/transforms/transforms.factor | 2 +- core/combinators/combinators-tests.factor | 12 +++++++++++- core/combinators/combinators.factor | 4 ++-- 3 files changed, 14 insertions(+), 4 deletions(-) diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 7afac0440f..808ea6a141 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -70,7 +70,7 @@ IN: stack-checker.transforms [ [ no-case ] ] [ - dup peek quotation? [ + dup peek callable? [ dup peek swap but-last ] [ [ no-case ] swap diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 5a56d2b636..1a73e22e31 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -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 \ No newline at end of file diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index c4c18c1c62..e356a6d246 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -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 ; From cb174f0db10bbf53831e499eaeab5da52c2e3919 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 4 Feb 2009 04:17:24 -0600 Subject: [PATCH 3/6] Regression: HTTP server would fail to serve files with binary encoding after Dan's io.encodings.iana changes from earlier today --- basis/http/server/server-tests.factor | 17 ++++++++++++++++- basis/http/server/server.factor | 6 ++---- 2 files changed, 18 insertions(+), 5 deletions(-) diff --git a/basis/http/server/server-tests.factor b/basis/http/server/server-tests.factor index fdba9a63ef..171973fcd8 100644 --- a/basis/http/server/server-tests.factor +++ b/basis/http/server/server-tests.factor @@ -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" ] [ + + "text/plain" >>content-type + utf8 >>content-charset + unparse-content-type +] unit-test + +[ "text/xml" ] [ + + "text/xml" >>content-type + binary >>content-charset + unparse-content-type +] unit-test \ No newline at end of file diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 97c14a6457..b6ee70057b 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -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 ) [ From 4ee7fb1c30a18c120d37bffeb16bf5be7974dc00 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 4 Feb 2009 04:58:19 -0600 Subject: [PATCH 4/6] Minor performance improvement for io.encodings.chinese: don't call 'linear' all the time --- basis/io/encodings/chinese/chinese.factor | 34 +++++++++++------------ 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/basis/io/encodings/chinese/chinese.factor b/basis/io/encodings/chinese/chinese.factor index 01ddb810ba..9d50583ce5 100644 --- a/basis/io/encodings/chinese/chinese.factor +++ b/basis/io/encodings/chinese/chinese.factor @@ -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 ; + B{ } 4sequence dup reverse-here ; : >interval-map-by ( start-quot end-quot value-quot seq -- interval-map ) '[ _ [ @ 2array ] _ tri ] { } map>assoc ; 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 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,7 +109,7 @@ 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 ; From f8d80faed37b4ea5ec6425b988b79cc69c0baeb4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 4 Feb 2009 05:13:12 -0600 Subject: [PATCH 5/6] Add 1sequence word. Add unit tests for existing 1vector and 1byte-array words, and make them use 1sequence --- core/byte-arrays/byte-arrays-tests.factor | 2 ++ core/byte-arrays/byte-arrays.factor | 4 ++-- core/sequences/sequences-docs.factor | 4 ++++ core/sequences/sequences.factor | 8 +++++++- core/vectors/vectors-tests.factor | 2 ++ core/vectors/vectors.factor | 2 +- 6 files changed, 18 insertions(+), 4 deletions(-) diff --git a/core/byte-arrays/byte-arrays-tests.factor b/core/byte-arrays/byte-arrays-tests.factor index edaea108a1..1c3e4d3bdf 100644 --- a/core/byte-arrays/byte-arrays-tests.factor +++ b/core/byte-arrays/byte-arrays-tests.factor @@ -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 \ No newline at end of file diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index f0d188ce4a..72989ac447 100644 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -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 [ set-first ] keep ; inline +: 1byte-array ( x -- byte-array ) B{ } 1sequence ; inline : 2byte-array ( x y -- byte-array ) B{ } 2sequence ; inline diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index f213be4fe7..6ca782a202 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -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" } "." } ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 2c30a62fe3..9e64cfa536 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -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 diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index f2e29d79e8..12e2ea49f7 100644 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -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 \ No newline at end of file diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor index a6bfef71d0..1bdda7b69d 100644 --- a/core/vectors/vectors.factor +++ b/core/vectors/vectors.factor @@ -40,7 +40,7 @@ M: sequence new-resizable drop ; INSTANCE: vector growable -: 1vector ( x -- vector ) 1array >vector ; +: 1vector ( x -- vector ) V{ } 1sequence ; : ?push ( elt seq/f -- seq ) [ 1 ] unless* [ push ] keep ; From 489019acd07ac446ad445de8aae91128cf70050a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 4 Feb 2009 05:14:00 -0600 Subject: [PATCH 6/6] io.encodings.chinese and io.encodings.japanese: use [1234]byte-array words instead of B{ } new-sequence and [1234]array >byte-array --- basis/io/encodings/chinese/chinese.factor | 14 +++++++------- basis/io/encodings/japanese/japanese.factor | 8 ++++---- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/basis/io/encodings/chinese/chinese.factor b/basis/io/encodings/chinese/chinese.factor index 9d50583ce5..b0013b6e08 100644 --- a/basis/io/encodings/chinese/chinese.factor +++ b/basis/io/encodings/chinese/chinese.factor @@ -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 @@ -65,7 +65,7 @@ TUPLE: range ufirst ulast bfirst blast ; 126 /mod HEX: 81 + swap 10 /mod HEX: 30 + swap HEX: 81 + - B{ } 4sequence dup reverse-here ; + 4byte-array dup reverse-here ; : >interval-map-by ( start-quot end-quot value-quot seq -- interval-map ) '[ _ [ @ 2array ] _ tri ] { } map>assoc ; inline @@ -115,13 +115,13 @@ M: gb18030 encode-char ( char stream encoding -- ) : 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 ; diff --git a/basis/io/encodings/japanese/japanese.factor b/basis/io/encodings/japanese/japanese.factor index e3257ad63e..194ade377b 100644 --- a/basis/io/encodings/japanese/japanese.factor +++ b/basis/io/encodings/japanese/japanese.factor @@ -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