Merge commit 'erg/master'

core/io/files/files.factor

@@ -126,3 +126,17 @@ TUPLE: pathname string ;
 C: <pathname> pathname
 
 M: pathname <=> [ pathname-string ] compare ;
+
+HOOK: library-roots io-backend ( -- seq )
+HOOK: binary-roots io-backend ( -- seq )
+
+: find-file ( seq str -- path/f )
+    [
+        [ path+ exists? ] curry find nip
+    ] keep over [ path+ ] [ drop ] if ;
+
+: find-library ( str -- path/f )
+    library-roots swap find-file ;
+
+: find-binary ( str -- path/f )
+    binary-roots swap find-file ;

extra/io/unix/files/files.factor

@@ -38,3 +38,21 @@ M: unix-io make-directory ( path -- )
 
 M: unix-io delete-directory ( path -- )
     rmdir io-error ;
+
+M: unix-io binary-roots ( -- seq )
+    {
+        "/bin" "/sbin"
+        "/usr/bin" "/usr/sbin"
+        "/usr/local/bin" "/usr/local/sbin"
+        "/opt/local/bin" "/opt/local/sbin"
+        "~/bin"
+    } ;
+
+M: unix-io library-roots ( -- seq )
+    {
+        "/lib"
+        "/usr/lib"
+        "/usr/local/lib"
+        "/opt/local/lib"
+        "/lib64"
+    } ;

extra/io/windows/ce/files/files.factor

@@ -7,7 +7,8 @@ IN: windows.ce.files
 ! M: windows-ce-io normalize-pathname ( string -- string )
     ! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
 
-M: windows-ce-io CreateFile-flags ( -- DWORD ) FILE_ATTRIBUTE_NORMAL ;
+M: windows-ce-io CreateFile-flags ( DWORD -- DWORD )
+    FILE_ATTRIBUTE_NORMAL bitor ;
 M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ;
 
 : finish-read ( port status bytes-ret -- )

extra/io/windows/mmap/mmap.factor

@@ -62,7 +62,7 @@ M: windows-ce-io with-privileges
 
 : mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
     { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
-        >r >r open-file dup f r> 0 0 f
+        >r >r 0 open-file dup f r> 0 0 f
         CreateFileMapping [ win32-error=0/f ] keep
         dup close-later
         dup

extra/io/windows/nt/files/files.factor

@@ -3,8 +3,8 @@ io.windows.nt io.windows.nt.backend kernel libc math
 threads windows windows.kernel32 ;
 IN: io.windows.nt.files
 
-M: windows-nt-io CreateFile-flags ( -- DWORD )
+M: windows-nt-io CreateFile-flags ( DWORD -- DWORD )
-    FILE_FLAG_OVERLAPPED ;
+    FILE_FLAG_OVERLAPPED bitor ;
 
 M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
     make-overlapped ;

extra/io/windows/windows.factor

@@ -4,13 +4,23 @@ USING: alien alien.c-types arrays destructors io io.backend
 io.buffers io.files io.nonblocking io.sockets io.binary
 io.sockets.impl windows.errors strings io.streams.duplex kernel
 math namespaces sequences windows windows.kernel32
-windows.winsock splitting ;
+windows.shell32 windows.winsock splitting ;
 IN: io.windows
 
 TUPLE: windows-nt-io ;
 TUPLE: windows-ce-io ;
 UNION: windows-io windows-nt-io windows-ce-io ;
 
+M: windows-io library-roots ( -- seq )
+    [
+        windows ,
+    ] { } make ;
+
+M: windows-io binary-roots ( -- seq )
+    [
+        windows ,
+    ] { } make ;
+
 M: windows-io destruct-handle CloseHandle drop ;
 
 M: windows-io destruct-socket closesocket drop ;
@@ -23,7 +33,7 @@ TUPLE: win32-file handle ptr overlapped ;
 : <win32-duplex-stream> ( in out -- stream )
     >r f <win32-file> r> f <win32-file> handle>duplex-stream ;
 
-HOOK: CreateFile-flags io-backend ( -- DWORD )
+HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
 HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
 HOOK: add-completion io-backend ( port -- )
 
@@ -31,7 +41,8 @@ M: windows-io normalize-directory ( string -- string )
     "\\" ?tail drop "\\*" append ;
 
 : share-mode ( -- fixnum )
-    FILE_SHARE_READ FILE_SHARE_WRITE bitor ; inline
+    FILE_SHARE_READ FILE_SHARE_WRITE bitor
+    FILE_SHARE_DELETE bitor ; foldable
 
 M: win32-file init-handle ( handle -- )
     drop ;
@@ -40,24 +51,25 @@ M: win32-file close-handle ( handle -- )
     win32-file-handle CloseHandle drop ;
 
 ! Clean up resources (open handle) if add-completion fails
-: open-file ( path access-mode create-mode -- handle )
+: open-file ( path access-mode create-mode flags -- handle )
     [
-        >r share-mode f r> CreateFile-flags f CreateFile
+        >r >r >r normalize-pathname r>
+        share-mode f r> r> CreateFile-flags f CreateFile
         dup invalid-handle? dup close-later
         dup add-completion
     ] with-destructors ;
 
 : open-pipe-r/w ( path -- handle )
-    GENERIC_READ GENERIC_WRITE bitor OPEN_EXISTING open-file ;
+    GENERIC_READ GENERIC_WRITE bitor OPEN_EXISTING 0 open-file ;
 
 : open-read ( path -- handle length )
-    normalize-pathname GENERIC_READ OPEN_EXISTING open-file 0 ;
+    GENERIC_READ OPEN_EXISTING 0 open-file 0 ;
 
 : open-write ( path -- handle length )
-    normalize-pathname GENERIC_WRITE CREATE_ALWAYS open-file 0 ;
+    GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 ;
 
 : (open-append) ( path -- handle )
-    normalize-pathname GENERIC_WRITE OPEN_ALWAYS open-file ;
+    GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
 
 : set-file-pointer ( handle length -- )
     dupd d>w/w <uint> FILE_BEGIN SetFilePointer

extra/random-tester/utils/utils.factor

@@ -1,5 +1,5 @@
 USING: arrays assocs combinators.lib continuations kernel
-math math.functions namespaces quotations random sequences
+math math.functions memoize namespaces quotations random sequences
 sequences.private shuffle ;
 
 IN: random-tester.utils
@@ -93,3 +93,14 @@ C: <p-list> p-list
     >r make-p-list r> (each-permutation) ;
 
 
+: builder-permutations ( n -- seq )
+    { [ compose ] [ swap curry ] } swap permutations
+    [ concat ] map ; foldable
+
+: all-quot-permutations ( seq -- newseq )
+    dup length 1- builder-permutations
+    swap [ 1quotation ] map dup length permutations
+    [ swap [ >r seq>stack r> call ] curry* map ] curry* map ;
+
+! clear { map sq 10 } all-quot-permutations [ [ [ [ [ call ] keep datastack length 2 = [ . .s nl ] when ] catch ] in-thread drop ] each ] each
+! clear { map sq sq 10 } all-quot-permutations [ [ [ [ [ call ] keep datastack length 2 = [ . .s nl ] when ] catch ] in-thread drop ] each ] each

extra/ui/windows/windows.factor

@@ -4,8 +4,8 @@ USING: alien alien.c-types arrays assocs ui ui.gadgets
 ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel
 math math.vectors namespaces prettyprint sequences strings
 vectors words windows.kernel32 windows.gdi32 windows.user32
-windows.opengl32 windows.messages windows.types windows.nt
+windows.opengl32 windows.messages windows.types
-windows threads timers libc combinators continuations
+windows.nt windows threads timers libc combinators continuations
 command-line shuffle opengl ui.render ;
 IN: ui.windows
 

extra/windows/nt/nt.factor

@@ -13,5 +13,3 @@ USING: alien sequences ;
     { "glu"      "glu32.dll"    "stdcall" }
     { "freetype" "freetype6.dll" "cdecl"  }
 } [ first3 add-library ] each
-
-USING: windows.shell32 ;

extra/windows/shell32/shell32.factor

@@ -1,5 +1,5 @@
 USING: alien alien.c-types alien.syntax combinators
-kernel windows ;
+kernel windows windows.user32 ;
 IN: windows.shell32
 
 : CSIDL_DESKTOP HEX: 00 ; inline
@@ -67,25 +67,27 @@ IN: windows.shell32
 : CSIDL_FLAG_CREATE HEX: 8000 ; inline
 : CSIDL_FLAG_MASK HEX: ff00 ; inline
 
+
 : S_OK 0 ; inline
 : S_FALSE 1 ; inline
 : E_FAIL HEX: 80004005 ; inline
 : E_INVALIDARG HEX: 80070057 ; inline
 : ERROR_FILE_NOT_FOUND 2 ; inline
 
-
 : SHGFP_TYPE_CURRENT 0 ; inline
 : SHGFP_TYPE_DEFAULT 1 ; inline
 
 LIBRARY: shell32
 
-TYPEDEF: void* PIDLIST_ABSOLUTE
 FUNCTION: HRESULT SHGetFolderPathW ( HWND hwndOwner, int nFolder, HANDLE hToken, DWORD dwReserved, LPTSTR pszPath ) ;
-! SHGetSpecialFolderLocation
-! SHGetSpecialFolderPath
-
 : SHGetFolderPath SHGetFolderPathW ; inline
 
+FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFile, LPCTSTR lpParameters, LPCTSTR lpDirectory, INT nShowCmd ) ;
+: ShellExecute ShellExecuteW ; inline
+
+: open-in-explorer ( dir -- )
+    f "open" rot f f SW_SHOWNORMAL ShellExecute drop ;
+
 : shell32-error ( n -- )
     dup S_OK = [
         drop
@@ -111,6 +113,9 @@ FUNCTION: HRESULT SHGetFolderPathW ( HWND hwndOwner, int nFolder, HANDLE hToken,
 : application-data ( -- str )
     CSIDL_APPDATA shell32-directory ;
 
+: windows ( -- str )
+    CSIDL_WINDOWS shell32-directory ;
+
 : programs ( -- str )
     CSIDL_PROGRAMS shell32-directory ;