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

basis/db/db-docs.factor

@@ -251,7 +251,7 @@ ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial"
 { $subsection sql-query }
 "Here's an example usage where we'll make a book table, insert some objects, and query them." $nl
 "First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
-{ $code "
+{ $code """
 USING: db.sqlite db io.files io.files.temp ;
 : with-book-db ( quot -- )
     "book.db" temp-file <sqlite-db> swap with-db ; inline" }
@@ -259,16 +259,16 @@ USING: db.sqlite db io.files io.files.temp ;
 { $code " "create table books
     (id integer primary key, title text, author text, date_published timestamp,
      edition integer, cover_price double, condition text)"
-    [ sql-command ] with-book-db" }
+    [ sql-command ] with-book-db""" }
 "Time to insert some books:"
-{ $code "
+{ $code """
 "insert into books
     (title, author, date_published, edition, cover_price, condition)
     values('Factor for Sheeple', 'Mister Stacky Pants', date('now'), 1, 13.37, 'mint')"
-[ sql-command ] with-book-db" }
+[ sql-command ] with-book-db""" }
 "Now let's select the book:"
-{ $code "
-"select id, title, cover_price from books;" [ sql-query ] with-book-db " }
+{ $code """
+"select id, title, cover_price from books;" [ sql-query ] with-book-db""" }
 "Notice that the result of this query is a Factor array containing the database rows as arrays of strings. We would have to convert the " { $snippet "cover_price" } " from a string to a number in order to use it in a calculation." $nl
 "In conclusion, this method of accessing a database is supported, but it is fairly low-level and generally specific to a single database. The " { $vocab-link "db.tuples" } " vocabulary is a good alternative to writing SQL by hand." ;
 
@@ -278,13 +278,13 @@ ARTICLE: "db-custom-database-combinators" "Custom database combinators"
 "Make a " { $snippet "with-" } " combinator to open and close a database so that resources are not leaked." $nl
 
 "SQLite example combinator:"
-{ $code "
+{ $code """
 USING: db.sqlite db io.files io.files.temp ;
 : with-sqlite-db ( quot -- )
-    "my-database.db" temp-file <sqlite-db> swap with-db ; inline" } 
+    "my-database.db" temp-file <sqlite-db> swap with-db ; inline""" } 
 
 "PostgreSQL example combinator:"
-{ $code " USING: db.postgresql db ;
+{ $code """USING: db.postgresql db ;
 : with-postgresql-db ( quot -- )
     <postgresql-db>
         "localhost" >>host
@@ -292,7 +292,7 @@ USING: db.sqlite db io.files io.files.temp ;
         "erg" >>username
         "secrets?" >>password
         "factor-test" >>database
-    swap with-db ; inline"
+    swap with-db ; inline"""
 } ;
 
 ABOUT: "db"

basis/db/sqlite/sqlite.factor

@@ -201,19 +201,19 @@ M: sqlite-db-connection persistent-table ( -- assoc )
 
 : insert-trigger ( -- string )
     [
-    "
+    """
         CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE INSERT ON ${table-name}
         FOR EACH ROW BEGIN
             SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
             WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
         END;
-    " interpolate
+    """ interpolate
     ] with-string-writer ;
 
 : insert-trigger-not-null ( -- string )
     [
-    "
+    """
         CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE INSERT ON ${table-name}
         FOR EACH ROW BEGIN
@@ -221,24 +221,24 @@ M: sqlite-db-connection persistent-table ( -- assoc )
             WHERE NEW.${table-id} IS NOT NULL
                 AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
         END;
-    " interpolate
+    """ interpolate
     ] with-string-writer ;
 
 : update-trigger ( -- string )
     [
-    "
+    """
         CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE UPDATE ON ${table-name}
         FOR EACH ROW BEGIN
             SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
             WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
         END;
-    " interpolate
+    """ interpolate
     ] with-string-writer ;
 
 : update-trigger-not-null ( -- string )
     [
-    "
+    """
         CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE UPDATE ON ${table-name}
         FOR EACH ROW BEGIN
@@ -246,30 +246,30 @@ M: sqlite-db-connection persistent-table ( -- assoc )
             WHERE NEW.${table-id} IS NOT NULL
                 AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
         END;
-    " interpolate
+    """ interpolate
     ] with-string-writer ;
 
 : delete-trigger-restrict ( -- string )
     [
-    "
+    """
         CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE DELETE ON ${foreign-table-name}
         FOR EACH ROW BEGIN
             SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fkd_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
             WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
         END;
-    " interpolate
+    """ interpolate
     ] with-string-writer ;
 
 : delete-trigger-cascade ( -- string )
-    
-    "
+    [
+    """
         CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
         BEFORE DELETE ON ${foreign-table-name}
         FOR EACH ROW BEGIN
             DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
         END;
-    " interpolate
+    """ interpolate
     ] with-string-writer ;
 
 : can-be-null? ( -- ? )

basis/debugger/debugger.factor

@@ -319,7 +319,9 @@ M: lexer-error error-help
 M: bad-effect summary
     drop "Bad stack effect declaration" ;
 
-M: bad-escape summary drop "Bad escape code" ;
+M: bad-escape error.
+    "Bad escape code: \\" write
+    char>> 1string print ;
 
 M: bad-literal-tuple summary drop "Bad literal tuple" ;
 

basis/math/vectors/simd/simd-docs.factor

@@ -1,6 +1,6 @@
-USING: help.markup help.syntax sequences math math.vectors
-classes.tuple.private
-math.vectors.simd.intrinsics cpu.architecture ;
+USING: classes.tuple.private cpu.architecture help.markup
+help.syntax kernel.private math math.vectors
+math.vectors.simd.intrinsics sequences ;
 IN: math.vectors.simd
 
 ARTICLE: "math.vectors.simd.intro" "Introduction to SIMD support"

basis/multiline/multiline-tests.factor

@@ -8,17 +8,6 @@ bar
 ;
 
 [ "foo\nbar\n" ] [ test-it ] unit-test
-[ "foo\nbar\n" ] [ <" foo
-bar
-"> ] unit-test
-
-[ "hello\nworld" ] [ <" hello
-world"> ] unit-test
-
-[ "hello" "world" ] [ <" hello"> <" world"> ] unit-test
-
-[ "\nhi" ] [ <"
-hi"> ] unit-test
 
 
 ! HEREDOC:

basis/random/random-docs.factor

@@ -72,6 +72,18 @@ HELP: randomize
 }
 { $description "Randomizes a sequence in-place with the Fisher-Yates algorithm and returns the sequence." } ;
 
+HELP: sample
+{ $values
+    { "seq" sequence } { "n" integer }
+    { "seq'" sequence }
+}
+{ $description "Takes " { $snippet "n" } " samples at random without replacement from a sequence. Throws an error if " { $snippet "n" } " is longer than the sequence." }
+{ $examples
+    { $unchecked-example "USING: random prettyprint ; { 1 2 3 } 2 sample ."
+        "{ 3 2 }"
+    }
+} ;
+
 HELP: delete-random
 { $values
      { "seq" sequence }
@@ -100,6 +112,8 @@ $nl
 { $subsection "random-protocol" }
 "Randomizing a sequence:"
 { $subsection randomize }
+"Sampling a sequences:"
+{ $subsection sample }
 "Deleting a random element from a sequence:"
 { $subsection delete-random }
 "Random numbers with " { $snippet "n" } " bits:"

basis/random/random-tests.factor

@@ -25,3 +25,8 @@ IN: random.tests
 [ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test
 
 [ 49 ] [ 50 random-bits* log2 ] unit-test
+
+[ { 1 2 } 3 sample ] [ too-many-samples?  ] must-fail-with
+
+[ 3 ] [ { 1 2 3 4 } 3 sample prune length ] unit-test
+[ 99 ] [ 100 99 sample prune length ] unit-test

basis/random/random.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel math namespaces sequences
-io.backend io.binary combinators system vocabs.loader
-summary math.bitwise byte-vectors fry byte-arrays
-math.ranges math.constants math.functions accessors ;
+USING: accessors alien.c-types assocs byte-arrays byte-vectors
+combinators fry io.backend io.binary kernel locals math
+math.bitwise math.constants math.functions math.ranges
+namespaces sequences sets summary system vocabs.loader ;
 IN: random
 
 SYMBOL: system-random-generator
@@ -60,6 +60,25 @@ PRIVATE>
     [ [ iota random ] [ 1 - ] bi [ pick exchange ] keep ]
     while drop ;
 
+ERROR: too-many-samples seq n ;
+
+<PRIVATE
+
+:: next-sample ( length n seq hashtable -- elt )
+    n hashtable key? [
+        length n 1 + length mod seq hashtable next-sample
+    ] [
+        n hashtable conjoin
+        n seq nth
+    ] if ;
+
+PRIVATE>
+
+: sample ( seq n -- seq' )
+    2dup [ length ] dip < [ too-many-samples ] when
+    swap [ length ] [ ] bi H{ } clone 
+    '[ _ dup random _ _ next-sample ] replicate ;
+
 : delete-random ( seq -- elt )
     [ length random-integer ] keep [ nth ] 2keep delete-nth ;
 

basis/wrap/strings/strings-tests.factor

@@ -1,29 +1,29 @@
 ! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: wrap.strings tools.test multiline ;
+USING: wrap.strings tools.test ;
 IN: wrap.strings.tests
 
 [
-    <" This is a
+    """This is a
 long piece
 of text
 that we
 wish to
-word wrap.">
+word wrap."""
 ] [
-    <" This is a long piece of text that we wish to word wrap."> 10
+    """This is a long piece of text that we wish to word wrap.""" 10
     wrap-string
 ] unit-test
     
 [
-    <"   This is a
+    """  This is a
   long piece
   of text
   that we
   wish to
-  word wrap.">
+  word wrap."""
 ] [
-    <" This is a long piece of text that we wish to word wrap."> 12
+    """This is a long piece of text that we wish to word wrap.""" 12
     "  " wrap-indented-string
 ] unit-test
 

basis/xml/syntax/syntax-docs.factor

@@ -54,6 +54,7 @@ $nl
 "one two three" " " split
 [ [XML <item><-></item> XML] ] map
 <XML <doc><-></doc> XML> pprint-xml"""
+
 """<?xml version="1.0" encoding="UTF-8"?>
 <doc>
   <item>
@@ -74,7 +75,7 @@ $nl
     false [ f ]
     url [ URL" http://factorcode.org/" ]
     string [ "hello" ]
-    word [ \ drop ] |
+    word [ \\ drop ] |
     <XML
         <x
             number=<-number->
@@ -82,7 +83,9 @@ $nl
             url=<-url->
             string=<-string->
             word=<-word-> />
-    XML> pprint-xml ]"""
+    XML> pprint-xml
+]"""
+
 """<?xml version="1.0" encoding="UTF-8"?>
 <x number="3" url="http://factorcode.org/" string="hello" word="drop"/>""" }
 "XML interpolation can also be used, in conjunction with " { $vocab-link "inverse" } " in pattern matching. For example:"
@@ -94,7 +97,8 @@ $nl
         { [ [XML <b val='yes'/> XML] ] [ "yes" ] }
         { [ [XML <b val=<->/> XML] ] [ "no" prepend ] }
     } switch ;
-[XML <a>pple</a> XML] dispatch write""" "apple" } ;
+[XML <a>pple</a> XML] dispatch write"""
+"apple" } ;
 
 HELP: XML-NS:
 { $syntax "XML-NS: name http://url" }

basis/xml/writer/writer-docs.factor

@@ -52,7 +52,8 @@ HELP: sensitive-tags
 { $example """USING: xml.syntax xml.writer namespaces ;
 [XML <html> <head>   <title> something</title></head><body><pre>bing
 bang
-   bong</pre></body></html> XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable "} {"
+   bong</pre></body></html> XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable"""
+"""
 <html>
   <head>
     <title>

core/strings/parser/parser.factor

@@ -5,7 +5,7 @@ namespaces parser sequences splitting strings arrays
 math.order ;
 IN: strings.parser
 
-ERROR: bad-escape ;
+ERROR: bad-escape char ;
 
 : escape ( escape -- ch )
     H{
@@ -19,7 +19,7 @@ ERROR: bad-escape ;
         { CHAR: 0  CHAR: \0 }
         { CHAR: \\ CHAR: \\ }
         { CHAR: \" CHAR: \" }
-    } at [ bad-escape ] unless* ;
+    } ?at [ bad-escape ] unless ;
 
 SYMBOL: name>char-hook
 

core/syntax/syntax-docs.factor

@@ -530,17 +530,19 @@ HELP: CHAR:
 } ;
 
 HELP: "
-{ $syntax "\"string...\"" }
-{ $syntax "\"\"\"string...\"\"\"" }
+{ $syntax "\"string...\"" "\"\"\"string...\"\"\"" }
 { $values { "string" "literal and escaped characters" } }
-{ $description "Reads from the input string until the next occurrence of " { $link POSTPONE: " } " or " { $snippet "\"\"\"" } ", and appends the resulting string to the parse tree. String literals can span multiple lines. For strings beginning with a single double-quote, the " { $link POSTPONE: " } " character and various other special characters can be read by inserting " { $link "escape" } ". For triple quoted strings, the double-quote character does not require escaping." }
+{ $description "Reads from the input string until the next occurrence of " { $snippet "\"" } " or " { $snippet "\"\"\"" } ", and appends the resulting string to the parse tree. String literals can span multiple lines. Various special characters can be read by inserting " { $link "escape" } ". For triple quoted strings, the double-quote character does not require escaping." }
 { $examples
-    "A string with a newline in it:"
+    "A string with an escaped newline in it:"
     { $example "USE: io" "\"Hello\\nworld\" print" "Hello\nworld" }
+    "A string with an actual newline in it:"
+    { $example "USE: io" "\"Hello\nworld\" print" "Hello\nworld" }
     "A string with a named Unicode code point:"
     { $example "USE: io" "\"\\u{greek-capital-letter-sigma}\" print" "\u{greek-capital-letter-sigma}" }
     "A triple-quoted string:"
-    { $example "USE: io \"\"\"\"Teach a man to fish...\"\"\"\" print" """"Teach a man to fish..."""" }
+    { $example "USE: io \"\"\"Teach a man to \"fish\"...\nand fish will go extinct\"\"\" print" """Teach a man to \"fish\"...
+and fish will go extinct""" }
 } ;
 
 HELP: SBUF"

extra/rpn/rpn-tests.factor

@@ -0,0 +1,4 @@
+IN: rpn.tests
+USING: rpn lists tools.test ;
+
+[ { 2 } ] [ "4 2 -" rpn-parse rpn-eval list>array ] unit-test

extra/rpn/rpn.factor

@@ -10,7 +10,7 @@ TUPLE: push-insn value ;
 GENERIC: eval-insn ( stack insn -- stack )
 
 : binary-op ( stack quot: ( x y -- z ) -- stack )
-    [ uncons uncons ] dip dip cons ; inline
+    [ uncons uncons [ swap ] dip ] dip dip cons ; inline
 
 M: add-insn eval-insn drop [ + ] binary-op ;
 M: sub-insn eval-insn drop [ - ] binary-op ;
@@ -35,11 +35,11 @@ M: push-insn eval-insn value>> swons ;
 : print-stack ( list -- )
     [ number>string print ] leach ;
 
-: rpn-eval ( tokens -- )
-    nil [ eval-insn ] foldl print-stack ;
+: rpn-eval ( tokens -- stack )
+    nil [ eval-insn ] foldl ;
 
 : rpn ( -- )
     "RPN> " write flush
-    readln [ rpn-parse rpn-eval rpn ] when* ;
+    readln [ rpn-parse rpn-eval print-stack rpn ] when* ;
 
 MAIN: rpn

extra/sequences/product/product-docs.factor

@@ -24,8 +24,8 @@ HELP: <product-sequence>
 { $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." }
 { $examples
 { $example """USING: arrays prettyprint sequences.product ;
-{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
-""" """ {
+{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array ."""
+"""{
     { 1 "a" }
     { 2 "a" }
     { 3 "a" }

extra/site-watcher/email/email.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: smtp namespaces accessors kernel arrays ;
+USING: smtp namespaces accessors kernel arrays site-watcher.db ;
 IN: site-watcher.email
 
 SYMBOL: site-watcher-from
@@ -11,4 +11,4 @@ site-watcher-from [ "factor-site-watcher@gmail.com" ] initialize
     pick [
         [ <email> site-watcher-from get >>from ] 3dip
         [ 1array >>to ] [ >>body ] [ >>subject ] tri* send-email 
-    ] [ 3drop ] if ;
+    ] [ 3drop ] if ;

extra/svg/svg-tests.factor

@@ -1,6 +1,6 @@
 ! (c)2009 Joe Groff, see BSD license
 USING: accessors arrays literals math math.affine-transforms
-math.functions sequences svg tools.test xml xml.traversal ;
+math.functions sequences svg tools.test xml xml.traversal multiline ;
 IN: svg.tests
 
 { 1.0 2.25 } { -3.0 4.0 } { 5.5 0.5 } <affine-transform> 1array [