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

basis/compiler/tests/redefine3.factor

@@ -5,11 +5,11 @@ IN: compiler.tests.redefine3
 
 GENERIC: sheeple ( obj -- x )
 
-M: object sheeple drop "sheeple" ;
+M: object sheeple drop "sheeple" ; inline
 
 MIXIN: empty-mixin
 
-M: empty-mixin sheeple drop "wake up" ;
+M: empty-mixin sheeple drop "wake up" ; inline
 
 : sheeple-test ( -- string ) { } sheeple ;
 

basis/compiler/tests/stack-trace.factor

@@ -13,7 +13,7 @@ IN: compiler.tests.stack-trace
 [ baz ] [ 3 = ] must-fail-with
 [ t ] [
     symbolic-stack-trace
-    [ word? ] filter
+    2 head*
     { baz bar foo } tail?
 ] unit-test
 
@@ -24,7 +24,7 @@ IN: compiler.tests.stack-trace
 [ t ] [
     [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any?
 ] unit-test
-    
+
 [ t f ] [
     [ { "hi" } bleh ] ignore-errors
     \ + stack-trace-any?

basis/io/backend/windows/windows.factor

@@ -4,23 +4,36 @@ USING: alien alien.c-types arrays destructors io io.backend
 io.buffers io.files io.ports io.binary io.timeouts system
 strings kernel math namespaces sequences windows.errors
 windows.kernel32 windows.shell32 windows.types windows.winsock
-splitting continuations math.bitwise accessors ;
+splitting continuations math.bitwise accessors init sets assocs ;
 IN: io.backend.windows
 
+: win32-handles ( -- assoc )
+    \ win32-handles [ H{ } clone ] initialize-alien ;
+
+TUPLE: win32-handle < identity-tuple handle disposed ;
+
+M: win32-handle hashcode* handle>> hashcode* ;
+
 : set-inherit ( handle ? -- )
-    [ HANDLE_FLAG_INHERIT ] dip
+    [ handle>> HANDLE_FLAG_INHERIT ] dip
     >BOOLEAN SetHandleInformation win32-error=0/f ;
 
-TUPLE: win32-handle handle disposed ;
-
 : new-win32-handle ( handle class -- win32-handle )
-    new swap [ >>handle ] [ f set-inherit ] bi ;
+    new swap >>handle
+    dup f set-inherit
+    dup win32-handles conjoin ;
 
 : <win32-handle> ( handle -- win32-handle )
     win32-handle new-win32-handle ;
 
+ERROR: disposing-twice ;
+
+: unregister-handle ( handle -- )
+    win32-handles delete-at*
+    [ t >>disposed drop ] [ disposing-twice ] if ;
+
 M: win32-handle dispose* ( handle -- )
-    handle>> CloseHandle drop ;
+    [ unregister-handle ] [ handle>> CloseHandle win32-error=0/f ] bi ;
 
 TUPLE: win32-file < win32-handle ptr ;
 

basis/io/files/windows/windows.factor

@@ -47,10 +47,8 @@ IN: io.files.windows
     GetLastError ERROR_ALREADY_EXISTS = not ;
 
 : set-file-pointer ( handle length method -- )
-    [ dupd d>w/w <uint> ] dip SetFilePointer
-    INVALID_SET_FILE_POINTER = [
-        CloseHandle "SetFilePointer failed" throw
-    ] when drop ;
+    [ [ handle>> ] dip d>w/w <uint> ] dip SetFilePointer
+    INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ;
 
 HOOK: open-append os ( path -- win32-file )
 

basis/io/launcher/windows/nt/nt-tests.factor

@@ -164,4 +164,19 @@ IN: io.launcher.windows.nt.tests
     "append-test" temp-file ascii file-contents
 ] unit-test
 
+[ "( scratchpad ) " ] [
+    console-vm "-run=listener" 2array
+    ascii [ "USE: system 0 exit" print flush readln ] with-process-stream
+] unit-test
 
+[ ] [
+    console-vm "-run=listener" 2array
+    ascii [ "USE: system 0 exit" print ] with-process-writer
+] unit-test
+
+[ ] [
+    <process>
+    console-vm "-run=listener" 2array >>command
+    "vocab:io/launcher/windows/nt/test/input.txt" >>stdin
+    try-process
+] unit-test

basis/io/launcher/windows/nt/nt.factor

@@ -10,21 +10,21 @@ IN: io.launcher.windows.nt
 
 : duplicate-handle ( handle -- handle' )
     GetCurrentProcess ! source process
-    swap ! handle
+    swap handle>> ! handle
     GetCurrentProcess ! target process
     f <void*> [ ! target handle
         DUPLICATE_SAME_ACCESS ! desired access
         TRUE ! inherit handle
-        DUPLICATE_CLOSE_SOURCE ! options
+        0 ! options
         DuplicateHandle win32-error=0/f
-    ] keep *void* ;
+    ] keep *void* <win32-handle> &dispose ;
 
 ! /dev/null simulation
 : null-input ( -- pipe )
-    (pipe) [ in>> handle>> ] [ out>> dispose ] bi ;
+    (pipe) [ in>> &dispose ] [ out>> dispose ] bi ;
 
 : null-output ( -- pipe )
-    (pipe) [ in>> dispose ] [ out>> handle>> ] bi ;
+    (pipe) [ in>> dispose ] [ out>> &dispose ] bi ;
 
 : null-pipe ( mode -- pipe )
     {
@@ -49,7 +49,7 @@ IN: io.launcher.windows.nt
     create-mode
     FILE_ATTRIBUTE_NORMAL ! flags and attributes
     f ! template file
-    CreateFile dup invalid-handle? <win32-file> &dispose handle>> ;
+    CreateFile dup invalid-handle? <win32-file> &dispose ;
 
 : redirect-append ( path access-mode create-mode -- handle )
     [ path>> ] 2dip
@@ -58,10 +58,10 @@ IN: io.launcher.windows.nt
     dup 0 FILE_END set-file-pointer ;
 
 : redirect-handle ( handle access-mode create-mode -- handle )
-    2drop handle>> duplicate-handle ;
+    2drop ;
 
 : redirect-stream ( stream access-mode create-mode -- handle )
-    [ underlying-handle handle>> ] 2dip redirect-handle ;
+    [ underlying-handle ] 2dip redirect-handle ;
 
 : redirect ( obj access-mode create-mode -- handle )
     {
@@ -72,7 +72,7 @@ IN: io.launcher.windows.nt
         { [ pick win32-file? ] [ redirect-handle ] }
         [ redirect-stream ]
     } cond
-    dup [ dup t set-inherit ] when ;
+    dup [ dup t set-inherit handle>> ] when ;
 
 : redirect-stdout ( process args -- handle )
     drop

basis/io/launcher/windows/nt/test/input.txt

@@ -0,0 +1 @@
+USE: system 0 exit

basis/multiline/multiline-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax strings ;
 IN: multiline
 
 HELP: STRING:
@@ -19,24 +19,33 @@ 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\"." }
+{ $syntax "HEREDOC: marker\n...text...\nmarker" }
+{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } }
+{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: HEREDOC: } " until the end of the line containing the " { $link POSTPONE: HEREDOC: } ". Text is captured until a line is found conatining exactly this delimter string." }
+{ $warning "Whitespace is significant." }
 { $examples
     { $example "USING: multiline prettyprint ;"
-               "HEREDOC: END\nx\nEND ."
+               "HEREDOC: END\nx\nEND\n."
                "\"x\\n\""
     }
-    { $example "USING: multiline prettyprint ;"
-               "HEREDOC: END\nxEND ."
-               "\"x\""
-    }
     { $example "USING: multiline prettyprint sequences ;"
-               "2 5 HEREDOC: zap\nfoo\nbarzap subseq ."
+               "2 5 HEREDOC: zap\nfoo\nbar\nzap\nsubseq ."
                "\"o\\nb\""
     }
 } ;
 
+HELP: DELIMITED:
+{ $syntax "DELIMITED: marker\n...text...\nmarker" }
+{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } }
+{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: DELIMITED: } " until the end of the line containing the " { $link POSTPONE: DELIMITED: } ". Text is captured until the exact delimiter string is found, regardless of where." }
+{ $examples
+    { $example "USING: multiline prettyprint ;"
+               "DELIMITED: factor blows my mind"
+"whoafactor blows my mind ."
+                "\"whoa\""
+    }
+} ;
+
 { POSTPONE: <" POSTPONE: STRING: } related-words
 
 HELP: parse-multiline-string
@@ -49,6 +58,7 @@ ARTICLE: "multiline" "Multiline"
 { $subsection POSTPONE: STRING: }
 { $subsection POSTPONE: <" }
 { $subsection POSTPONE: HEREDOC: }
+{ $subsection POSTPONE: DELIMITED: }
 "Multiline comments:"
 { $subsection POSTPONE: /* }
 "Writing new multiline parsing words:"

basis/multiline/multiline-tests.factor

@@ -1,4 +1,4 @@
-USING: multiline tools.test ;
+USING: accessors eval multiline tools.test ;
 IN: multiline.tests
 
 STRING: test-it
@@ -26,36 +26,66 @@ hi"> ] unit-test
 [ "foo\nbar\n" ] [ HEREDOC: END
 foo
 bar
-END ] unit-test
-
-[ "foo\nbar" ] [ HEREDOC: END
-foo
-barEND ] unit-test
+END
+] unit-test
 
 [ "" ] [ HEREDOC: END
-END ] unit-test
+END
+] unit-test
 
-[ " " ] [ HEREDOC: END
- END ] unit-test
+[ " END\n" ] [ HEREDOC: END
+ END
+END
+] unit-test
 
 [ "\n" ] [ HEREDOC: END
 
-END ] unit-test
+END
+] unit-test
 
-[ "x" ] [ HEREDOC: END
-xEND ] unit-test
+[ "x\n" ] [ HEREDOC: END
+x
+END
+] unit-test
 
-[ "xyz " ] [ HEREDOC: END
-xyz END ] unit-test
+[ "x\n" ] [ HEREDOC:       END
+x
+END
+] unit-test
+
+[ "xyz \n" ] [ HEREDOC: END
+xyz 
+END
+] unit-test
 
 [ "} ! * # \" «\n" ] [ HEREDOC: END
 } ! * # " «
-END ] unit-test
+END
+] unit-test
 
-[ 21 "foo\nbar" " HEREDOC: FOO\n FOO\n" 22 ] [ 21 HEREDOC: X
+[ 21 "foo\nbar\n" " HEREDOC: FOO\n FOO\n" 22 ] [ 21 HEREDOC: X
 foo
-barX HEREDOC: END ! mumble
+bar
+X
+HEREDOC: END
  HEREDOC: FOO
  FOO
-END 22 ] unit-test
+END
+22 ] unit-test
 
+[ "lol\n xyz\n" ]
+[
+HEREDOC: xyz
+lol
+ xyz
+xyz
+] unit-test
+
+
+[ "lol" ]
+[ DELIMITED: aol
+lolaol ] unit-test
+
+[ "whoa" ]
+[ DELIMITED: factor blows my mind
+whoafactor blows my mind ] unit-test

basis/multiline/multiline.factor

@@ -4,6 +4,8 @@ USING: namespaces make parser lexer kernel sequences words
 quotations math accessors locals ;
 IN: multiline
 
+ERROR: bad-heredoc identifier ;
+
 <PRIVATE
 : next-line-text ( -- str )
     lexer get dup next-line line-text>> ;
@@ -46,6 +48,28 @@ SYNTAX: STRING:
         change-column drop
     ] "" make ;
 
+: rest-of-line ( -- seq )
+    lexer get [ line-text>> ] [ column>> ] bi tail ;
+
+:: advance-same-line ( text -- )
+    lexer get [ text length + ] change-column drop ;
+
+:: (parse-til-line-begins) ( begin-text -- )
+    lexer get still-parsing? [
+        lexer get line-text>> begin-text sequence= [
+            begin-text advance-same-line
+        ] [
+            lexer get line-text>> % "\n" %
+            lexer get next-line
+            begin-text (parse-til-line-begins)
+        ] if
+    ] [
+        begin-text bad-heredoc
+    ] if ;
+
+: parse-til-line-begins ( begin-text -- seq )
+    [ (parse-til-line-begins) ] "" make ;
+
 PRIVATE>
 
 : parse-multiline-string ( end-text -- str )
@@ -66,7 +90,13 @@ SYNTAX: {"
 SYNTAX: /* "*/" parse-multiline-string drop ;
 
 SYNTAX: HEREDOC:
-    scan
+    lexer get skip-blank
+    rest-of-line
     lexer get next-line
-    0 (parse-multiline-string)
-    parsed ;
+    parse-til-line-begins parsed ;
+
+SYNTAX: DELIMITED:
+    lexer get skip-blank
+    rest-of-line
+    lexer get next-line
+    0 (parse-multiline-string) parsed ;

core/lexer/lexer.factor

@@ -49,7 +49,7 @@ M: lexer skip-word ( lexer -- )
     ] change-lexer-column ;
 
 : still-parsing? ( lexer -- ? )
-    [ line>> ] [ text>> ] bi length <= ;
+    [ line>> ] [ text>> length ] bi <= ;
 
 : still-parsing-line? ( lexer -- ? )
     [ column>> ] [ line-length>> ] bi < ;

core/slots/slots-tests.factor

@@ -18,23 +18,6 @@ TUPLE: hello length ;
 
 [ "xyz" 4 >>length ] [ no-method? ] must-fail-with
 
-[ t ] [ r/o-test \ foo>> method "foldable" word-prop ] unit-test
-[ t ] [ r/o-test \ foo>> method "flushable" word-prop ] unit-test
-
-[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
-[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
-
-! See if declarations are cleared on redefinition
-[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval( -- ) ] unit-test
-
-[ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
-[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
-
-[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval( -- ) ] unit-test
-
-[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
-[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
-
 ! Test protocol slots
 SLOT: my-protocol-slot-test