Merge branch 'master' into new_ui

basis/io/backend/unix/unix.factor

@@ -46,14 +46,14 @@ M: fd cancel-operation ( fd -- )
         2bi
     ] if ;
 
-M: unix (stream-seek) ( n seek-type stream -- )
+M: unix seek-handle ( n seek-type handle -- )
     swap {
         { io:seek-absolute [ SEEK_SET ] }
         { io:seek-relative [ SEEK_CUR ] }
         { io:seek-end [ SEEK_END ] }
         [ io:bad-seek-type ]
     } case
-    [ handle>> fd>> swap ] dip lseek io-error ;
+    [ fd>> swap ] dip lseek io-error ;
 
 SYMBOL: +retry+ ! just try the operation again without blocking
 SYMBOL: +input+

basis/io/backend/windows/nt/nt.factor

@@ -87,11 +87,11 @@ ERROR: invalid-file-size n ;
 : handle>file-size ( handle -- n )
     0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
 
-M: winnt (stream-seek) ( n seek-type stream -- )
+M: winnt seek-handle ( n seek-type handle -- )
     swap {
-        { seek-absolute [ handle>> (>>ptr) ] }
+        { seek-absolute [ (>>ptr) ] }
-        { seek-relative [ handle>> [ + ] change-ptr drop ] }
+        { seek-relative [ [ + ] change-ptr drop ] }
-        { seek-end [ handle>> [ handle>> handle>file-size + ] keep (>>ptr) ] }
+        { seek-end [ [ handle>> handle>file-size + ] keep (>>ptr) ] }
         [ bad-seek-type ]
     } case ;
 

basis/io/buffers/buffers.factor

@@ -21,9 +21,6 @@ M: buffer dispose* ptr>> free ;
 : buffer-reset ( n buffer -- )
     swap >>fill 0 >>pos drop ;
 
-: buffer-reset-hard ( buffer -- )
-    0 >>fill 0 >>pos drop ;
-
 : buffer-capacity ( buffer -- n )
     [ size>> ] [ fill>> ] bi - ; inline
 

basis/io/ports/ports.factor

@@ -120,12 +120,17 @@ M: output-port stream-write
 
 HOOK: (wait-to-write) io-backend ( port -- )
 
-HOOK: (stream-seek) os ( n seek-type stream -- )
+HOOK: seek-handle os ( n seek-type handle -- )
 
-M: port stream-seek ( n seek-type stream -- )
+M: input-port stream-seek ( n seek-type stream -- )
-    dup check-disposed
+    [ check-disposed ]
-    [ buffer>> buffer-reset-hard 2drop ] [ (stream-seek) ] 3bi ;
+    [ buffer>> 0 swap buffer-reset ]
+    [ handle>> seek-handle ] tri ;
 
+M: output-port stream-seek ( n seek-type stream -- )
+    [ check-disposed ]
+    [ stream-flush ]
+    [ handle>> seek-handle ] tri ;
 
 GENERIC: shutdown ( handle -- )
 

core/io/files/files-tests.factor

@@ -1,8 +1,7 @@
-USING: tools.test io.files io.files.private io.files.temp
+USING: arrays debugger.threads destructors io io.directories
-io.directories io.encodings.8-bit arrays make system
+io.encodings.8-bit io.encodings.ascii io.encodings.binary
-io.encodings.binary io threads kernel continuations
+io.files io.files.private io.files.temp io.files.unique kernel
-io.encodings.ascii sequences strings accessors
+make math sequences system threads tools.test ;
-io.encodings.utf8 math destructors namespaces ;
 IN: io.files.tests
 
 \ exists? must-infer
@@ -75,3 +74,67 @@ USE: debugger.threads
 [ t ] [ "quux-test.txt" temp-file exists? ] unit-test
 
 [ ] [ "quux-test.txt" temp-file delete-file ] unit-test
+
+! File seeking tests
+[ B{ 3 2 3 4 5 } ]
+[
+    "seek-test1" unique-file binary
+    [
+        [
+            B{ 1 2 3 4 5 } write 0 seek-absolute seek-output
+            B{ 3 } write
+        ] with-file-writer
+    ] [
+        file-contents
+    ] 2bi
+] unit-test
+
+[ B{ 1 2 3 4 3 } ]
+[
+    "seek-test2" unique-file binary
+    [
+        [
+            B{ 1 2 3 4 5 } write -1 seek-relative seek-output
+            B{ 3 } write
+        ] with-file-writer
+    ] [
+        file-contents
+    ] 2bi
+] unit-test
+
+[ B{ 1 2 3 4 5 0 3 } ]
+[
+    "seek-test3" unique-file binary
+    [
+        [
+            B{ 1 2 3 4 5 } write 1 seek-relative seek-output
+            B{ 3 } write
+        ] with-file-writer
+    ] [
+        file-contents
+    ] 2bi
+] unit-test
+
+[ B{ 3 } ]
+[
+    B{ 1 2 3 4 5 } "seek-test4" unique-file binary [
+        set-file-contents
+    ] [
+        [
+            -3 seek-end seek-input 1 read
+        ] with-file-reader
+    ] 2bi
+] unit-test
+
+[ B{ 2 } ]
+[
+    B{ 1 2 3 4 5 } "seek-test5" unique-file binary [
+        set-file-contents
+    ] [
+        [
+            3 seek-absolute seek-input
+            -2 seek-relative seek-input
+            1 read
+        ] with-file-reader
+    ] 2bi
+] unit-test

core/io/io-docs.factor

@@ -68,6 +68,51 @@ HELP: stream-copy
 { $description "Copies the contents of one stream into another, closing both streams when done." } 
 $io-error ;
 
+
+HELP: stream-seek
+{ $values
+     { "n" integer } { "seek-type" "a seek singleton" } { "stream" "a stream" }
+}
+{ $description "Moves the pointer associated with a stream's handle to an offset " { $snippet "n" } " bytes from the seek type so that further reading or writing happens at the new location. For output streams, the buffer is flushed before seeking. Seeking past the end of an output stream will pad the difference with zeros once the stream is written to again." $nl
+    "Three methods of seeking are supported:"
+    { $list { $link seek-absolute } { $link seek-relative } { $link seek-end } }
+}
+{ $notes "Stream seeking is not supported on streams that do not have a known length, e.g. TCP/IP streams." } ;
+
+HELP: seek-absolute
+{ $values
+    
+     { "value" "a seek singleton" }
+}
+{ $description "Seeks to an offset from the beginning of the stream." } ;
+
+HELP: seek-end
+{ $values
+    
+     { "value" "a seek singleton" }
+}
+{ $description "Seeks to an offset from the end of the stream. If the offset puts the stream pointer past the end of the data on an output stream, writing to it will pad the difference with zeros." } ;
+
+HELP: seek-relative
+{ $values
+    
+     { "value" "a seek singleton" }
+}
+{ $description "Seeks to an offset from the current position of the stream pointer." } ;
+
+
+HELP: seek-input
+{ $values
+     { "n" integer } { "seek-type" "a seek singleton" }
+}
+{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link input-stream } "." } ;
+
+HELP: seek-output
+{ $values
+     { "n" integer } { "seek-type" "a seek singleton" }
+}
+{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link output-stream } "." } ;
+
 HELP: input-stream
 { $var-description "Holds an input stream for various implicit stream operations. Rebound using " { $link with-input-stream } " and " { $link with-input-stream* } "." } ;
 
@@ -196,6 +241,8 @@ $nl
 { $subsection stream-write }
 "This word is only required for string output streams:"
 { $subsection stream-nl }
+"This word is for streams that allow seeking:"
+{ $subsection stream-seek }
 "For a discussion of the distinction between binary and string streams, see " { $link "stream-elements" } "."
 { $see-also "io.timeouts" } ;
 
@@ -249,6 +296,8 @@ $nl
 { $subsection read-partial }
 "If the default input stream is a string stream (" { $link "stream-elements" } "), lines of text can be read:"
 { $subsection readln }
+"Seeking on the default input stream:"
+{ $subsection seek-input }
 "A pair of combinators for rebinding the " { $link input-stream } " variable:"
 { $subsection with-input-stream }
 { $subsection with-input-stream* }
@@ -256,7 +305,7 @@ $nl
 { $subsection output-stream }
 "Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user."
 $nl
-"Words writing to the default input stream:"
+"Words writing to the default output stream:"
 { $subsection flush }
 { $subsection write1 }
 { $subsection write }
@@ -265,6 +314,8 @@ $nl
 { $subsection print }
 { $subsection nl }
 { $subsection bl }
+"Seeking on the default output stream:"
+{ $subsection seek-output }
 "A pair of combinators for rebinding the " { $link output-stream } " variable:"
 { $subsection with-output-stream }
 { $subsection with-output-stream* }

core/io/io-tests.factor

@@ -1,6 +1,4 @@
-USING: arrays io io.files kernel math parser strings system
+USING: io parser tools.test words ;
-tools.test words namespaces make io.encodings.8-bit
-io.encodings.binary sequences io.files.unique ;
 IN: io.tests
 
 [ f ] [
@@ -10,66 +8,3 @@ IN: io.tests
 
 ! Make sure we use correct to_c_string form when writing
 [ ] [ "\0" write ] unit-test
-
-[ B{ 3 2 3 4 5 } ]
-[
-    "seek-test1" unique-file binary
-    [
-        [
-            B{ 1 2 3 4 5 } write flush 0 seek-absolute seek-output
-            B{ 3 } write
-        ] with-file-writer
-    ] [
-        file-contents
-    ] 2bi
-] unit-test
-
-[ B{ 1 2 3 4 3 } ]
-[
-    "seek-test2" unique-file binary
-    [
-        [
-            B{ 1 2 3 4 5 } write flush -1 seek-relative seek-output
-            B{ 3 } write
-        ] with-file-writer
-    ] [
-        file-contents
-    ] 2bi
-] unit-test
-
-[ B{ 1 2 3 4 5 0 3 } ]
-[
-    "seek-test3" unique-file binary
-    [
-        [
-            B{ 1 2 3 4 5 } write flush 1 seek-relative seek-output
-            B{ 3 } write
-        ] with-file-writer
-    ] [
-        file-contents
-    ] 2bi
-] unit-test
-
-[ B{ 3 } ]
-[
-    B{ 1 2 3 4 5 } "seek-test4" unique-file binary [
-        set-file-contents
-    ] [
-        [
-            -3 seek-end seek-input 1 read
-        ] with-file-reader
-    ] 2bi
-] unit-test
-
-[ B{ 2 } ]
-[
-    B{ 1 2 3 4 5 } "seek-test5" unique-file binary [
-        set-file-contents
-    ] [
-        [
-            3 seek-absolute seek-input
-            -2 seek-relative seek-input
-            1 read
-        ] with-file-reader
-    ] 2bi
-] unit-test