Merge branch 'master' of git://github.com/slavapestov/factor

basis/combinators/random/random-docs.factor

@@ -32,17 +32,21 @@ HELP: casep
 { $examples
     "The following two forms will output 1 with 0.2 probability, 2 with 0.3 probability and 3 with 0.5 probability"
     { $code
-        "USING: combinators.random ;"
-        "{ { 0.2 [ 1 ] }"
+        "USING: combinators.random prettyprint ;"
+        "{"
+        "    { 0.2 [ 1 ] }"
         "    { 0.3 [ 2 ] }"
-        "  { 0.5 [ 3 ] } } casep ."
+        "    { 0.5 [ 3 ] }"
+        "} casep ."
     }
     $nl
     { $code
-        "USING: combinators.random ;"
-        "{ { 0.2 [ 1 ] }"
+        "USING: combinators.random prettyprint ;"
+        "{"
+        "    { 0.2 [ 1 ] }"
         "    { 0.3 [ 2 ] }"
-        "  { [ 3 ] } } casep ."
+        "    [ 3 ]"
+        "} casep ."
     }
 
 }
@@ -62,17 +66,21 @@ HELP: casep*
 { $examples
     "The following two forms will output 1 with 0.5 probability, 2 with 0.25 probability and 3 with 0.25 probability"
     { $code
-        "USING: combinators.random ;"
-        "{ { 0.5 [ 1 ] }"
+        "USING: combinators.random prettyprint ;"
+        "{"
+        "    { 0.5 [ 1 ] }"
         "    { 0.5 [ 2 ] }"
-        "  { 1 [ 3 ] } } casep* ."
+        "    { 1 [ 3 ] }"
+        "} casep* ."
     }
     $nl
     { $code
-        "USING: combinators.random ;"
-        "{ { 0.5 [ 1 ] }"
+        "USING: combinators.random prettyprint ;"
+        "{"
+        "    { 0.5 [ 1 ] }"
         "    { 0.5 [ 2 ] }"
-        "  { [ 3 ] } } casep* ."
+        "    [ 3 ]"
+        "} casep* ."
     }
 
 }

basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor

@@ -24,10 +24,10 @@ V{ } 5 test-bb
 
 [ ] [ test-tdmsc ] unit-test
 
-[ V{ 4 } ] [ 1 get 1array merge-set [ number>> ] map ] unit-test
-[ V{ 4 } ] [ 2 get 1array merge-set [ number>> ] map ] unit-test
-[ V{ } ] [ 0 get 1array merge-set ] unit-test
-[ V{ } ] [ 4 get 1array merge-set ] unit-test
+[ { 4 } ] [ 1 get 1array merge-set [ number>> ] map ] unit-test
+[ { 4 } ] [ 2 get 1array merge-set [ number>> ] map ] unit-test
+[ { } ] [ 0 get 1array merge-set ] unit-test
+[ { } ] [ 4 get 1array merge-set ] unit-test
 
 V{ } 0 test-bb
 V{ } 1 test-bb
@@ -70,5 +70,5 @@ V{ } 7 test-bb
 
 [ ] [ test-tdmsc ] unit-test
 
-[ V{ 2 } ] [ { 2 3 4 5 } [ get ] map merge-set [ number>> ] map ] unit-test
-[ V{ } ] [ { 0 1 6 7 } [ get ] map merge-set ] unit-test
+[ { 2 } ] [ { 2 3 4 5 } [ get ] map merge-set [ number>> ] map ] unit-test
+[ { } ] [ { 0 1 6 7 } [ get ] map merge-set ] unit-test

basis/environment/environment-docs.factor

@@ -22,7 +22,11 @@ HELP: os-env
 { $description "Looks up the value of a shell environment variable." }
 { $examples
     "This is an operating system-specific feature. On Unix, you can do:"
-    { $unchecked-example "\"USER\" os-env print" "jane" }
+    { $unchecked-example
+        "USING: environment io ;"
+        "\"USER\" os-env print"
+        "jane"
+    }
 } ;
 
 HELP: os-envs

basis/http/http.factor

@@ -108,7 +108,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
 
 : (unparse-cookie) ( cookie -- strings )
     [
-        dup name>> check-cookie-string >lower
+        dup name>> check-cookie-string
         over value>> check-cookie-value unparse-cookie-value
         "$path" over path>> unparse-cookie-value
         "$domain" over domain>> unparse-cookie-value
@@ -120,7 +120,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
 
 : unparse-set-cookie ( cookie -- string )
     [
-        dup name>> check-cookie-string >lower
+        dup name>> check-cookie-string
         over value>> check-cookie-value unparse-cookie-value
         "path" over path>> unparse-cookie-value
         "domain" over domain>> unparse-cookie-value

basis/http/parsers/parsers-tests.factor

@@ -11,6 +11,10 @@ IN: http.parsers.tests
 [ "__s=12345567" parse-cookie ]
 unit-test
 
+[ { T{ cookie { name "CaseSensitive" } { value "aBc" } } } ]
+[ "CaseSensitive=aBc" parse-cookie ]
+unit-test
+
 [ { T{ cookie { name "__s" } { value "12345567" } } } ]
 [ "__s=12345567;" parse-cookie ]
 unit-test

basis/http/parsers/parsers.factor

@@ -135,7 +135,7 @@ PEG: parse-header-line ( string -- pair )
     2choice case-sensitive ;
 
 : 'attr' ( -- parser )
-    'token' case-insensitive ;
+    'token' case-sensitive ;
 
 : 'av-pair' ( -- parser )
     [

basis/io/encodings/8-bit/latin9/latin9-docs.factor

@@ -4,7 +4,7 @@ USING: help.markup help.syntax ;
 IN: io.encodings.8-bit.latin9
 
 HELP: latin9
-{ $var-description "This is the ISO-8859-15 encoding, also called Latin-9 and unoffically as Latin-0. It is an 8-bit superset of ASCII designed as a modification of Latin-1, removing little-used characters in favor of the Euro symbol and other characters." } 
+{ $var-description "This is the ISO-8859-15 encoding, also called Latin-9 and unofficially as Latin-0. It is an 8-bit superset of ASCII designed as a modification of Latin-1, removing little-used characters in favor of the Euro symbol and other characters." }
 { $see-also "encodings-introduction" } ;
 
 ARTICLE: "io.encodings.8-bit.latin9" "Latin9 encoding"

basis/io/encodings/shift-jis/shift-jis-docs.factor

@@ -4,7 +4,7 @@ USING: help.markup help.syntax ;
 IN: io.encodings.shift-jis
 
 ARTICLE: "io.encodings.shift-jis" "Shift JIS"
-"Shift JIS is a text encoding for Japanese. There are multiple versions, depending on whether the offical standard or the modified Microsoft version is required."
+"Shift JIS is a text encoding for Japanese. There are multiple versions, depending on whether the official standard or the modified Microsoft version is required."
 { $subsections
     shift-jis
     windows-31j

basis/io/sockets/icmp/icmp.factor

@@ -41,7 +41,7 @@ M: icmp4 resolve-host 1array ;
 
 TUPLE: icmp6 < ipv6 ;
 
-C: <icmp6> icmp6
+: <icmp6> ( host -- icmp6 ) 0 icmp6 boa ;
 
 M: ipv6 with-icmp host>> <icmp6> ;
 

basis/io/sockets/secure/unix/unix-tests.factor

@@ -41,7 +41,11 @@ io.sockets.secure.unix.debug ;
     ] server-test
 ] unit-test
 
-[ client-test ] [ premature-close? ] must-fail-with
+! Actually, this should not be an error since many HTTPS servers
+! (eg, google.com) do this.
+
+! [ client-test ] [ premature-close? ] must-fail-with
+[ "hello" ] [ client-test ] unit-test
 
 ! Now, try validating the certificate. This should fail because its
 ! actually an invalid certificate

basis/io/sockets/sockets-tests.factor

@@ -1,11 +1,12 @@
 USING: io.sockets io.sockets.private sequences math tools.test
 namespaces accessors kernel destructors calendar io.timeouts
 io.encodings.utf8 io concurrency.promises threads
-io.streams.string ;
+io.streams.string present ;
 IN: io.sockets.tests
 
+[ T{ local f "/tmp/foo" } ] [ "/tmp/foo" <local> ] unit-test
 [ T{ inet4 f f 0 } ] [ f 0 <inet4> ] unit-test
-[ T{ inet6 f f 0 } ] [ f 0 <inet6> ] unit-test
+[ T{ inet6 f f 0 1 } ] [ f 1 <inet6> ] unit-test
 
 [ T{ inet f "google.com" f } ] [ "google.com" f <inet> ] unit-test
 
@@ -13,10 +14,23 @@ IN: io.sockets.tests
 [ T{ inet f "google.com" 80 } ] [ "google.com" 0 <inet> 80 with-port ] unit-test
 [ T{ inet4 f "8.8.8.8" 0 } ] [ "8.8.8.8" 0 <inet4> ] unit-test
 [ T{ inet4 f "8.8.8.8" 53 } ] [ "8.8.8.8" 0 <inet4> 53 with-port ] unit-test
-[ T{ inet6 f "5:5:5:5:6:6:6:6" 12 } ] [ "5:5:5:5:6:6:6:6" 0 <inet6> 12 with-port ] unit-test
+[ T{ inet6 f "5:5:5:5:6:6:6:6" 0 12 } ] [ "5:5:5:5:6:6:6:6" 0 <inet6> 12 with-port ] unit-test
+[ T{ inet6 f "fe80::1" 1 80 } ] [ T{ ipv6 f "fe80::1" 1 } 80 with-port ] unit-test
+
+: test-sockaddr ( addrspec -- )
+    [ dup make-sockaddr ] keep parse-sockaddr assert= ;
+
+[ ] [ T{ inet4 f "8.8.8.8" 53 } test-sockaddr ] unit-test
+[ ] [ T{ inet6 f "5:5:5:5:6:6:6:6" 0 12 } test-sockaddr ] unit-test
+[ ] [ T{ inet6 f "fe80:0:0:0:0:0:0:1" 1 80 } test-sockaddr ] unit-test
 
 [ T{ inet f "google.com" 80 } ] [ "google.com" 80 with-port ] unit-test
 
+! Test present on addrspecs
+[ "4.4.4.4:12" ] [ "4.4.4.4" 12 <inet4> present ] unit-test
+[ "::1:12" ] [ "::1" 12 <inet6> present ] unit-test
+[ "fe80::1%1:12" ] [ "fe80::1" 1 12 inet6 boa present ] unit-test
+
 [ B{ 1 2 3 4 } ]
 [ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
 

basis/io/sockets/sockets.factor

@@ -125,9 +125,11 @@ M: inet4 present
 
 M: inet4 protocol drop 0 ;
 
-TUPLE: ipv6 { host ?string read-only } ;
+TUPLE: ipv6
+{ host ?string read-only }
+{ scope-id integer read-only } ;
 
-C: <ipv6> ipv6
+: <ipv6> ( host -- ipv6 ) 0 ipv6 boa ;
 
 M: ipv6 inet-ntop ( data addrspec -- str )
     drop 16 memory>byte-array 2 <groups> [ be> >hex ] map ":" join ;
@@ -184,23 +186,31 @@ M: ipv6 make-sockaddr ( inet -- sockaddr )
         AF_INET6 >>family
         swap
         [ port>> htons >>port ]
-        [ host>> "::" or ]
-        [ inet-pton >>addr ] tri ;
+        [ [ host>> "::" or ] keep inet-pton >>addr ]
+        [ scope-id>> >>scopeid ]
+        tri ;
 
 M: ipv6 parse-sockaddr
-    [ addr>> ] dip inet-ntop <ipv6> ;
+    [ [ addr>> ] dip inet-ntop ] [ drop scopeid>> ] 2bi
+    ipv6 boa ;
+
+M: ipv6 present
+    [ host>> ] [ scope-id>> ] bi
+    [ number>string "%" glue ] unless-zero ;
 
 TUPLE: inet6 < ipv6 { port integer read-only } ;
 
-C: <inet6> inet6
+: <inet6> ( host port -- inet6 ) [ 0 ] dip inet6 boa ;
 
-M: ipv6 with-port [ host>> ] dip <inet6> ;
+M: ipv6 with-port
+    [ [ host>> ] [ scope-id>> ] bi ] dip
+    inet6 boa ;
 
 M: inet6 parse-sockaddr
     [ call-next-method ] [ drop port>> ntohs ] 2bi with-port ;
 
 M: inet6 present
-    [ host>> ] [ port>> number>string ] bi ":" glue ;
+    [ call-next-method ] [ port>> number>string ] bi ":" glue ;
 
 M: inet6 protocol drop 0 ;
 

basis/io/styles/styles-docs.factor

@@ -221,7 +221,7 @@ HELP: background
         "10 iota ["
         "    \"Hello world\\n\""
         "    swap 10 / 1 over - over 1 <rgba>"
-        "    background associate format nl"
+        "    background associate format"
         "] each"
     }
 } ;

basis/lists/lists-docs.factor

@@ -132,11 +132,11 @@ HELP: leach
 
 HELP: foldl
 { $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "result" "the final result" } }
-{ $description "Combines successive elements of the list (in a left-assocative order) using a binary operation and outputs the final result." } ;
+{ $description "Combines successive elements of the list (in a left-associative order) using a binary operation and outputs the final result." } ;
 
 HELP: foldr
 { $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "result" "the final result" } }
-{ $description "Combines successive elements of the list (in a right-assocative order) using a binary operation, and outputs the final result." } ;
+{ $description "Combines successive elements of the list (in a right-associative order) using a binary operation, and outputs the final result." } ;
 
 HELP: lmap
 { $values { "list" list } { "quot" { $quotation "( ... elt -- ... newelt )" } } { "result" "the final result" } }
@@ -144,7 +144,7 @@ HELP: lmap
 
 HELP: lreverse
 { $values { "list" list } { "newlist" list } }
-{ $description "Reverses the input list, outputing a new, reversed list. The output is a strict cons list." } ;
+{ $description "Reverses the input list, outputting a new, reversed list. The output is a strict cons list." } ;
 
 HELP: list>array
 { $values { "list" list } { "array" array } }

basis/locals/locals-docs.factor

@@ -127,7 +127,7 @@ TUPLE: counter adder subtractor ;
 <counter>
 [ adder>>      call . ]
 [ adder>>      call . ]
-[ subtractor>> call . ] tri """
+[ subtractor>> call . ] tri"""
 """1
 2
 1"""

basis/math/combinatorics/combinatorics-docs.factor

@@ -46,7 +46,7 @@ HELP: all-permutations
 
 HELP: each-permutation
 { $values { "seq" sequence } { "quot" { $quotation "( seq -- )" } } }
-{ $description "Applies the quotation to each permuation of " { $snippet "seq" } " in order." } ;
+{ $description "Applies the quotation to each permutation of " { $snippet "seq" } " in order." } ;
 
 HELP: inverse-permutation
 { $values { "seq" sequence } { "permutation" sequence } }

basis/math/polynomials/polynomials-tests.factor

@@ -33,3 +33,9 @@ IN: math.polynomials.tests
 
 [ { 10 200 3000 } ] [ { 1 10 100 1000 } pdiff ] unit-test
 
+
+[ { -512 2304 -4608 5376 -4032 2016 -672 144 -18 1 } ]
+[ { -2 1 } 9 p^ ] unit-test
+
+[ 0 ]
+[ 2 { -2 1 } 9 p^ polyval ] unit-test

basis/math/polynomials/polynomials.factor

@@ -91,7 +91,10 @@ PRIVATE>
     dup length iota v* rest ;
 
 : polyval ( x p -- p[x] )
-    [ length swap powers ] [ nip ] 2bi v. ;
+    ! Horner scheme
+    [ nip <reversed> unclip-slice swap ]
+    [ drop ] 2bi
+    '[ [ _ * ] dip + ] each ;
 
 MACRO: polyval* ( p -- )
     reverse

basis/tools/deploy/deploy-tests.factor

@@ -137,9 +137,16 @@ os macosx? [
 
 [ ] [ "tools.deploy.test.20" shake-and-bake ] unit-test
 
-[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo>Factor</foo>\n" ]
-[ deploy-test-command ascii [ contents ] with-process-reader ] unit-test
+[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo>Factor</foo>" ]
+[ deploy-test-command ascii [ readln ] with-process-reader ] unit-test
 
 [ ] [ 800000 small-enough? ] unit-test
 
+[ ] [ "tools.deploy.test.21" shake-and-bake ] unit-test
+
+[ "1 2 3" ]
+[ deploy-test-command ascii [ readln ] with-process-reader ] unit-test
+
+[ ] [ 600000 small-enough? ] unit-test
+
 [ ] [ "benchmark.ui-panes" shake-and-bake run-temp-image ] unit-test

basis/tools/deploy/test/21/21.factor

@@ -0,0 +1,7 @@
+USING: formatting ;
+IN: tools.deploy.test.21
+
+: formatting-test ( -- )
+    1 2 3 "%d %d %d" printf ;
+
+MAIN: formatting-test

basis/tools/deploy/test/21/deploy.factor

@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-name "tools.deploy.test.21" }
+    { deploy-ui? f }
+    { deploy-c-types? f }
+    { deploy-console? t }
+    { deploy-unicode? f }
+    { "stop-after-last-window?" t }
+    { deploy-io 2 }
+    { deploy-reflection 1 }
+    { deploy-word-props? f }
+    { deploy-math? t }
+    { deploy-threads? t }
+    { deploy-word-defs? f }
+}

basis/ui/tools/listener/listener-docs.factor

@@ -32,7 +32,7 @@ $nl
 { $heading "Implementation" }
 "Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } "). Clickable presentations can also be printed to the listener; see " { $link "ui-presentations" } "." ;
 
-TIP: "You can read documentation by pressing F1." ;
+TIP: "You can read documentation by pressing " { $snippet "F1" } "." ;
 
 TIP: "The listener tool remembers previous lines of input. Press " { $command interactor "completion" recall-previous } " and " { $command interactor "completion" recall-next } " to cycle through them." ;
 

core/combinators/combinators-docs.factor

@@ -355,6 +355,7 @@ HELP: case
 { $examples
     { $example
         "USING: combinators io kernel ;"
+        "IN: scratchpad"
         "SYMBOLS: yes no maybe ;"
         "maybe {"
         "    { yes [ ] } ! Do nothing"

core/definitions/definitions-docs.factor

@@ -34,7 +34,7 @@ $nl
 $nl
 "Now, after some heavily editing and refactoring, the file looks like this:"
 { $code
-    "USING: namespaces ;"
+    "USING: make ;"
     "IN: a"
     ": hello ( -- ) \"Hello\" % ;"
     ": hello-world ( -- str ) [ hello \" \" % world ] \"\" make ;"

extra/bunny/model/model.factor

@@ -42,7 +42,7 @@ IN: bunny.model
 
 : model-path ( -- path ) "bun_zipper.ply" temp-file ;
 
-: model-url ( -- url ) "http://factorcode.org/slava/bun_zipper.ply" ;
+: model-url ( -- url ) "http://duriansoftware.com/joe/media/bun_zipper.ply" ;
 
 : maybe-download ( -- path )
     model-path dup exists? [

extra/dns/dns.factor

@@ -368,7 +368,6 @@ M: SOA rdata>byte-array
 : message>query-name ( message -- string )
     query>> first name>> dotted> ;
 
-USE: nested-comments
 (*
 M: string resolve-host
     dup >lower "localhost" = [

extra/gpu/demos/bunny/bunny.factor

@@ -145,7 +145,7 @@ UNIFORM-TUPLE: loading-uniforms
 
 : bunny-model-path ( -- path ) "bun_zipper.ply" temp-file ;
 
-CONSTANT: bunny-model-url "http://factorcode.org/slava/bun_zipper.ply"
+CONSTANT: bunny-model-url "http://duriansoftware.com/joe/media/bun_zipper.ply"
 
 : download-bunny ( -- path )
     bunny-model-path dup exists? [

extra/tools/dns/dns.factor

@@ -7,7 +7,7 @@ IN: tools.dns
     [ write " has address " write ] [ print ] bi* ;
 
 : a-message. ( message -- )
-    [ message>query-name ] [ message>names ] bi
+    [ message>query-name ] [ message>a-names ] bi
     [ a-line. ] with each ;
 
 : mx-line. ( host pair -- )