support read-only mmap

diff --git a/basis/io/mmap/functor/functor.factor b/basis/io/mmap/functor/functor.factor
index 21b3d294c99265d95820f050bd1046e916c874cc..a80ce3bc82b1705fdc2d871214a8b26934b4b39c 100644 (file)
--- a/basis/io/mmap/functor/functor.factor
+++ b/basis/io/mmap/functor/functor.factor
@@ -9,13 +9,14 @@ SLOT: length
 
 : mapped-file>direct ( mapped-file type -- alien length )
     [ [ address>> ] [ length>> ] bi ] dip
-    heap-size [ 1- + ] keep /i ;
+    heap-size [ 1 - + ] keep /i ;
 
 FUNCTOR: define-mapped-array ( T -- )
 
-<mapped-A>         DEFINES <mapped-${T}-array>
-<A>                IS      <direct-${T}-array>
-with-mapped-A-file DEFINES with-mapped-${T}-file
+<mapped-A>                DEFINES <mapped-${T}-array>
+<A>                       IS      <direct-${T}-array>
+with-mapped-A-file        DEFINES with-mapped-${T}-file
+with-mapped-A-file-reader DEFINES with-mapped-${T}-file-reader
 
 WHERE
 
@@ -25,4 +26,7 @@ WHERE
 : with-mapped-A-file ( path quot -- )
     '[ <mapped-A> @ ] with-mapped-file ; inline
 
+: with-mapped-A-file-reader ( path quot -- )
+    '[ <mapped-A> @ ] with-mapped-file-reader ; inline
+
 ;FUNCTOR

diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor
index f0adb4732112bab5957f19e7e22b7205cafb40fc..1da82e42e222f8c3781250bc01af7128aecd731b 100644 (file)
--- a/basis/io/mmap/mmap-docs.factor
+++ b/basis/io/mmap/mmap-docs.factor
@@ -18,7 +18,13 @@ HELP: <mapped-file>
 
 HELP: with-mapped-file
 { $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
-{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
+{ $contract "Opens a file for read/write access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
+{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." }
+{ $errors "Throws an error if a memory mapping could not be established." } ;
+
+HELP: with-mapped-file-reader
+{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
+{ $contract "Opens a file for read-only access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
 { $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." }
 { $errors "Throws an error if a memory mapping could not be established." } ;
 

diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor
index 1a584715144b470606f5e1a48a63c39f7fd767be..e03d5fb30b8c3f2954c08b0b9139b91d4f99762d 100644 (file)
--- a/basis/io/mmap/mmap.factor
+++ b/basis/io/mmap/mmap.factor
@@ -8,14 +8,27 @@ IN: io.mmap
 
 TUPLE: mapped-file address handle length disposed ;
 
-HOOK: (mapped-file) os ( path length -- address handle )
+HOOK: (mapped-file-reader) os ( path length -- address handle )
+HOOK: (mapped-file-r/w) os ( path length -- address handle )
 
 ERROR: bad-mmap-size path size ;
 
-: <mapped-file> ( path -- mmap )
+<PRIVATE
+
+: prepare-mapped-file ( path -- path' n )
     [ normalize-path ] [ file-info size>> ] bi
-    dup 0 <= [ bad-mmap-size ] when
-    [ (mapped-file) ] keep
+    dup 0 <= [ bad-mmap-size ] when ;
+
+PRIVATE>
+
+: <mapped-file-reader> ( path -- mmap )
+    prepare-mapped-file
+    [ (mapped-file-reader) ] keep
+    f mapped-file boa ;
+
+: <mapped-file> ( path -- mmap )
+    prepare-mapped-file
+    [ (mapped-file-r/w) ] keep
     f mapped-file boa ;
 
 HOOK: close-mapped-file io-backend ( mmap -- )
@@ -25,6 +38,9 @@ M: mapped-file dispose* ( mmap -- ) close-mapped-file ;
 : with-mapped-file ( path quot -- )
     [ <mapped-file> ] dip with-disposal ; inline
 
+: with-mapped-file-reader ( path quot -- )
+    [ <mapped-file-reader> ] dip with-disposal ; inline
+
 {
     { [ os unix? ] [ "io.mmap.unix" require ] }
     { [ os winnt? ] [ "io.mmap.windows" require ] }

diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor
index 0fa8e1151f2c9e850578160ab34df811c3174008..0424321b84a65885781b34e69dcf2d8857ce3b81 100644 (file)
--- a/basis/io/mmap/unix/unix.factor
+++ b/basis/io/mmap/unix/unix.factor
@@ -13,11 +13,16 @@ IN: io.mmap.unix
         [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep
     ] with-destructors ;
 
-M: unix (mapped-file)
+M: unix (mapped-file-r/w)
     { PROT_READ PROT_WRITE } flags
     { MAP_FILE MAP_SHARED } flags
     mmap-open ;
 
+M: unix (mapped-file-reader)
+    { PROT_READ } flags
+    { MAP_FILE MAP_SHARED } flags
+    mmap-open ;
+
 M: unix close-mapped-file ( mmap -- )
     [ [ address>> ] [ length>> ] bi munmap io-error ]
     [ handle>> close-file ]

diff --git a/basis/io/mmap/windows/windows.factor b/basis/io/mmap/windows/windows.factor
index fcdf4165115d779b392e04df24ee8475473c3c94..ebd8109d14e8c82b90b7f687af385e8a81133551 100644 (file)
--- a/basis/io/mmap/windows/windows.factor
+++ b/basis/io/mmap/windows/windows.factor
@@ -28,7 +28,7 @@ M: win32-mapped-file dispose
 
 C: <win32-mapped-file> win32-mapped-file
 
-M: windows (mapped-file)
+M: windows (mapped-file-r/w)
     [
         { GENERIC_WRITE GENERIC_READ } flags
         OPEN_ALWAYS
@@ -37,6 +37,15 @@ M: windows (mapped-file)
         -rot <win32-mapped-file>
     ] with-destructors ;
 
+M: windows (mapped-file-reader)
+    [
+        GENERIC_READ
+        OPEN_ALWAYS
+        { PAGE_READONLY SEC_COMMIT } flags
+        FILE_MAP_READ mmap-open
+        -rot <win32-mapped-file>
+    ] with-destructors ;
+
 M: windows close-mapped-file ( mapped-file -- )
     [
         [ handle>> &dispose drop ]