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

basis/multiline/multiline-docs.factor

@@ -18,6 +18,16 @@ HELP: /*
            ""
 } ;
 
+HELP: HEREDOC:
+{ $syntax "HEREDOC: marker\n...text...marker" }
+{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "" "a string" } }
+{ $description "A multiline string syntax with a user-specified terminating delimiter.  HEREDOC: reads the next word, and uses it as the 'close quote'.  All input from the beginning of the HEREDOC:'s next line, until the first appearance of the word's name, becomes a string.  The terminating word does not need to be at the beginning of a line.\n\nThe HEREDOC: line should not have anything after the delimiting word.  The delimiting word should be an alphanumeric token.  It should not be, as in some other languages, a \"quoted string\"." }
+{ $examples
+    { $example "USING: heredoc ;" "HEREDOC: END\nx\nEND" "! \"x\\n\"" }
+    { $example "HEREDOC: END\nxEND" "! \"x\"" }
+    { $example "2 5 HEREDOC: zap\nfoo\nbarzap subseq" "! \"o\\nb\"" }
+} ;
+
 { POSTPONE: <" POSTPONE: STRING: } related-words
 
 HELP: parse-multiline-string
@@ -29,6 +39,7 @@ ARTICLE: "multiline" "Multiline"
 "Multiline strings:"
 { $subsection POSTPONE: STRING: }
 { $subsection POSTPONE: <" }
+{ $subsection POSTPONE: HEREDOC: }
 "Multiline comments:"
 { $subsection POSTPONE: /* }
 "Writing new multiline parsing words:"

basis/multiline/multiline-tests.factor

@@ -19,3 +19,43 @@ world"> ] unit-test
 
 [ "\nhi" ] [ <"
 hi"> ] unit-test
+
+
+! HEREDOC:
+
+[ "foo\nbar\n" ] [ HEREDOC: END
+foo
+bar
+END ] unit-test
+
+[ "foo\nbar" ] [ HEREDOC: END
+foo
+barEND ] unit-test
+
+[ "" ] [ HEREDOC: END
+END ] unit-test
+
+[ " " ] [ HEREDOC: END
+ END ] unit-test
+
+[ "\n" ] [ HEREDOC: END
+
+END ] unit-test
+
+[ "x" ] [ HEREDOC: END
+xEND ] unit-test
+
+[ "xyz " ] [ HEREDOC: END
+xyz END ] unit-test
+
+[ "} ! * # \" «\n" ] [ HEREDOC: END
+} ! * # " «
+END ] unit-test
+
+[ 21 "foo\nbar" " HEREDOC: FOO\n FOO\n" 22 ] [ 21 HEREDOC: X
+foo
+barX HEREDOC: END ! mumble
+ HEREDOC: FOO
+ FOO
+END 22 ] unit-test
+

basis/multiline/multiline.factor

@@ -27,7 +27,7 @@ SYNTAX: STRING:
 
 <PRIVATE
 
-:: (parse-multiline-string) ( i end -- j )
+:: (scan-multiline-string) ( i end -- j )
     lexer get line-text>> :> text
     text [
         end text i start* [| j |
@@ -35,18 +35,21 @@ SYNTAX: STRING:
         ] [
             text i short tail % CHAR: \n ,
             lexer get next-line
-            0 end (parse-multiline-string)
+            0 end (scan-multiline-string)
         ] if*
     ] [ end unexpected-eof ] if ;
         
+:: (parse-multiline-string) ( end-text skip-n-chars -- str )
+    [
+        lexer get
+        [ skip-n-chars + end-text (scan-multiline-string) ]
+        change-column drop
+    ] "" make ;
+
 PRIVATE>
 
 : parse-multiline-string ( end-text -- str )
-    [
+    1 (parse-multiline-string) ;
-        lexer get
-        [ 1 + swap (parse-multiline-string) ]
-        change-column drop
-    ] "" make ;
 
 SYNTAX: <"
     "\">" parse-multiline-string parsed ;
@@ -61,3 +64,9 @@ SYNTAX: {"
     "\"}" parse-multiline-string parsed ;
 
 SYNTAX: /* "*/" parse-multiline-string drop ;
+
+SYNTAX: HEREDOC:
+    scan
+    lexer get next-line
+    0 (parse-multiline-string)
+    parsed ;

basis/sorting/functor/functor.factor

@@ -10,7 +10,7 @@ NAME>=< DEFINES ${NAME}>=<
 
 WHERE
 
-: NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ;
+: NAME<=> ( obj1 obj2 -- <=> ) QUOT compare ;
 : NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ;
 
 ;FUNCTOR

extra/multi-methods/multi-methods.factor

@@ -21,7 +21,7 @@ SYMBOL: total
 : canonicalize-specializer-1 ( specializer -- specializer' )
     [
         [ class? ] filter
-        [ length <reversed> [ 1+ neg ] map ] keep zip
+        [ length <reversed> [ 1 + neg ] map ] keep zip
         [ length args [ max ] change ] keep
     ]
     [
@@ -104,7 +104,7 @@ SYMBOL: total
         { 0 [ [ dup ] ] }
         { 1 [ [ over ] ] }
         { 2 [ [ pick ] ] }
-        [ 1- picker [ dip swap ] curry ]
+        [ 1 - picker [ dip swap ] curry ]
     } case ;
 
 : (multi-predicate) ( class picker -- quot )

extra/multi-methods/tests/canonicalize.factor

@@ -1,6 +1,6 @@
-IN: multi-methods.tests
 USING: multi-methods tools.test math sequences namespaces system
 kernel strings ;
+IN: multi-methods.tests
 
 [ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
 

extra/multi-methods/tests/definitions.factor

@@ -1,9 +1,10 @@
-IN: multi-methods.tests
 USING: multi-methods tools.test math sequences namespaces system
 kernel strings words compiler.units quotations ;
+IN: multi-methods.tests
 
 DEFER: fake
 \ fake H{ } clone "multi-methods" set-word-prop
+<< (( -- )) \ fake set-stack-effect >>
 
 [ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
 

extra/multi-methods/tests/legacy.factor

@@ -1,5 +1,5 @@
-IN: multi-methods.tests
 USING: math strings sequences tools.test ;
+IN: multi-methods.tests
 
 GENERIC: legacy-test ( a -- b )
 

extra/multi-methods/tests/syntax.factor

@@ -1,9 +1,10 @@
-IN: multi-methods.tests
 USING: multi-methods tools.test math sequences namespaces system
 kernel strings definitions prettyprint debugger arrays
 hashtables continuations classes assocs accessors see ;
+RENAME: GENERIC: multi-methods => multi-methods:GENERIC:
+IN: multi-methods.tests
 
-GENERIC: first-test ( -- )
+multi-methods:GENERIC: first-test ( -- )
 
 [ t ] [ \ first-test generic? ] unit-test
 
@@ -13,14 +14,14 @@ SINGLETON: paper    INSTANCE: paper thing
 SINGLETON: scissors INSTANCE: scissors thing
 SINGLETON: rock     INSTANCE: rock thing
 
-GENERIC: beats? ( obj1 obj2 -- ? )
+multi-methods:GENERIC: beats? ( obj1 obj2 -- ? )
 
-METHOD: beats? { paper scissors } t ;
+METHOD: beats? { paper scissors } 2drop t ;
-METHOD: beats? { scissors rock } t ;
+METHOD: beats? { scissors rock } 2drop t ;
-METHOD: beats? { rock paper } t ;
+METHOD: beats? { rock paper } 2drop t ;
-METHOD: beats? { thing thing } f ;
+METHOD: beats? { thing thing } 2drop f ;
 
-: play ( obj1 obj2 -- ? ) beats? 2nip ;
+: play ( obj1 obj2 -- ? ) beats? ;
 
 [ { } 3 play ] must-fail
 [ t ] [ error get no-method? ] unit-test
@@ -34,7 +35,7 @@ METHOD: beats? { thing thing } f ;
 
 SYMBOL: some-var
 
-GENERIC: hook-test ( -- obj )
+multi-methods:GENERIC: hook-test ( obj -- obj )
 
 METHOD: hook-test { array { some-var array } } reverse ;
 METHOD: hook-test { { some-var array } } class ;
@@ -57,7 +58,7 @@ TUPLE: busted-1 ;
 TUPLE: busted-2 ; INSTANCE: busted-2 busted
 TUPLE: busted-3 ;
 
-GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
+multi-methods:GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
 
 METHOD: busted-sort { busted-1 busted-2 } ;
 METHOD: busted-sort { busted-2 busted-3 } ;