(* Copyright (c) 2001, 2015 David C.J. Matthews This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 as published by the Free Software Foundation. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (* This contains various types and other values which are needed in various modules. All the exported types are contained in other structures. *) structure Base: sig val winCall0: Foreign.symbol -> unit -> 'a Foreign.conversion -> unit -> 'a val winCall1: Foreign.symbol -> 'a Foreign.conversion -> 'b Foreign.conversion -> 'a -> 'b val winCall2: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion -> 'c Foreign.conversion -> 'a * 'b -> 'c val winCall3: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion -> 'd Foreign.conversion -> 'a * 'b * 'c -> 'd val winCall4: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion -> 'e Foreign.conversion -> 'a * 'b * 'c * 'd -> 'e val winCall5: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion -> 'f Foreign.conversion -> 'a * 'b * 'c * 'd * 'e -> 'f val winCall6: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion -> 'g Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f -> 'g val winCall7: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion * 'g Foreign.conversion -> 'h Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g -> 'h val winCall8: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion -> 'i Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h -> 'i val winCall9: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion -> 'j Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i -> 'j val winCall10: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion * 'j Foreign.conversion -> 'k Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j -> 'k val winCall11: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion * 'j Foreign.conversion * 'k Foreign.conversion -> 'l Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k -> 'l val winCall12: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion * 'j Foreign.conversion * 'k Foreign.conversion * 'l Foreign.conversion -> 'm Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l -> 'm val winCall13: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion * 'j Foreign.conversion * 'k Foreign.conversion * 'l Foreign.conversion * 'm Foreign.conversion -> 'n Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm -> 'n val winCall14: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion * 'j Foreign.conversion * 'k Foreign.conversion * 'l Foreign.conversion * 'm Foreign.conversion * 'n Foreign.conversion -> 'o Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm * 'n -> 'o val winAbi: Foreign.LibFFI.abi val kernel: string -> Foreign.symbol and user: string -> Foreign.symbol and commdlg: string -> Foreign.symbol and gdi: string -> Foreign.symbol and shell: string -> Foreign.symbol and comctl: string -> Foreign.symbol val cSIZE_T: int Foreign.conversion and cLPARAM: int Foreign.conversion and cLONG_PTR: int Foreign.conversion and cULONG_PTR: int Foreign.conversion and cINT_PTR: int Foreign.conversion and cUINT_PTR: int Foreign.conversion and cDWORD: int Foreign.conversion and cWORD: int Foreign.conversion and cDWORD_PTR: int Foreign.conversion and cUINT_PTRw: SysWord.word Foreign.conversion val cUint8w: Word8.word Foreign.conversion and cUint16w: Word.word Foreign.conversion and cUint32w: Word32.word Foreign.conversion and cUintw: Word32.word Foreign.conversion and cUlongw: Word32.word Foreign.conversion val cDWORDw: Word32.word Foreign.conversion and cWORDw: Word.word Foreign.conversion val cBool: bool Foreign.conversion val successState: string -> unit Foreign.conversion val cPOSINT: string -> int Foreign.conversion type POINT = { x: int, y: int } val cPoint: POINT Foreign.conversion type RECT = { left: int, top: int, right: int, bottom: int } val cRect: RECT Foreign.conversion type SIZE = { cx: int, cy: int } val cSize: SIZE Foreign.conversion eqtype 'a HANDLE val hNull: 'a HANDLE val isHNull: 'a HANDLE -> bool val handleOfVoidStar: Foreign.Memory.voidStar -> 'a HANDLE and voidStarOfHandle: 'a HANDLE -> Foreign.Memory.voidStar eqtype HMENU and HDC and HWND and HINSTANCE and HGDIOBJ and HDROP and HRSRC and HUPDATE val cHGDIOBJ: HGDIOBJ Foreign.conversion and cHDROP: HDROP Foreign.conversion and cHMENU: HMENU Foreign.conversion and cHINSTANCE: HINSTANCE Foreign.conversion and cHDC: HDC Foreign.conversion and cHWND: HWND Foreign.conversion val cHMENUOPT: HMENU option Foreign.conversion and cHGDIOBJOPT: HGDIOBJ option Foreign.conversion and cHWNDOPT: HWND option Foreign.conversion and cHRSRC: HRSRC Foreign.conversion and cHUPDATE: HUPDATE Foreign.conversion val hgdiObjNull:HGDIOBJ and isHgdiObjNull: HGDIOBJ -> bool and hdcNull: HDC and isHdcNull: HDC -> bool and hmenuNull: HMENU and isHmenuNull: HMENU -> bool and hinstanceNull: HINSTANCE and isHinstanceNull: HINSTANCE -> bool and hwndNull: HWND type HPALETTE = HGDIOBJ and HFONT = HGDIOBJ and HPEN = HGDIOBJ and HBITMAP = HGDIOBJ and HRGN = HGDIOBJ and HBRUSH = HGDIOBJ and HENHMETAFILE = HGDIOBJ and HMETAFILE = HGDIOBJ val cHPALETTE: HPALETTE Foreign.conversion and cHFONT: HFONT Foreign.conversion and cHPEN: HPEN Foreign.conversion and cHBITMAP: HBITMAP Foreign.conversion and cHRGN: HRGN Foreign.conversion and cHBRUSH: HBRUSH Foreign.conversion and cHENHMETAFILE: HENHMETAFILE Foreign.conversion and cHMETAFILE: HMETAFILE Foreign.conversion type HICON = HGDIOBJ and HCURSOR = HGDIOBJ val cHICON: HICON Foreign.conversion and cHCURSOR: HCURSOR Foreign.conversion val absConversion: {abs: 'a -> 'b, rep: 'b -> 'a} -> 'a Foreign.conversion -> 'b Foreign.conversion val tableLookup: (''a * ''b) list * ((''b -> ''a) * (''a -> ''b)) option -> (''a -> ''b) * (''b -> ''a) and tableSetLookup: (''a * Word32.word) list * ((Word32.word -> ''a) * (''a -> Word32.word)) option -> (''a list -> Word32.word) * (Word32.word -> ''a list) val tableConversion: (''a * ''b) list * ((''b -> ''a) * (''a -> ''b)) option -> ''b Foreign.conversion -> ''a Foreign.conversion (* tableSetConversion is always a cUint *) and tableSetConversion: (''a * Word32.word) list * ((Word32.word -> ''a) * (''a -> Word32.word)) option -> ''a list Foreign.conversion val list2Vector: 'a Foreign.conversion -> 'a list -> Foreign.Memory.voidStar * int datatype ClassType = NamedClass of string | ClassAtom of int val cCLASS: ClassType Foreign.conversion datatype ClipboardFormat = CF_NONE | CF_TEXT | CF_BITMAP | CF_METAFILEPICT | CF_SYLK | CF_DIF | CF_TIFF | CF_OEMTEXT | CF_DIB | CF_PALETTE | CF_PENDATA | CF_RIFF | CF_WAVE | CF_UNICODETEXT | CF_ENHMETAFILE | CF_OWNERDISPLAY | CF_DSPTEXT | CF_DSPBITMAP | CF_DSPMETAFILEPICT | CF_DSPENHMETAFILE | CF_PRIVATE of int | CF_GDIOBJ of int | CF_REGISTERED of int | CF_HDROP | CF_LOCALE val clipLookup: (ClipboardFormat -> int) * (int -> ClipboardFormat) datatype RESID = IdAsInt of int | IdAsString of string val cRESID: RESID Foreign.conversion val STRINGOPT: string option Foreign.conversion val cCHARARRAY: int -> string Foreign.conversion val fromCstring: Foreign.Memory.voidStar -> string val toCstring: string -> Foreign.Memory.voidStar (* Memory must be freed *) val copyStringToMem: Foreign.Memory.voidStar * int * string -> unit val fromCWord8vec: Foreign.Memory.voidStar * int -> Word8Vector.vector val toCWord8vec: Word8Vector.vector -> Foreign.Memory.voidStar (* Memory must be freed *) val getStringCall: (Foreign.Memory.voidStar * int -> int) -> string val getStringWithNullIsLength: (Foreign.Memory.voidStar * int -> int) -> string val getVectorResult: 'a Foreign.conversion -> (Foreign.Memory.voidStar * int -> int) -> int -> 'a vector eqtype HGLOBAL val cHGLOBAL: HGLOBAL Foreign.conversion val GlobalAlloc: int * int -> HGLOBAL val GlobalLock: HGLOBAL -> Foreign.Memory.voidStar val GlobalFree: HGLOBAL -> HGLOBAL val GlobalSize: HGLOBAL -> int val GlobalUnlock: HGLOBAL -> bool val HIWORD: Word32.word -> Word.word val LOWORD: Word32.word -> Word.word val MAKELONG: Word.word * Word.word -> Word32.word val HIBYTE: Word.word -> Word8.word val LOBYTE: Word.word -> Word8.word val unicodeToString: Word8Vector.vector -> string val stringToUnicode: string -> Word8Vector.vector val GetLastError: unit -> OS.syserror val checkResult: bool -> unit val raiseSysErr: unit -> 'a structure FindReplaceFlags: sig include BIT_FLAGS val FR_DIALOGTERM : flags val FR_DOWN : flags val FR_FINDNEXT : flags val FR_HIDEMATCHCASE : flags val FR_HIDEUPDOWN : flags val FR_HIDEWHOLEWORD : flags val FR_MATCHCASE : flags val FR_NOMATCHCASE : flags val FR_NOUPDOWN : flags val FR_NOWHOLEWORD : flags val FR_REPLACE : flags val FR_REPLACEALL : flags val FR_SHOWHELP : flags val FR_WHOLEWORD : flags val cFindReplaceFlags: flags Foreign.conversion end end = struct open Foreign (* val System_isShort : vol -> bool = RunCall.run_call1 RuntimeCalls.POLY_SYS_is_short*) fun absConversion {abs: 'a -> 'b, rep: 'b -> 'a} (c: 'a conversion) : 'b conversion = let val { load=loadI, store=storeI, ctype } = breakConversion c fun load m = abs(loadI m) fun store(m, v) = storeI(m, rep v) in makeConversion { load = load, store = store, ctype = ctype } end (* In many cases we can pass a set of options as a bit set. *) (* fun bitsetConversion {abs, rep} = let val (fromC, toC, Ctype) = breakConversion INT val fromList = List.foldl (fn(i, n) => IntInf.orb(rep i, n)) 0 fun toList n = [abs n] (* This is a bit of a mess. *) in mkConversion (toList o fromCuint) (toCuint o fromList) Cuint end*) (* Conversions between Word/Word32/LargeWord etc. *) local open Memory LowLevel fun noFree () = () in local fun load(m: voidStar): Word8.word = get8(m, 0w0) fun store(m: voidStar, i: Word8.word) = (set8(m, 0w0, i); noFree) in val cUint8w: Word8.word conversion = makeConversion{ load=load, store=store, ctype = cTypeUint8 } end local fun load(m: voidStar): Word.word = get16(m, 0w0) fun store(m: voidStar, i: Word.word) = (set16(m, 0w0, i); noFree) in val cUint16w: Word.word conversion = makeConversion{ load=load, store=store, ctype = cTypeInt16 } end local fun load(m: voidStar): Word32.word = get32(m, 0w0) fun store(m: voidStar, i: Word32.word) = (set32(m, 0w0, i); noFree) in val cUint32w: Word32.word conversion = makeConversion{ load=load, store=store, ctype = cTypeUint32 } end val cUintw = cUint32w (* Int should be 32-bits on Windows. *) val _ = #size LowLevel.cTypeUint = #size LowLevel.cTypeUint32 orelse raise Fail "unsigned int is not 32-bits" val cUlongw = cUint32w val _ = #size LowLevel.cTypeUlong = #size LowLevel.cTypeUint32 orelse raise Fail "unsigned long is not 32-bits" end val cDWORD = cUint32 (* Defined to be 32-bit unsigned *) and cWORD = cUint16 (* Defined to be 16-bit unsigned *) val cDWORDw = cUint32w and cWORDw = cUint16w (* For some reason Windows has both INT_PTR and LONG_PTR and they are slightly different. *) val cLONG_PTR = if #size LowLevel.cTypePointer = 0w4 then cLong else cInt64 val cINT_PTR = if #size LowLevel.cTypePointer = 0w4 then cInt else cInt64 val cULONG_PTR = if #size LowLevel.cTypePointer = 0w4 then cUlong else cUint64 val cUINT_PTR = if #size LowLevel.cTypePointer = 0w4 then cUint else cUint64 val cLPARAM = cLONG_PTR val cSIZE_T = cULONG_PTR (* Probably. *) val cDWORD_PTR = cULONG_PTR (* Defined to be the same so I'm not sure why it's there .*) val cUINT_PTRw = absConversion{abs=Memory.voidStar2Sysword, rep=Memory.sysWord2VoidStar} cPointer (* These are called XXX32.DLL on both 32-bit and 64-bit. *) fun kernel name = getSymbol(loadLibrary "kernel32.dll") name and user sym = getSymbol(loadLibrary "user32.DLL") sym and commdlg sym = getSymbol(loadLibrary "comdlg32.DLL") sym and gdi sym = getSymbol(loadLibrary "gdi32.DLL") sym and shell sym = getSymbol(loadLibrary "shell32.DLL") sym and comctl sym = getSymbol(loadLibrary "comctl32.DLL") sym (* We need to use the Pascal calling convention on 32-bit Windows. *) val winAbi = case List.find (fn ("stdcall", _) => true | _ => false) LibFFI.abiList of SOME(_, abi) => abi | NONE => LibFFI.abiDefault (* As well as setting the abi we can also use the old argument order. *) fun winCall0 sym argConv resConv = buildCall0withAbi(winAbi, sym, argConv, resConv) and winCall1 sym argConv resConv = buildCall1withAbi(winAbi, sym, argConv, resConv) and winCall2 sym argConv resConv = buildCall2withAbi(winAbi, sym, argConv, resConv) and winCall3 sym argConv resConv = buildCall3withAbi(winAbi, sym, argConv, resConv) and winCall4 sym argConv resConv = buildCall4withAbi(winAbi, sym, argConv, resConv) and winCall5 sym argConv resConv = buildCall5withAbi(winAbi, sym, argConv, resConv) and winCall6 sym argConv resConv = buildCall6withAbi(winAbi, sym, argConv, resConv) and winCall7 sym argConv resConv = buildCall7withAbi(winAbi, sym, argConv, resConv) and winCall8 sym argConv resConv = buildCall8withAbi(winAbi, sym, argConv, resConv) and winCall9 sym argConv resConv = buildCall9withAbi(winAbi, sym, argConv, resConv) and winCall10 sym argConv resConv = buildCall10withAbi(winAbi, sym, argConv, resConv) and winCall11 sym argConv resConv = buildCall11withAbi(winAbi, sym, argConv, resConv) and winCall12 sym argConv resConv = buildCall12withAbi(winAbi, sym, argConv, resConv) and winCall13 sym argConv resConv = buildCall13withAbi(winAbi, sym, argConv, resConv) and winCall14 sym argConv resConv = buildCall14withAbi(winAbi, sym, argConv, resConv) (* Previously we had a specific call to do this. The error state is no longer set by the new FFI. *) (* fun GetLastError(): OS.syserror = RunCall.run_call2 RuntimeCalls.POLY_SYS_os_specific (1100, ()) *) local val getLastError = winCall0 (kernel "GetLastError") () cDWORD in fun GetLastError(): OS.syserror = (* Windows error codes are negative values in OS.syserror. *) RunCall.unsafeCast (~ (getLastError())) end (* The string argument of the SysErr exception is supposed to match the result of OS.errMsg. *) fun raiseSysErr () = let val err = GetLastError() in raise OS.SysErr(OS.errorMsg err, SOME err) end (* Many system calls return bool. If the result is false we raise an exception. *) fun checkResult true = () | checkResult false = raiseSysErr () val cBool: bool conversion = absConversion{abs = fn 0 => false | _ => true, rep = fn false => 0 | true => 1} cInt fun successState name: unit conversion = absConversion { abs = checkResult, rep = fn _ => raise Fail ("successState:" ^ name) } cBool type POINT = { x: int, y: int } local fun breakPoint ({x,y}: POINT) = (x,y) fun mkPoint (x,y): POINT = {x=x, y=y} in val cPoint = absConversion {abs=mkPoint, rep=breakPoint} (cStruct2 (cLong, cLong)) end type RECT = { left: int, top: int, right: int, bottom: int } local fun breakRect ({left,top,right,bottom}: RECT) = (left,top,right,bottom) fun mkRect (left,top,right,bottom): RECT = {left=left,top=top,right=right,bottom=bottom} in val cRect = absConversion {abs=mkRect, rep=breakRect} (cStruct4 (cLong,cLong,cLong,cLong)) end type SIZE = { cx: int, cy: int } local fun breakSize ({cx,cy}: SIZE) = (cx,cy) fun mkSize (cx,cy): SIZE = {cx=cx, cy=cy} in val cSize = absConversion {abs=mkSize, rep=breakSize} (cStruct2 (cLong,cLong)) end (* Handles are generally opaque values. We want them to be eqtypes, though. *) local structure HandStruct :> sig eqtype 'a HANDLE val hNull: 'a HANDLE val isHNull: 'a HANDLE -> bool val handleOfVoidStar: Memory.voidStar -> 'a HANDLE and voidStarOfHandle: 'a HANDLE -> Memory.voidStar end = struct type 'a HANDLE = Memory.voidStar val hNull = Memory.null fun isHNull h = h = hNull (* We sometimes need the next two functions internally. They're needed externally unless we change the result type of SendMessage to allow us to return a handle for certain messages. *) fun handleOfVoidStar h = h and voidStarOfHandle h = h end in open HandStruct end (* We just need these as placeholders. We never create values of these types. They are used simply as a way of creating different handle types. *) (* Don't use abstype - we want them to eqtypes *) datatype GdiObj = GdiObj and Instance = Instance and Drop = Drop and DeviceContext = DeviceContext and Menu = Menu and Window = Window and Global = Global and Src = Src and Update = Update (* HINSTANCE is used as an instance of a module. *) type HINSTANCE = Instance HANDLE and HDROP = Drop HANDLE and HGDIOBJ = GdiObj HANDLE and HDC = DeviceContext HANDLE and HMENU = Menu HANDLE and HWND = Window HANDLE and HGLOBAL = Global HANDLE and HRSRC = Src HANDLE and HUPDATE = Update HANDLE local fun cHANDLE() = absConversion {abs=handleOfVoidStar, rep=voidStarOfHandle} cPointer fun hoptOfvs n = if Memory.voidStar2Sysword n = 0w0 then NONE else SOME(handleOfVoidStar n) fun cHANDLEOPT() = absConversion {abs=hoptOfvs, rep=fn v => voidStarOfHandle(getOpt(v, hNull)) } cPointer in val cHGDIOBJ: HGDIOBJ conversion = cHANDLE() and cHDROP: HDROP conversion = cHANDLE() and cHMENU: HMENU conversion = cHANDLE() and cHINSTANCE: HINSTANCE conversion = cHANDLE() and cHDC: HDC conversion = cHANDLE() and cHWND: HWND conversion = cHANDLE() val cHMENUOPT: HMENU option conversion = cHANDLEOPT() and cHGDIOBJOPT: HGDIOBJ option conversion = cHANDLEOPT() and cHWNDOPT: HWND option conversion = cHANDLEOPT() val cHGLOBAL: HGLOBAL conversion = cHANDLE() and cHRSRC: HRSRC conversion = cHANDLE() and cHUPDATE: HUPDATE conversion = cHANDLE() end (* Temporary declarations. *) val hgdiObjNull:HGDIOBJ = hNull and isHgdiObjNull: HGDIOBJ -> bool = isHNull and hdcNull: HDC = hNull and isHdcNull: HDC -> bool = isHNull and hmenuNull: HMENU = hNull and isHmenuNull: HMENU -> bool = isHNull and hinstanceNull: HINSTANCE = hNull and isHinstanceNull: HINSTANCE -> bool = isHNull and hwndNull: HWND = hNull (* All these are various kinds of HGDIOBJ. It's too complicated to try to use different types for them. *) type HPALETTE = HGDIOBJ and HFONT = HGDIOBJ and HPEN = HGDIOBJ and HBITMAP = HGDIOBJ and HRGN = HGDIOBJ and HBRUSH = HGDIOBJ and HENHMETAFILE = HGDIOBJ and HMETAFILE = HGDIOBJ val cHPALETTE: HPALETTE conversion = cHGDIOBJ and cHFONT: HFONT conversion = cHGDIOBJ and cHPEN: HPEN conversion = cHGDIOBJ and cHBITMAP: HBITMAP conversion = cHGDIOBJ and cHRGN: HRGN conversion = cHGDIOBJ and cHBRUSH: HBRUSH conversion = cHGDIOBJ and cHENHMETAFILE: HENHMETAFILE conversion = cHGDIOBJ and cHMETAFILE: HMETAFILE conversion = cHGDIOBJ (* I'm not so happy about treating these as HGDIOBJ but it makes the types of messages such as BM_SETIMAGE simpler. *) type HICON = HGDIOBJ and HCURSOR = HGDIOBJ val cHICON = cHGDIOBJ and cHCURSOR = cHGDIOBJ (* The easiest way to deal with datatypes is often by way of a table. *) fun tableLookup (table: (''a * ''b) list, default) = let fun toInt [] x = (case default of NONE => raise Fail "tableLookup: not found" | SOME (_, d) => d x) | toInt ((y, i) :: tl) x = if x = y then i else toInt tl x fun fromInt [] x = (case default of NONE => raise Fail ("tableLookup: not found") | SOME (d, _) => d x) | fromInt ((y, i) :: tl) x = if x = i then y else fromInt tl x in (toInt table, fromInt table) end fun tableConversion (table: (''a * ''b) list, default) (conv: ''b conversion): ''a conversion = let val (toInt, fromInt) = tableLookup(table, default) in absConversion {abs = fromInt, rep = toInt} conv end (* In other cases we have sets of options. We represent them by a list. The order of the elements in the table is significant if we are to be able to handle multiple bits. Patterns with more than one bit set MUST be placed later than those with a subset of those bits. *) fun tableSetLookup (table: (''a * Word32.word) list, default) = let open Word32 (* Conversion to integer - just fold the values. *) fun toInt' [] x = (case default of NONE => raise Fail "tableLookup: not found" | SOME (_, d) => d x) | toInt' ((y, i) :: tl) x = if x = y then i else toInt' tl x val toInt = List.foldl (fn (a, b) => orb(toInt' table a, b)) 0w0 (* It would speed up the searches if we ordered the list so that multiple bit entries preceded those with fewer bits but it's much easier to lay out the tables if we do it this way. *) fun fromInt _ _ 0w0 = [] (* Zero is an empty list. *) | fromInt [] NONE x = (* Not found *) (case default of NONE => raise Fail ("tableLookup: not found" ^ Word32.toString x) | SOME (d, _) => [d x]) | fromInt [] (SOME(res, bits)) x = (* Found something - remove it from the set. *) (res :: fromInt table NONE (andb(x, notb bits))) | fromInt ((res, bits)::tl) sofar x = if bits <> 0w0 andalso andb(x, bits) = bits then (* Matches *) fromInt tl (SOME(res, bits)) x else (* Doesn't match *) fromInt tl sofar x in (toInt, fromInt table NONE) end fun tableSetConversion (table: (''a * Word32.word) list, default): ''a list conversion = let val (toInt, fromInt) = tableSetLookup(table, default) in absConversion {abs = fromInt, rep = toInt} cUintw end structure FindReplaceFlags:> sig include BIT_FLAGS val FR_DIALOGTERM : flags val FR_DOWN : flags val FR_FINDNEXT : flags val FR_HIDEMATCHCASE : flags val FR_HIDEUPDOWN : flags val FR_HIDEWHOLEWORD : flags val FR_MATCHCASE : flags val FR_NOMATCHCASE : flags val FR_NOUPDOWN : flags val FR_NOWHOLEWORD : flags val FR_REPLACE : flags val FR_REPLACEALL : flags val FR_SHOWHELP : flags val FR_WHOLEWORD : flags val cFindReplaceFlags: flags conversion end = struct open Word32 type flags = word val toWord = toLargeWord and fromWord = fromLargeWord val flags = List.foldl (fn (a, b) => orb(a,b)) 0w0 fun allSet (fl1, fl2) = andb(fl1, fl2) = fl1 fun anySet (fl1, fl2) = andb(fl1, fl2) <> 0w0 fun clear (fl1, fl2) = andb(notb fl1, fl2) val FR_DOWN = 0wx00000001 val FR_WHOLEWORD = 0wx00000002 val FR_MATCHCASE = 0wx00000004 val FR_FINDNEXT = 0wx00000008 val FR_REPLACE = 0wx00000010 val FR_REPLACEALL = 0wx00000020 val FR_DIALOGTERM = 0wx00000040 val FR_SHOWHELP = 0wx00000080 val FR_NOUPDOWN = 0wx00000400 val FR_NOMATCHCASE = 0wx00000800 val FR_NOWHOLEWORD = 0wx00001000 val FR_HIDEUPDOWN = 0wx00004000 val FR_HIDEMATCHCASE = 0wx00008000 val FR_HIDEWHOLEWORD = 0wx00010000 val all = flags[FR_DOWN, FR_WHOLEWORD, FR_MATCHCASE, FR_FINDNEXT, FR_REPLACE, FR_REPLACEALL, FR_DIALOGTERM, FR_NOUPDOWN, FR_NOMATCHCASE, FR_NOWHOLEWORD, FR_HIDEUPDOWN, FR_HIDEMATCHCASE, FR_HIDEWHOLEWORD] val intersect = List.foldl (fn (a, b) => andb(a,b)) all val cFindReplaceFlags = cDWORDw end (* The class "string" may be a name or an atom. *) datatype ClassType = NamedClass of string | ClassAtom of int local open Memory val {store=storeS, load=loadS, ctype} = breakConversion cString fun storeClass(m, ClassAtom i) = if i >= 0 andalso i < 0xC000 then (setAddress(m, 0w0, sysWord2VoidStar(SysWord.fromInt i)); fn () => ()) else raise Fail "atom out of range" | storeClass(m, NamedClass s) = storeS(m, s) fun loadClass m = let val v = getAddress(m, 0w0) in if voidStar2Sysword v < 0wxC000 then ClassAtom(SysWord.toInt(voidStar2Sysword v)) else NamedClass(loadS m) end in val cCLASS = makeConversion { load = loadClass, store = storeClass, ctype = ctype } end (* Clipboard formats. I've added CF_NONE, CF_PRIVATE, CF_GDIOBJ and CF_REGISTERED. This is here because it is used in both Clipboard and Message (WM_RENDERFORMAT) *) datatype ClipboardFormat = CF_NONE | CF_TEXT | CF_BITMAP | CF_METAFILEPICT | CF_SYLK | CF_DIF | CF_TIFF | CF_OEMTEXT | CF_DIB | CF_PALETTE | CF_PENDATA | CF_RIFF | CF_WAVE | CF_UNICODETEXT | CF_ENHMETAFILE | CF_OWNERDISPLAY | CF_DSPTEXT | CF_DSPBITMAP | CF_DSPMETAFILEPICT | CF_DSPENHMETAFILE | CF_PRIVATE of int | CF_GDIOBJ of int | CF_REGISTERED of int | CF_HDROP | CF_LOCALE local val tab = [ (CF_NONE, 0), (CF_TEXT, 1), (CF_BITMAP, 2), (CF_METAFILEPICT, 3), (CF_SYLK, 4), (CF_DIF, 5), (CF_TIFF, 6), (CF_OEMTEXT, 7), (CF_DIB, 8), (CF_PALETTE, 9), (CF_PENDATA, 10), (CF_RIFF, 11), (CF_WAVE, 12), (CF_UNICODETEXT, 13), (CF_ENHMETAFILE, 14), (CF_HDROP, 15), (CF_LOCALE, 16), (CF_OWNERDISPLAY, 0x0080), (CF_DSPTEXT, 0x0081), (CF_DSPBITMAP, 0x0082), (CF_DSPMETAFILEPICT, 0x0083), (CF_DSPENHMETAFILE, 0x008E) ] fun toInt (CF_PRIVATE i) = if i >= 0 andalso i < 0xff then 0x0200 + i else raise Size | toInt (CF_GDIOBJ i) = if i >= 0 andalso i < 0xff then 0x0300 + i else raise Size | toInt (CF_REGISTERED i) = i | toInt _ = raise Match fun fromInt i = if i >= 0x0200 andalso i <= 0x02ff then CF_PRIVATE(i-0x0200) else if i >= 0x0300 andalso i <= 0x03ff then CF_GDIOBJ(i-0x0300) else if i >= 0xC000 andalso i < 0xFFFF then CF_REGISTERED i else raise Match in val clipLookup = tableLookup (tab, SOME(fromInt, toInt)) end (* Resources may be specified by strings or by ints. *) datatype RESID = IdAsInt of int | IdAsString of string local open Memory val {store=storeS, load=loadS, ctype} = breakConversion cString fun storeResid(m, IdAsInt i) = if i >= 0 andalso i < 65536 then (setAddress(m, 0w0, sysWord2VoidStar(SysWord.fromInt i)); fn () => ()) else raise Fail "resource id out of range" | storeResid(m, IdAsString s) = storeS(m, s) fun loadResid m = let val v = getAddress(m, 0w0) in if voidStar2Sysword v < 0w65536 then IdAsInt(SysWord.toInt(voidStar2Sysword v)) else IdAsString(loadS m) end in val cRESID = makeConversion { load = loadResid, store = storeResid, ctype = ctype } end (*datatype HelpContext = HelpInfo_MenuItem of | HelpInfo_Window of type HELPINFO = { }*) (* Useful conversions. *) (* Various functions return zero if error. This conversion checks for that. *) fun cPOSINT _ = absConversion {abs = fn 0 => raiseSysErr() | n => n, rep = fn i => i} cInt (* Conversion between string option and C strings. NONE is converted to NULL. *) val STRINGOPT = cOptionPtr cString (* Convert a C string to ML. *) fun fromCstring buff = let open Memory (* We can't use #load cString because the argument is the address of the address of the string. *) fun sLen i = if get8(buff, i) = 0w0 then i else sLen(i+0w1) val length = sLen 0w0 fun loadChar i = Char.chr(Word8.toInt(get8(buff, Word.fromInt i))) in CharVector.tabulate(Word.toInt length, loadChar) end (* Copy a string to a particular offset in a buffer and add a null terminator. *) fun copyStringToMem (buf, n, s) = let open Memory infix 6 ++ fun copyToBuf (i, v) = set8(buf, Word.fromInt(i+n), Byte.charToByte v) in CharVector.appi copyToBuf s; set8(buf, Word.fromInt(n + size s), 0w0) end fun toCstring s = let open Memory val sLen = Word.fromInt(String.size s) val sMem = malloc(sLen + 0w1) val () = copyStringToMem(sMem, 0, s) in sMem end (* When getting a string it is often the case that passing NULL returns the length required. Then a second call will actually retrieve the string. *) fun getStringWithNullIsLength(f: Memory.voidStar*int -> int): string = let open Memory val realLength = f(null, 0) val buff = malloc (Word.fromInt(realLength+1)) val _ = f(buff, realLength) handle ex => (free buff; raise ex) in fromCstring buff before free buff end (* In several cases when extracting a string it is not possible in advance to know how big to make the buffer. This function loops until all the string has been extracted. *) (* This is at least needed for GetClassName *) fun getStringCall(f: Memory.voidStar*int -> int): string = let open Memory fun doCall initialSize = let (* Allocate a buffer to receive the result. For safety we make it one character longer than we actually say because it's not always clear whether the length we pass is the size including the NULL. Equally we are only certain we have read the whole string if the return value is less than initialSize-1 because the return value could be the number of real characters copied to the buffer. *) val buff = malloc (Word.fromInt(initialSize+1)) val resultSize = f(buff, initialSize) handle ex => (free buff; raise ex) in if resultSize < initialSize-1 then (* We've got it all. *) fromCstring buff before free buff else ( free buff; doCall(initialSize + initialSize div 2) ) end in doCall (*1024*) 3 (* Use a small size initially for testing. *) end (* We have a number of calls that extract a vector of results. They are called with an initial size, set the vector to the results and return a count of the number actually assigned. *) fun getVectorResult(element: 'a conversion) = let val { load=loadElem, ctype={size=sizeElem, ...}, ...} = breakConversion element fun run f initialCount = let open Memory infix 6 ++ -- val vec = malloc(Word.fromInt initialCount * sizeElem) fun getElement i = loadElem(vec ++ Word.fromInt i * sizeElem) val resultCount = f (vec, initialCount) handle ex => (free vec; raise ex) in Vector.tabulate(resultCount, getElement) before free vec end in run end (* Some C functions take a vector of values to allow a variable number of elements to be passed. We use a list for this in ML. *) (* TODO: This discards the result of any store function so if we store strings we'll leak store. *) fun list2Vector (conv: 'a conversion) (l:'a list): Memory.voidStar * int = let val count = List.length l val {store=storea, ctype={size=sizea, ...}, ...} = breakConversion conv open Memory infix 6 ++ val vec = malloc(Word.fromInt count * sizea) fun setItem(item, v) = (ignore(storea(v, item)); v ++ sizea) val _ = List.foldl setItem vec l in (vec, count) end val GlobalAlloc = winCall2 (kernel "GlobalAlloc") (cInt, cSIZE_T) cHGLOBAL val GlobalLock = winCall1 (kernel "GlobalLock") (cHGLOBAL) cPointer val GlobalFree = winCall1 (kernel "GlobalFree") (cHGLOBAL) cHGLOBAL val GlobalSize = winCall1 (kernel "GlobalSize") (cHGLOBAL) cSIZE_T val GlobalUnlock = winCall1 (kernel "GlobalUnlock") (cHGLOBAL) cBool (* Conversion for Word8Vector. We can't do this as a general conversion because we can't find out how big the C vector is. *) fun fromCWord8vec (buff, length) = Word8Vector.tabulate(length, fn i => Memory.get8(buff, Word.fromInt i)) fun toCWord8vec(s: Word8Vector.vector): Memory.voidStar = let open Memory Word8Vector val sLen = Word.fromInt(length s) val sMem = malloc sLen val () = appi(fn(i, b) => set8(sMem, Word.fromInt i, b)) s in sMem end (* (* Conversion for a fixed size byte array. *) fun BYTEARRAY n = let val base = Cstruct (List.tabulate (n, fn _ => Cchar)) fun from v = toWord8vec(address v, n) fun to w = if Word8Vector.length w <> n then raise Size else deref(fromWord8vec w) in mkConversion from to base end *) (* Conversion for a fixed size char array. *) fun cCHARARRAY n : string conversion = let (* Make it a struct of chars *) val { size=sizeC, align=alignC, ffiType=ffiTypeC } = LowLevel.cTypeChar val arraySize = sizeC * Word.fromInt n fun ffiType () = LibFFI.createFFItype { size = arraySize, align = alignC, typeCode=LibFFI.ffiTypeCodeStruct, elements = List.tabulate (n, fn _ => ffiTypeC()) } val arrayType: LowLevel.ctype = { size = arraySize, align = alignC, ffiType = ffiType } open Memory fun load(v: voidStar): string = let (* It should be null-terminated but just in case... *) fun sLen i = if i = Word.fromInt n orelse get8(v, i) = 0w0 then i else sLen(i+0w1) val length = sLen 0w0 fun loadChar i = Char.chr(Word8.toInt(get8(v, Word.fromInt i))) in CharVector.tabulate(Word.toInt length, loadChar) end fun store(v: voidStar, s: string) = let (* The length must be less than the size to allow for the null *) val sLen = size s val _ = sLen < n orelse raise Fail "string too long" in CharVector.appi(fn(i, ch) => set8(v, Word.fromInt i, Word8.fromInt(Char.ord ch))) s; set8(v, Word.fromInt sLen, 0w0); fn () => () end in makeConversion { load = load, store = store, ctype = arrayType } end (* These should always be UNSIGNED values. *) local open Word32 infix << >> orb andb val w32ToW = Word.fromLargeWord o Word32.toLargeWord and wTow32 = Word32.fromLargeWord o Word.toLargeWord in fun LOWORD(l) = w32ToW(l andb 0wxFFFF) fun HIWORD(l) = w32ToW((l >> 0w16) andb 0wxFFFF) fun MAKELONG(a, b) = (wTow32 b << 0w16) orb (wTow32 a andb 0wxFFFF) end local open Word infix << >> orb andb val wToW8 = Word8.fromLargeWord o Word.toLargeWord in fun HIBYTE(w) = wToW8((w >> 0w8) andb 0wxFF) fun LOBYTE(w) = wToW8(w andb 0wxFF) end (* Convert between strings and vectors containing Unicode characters. N.B. These are not null terminated. *) local val CP_ACP = 0 (* Default *) val WideCharToMultiByte = winCall8 (kernel "WideCharToMultiByte") (cUint, cDWORD, cByteArray, cInt, cPointer, cInt, cPointer, cPointer) cInt val MultiByteToWideChar = winCall6 (kernel "MultiByteToWideChar") (cUint, cDWORD, cString, cInt, cPointer, cInt) cInt in fun unicodeToString(w: Word8Vector.vector): string = let open Memory val inputLength = Word8Vector.length w div 2 (* Number of unicode chars *) val outputLength = WideCharToMultiByte(CP_ACP, 0, w, inputLength, null, 0, null, null) val outputBuf = malloc(Word.fromInt outputLength) val conv = WideCharToMultiByte(CP_ACP, 0, w, inputLength, outputBuf, outputLength, null, null) fun loadChar i = Char.chr(Word8.toInt(get8(outputBuf, Word.fromInt i))) in (* We can't use fromCstring here because it's not necessarily null terminated. *) CharVector.tabulate(conv, loadChar) before free outputBuf end fun stringToUnicode(s: string): Word8Vector.vector = let open Memory val inputLength = size s (* This does not include a terminating NULL *) (* The lengths returned by MultiByteToWideChar are the number of Unicode chars *) val outputLength = MultiByteToWideChar(CP_ACP, 0, s, inputLength, null, 0) val outputBuf = malloc(Word.fromInt outputLength * 0w2) val conv = MultiByteToWideChar(CP_ACP, 0, s, inputLength, outputBuf, outputLength) fun loadByte i = get8(outputBuf, Word.fromInt i) in Word8Vector.tabulate(conv*2, loadByte) before free outputBuf end end end;