[MLton-commit] r5273
Vesa Karvonen
vesak at mlton.org
Tue Feb 20 09:01:06 PST 2007
Tweaked Makefile to work on multiple platforms (make check runs even on
32-bit Linux).
Moved notable extensions to a separate signature for clarity.
Specified (but not yet implemented) a number of extensions.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/windows/unstable/Makefile
U mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h
U mltonlib/trunk/com/ssh/windows/unstable/detail/lib/windows.c
U mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml
U mltonlib/trunk/com/ssh/windows/unstable/lib.mlb
U mltonlib/trunk/com/ssh/windows/unstable/public/export.sml
A mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig
U mltonlib/trunk/com/ssh/windows/unstable/public/windows.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/windows/unstable/Makefile
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/Makefile 2007-02-20 13:29:46 UTC (rev 5272)
+++ mltonlib/trunk/com/ssh/windows/unstable/Makefile 2007-02-20 17:01:01 UTC (rev 5273)
@@ -3,6 +3,8 @@
# This code is released under the MLton license, a BSD-style license.
# See the LICENSE file or http://mlton.org/License for details.
+##########################################################################
+
target-arch := $(shell mlton -show path-map | awk '/^TARGET_ARCH/ {print $$2}')
target-os := $(shell mlton -show path-map | awk '/^TARGET_OS/ {print $$2}')
target-id := $(target-arch)-$(target-os)
@@ -10,8 +12,12 @@
bin-dir := .bin/$(target-id)
gen-dir := generated/$(target-id)
+mlb-path-map := $(gen-dir)/mlb-path-map
+
ffi-h-files := $(wildcard detail/ffi/*.h)
+nlffi-mlb := $(gen-dir)/nlffi/lib.mlb
+
lib-dir := detail/lib
lib-c-files := $(wildcard detail/lib/*.c)
lib-o-files := $(patsubst $(lib-dir)/%.c,$(bin-dir)/%.o,$(lib-c-files))
@@ -19,31 +25,41 @@
lib-file := libwin-$(target-id).lib
+def-use-file := lib.$(target-id).du
+
+##########################################################################
+
.PHONY : all clean help check
help :
@echo "Targets:"
@echo " all Builds the static link library and NLFFI files"
+ @echo " check Type check the SML code (does not check C code)"
@echo " clean Removes generated files"
@echo " help Prints this message"
- @echo " check Type check the SML code"
-mlb-path-map : Makefile
- echo 'MLTON_LIB $(shell cd ../../../.. && pwd)' > $@
- echo 'SML_COMPILER mlton' >> $@
+all : $(lib-file) $(nlffi-mlb)
-all : $(lib-file) $(gen-dir)/nlffi/lib.mlb
-
clean :
- rm -rf $(bin-dir) $(gen-dir)/nlffi $(lib-file) mlb-path-map
+ rm -rf $(bin-dir) $(gen-dir) $(lib-file) $(def-use-file)
-check : $(gen-dir)/nlffi/lib.mlb mlb-path-map
- mlton -stop tc -mlb-path-map mlb-path-map lib.mlb
+check : $(nlffi-mlb) $(mlb-path-map)
+ mlton -stop tc \
+ -mlb-path-map $(mlb-path-map) \
+ -prefer-abs-paths true \
+ -show-def-use $(def-use-file) \
+ lib.mlb
+##########################################################################
+
+$(mlb-path-map) : Makefile
+ echo 'MLTON_LIB $(shell cd ../../../.. && pwd)' > $@
+ echo 'SML_COMPILER mlton' >> $@
+
$(lib-file) : $(lib-o-files)
ar cr $@ $^
-$(gen-dir)/nlffi/lib.mlb : $(ffi-h-files)
+$(nlffi-mlb) : $(ffi-h-files)
mkdir -p $(@D)
mlnlffigen -dir $(@D) \
-mlbfile $(@F) \
@@ -59,3 +75,5 @@
-c \
-o $@ \
$<
+
+##########################################################################
Modified: mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h 2007-02-20 13:29:46 UTC (rev 5272)
+++ mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h 2007-02-20 17:01:01 UTC (rev 5273)
@@ -27,13 +27,18 @@
/************************************************************************/
+WIN_TYPEDEF(LPVOID, void *);
+
+WIN_TYPEDEF(BOOL, int);
WIN_TYPEDEF(BYTE, unsigned char);
WIN_TYPEDEF(WORD, unsigned short);
WIN_TYPEDEF(DWORD, unsigned long);
WIN_TYPEDEF(LONG, long);
+WIN_TYPEDEF(LONGLONG, long long);
WIN_TYPEDEF(LPBYTE, BYTE *);
WIN_TYPEDEF(LPDWORD, DWORD *);
+WIN_TYPEDEF(LPLONG, LONG *);
WIN_TYPEDEF(LPCTSTR, const char *);
WIN_TYPEDEF(LPTSTR, char *);
@@ -135,6 +140,61 @@
/************************************************************************/
+WIN_TYPEDEF(HANDLE, void *);
+
+WIN_FUNCTION(CloseHandle, BOOL, 1, (HANDLE));
+
+/************************************************************************/
+
+WIN_CONST(WAIT_OBJECT_0, DWORD);
+WIN_CONST(WAIT_ABANDONED_0, DWORD);
+WIN_CONST(WAIT_IO_COMPLETION, DWORD);
+WIN_CONST(WAIT_TIMEOUT, DWORD);
+WIN_CONST(WAIT_FAILED, DWORD);
+
+WIN_FUNCTION(WaitForMultipleObjectsEx, DWORD, 5,
+ (DWORD, const HANDLE *, BOOL, DWORD, BOOL));
+WIN_FUNCTION(WaitForMultipleObjects, DWORD, 4,
+ (DWORD, const HANDLE *, BOOL, DWORD));
+
+/************************************************************************/
+
+WIN_FUNCTION(CreateSemaphore, HANDLE, 4,
+ (LPSECURITY_ATTRIBUTES, LONG, LONG, LPCTSTR));
+WIN_FUNCTION(ReleaseSemaphore, BOOL, 3, (HANDLE, LONG, LPLONG));
+
+/************************************************************************/
+
+WIN_FUNCTION(CreateMutex, HANDLE, 3, (LPSECURITY_ATTRIBUTES, BOOL, LPCTSTR));
+WIN_FUNCTION(ReleaseMutex, BOOL, 1, (HANDLE));
+
+/************************************************************************/
+
+WIN_FUNCTION(CreateWaitableTimer, HANDLE, 3,
+ (LPSECURITY_ATTRIBUTES, BOOL, LPCTSTR));
+WIN_FUNCTION(CancelWaitableTimer, BOOL, 1, (HANDLE));
+
+BOOL win_SetWaitableTimer(HANDLE, LONGLONG, LONG, BOOL);
+
+/************************************************************************/
+
+WIN_CONST(FILE_NOTIFY_CHANGE_ATTRIBUTES, DWORD);
+WIN_CONST(FILE_NOTIFY_CHANGE_DIR_NAME, DWORD);
+WIN_CONST(FILE_NOTIFY_CHANGE_FILE_NAME, DWORD);
+WIN_CONST(FILE_NOTIFY_CHANGE_LAST_WRITE, DWORD);
+WIN_CONST(FILE_NOTIFY_CHANGE_SECURITY, DWORD);
+WIN_CONST(FILE_NOTIFY_CHANGE_SIZE, DWORD);
+
+WIN_FUNCTION(FindFirstChangeNotification, HANDLE, 3, (LPCTSTR, BOOL, DWORD));
+WIN_FUNCTION(FindCloseChangeNotification, BOOL, 1, (HANDLE));
+WIN_FUNCTION(FindNextChangeNotification, BOOL, 1, (HANDLE));
+
+/************************************************************************/
+
+WIN_FUNCTION(GetCurrentProcessId, DWORD, 0, (void));
+
+/************************************************************************/
+
LPTSTR win_FormatErrorLocalAlloc(DWORD error);
#endif
Modified: mltonlib/trunk/com/ssh/windows/unstable/detail/lib/windows.c
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/detail/lib/windows.c 2007-02-20 13:29:46 UTC (rev 5272)
+++ mltonlib/trunk/com/ssh/windows/unstable/detail/lib/windows.c 2007-02-20 17:01:01 UTC (rev 5273)
@@ -91,8 +91,19 @@
/************************************************************************/
-LPTSTR win_FormatErrorLocalAlloc(DWORD error)
+BOOL
+win_SetWaitableTimer(HANDLE handle, LONGLONG dueTime, LONG period, BOOL resume)
{
+ LARGE_INTEGER liDueTime;
+ liDueTime.QuadPart = dueTime;
+ return SetWaitableTimer(handle, &liDueTime, period, NULL, NULL, resume);
+}
+
+/************************************************************************/
+
+LPTSTR
+win_FormatErrorLocalAlloc(DWORD error)
+{
LPTSTR msg = NULL;
FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER |
FORMAT_MESSAGE_FROM_SYSTEM |
Modified: mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml 2007-02-20 13:29:46 UTC (rev 5272)
+++ mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml 2007-02-20 17:01:01 UTC (rev 5273)
@@ -7,7 +7,7 @@
(* XXX make pretty printing of args in error messages a compile time option *)
(* Implementation of Windows utilities. *)
-structure Windows :> WINDOWS = struct
+structure Windows :> WINDOWS_EX = struct
local
open Type Prettier
in
@@ -303,12 +303,10 @@
end
structure Module = struct
- type hmodule = C.voidptr
+ type t = C.voidptr
- val null = C.Ptr.null'
-
fun getFileName m = let
- val m' = getOpt (m, null)
+ val m' = getOpt (m, C.Ptr.null')
in
onError0ElseTruncatedSize
(fn () => F"Module.getFileName"[A (opt ptr) m])
@@ -325,4 +323,63 @@
(fn () => F"Path.getShortName"[A str p])
(fn (b, s) => F_win_GetShortPathName.f' (p', b, s)))
end
+
+ structure Wait = struct
+ type t = C.voidptr
+
+ type 'a waitable = Unit.t
+
+ datatype 'a result
+ = ABANDONED of 'a
+ | OBJECT of 'a
+ | TIMEOUT
+
+ val prepare = undefined
+
+ val any = undefined
+ val all = undefined
+ end
+
+ structure Semaphore = struct
+ type t = C.voidptr
+ val create = undefined
+ val close = undefined
+ val release = undefined
+ val toWait = undefined
+ end
+
+ structure Mutex = struct
+ type t = C.voidptr
+ val create = undefined
+ val close = undefined
+ val toWait = undefined
+ end
+
+ structure Timer = struct
+ type t = C.voidptr
+ val create = undefined
+ val close = undefined
+ val set = undefined
+ val cancel = undefined
+ val toWait = undefined
+ end
+
+ structure FileChange = struct
+ structure Filter = struct
+ open BitFlags
+ fun `x = SysWord.fromWord (C.Get.ulong' (x ()))
+ val attributes = `G_win_FILE_NOTIFY_CHANGE_ATTRIBUTES.obj'
+ val dirName = `G_win_FILE_NOTIFY_CHANGE_DIR_NAME.obj'
+ val fileName = `G_win_FILE_NOTIFY_CHANGE_FILE_NAME.obj'
+ val lastWrite = `G_win_FILE_NOTIFY_CHANGE_LAST_WRITE.obj'
+ val security = `G_win_FILE_NOTIFY_CHANGE_SECURITY.obj'
+ val size = `G_win_FILE_NOTIFY_CHANGE_SIZE.obj'
+ end
+
+ type t = C.voidptr
+ val first = undefined
+ val next = undefined
+ val close = undefined
+ val toWait = undefined
+ end
end
Modified: mltonlib/trunk/com/ssh/windows/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/lib.mlb 2007-02-20 13:29:46 UTC (rev 5272)
+++ mltonlib/trunk/com/ssh/windows/unstable/lib.mlb 2007-02-20 17:01:01 UTC (rev 5273)
@@ -22,6 +22,7 @@
in
local
public/windows.sig
+ public/windows-ex.sig
detail/windows.sml
in
public/export.sml
Modified: mltonlib/trunk/com/ssh/windows/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/public/export.sml 2007-02-20 13:29:46 UTC (rev 5272)
+++ mltonlib/trunk/com/ssh/windows/unstable/public/export.sml 2007-02-20 17:01:01 UTC (rev 5273)
@@ -6,8 +6,9 @@
(** == Exported signatures == *)
-signature WINDOWS = WINDOWS
+signature WINDOWS = WINDOWS
+signature WINDOWS_EX = WINDOWS_EX
(** == Exported structures == *)
-structure Windows : WINDOWS = Windows
+structure Windows : WINDOWS_EX = Windows
Added: mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig 2007-02-20 13:29:46 UTC (rev 5272)
+++ mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig 2007-02-20 17:01:01 UTC (rev 5273)
@@ -0,0 +1,90 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * This signature specifies some notable extensions to the {WINDOWS} signature.
+ *)
+signature WINDOWS_EX = sig
+ include WINDOWS
+
+ structure EventLog : sig
+ structure Type : sig
+ include BIT_FLAGS
+ val auditFailure : flags
+ val auditSuccess : flags
+ val error : flags
+ val information : flags
+ val warning : flags
+ end
+ end
+
+ structure Module : sig
+ eqtype t
+ val getFileName : t Option.t -> String.t
+ end
+
+ structure Path : sig
+ val getShortName : String.t UnOp.t
+ end
+
+ structure Wait : sig
+ type t
+
+ type 'a waitable
+
+ datatype 'a result
+ = ABANDONED of 'a
+ | OBJECT of 'a
+ | TIMEOUT
+
+ val prepare : (t * 'a) List.t -> 'a waitable
+
+ val any : 'a waitable * Real.t -> 'a result
+ val all : 'a waitable * Real.t -> 'a result
+ end
+
+ structure Semaphore : sig
+ type t
+ val create : {init : Int32.t, max : Int32.t, name : String.t Option.t} -> t
+ val close : t Effect.t
+ val release : t * Int32.t -> Int32.t
+ val toWait : t -> Wait.t
+ end
+
+ structure Mutex : sig
+ type t
+ val create : {name : String.t Option.t, own : Bool.t} -> t
+ val close : t Effect.t
+ val toWait : t -> Wait.t
+ end
+
+ structure Timer : sig
+ type t
+ val create : {manual : Bool.t, name : String.t Option.t} -> t
+ val close : t Effect.t
+ val set : {timer : t, due : Int64.t, period : Int32.t} Effect.t
+ val cancel : t Effect.t
+ val toWait : t -> Wait.t
+ end
+
+ structure FileChange : sig
+ structure Filter : sig
+ include BIT_FLAGS
+ val fileName : flags
+ val dirName : flags
+ val attributes : flags
+ val size : flags
+ val lastWrite : flags
+ val security : flags
+ end
+
+ type t
+ val first : String.t * Bool.t * Filter.flags -> t
+ val next : t Effect.t
+ val close : t Effect.t
+ val toWait : t -> Wait.t
+ end
+end
Property changes on: mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/windows/unstable/public/windows.sig
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/public/windows.sig 2007-02-20 13:29:46 UTC (rev 5272)
+++ mltonlib/trunk/com/ssh/windows/unstable/public/windows.sig 2007-02-20 17:01:01 UTC (rev 5273)
@@ -7,9 +7,9 @@
(**
* Signature for Windows utilities.
*
- * Parts of this signature follow the SML Basis Library specification:
- *
- * http://mlton.org/basis/windows.html .
+ * Aside from a few minor extensions, this signature specifies a subset of
+ * the [http://mlton.org/basis/windows.html Windows structure] in the
+ * Standard ML Basis Library.
*)
signature WINDOWS = sig
structure Key : sig
@@ -59,24 +59,4 @@
val queryValueEx : hkey * String.t -> value Option.t
val setValueEx : (hkey * String.t * value) Effect.t
end
-
- structure EventLog : sig
- structure Type : sig
- include BIT_FLAGS
- val auditFailure : flags
- val auditSuccess : flags
- val error : flags
- val information : flags
- val warning : flags
- end
- end
-
- structure Module : sig
- type hmodule
- val getFileName : hmodule Option.t -> String.t
- end
-
- structure Path : sig
- val getShortName : String.t UnOp.t
- end
end
More information about the MLton-commit
mailing list