diff --git a/rtl/win32/base.pp b/rtl/win32/base.pp index 9324b64c32..441b945a40 100644 --- a/rtl/win32/base.pp +++ b/rtl/win32/base.pp @@ -105,14 +105,16 @@ unit base; CALTYPE = cardinal; CALID = cardinal; CCHAR = char; + WCHAR = word; COLORREF = cardinal; DWORD = cardinal; + THandle = cardinal; DWORDLONG = double; PDWORDLONG = ^DWORDLONG; FLOAT = single; - HANDLE = pointer; + HANDLE = THandle; HACCEL = HANDLE; HBITMAP = HANDLE; HBRUSH = HANDLE; @@ -514,12 +516,7 @@ end. { $Log$ - Revision 1.3 1998-05-06 12:36:50 michael - + Removed log from before restored version. + Revision 1.4 1998-06-10 10:39:11 peter + * working w32 rtl - Revision 1.2 1998/03/27 00:50:22 peter - * small fixes so it compiles - - Revision 1.1.1.1 1998/03/25 11:18:46 root - * Restored version } diff --git a/rtl/win32/defines.pp b/rtl/win32/defines.pp index bc12f4cc4e..01cf6cb0c5 100644 --- a/rtl/win32/defines.pp +++ b/rtl/win32/defines.pp @@ -37,43 +37,43 @@ Unimplemented: /* EnumResLangProc */ - #define RT_ACCELERATOR (MAKEINTRESOURCE(9)) - #define RT_BITMAP (MAKEINTRESOURCE(2)) - #define RT_DIALOG (MAKEINTRESOURCE(5)) - #define RT_FONT (MAKEINTRESOURCE(8)) - #define RT_FONTDIR (MAKEINTRESOURCE(7)) - #define RT_MENU (MAKEINTRESOURCE(4)) - #define RT_RCDATA (MAKEINTRESOURCE(10)) - #define RT_STRING (MAKEINTRESOURCE(6)) - #define RT_MESSAGETABLE (MAKEINTRESOURCE(11)) - #define RT_CURSOR (MAKEINTRESOURCE(1)) - #define RT_GROUP_CURSOR (MAKEINTRESOURCE(12)) - #define RT_ICON (MAKEINTRESOURCE(3)) - #define RT_GROUP_ICON (MAKEINTRESOURCE(13)) - #define RT_VERSION (MAKEINTRESOURCE(16)) + #define RT_ACCELERATOR (MAKEINTRESOURCE(9)) + #define RT_BITMAP (MAKEINTRESOURCE(2)) + #define RT_DIALOG (MAKEINTRESOURCE(5)) + #define RT_FONT (MAKEINTRESOURCE(8)) + #define RT_FONTDIR (MAKEINTRESOURCE(7)) + #define RT_MENU (MAKEINTRESOURCE(4)) + #define RT_RCDATA (MAKEINTRESOURCE(10)) + #define RT_STRING (MAKEINTRESOURCE(6)) + #define RT_MESSAGETABLE (MAKEINTRESOURCE(11)) + #define RT_CURSOR (MAKEINTRESOURCE(1)) + #define RT_GROUP_CURSOR (MAKEINTRESOURCE(12)) + #define RT_ICON (MAKEINTRESOURCE(3)) + #define RT_GROUP_ICON (MAKEINTRESOURCE(13)) + #define RT_VERSION (MAKEINTRESOURCE(16)) /* GetIconInfo */ - #define IDC_ARROW (MAKEINTRESOURCE(32512)) - #define IDC_IBEAM (MAKEINTRESOURCE(32513)) - #define IDC_WAIT (MAKEINTRESOURCE(32514)) - #define IDC_CROSS (MAKEINTRESOURCE(32515)) - #define IDC_UPARROW (MAKEINTRESOURCE(32516)) - #define IDC_SIZENWSE (MAKEINTRESOURCE(32642)) - #define IDC_SIZENESW (MAKEINTRESOURCE(32643)) - #define IDC_SIZEWE (MAKEINTRESOURCE(32644)) - #define IDC_SIZENS (MAKEINTRESOURCE(32645)) - #define IDC_SIZEALL (MAKEINTRESOURCE(32646)) - #define IDC_NO (MAKEINTRESOURCE(32648)) - #define IDC_APPSTARTING (MAKEINTRESOURCE(32650)) - #define IDC_HELP (MAKEINTRESOURCE(32651)) - #define IDI_APPLICATION (MAKEINTRESOURCE(32512)) - #define IDI_HAND (MAKEINTRESOURCE(32513)) - #define IDI_QUESTION (MAKEINTRESOURCE(32514)) - #define IDI_EXCLAMATION (MAKEINTRESOURCE(32515)) - #define IDI_ASTERISK (MAKEINTRESOURCE(32516)) - #define IDI_WINLOGO (MAKEINTRESOURCE(32517)) + #define IDC_ARROW (MAKEINTRESOURCE(32512)) + #define IDC_IBEAM (MAKEINTRESOURCE(32513)) + #define IDC_WAIT (MAKEINTRESOURCE(32514)) + #define IDC_CROSS (MAKEINTRESOURCE(32515)) + #define IDC_UPARROW (MAKEINTRESOURCE(32516)) + #define IDC_SIZENWSE (MAKEINTRESOURCE(32642)) + #define IDC_SIZENESW (MAKEINTRESOURCE(32643)) + #define IDC_SIZEWE (MAKEINTRESOURCE(32644)) + #define IDC_SIZENS (MAKEINTRESOURCE(32645)) + #define IDC_SIZEALL (MAKEINTRESOURCE(32646)) + #define IDC_NO (MAKEINTRESOURCE(32648)) + #define IDC_APPSTARTING (MAKEINTRESOURCE(32650)) + #define IDC_HELP (MAKEINTRESOURCE(32651)) + #define IDI_APPLICATION (MAKEINTRESOURCE(32512)) + #define IDI_HAND (MAKEINTRESOURCE(32513)) + #define IDI_QUESTION (MAKEINTRESOURCE(32514)) + #define IDI_EXCLAMATION (MAKEINTRESOURCE(32515)) + #define IDI_ASTERISK (MAKEINTRESOURCE(32516)) + #define IDI_WINLOGO (MAKEINTRESOURCE(32517)) - #define VS_FILE_INFO (MAKEINTRESOURCE(16)) + #define VS_FILE_INFO (MAKEINTRESOURCE(16)) #ifdef UNICODE #define LPSTR_TEXTCALLBACK LPSTR_TEXTCALLBACKW #else @@ -81,10 +81,10 @@ #endif /* UNICODE */ /* TV_INSERTSTRUCT structure */ - #define TVI_ROOT ((HTREEITEM)0xFFFF0000) - #define TVI_FIRST ((HTREEITEM)0xFFFF0001) - #define TVI_LAST ((HTREEITEM)0xFFFF0002) - #define TVI_SORT ((HTREEITEM)0xFFFF0003) + #define TVI_ROOT ((HTREEITEM)0xFFFF0000) + #define TVI_FIRST ((HTREEITEM)0xFFFF0001) + #define TVI_LAST ((HTREEITEM)0xFFFF0002) + #define TVI_SORT ((HTREEITEM)0xFFFF0003) #ifdef UNICODE #define COLOROKSTRING COLOROKSTRINGW @@ -105,7 +105,7 @@ #endif /* MapWindowPoints */ - #define HWND_DESKTOP ((HWND)0) + #define HWND_DESKTOP ((HWND)0) #ifdef UNICODE #define ANIMATE_CLASS ANIMATE_CLASSW @@ -329,8 +329,8 @@ unit defines; BST_PUSHED = 4; MF_BYCOMMAND = 0; MF_BYPOSITION = $400; - MF_CHECKED = $8; - MF_UNCHECKED = 0; +// MF_CHECKED = $8; +// MF_UNCHECKED = 0; MF_HILITE = $80; { ChildWindowFromPointEx } MF_UNHILITE = 0; @@ -456,9 +456,6 @@ unit defines; SEC_IMAGE = 16777216; SEC_NOCACHE = 268435456; SEC_RESERVE = 67108864; - MEM_COMMIT = 4096; - MEM_RESERVE = 8192; - MEM_TOP_DOWN = 1048576; PAGE_EXECUTE = 16; PAGE_EXECUTE_READ = 32; PAGE_EXECUTE_READWRITE = 64; @@ -468,6 +465,7 @@ unit defines; MEM_COMMIT = 4096; MEM_FREE = 65536; MEM_RESERVE = 8192; + MEM_TOP_DOWN = 1048576; MEM_IMAGE = 16777216; MEM_MAPPED = 262144; MEM_PRIVATE = 131072; @@ -546,7 +544,7 @@ unit defines; LR_DEFAULTCOLOR = 0; LR_LOADREALSIZE = 128; { CreateMailslot, GetMailslotInfo } - LR_MONOCHROME = 1; +// LR_MONOCHROME = 1; MAILSLOT_WAIT_FOREVER = $ffffffff; { CreateMappedBitmap } MAILSLOT_NO_MESSAGE = $ffffffff; @@ -616,16 +614,16 @@ unit defines; DELETE = $10000; READ_CONTROL = $20000; GENERIC_EXECUTE = $20000000; - SERVICE_WIN32_OWN_PROCESS = 16; - SERVICE_WIN32_SHARE_PROCESS = 32; - SERVICE_KERNEL_DRIVER = 1; - SERVICE_FILE_SYSTEM_DRIVER = 2; - SERVICE_INTERACTIVE_PROCESS = 256; - SERVICE_BOOT_START = 0; - SERVICE_SYSTEM_START = 1; - SERVICE_AUTO_START = 2; - SERVICE_DEMAND_START = 3; - SERVICE_DISABLED = 4; +// SERVICE_WIN32_OWN_PROCESS = 16; +// SERVICE_WIN32_SHARE_PROCESS = 32; +// SERVICE_KERNEL_DRIVER = 1; +// SERVICE_FILE_SYSTEM_DRIVER = 2; +// SERVICE_INTERACTIVE_PROCESS = 256; +// SERVICE_BOOT_START = 0; +// SERVICE_SYSTEM_START = 1; +// SERVICE_AUTO_START = 2; +// SERVICE_DEMAND_START = 3; +// SERVICE_DISABLED = 4; SERVICE_ERROR_IGNORE = 0; SERVICE_ERROR_NORMAL = 1; SERVICE_ERROR_SEVERE = 2; @@ -835,7 +833,7 @@ unit defines; WH_MSGFILTER = -1; WH_SHELL = 10; WH_SYSMSGFILTER = 6; - WH_MSGFILTER = -1; + // WH_MSGFILTER = -1; { DefineDosDevice } WH_FOREGROUNDIDLE = 11; DDD_RAW_TARGET_PATH = 1; @@ -866,10 +864,10 @@ unit defines; DCTT_SUBDEV = $4; DC_VERSION = 10; DC_BINADJUST = 19; - DC_EMF_COMPLIANT = 20; +// DC_EMF_COMPLIANT = 20; { DeviceIoControl } { DlgDirList } - DC_DATATYPE_PRODUCED = 21; +// DC_DATATYPE_PRODUCED = 21; DDL_ARCHIVE = 32; DDL_DIRECTORY = 16; DDL_DRIVES = 16384; @@ -1317,8 +1315,8 @@ unit defines; CP_MACCP = 2; { GetDateFormat } CP_OEMCP = 1; - DATE_SHORTDATE = 1; - DATE_LONGDATE = 2; +// DATE_SHORTDATE = 1; +// DATE_LONGDATE = 2; { GetDCEx } DATE_USE_ALT_CALENDAR = 4; DCX_WINDOW = $1; @@ -1361,12 +1359,12 @@ unit defines; SIZEPALETTE = 104; NUMRESERVED = 106; COLORRES = 108; - PHYSICALWIDTH = 110; - PHYSICALHEIGHT = 111; - PHYSICALOFFSETX = 112; - PHYSICALOFFSETY = 113; - SCALINGFACTORX = 114; - SCALINGFACTORY = 115; +// PHYSICALWIDTH = 110; +// PHYSICALHEIGHT = 111; +// PHYSICALOFFSETX = 112; +// PHYSICALOFFSETY = 113; +// SCALINGFACTORX = 114; +// SCALINGFACTORY = 115; VREFRESH = 116; DESKTOPHORZRES = 118; DESKTOPVERTRES = 117; @@ -1496,13 +1494,13 @@ unit defines; PM_REMOVE = 1; { GetNamedPipeHandleState } PM_NOYIELD = 2; - PIPE_NOWAIT = 1; +// PIPE_NOWAIT = 1; { GetNamedPipeInfo } - PIPE_READMODE_MESSAGE = 2; +// PIPE_READMODE_MESSAGE = 2; PIPE_CLIENT_END = 0; PIPE_SERVER_END = 1; { GetNextWindow, GetWindow } - PIPE_TYPE_MESSAGE = 4; +// PIPE_TYPE_MESSAGE = 4; GW_HWNDNEXT = 2; GW_HWNDPREV = 3; GW_CHILD = 5; @@ -1683,9 +1681,9 @@ unit defines; SM_CXSMSIZE = 52; SM_CYSMSIZE = 53; SM_CXVSCROLL = 2; - SM_CYHSCROLL = 3; - SM_CXHSCROLL = 21; - SM_CYVSCROLL = 20; +// SM_CYHSCROLL = 3; +// SM_CXHSCROLL = 21; +// SM_CYVSCROLL = 20; SM_CYVTHUMB = 9; SM_CYCAPTION = 4; SM_CYKANJIWINDOW = 18; @@ -1822,12 +1820,12 @@ unit defines; CLR_NONE = $ffffffff; { ImageList_LoadImage } CLR_DEFAULT = $ff000000; - LR_DEFAULTCOLOR = 0; +// LR_DEFAULTCOLOR = 0; LR_LOADFROMFILE = 16; LR_LOADMAP3DCOLORS = 4096; LR_LOADTRANSPARENT = 32; { ImmConfigureIME } - LR_MONOCHROME = 1; +// LR_MONOCHROME = 1; IME_CONFIG_GENERAL = 1; IME_CONFIG_REGISTERWORD = 2; { ImmGetConversionList } @@ -2944,11 +2942,11 @@ unit defines; DM_COLLATE = $8000; DM_FORMNAME = $10000; DM_LOGPIXELS = $20000; - DM_BITSPERPEL = $40000; - DM_PELSWIDTH = $80000; - DM_PELSHEIGHT = $100000; - DM_DISPLAYFLAGS = $200000; - DM_DISPLAYFREQUENCY = $400000; +// DM_BITSPERPEL = $40000; +// DM_PELSWIDTH = $80000; +// DM_PELSHEIGHT = $100000; +// DM_DISPLAYFLAGS = $200000; +// DM_DISPLAYFREQUENCY = $400000; DM_ICMMETHOD = $800000; DM_ICMINTENT = $1000000; DM_MEDIATYPE = $2000000; @@ -3125,15 +3123,15 @@ unit defines; { EM_FINDWORDBREAK message } SFF_PLAINRTF = 16384; WB_CLASSIFY = 3; - WB_ISDELIMITER = 2; - WB_LEFT = 0; +// WB_ISDELIMITER = 2; +// WB_LEFT = 0; WB_LEFTBREAK = 6; WB_PREVBREAK = 6; WB_MOVEWORDLEFT = 4; WB_MOVEWORDPREV = 4; WB_MOVEWORDRIGHT = 5; WB_MOVEWORDNEXT = 5; - WB_RIGHT = 1; +// WB_RIGHT = 1; WB_RIGHTBREAK = 7; { EM_GETPUNCTUATION message } WB_NEXTBREAK = 7; @@ -3301,7 +3299,7 @@ unit defines; TTDT_RESHOW = 1; SBARS_SIZEGRIP = 256; { DL_DRAGGING message } - SBARS_SIZEGRIP = 256; +// SBARS_SIZEGRIP = 256; DL_MOVECURSOR = 3; DL_COPYCURSOR = 2; { Up-down control styles } @@ -3726,7 +3724,7 @@ unit defines; SE_GROUP_OWNER = $8; { SECURITY_DESCRIPTOR_CONTROL } SE_GROUP_LOGON_ID = $c0000000; - SECURITY_DESCRIPTOR_REVISION = 1; +// SECURITY_DESCRIPTOR_REVISION = 1; SECURITY_DESCRIPTOR_MIN_LENGTH = 20; SE_OWNER_DEFAULTED = 1; SE_GROUP_DEFAULTED = 2; @@ -4348,50 +4346,50 @@ unit defines; PFD_SWAP_EXCHANGE = $200; { Common control window classes } - ANIMATE_CLASSW = 'SysAnimate32'; - HOTKEY_CLASSW = 'msctls_hotkey32'; - PROGRESS_CLASSW = 'msctls_progress32'; - STATUSCLASSNAMEW = 'msctls_statusbar32'; + ANIMATE_CLASSW = 'SysAnimate32'; + HOTKEY_CLASSW = 'msctls_hotkey32'; + PROGRESS_CLASSW = 'msctls_progress32'; + STATUSCLASSNAMEW = 'msctls_statusbar32'; TOOLBARCLASSNAMEW = 'ToolbarWindow32'; - TOOLTIPS_CLASSW = 'tooltips_class32'; - TRACKBAR_CLASSW = 'msctls_trackbar32'; - UPDOWN_CLASSW = 'msctls_updown32'; - WC_HEADERW = 'SysHeader32'; - WC_LISTVIEWW = 'SysListView32'; - WC_TABCONTROLW = 'SysTabControl32'; - WC_TREEVIEWW = 'SysTreeView32'; + TOOLTIPS_CLASSW = 'tooltips_class32'; + TRACKBAR_CLASSW = 'msctls_trackbar32'; + UPDOWN_CLASSW = 'msctls_updown32'; + WC_HEADERW = 'SysHeader32'; + WC_LISTVIEWW = 'SysListView32'; + WC_TABCONTROLW = 'SysTabControl32'; + WC_TREEVIEWW = 'SysTreeView32'; - ANIMATE_CLASSA = 'SysAnimate32'; - HOTKEY_CLASSA = 'msctls_hotkey32'; - PROGRESS_CLASSA = 'msctls_progress32'; - STATUSCLASSNAMEA = 'msctls_statusbar32'; + ANIMATE_CLASSA = 'SysAnimate32'; + HOTKEY_CLASSA = 'msctls_hotkey32'; + PROGRESS_CLASSA = 'msctls_progress32'; + STATUSCLASSNAMEA = 'msctls_statusbar32'; TOOLBARCLASSNAMEA = 'ToolbarWindow32'; - TOOLTIPS_CLASSA = 'tooltips_class32'; - TRACKBAR_CLASSA = 'msctls_trackbar32'; - UPDOWN_CLASSA = 'msctls_updown32'; - WC_HEADERA = 'SysHeader32'; - WC_LISTVIEWA = 'SysListView32'; - WC_TABCONTROLA = 'SysTabControl32'; - WC_TREEVIEWA = 'SysTreeView32'; + TOOLTIPS_CLASSA = 'tooltips_class32'; + TRACKBAR_CLASSA = 'msctls_trackbar32'; + UPDOWN_CLASSA = 'msctls_updown32'; + WC_HEADERA = 'SysHeader32'; + WC_LISTVIEWA = 'SysListView32'; + WC_TABCONTROLA = 'SysTabControl32'; + WC_TREEVIEWA = 'SysTreeView32'; { Common dialog messages } - COLOROKSTRINGW = 'commdlg_ColorOK'; - FILEOKSTRINGW = 'commdlg_FileNameOK'; - FINDMSGSTRINGW = 'commdlg_FindReplace'; - HELPMSGSTRINGW = 'commdlg_help'; - LBSELCHSTRINGW = 'commdlg_LBSelChangedNotify'; - SETRGBSTRINGW = 'commdlg_SetRGBColor'; - SHAREVISTRINGW = 'commdlg_ShareViolation'; - COLOROKSTRINGA = 'commdlg_ColorOK'; - FILEOKSTRINGA = 'commdlg_FileNameOK'; - FINDMSGSTRINGA = 'commdlg_FindReplace'; - HELPMSGSTRINGA = 'commdlg_help'; - LBSELCHSTRINGA = 'commdlg_LBSelChangedNotify'; - SETRGBSTRINGA = 'commdlg_SetRGBColor'; - SHAREVISTRINGA = 'commdlg_ShareViolation'; + COLOROKSTRINGW = 'commdlg_ColorOK'; + FILEOKSTRINGW = 'commdlg_FileNameOK'; + FINDMSGSTRINGW = 'commdlg_FindReplace'; + HELPMSGSTRINGW = 'commdlg_help'; + LBSELCHSTRINGW = 'commdlg_LBSelChangedNotify'; + SETRGBSTRINGW = 'commdlg_SetRGBColor'; + SHAREVISTRINGW = 'commdlg_ShareViolation'; + COLOROKSTRINGA = 'commdlg_ColorOK'; + FILEOKSTRINGA = 'commdlg_FileNameOK'; + FINDMSGSTRINGA = 'commdlg_FindReplace'; + HELPMSGSTRINGA = 'commdlg_help'; + LBSELCHSTRINGA = 'commdlg_LBSelChangedNotify'; + SETRGBSTRINGA = 'commdlg_SetRGBColor'; + SHAREVISTRINGA = 'commdlg_ShareViolation'; UNICODE_NULL : WCHAR = 0; - INVALID_HANDLE_VALUE : HANDLE = -1; + INVALID_HANDLE_VALUE : THANDLE = -1; { PostMessage } HWND_BROADCAST : HWND = $FFFF; { RegCreateKey } @@ -4404,13 +4402,13 @@ unit defines; HWND_BOTTOM : HWND = 1; HWND_NOTOPMOST : HWND = -2; - HWND_TOP : HWND = 0; + HWND_TOP : HWND = 0; HWND_TOPMOST : HWND = -1; HINST_COMMCTRL : HINSTANCE = -1; - LPSTR_TEXTCALLBACKW : LPWSTR = -1; - LPSTR_TEXTCALLBACKA : LPSTR = -1; + LPSTR_TEXTCALLBACKW : LPWSTR = nil; + LPSTR_TEXTCALLBACKA : LPSTR = nil; implementation @@ -4418,9 +4416,7 @@ end. { $Log$ - Revision 1.2 1998-05-06 12:36:50 michael - + Removed log from before restored version. + Revision 1.3 1998-06-10 10:39:12 peter + * working w32 rtl - Revision 1.1.1.1 1998/03/25 11:18:46 root - * Restored version } diff --git a/rtl/win32/dos.pp b/rtl/win32/dos.pp index b9b4bafc14..d8ecbeac82 100644 --- a/rtl/win32/dos.pp +++ b/rtl/win32/dos.pp @@ -19,7 +19,12 @@ unit dos; interface +{ Include Win32 Consts,Types } +{$I win32.inc} + Const + Max_Path = 255; + {Bitmasks for CPU Flags} fcarry = $0001; fparity = $0004; @@ -70,13 +75,30 @@ Type Sec : word; End; - searchrec = packed record - time : longint; - size : longint; - attr : longint; - name : string; + PWin32FindData = ^TWin32FindData; + TWin32FindData = packed record + dwFileAttributes: Cardinal; + ftCreationTime: TFileTime; + ftLastAccessTime: TFileTime; + ftLastWriteTime: TFileTime; + nFileSizeHigh: Cardinal; + nFileSizeLow: Cardinal; + dwReserved0: Cardinal; + dwReserved1: Cardinal; + cFileName: array[0..MAX_PATH - 1] of Char; + cAlternateFileName: array[0..13] of Char; end; + Searchrec = Packed Record + FindHandle : THandle; + W32FindData : TWin32FindData; + time : longint; + size : longint; + attr : longint; + name : string; + end; + + registers = packed record case i : integer of 0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word); @@ -140,7 +162,61 @@ Procedure Keep(exitcode: word); implementation uses strings; -{$I win32.inc} +{****************************************************************************** + --- Conversion --- +******************************************************************************} + + function GetLastError : DWORD; + external 'kernel32' name 'GetLastError'; + function FileTimeToDosDateTime(const ft :TFileTime;var data,time : word) : boolean; + external 'kernel32' name 'FileTimeToDosDateTime'; + function DosDateTimeToFileTime(date,time : word;var ft :TFileTime) : boolean; + external 'kernel32' name 'DosDateTimeToFileTime'; + function FileTimeToLocalFileTime(const ft : TFileTime;var lft : TFileTime) : boolean; + external 'kernel32' name 'FileTimeToLocalFileTime'; + function LocalFileTimeToFileTime(const lft : TFileTime;var ft : TFileTime) : boolean; + external 'kernel32' name 'LocalFileTimeToFileTime'; + +type + Longrec=packed record + lo,hi : word; + end; + +function Last2DosError(d:dword):integer; +begin + Last2DosError:=d; +end; + + +Function DosToWinAttr (Const Attr : Longint) : longint; +begin + DosToWinAttr:=Attr; +end; + + +Function WinToDosAttr (Const Attr : Longint) : longint; +begin + WinToDosAttr:=Attr; +end; + + +Function DosToWinTime (DTime:longint;Var Wtime : TFileTime):boolean; +var + lft : TFileTime; +begin + DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,lft) and + LocalFileTimeToFileTime(lft,Wtime); +end; + + +Function WinToDosTime (Const Wtime : TFileTime;var DTime:longint):boolean; +var + lft : TFileTime; +begin + WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and + FileTimeToDosDateTime(lft,longrec(dtime).hi,longrec(dtime).lo); +end; + {****************************************************************************** --- Dos Interrupt --- @@ -153,7 +229,7 @@ end; procedure msdos(var regs : registers); begin - intr($21,regs); + { !!!!!!!! } end; @@ -161,6 +237,13 @@ end; --- Info / Date / Time --- ******************************************************************************} + function GetVersion : longint; + external 'kernel32' name 'GetVersion'; + procedure GetLocalTime(var t : TSystemTime); + external 'kernel32' name 'GetLocalTime'; + function SetLocalTime(const t : TSystemTime) : boolean; + external 'kernel32' name 'SetLocalTime'; + function dosversion : word; begin dosversion:=GetVersion; @@ -169,7 +252,7 @@ end; procedure getdate(var year,month,mday,wday : word); var - t : SYSTEMTIME; + t : TSystemTime; begin GetLocalTime(t); year:=t.wYear; @@ -181,7 +264,7 @@ end; procedure setdate(year,month,day : word); var - t : SYSTEMTIME; + t : TSystemTime; begin { we need the time set privilege } { so this function crash currently } @@ -197,7 +280,7 @@ end; procedure gettime(var hour,minute,second,sec100 : word); var - t : SYSTEMTIME; + t : TSystemTime; begin GetLocalTime(t); hour:=t.wHour; @@ -209,7 +292,7 @@ end; procedure settime(hour,minute,second,sec100 : word); var - t : SYSTEMTIME; + t : TSystemTime; begin { we need the time set privilege } { so this function crash currently } @@ -247,12 +330,53 @@ End; --- Exec --- ******************************************************************************} + function CreateProcess(lpApplicationName: PChar; lpCommandLine: PChar; + lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; + bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; + lpCurrentDirectory: PChar; const lpStartupInfo: TStartupInfo; + var lpProcessInformation: TProcessInformation): boolean; + external 'kernel32' name 'CreateProcessA'; + function getExitCodeProcess(h:THandle;var code:longint):boolean; + external 'kernel32' name 'GetExitCodeProcess'; + function WaitForSingleObject(hHandle: THandle; dwMilliseconds: DWORD): DWORD; + external 'kernel32' name 'WaitForSingleObject'; + function CloseHandle(h : THandle) : longint; + external 'kernel32' name 'CloseHandle'; + var lastdosexitcode : word; procedure exec(const path : pathstr;const comline : comstr); +var + SI: TStartupInfo; + PI: TProcessInformation; + Proc : THandle; + l : Longint; + AppPath, + AppParam : array[0..255] of char; begin - { !!!!!!!! } + FillChar(SI, SizeOf(SI), 0); + SI.cb:=SizeOf(SI); + SI.wShowWindow:=1; + Move(Path[1],AppPath,length(Path)); + AppPath[Length(Path)]:=#0; + AppParam[0]:='-'; + AppParam[1]:=' '; + Move(ComLine[1],AppParam[2],length(Comline)); + AppParam[Length(ComLine)+2]:=#0; + if not CreateProcess(PChar(@AppPath), PChar(@AppParam), Nil, Nil, False,$20, Nil, Nil, SI, PI) then + begin + DosError:=Last2DosError(GetLastError); + exit; + end; + Proc:=PI.hProcess; + CloseHandle(PI.hThread); + if WaitForSingleObject(Proc, Infinite) <> $ffffffff then + GetExitCodeProcess(Proc,l) + else + l:=-1; + CloseHandle(Proc); + LastDosExitCode:=l; end; @@ -290,17 +414,57 @@ end; --- Disk --- ******************************************************************************} + function GetDiskFreeSpace(drive:pchar;var sector_cluster,bytes_sector, + freeclusters,totalclusters:longint):boolean; + external 'kernel32' name 'GetDiskFreeSpaceA'; + function diskfree(drive : byte) : longint; +var + disk : array[1..4] of char; + secs,bytes, + free,total : longint; begin -{ !!!!!!!!! } - diskfree:=-1; + if drive=0 then + begin + disk[1]:='\'; + disk[2]:=#0; + end + else + begin + disk[1]:=chr(drive+64); + disk[2]:=':'; + disk[3]:='\'; + disk[4]:=#0; + end; + if GetDiskFreeSpace(@disk,secs,bytes,free,total) then + diskfree:=free*secs*bytes + else + diskfree:=-1; end; function disksize(drive : byte) : longint; +var + disk : array[1..4] of char; + secs,bytes, + free,total : longint; begin -{ !!!!!!!!! } - disksize:=-1; + if drive=0 then + begin + disk[1]:='\'; + disk[2]:=#0; + end + else + begin + disk[1]:=chr(drive+64); + disk[2]:=':'; + disk[3]:='\'; + disk[4]:=#0; + end; + if GetDiskFreeSpace(@disk,secs,bytes,free,total) then + disksize:=total*secs*bytes + else + disksize:=-1; end; @@ -308,77 +472,104 @@ end; --- Findfirst FindNext --- ******************************************************************************} - procedure searchrec2dossearchrec(var f : searchrec); - var - l,i : longint; - begin - l:=length(f.name); - for i:=1 to 12 do - f.name[i-1]:=f.name[i]; - f.name[l]:=#0; - end; - - procedure dossearchrec2searchrec(var f : searchrec); - var - l,i : longint; - begin - l:=12; - for i:=0 to 12 do - if f.name[i]=#0 then - begin - l:=i; - break; - end; - for i:=11 downto 0 do - f.name[i+1]:=f.name[i]; - f.name[0]:=chr(l); - end; - - procedure findfirst(const path : pathstr;attr : word;var f : searchRec); - - procedure _findfirst(path : pchar;attr : word;var f : searchrec); - begin - {!!!!!!!!!!!!!!} - end; - - var - path0 : array[0..80] of char; - begin - { no error } - doserror:=0; - strpcopy(path0,path); - _findfirst(path0,attr,f); - dossearchrec2searchrec(f); - end; - - procedure findnext(var f : searchRec); - - procedure _findnext(var f : searchrec); - begin - {!!!!!!!!!!!!!!} - end; - - begin - { no error } - doserror:=0; - searchrec2dossearchrec(f); - _findnext(f); - dossearchrec2searchrec(f); - end; - - procedure swapvectors; +{ Needed kernel calls } + + function FindFirstFile (lpFileName: PChar; var lpFindFileData: TWIN32FindData): THandle; + external 'kernel32' name 'FindFirstFileA'; + function FindNextFile (hFindFile: THandle; var lpFindFileData: TWIN32FindData): Boolean; + external 'kernel32' name 'FindNextFileA'; + function FindCloseFile (hFindFile: THandle): Boolean; + external 'kernel32' name 'FindClose'; + +Procedure StringToPchar (Var S : String); +Var L : Longint; +begin + L:=ord(S[0]); + Move (S[1],S[0],L); + S[L]:=#0; +end; + + +procedure FindMatch(var f:searchrec); +Var + TheAttr : Longint; +begin + TheAttr:=DosToWinAttr(F.Attr); +{ Find file with correct attribute } + While (F.W32FindData.dwFileAttributes and TheAttr)=0 do + begin + if not FindNextFile (F.FindHandle,F.W32FindData) then begin + DosError:=Last2DosError(GetLastError); + exit; end; + end; +{ Convert some attributes back } + f.size:=F.W32FindData.NFileSizeLow; + f.attr:=WinToDosAttr(F.W32FindData.dwFileAttributes); + WinToDosTime(F.W32FindData.ftLastWriteTime,f.Time); + f.Name:=StrPas(@F.W32FindData.cFileName); +end; - Procedure FindClose(Var f: SearchRec); - begin - end; +procedure findfirst(const path : pathstr;attr : word;var f : searchRec); +begin +{ no error } + doserror:=0; + F.Name:=Path; + F.Attr:=attr; + StringToPchar(f.name); +{ FindFirstFile is a Win32 Call. } + F.FindHandle:=FindFirstFile (pchar(@f.Name),F.W32FindData); + If longint(F.FindHandle)=Invalid_Handle_value then + begin + DosError:=Last2DosError(GetLastError); + exit; + end; +{ Find file with correct attribute } + FindMatch(f); +end; + + +procedure findnext(var f : searchRec); +begin +{ no error } + doserror:=0; + if not FindNextFile (F.FindHandle,F.W32FindData) then + begin + DosError:=Last2DosError(GetLastError); + exit; + end; +{ Find file with correct attribute } + FindMatch(f); +end; + + +procedure swapvectors; +begin +end; + + +Procedure FindClose(Var f: SearchRec); +begin + If longint(F.FindHandle)<>Invalid_Handle_value then + FindCloseFile(F.FindHandle); +end; + {****************************************************************************** --- File --- ******************************************************************************} + function GetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : boolean; + external 'kernel32' name 'GetFileTime'; + function SetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : boolean; + external 'kernel32' name 'SetFileTime'; + function SetFileAttributes(lpFileName : pchar;dwFileAttributes : longint) : boolean; + external 'kernel32' name 'SetFileAttributesA'; + function GetFileAttributes(lpFileName : pchar) : longint; + external 'kernel32' name 'GetFileAttributesA'; + procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr); var p1,i : longint; @@ -431,13 +622,13 @@ begin pa[i]:='\'; if (length(pa)>1) and (pa[1] in ['A'..'Z']) and (pa[2]=':') then begin - { we must get the right directory } - getdir(ord(pa[1])-ord('A')+1,s); - if (ord(pa[0])>2) and (pa[3]<>'\') then - if pa[1]=s[1] then - pa:=s+'\'+copy (pa,3,length(pa)) - else - pa:=pa[1]+':\'+copy (pa,3,length(pa)) + { we must get the right directory } + getdir(ord(pa[1])-ord('A')+1,s); + if (ord(pa[0])>2) and (pa[3]<>'\') then + if pa[1]=s[1] then + pa:=s+'\'+copy (pa,3,length(pa)) + else + pa:=pa[1]+':\'+copy (pa,3,length(pa)) end else if pa[1]='\' then @@ -509,25 +700,23 @@ end; procedure getftime(var f;var time : longint); -type - lr = record - lo,hi : word; - end; var - ft,lft : FILETIME; + ft : TFileTime; begin - if GetFileTime(filerec(f).handle,nil,nil,@ft) and - FileTimeToLocalFileTime(ft,lft) and - FileTimeToDosDateTime(lft,lr(time).hi,lr(time).lo) then - exit - else - time:=0; + if GetFileTime(filerec(f).Handle,nil,nil,@ft) and + WinToDosTime(ft,time) then + exit + else + time:=0; end; procedure setftime(var f;time : longint); +var + ft : TFileTime; begin - { !!!!!!!!!!!!! } + if DosToWinTime(time,ft) then + SetFileTime(filerec(f).Handle,nil,nil,@ft); end; @@ -559,6 +748,11 @@ end; terminated by a #0 } + function GetEnvironmentStrings : pchar; + external 'kernel32' name 'GetEnvironmentStringsA'; + function FreeEnvironmentStrings(p : pchar) : boolean; + external 'kernel32' name 'FreeEnvironmentStringsA'; + function envcount : longint; var hp,p : pchar; @@ -649,7 +843,10 @@ End; end. { $Log$ - Revision 1.6 1998-06-08 23:07:45 peter + Revision 1.7 1998-06-10 10:39:13 peter + * working w32 rtl + + Revision 1.6 1998/06/08 23:07:45 peter * dos interface is now 100% compatible * fixed call PASCALMAIN which must be direct asm diff --git a/rtl/win32/makefile b/rtl/win32/makefile index 1ee9ce7013..c886d624c9 100644 --- a/rtl/win32/makefile +++ b/rtl/win32/makefile @@ -3,7 +3,7 @@ # This file is part of the Free Pascal run time library. # Copyright (c) 1996-98 by Michael van Canneyt # -# Makefile for the Free Pascal Go32v1 Runtime Library +# Makefile for the Free Pascal Win32 Runtime Library # # See the file COPYING.FPC, included in this distribution, # for details about the copyright. @@ -21,24 +21,14 @@ # with the main makefile. ##################################################################### -# set the directory where to install the units. -ifndef UNITINSTALLDIR -UNITINSTALLDIR=c:\lib\ppc\win32 -endif - -# set the directory where to install libraries -ifndef LIBINSTALLDIR -LIBINSTALLDIR=c:\lib -endif - -# What is the Operating System -ifndef OS_SRC -OS_SRC=GO32V2 +# What is the Operating System ? +ifndef OS_SOURCE +OS_SOURCE=win32 endif # What is the target operating system ? ifndef OS_TARGET -OS_TARGET=WIN32 +OS_TARGET=win32 endif # What is the target processor : @@ -48,7 +38,6 @@ CPU=i386 endif # What compiler to use ? -# I think ppc386 is better (it's mostly in path) (FK) ifndef PP PP=ppc386 endif @@ -59,11 +48,24 @@ ifndef OPT OPT= endif -# Where is the ppumove program ? +# Where is the PPUMOVE program ? ifndef PPUMOVE PPUMOVE=ppumove endif +# Set this to 'shared' or 'static' +LIBTYPE=shared + +# AOUT should be defined in main makefile. +# But you can set it here too. +# AOUT = -DAOUT + +# Do you want to link to the C library ? +# Standard it is NO. You can set it to YES to link in th C library. +ifndef LINK_TO_C +LINK_TO_C=NO +endif + ##################################################################### # End of configurable section. # Do not edit after this line. @@ -88,13 +90,13 @@ OBJPASDIR=../objpas include $(CFG)/makefile.cfg # Get the system independent include file names. -# This will set the following variables : +# This will set the following variables : # SYSINCNAMES include $(INC)/makefile.inc SYSINCDEPS=$(addprefix $(INC)/,$(SYSINCNAMES)) # Get the processor dependent include file names. -# This will set the following variables : +# This will set the following variables : # CPUINCNAMES include $(PROCINC)/makefile.cpu SYSCPUDEPS=$(addprefix $(PROCINC)/,$(CPUINCNAMES)) @@ -106,27 +108,15 @@ SYSDEPS=$(SYSINCDEPS) $(SYSCPUDEPS) # System dependent ##################################################################### -# Determine needed extensions PPUEXT=.ppw -PPLEXT=.ppl -OEXT=.obj -ASMEXT=.s -LIBEXT=.a -# Define Windows Units +# Define Linux Units SYSTEMPPU=syswin32$(PPUEXT) OBJECTS=strings objpas \ - base \ dos \ -# crt objects printer \ - cpu mmx getopts \ - -# No loaders needed -LOADERS= - + base messages defines # Add Prefix and Suffixes -OBJLOADERS=$(addsuffix $(OEXT), $(LOADERS)) PPUOBJECTS=$(addsuffix $(PPUEXT), $(OBJECTS)) .PHONY : all install clean \ @@ -140,26 +130,22 @@ install : all $(INSTALL) *$(PPUEXT) *$(OEXT) $(UNITINSTALLDIR) clean : - -$(DEL) *$(OEXT) *$(ASMEXT) *$(PPUEXT) *.PPS log + -$(DEL) *$(OEXT) *$(ASMEXT) *$(PPUEXT) log ##################################################################### # Files ##################################################################### -# -# Loaders -# - # # Base Units (System, strings, os-dependent-base-unit) # -$(SYSTEMPPU) : syswin32.pp $(SYSDEPS) win32.inc +$(SYSTEMPPU) : syswin32.pp win32.inc $(SYSDEPS) $(PP) $(OPT) -Us -Sg syswin32.pp $(REDIR) strings$(PPUEXT) : $(PROCINC)/strings.pp $(SYSTEMPPU) $(COPY) $(PROCINC)/strings.pp . - $(PP) $(OPT) strings.pp $(REDIR) + $(PP) $(OPT) strings $(REDIR) $(DEL) strings.pp # @@ -178,77 +164,50 @@ objpas$(PPUEXT) : $(OBJPASDIR)/objpas.pp $(SYSTEMPPU) base$(PPUEXT) : base.pp $(SYSTEMPPU) $(PP) $(OPT) base.pp $(REDIR) +messages$(PPUEXT) : messages.pp $(SYSTEMPPU) + $(PP) $(OPT) messages.pp $(REDIR) + +defines$(PPUEXT) : defines.pp $(SYSTEMPPU) + $(PP) $(OPT) defines.pp $(REDIR) + # # TP7 Compatible RTL Units # -dos$(PPUEXT) : dos.pp $(INC)/filerec.inc $(INC)/textrec.inc \ - strings$(PPUEXT) $(SYSTEMPPU) win32.inc +dos$(PPUEXT) : $(DOSDEPS) $(INC)/filerec.inc $(INC)/textrec.inc $(SYSTEMPPU) $(PP) $(OPT) dos $(REDIR) -#crt$(PPUEXT) : crt.pp $(INC)/textrec.inc go32$(PPUEXT) $(SYSTEMPPU) -# $(PP) $(OPT) crt $(REDIR) - -#objects$(PPUEXT) : objects.pp $(SYSTEMPPU) -# $(PP) $(OPT) objects.pp $(REDIR) - -#printer$(PPUEXT) : printer.pp $(SYSTEMPPU) -# $(PP) $(OPT) printer.pp $(REDIR) +#objects$(PPUEXT) : $(INC)/objects.pp objinc.inc $(SYSTEMPPU) +# $(COPY) $(INC)/objects.pp . +# $(PP) $(OPT) objects $(REDIR) +# $(DEL) objects.pp # # Other RTL Units # -cpu$(PPUEXT) : $(PROCINC)/cpu.pp $(SYSTEMPPU) - $(COPY) $(PROCINC)/cpu.pp . - $(PP) $(OPT) cpu.pp $(REDIR) - $(DEL) cpu.pp - -mmx$(PPUEXT) : $(PROCINC)/mmx.pp cpu$(PPUEXT) $(SYSTEMPPU) - $(COPY) $(PROCINC)/mmx.pp . - $(PP) $(OPT) mmx.pp $(REDIR) - $(DEL) mmx.pp - -getopts$(PPUEXT) : $(PROCINC)/getopts.pp $(SYSTEMPPU) - $(COPY) $(PROCINC)/getopts.pp . - $(PP) $(OPT) getopts.pp $(REDIR) - $(DEL) getopts.pp - - ##################################################################### # Libs ##################################################################### -libs: all +libs : all libfpc$(LIBEXT) + +libfpc.so: + $(PPUMOVE) -o fpc *.ppu + +libfpc.a: + $(PPUMOVE) -s -o fpc *.ppu + +libinstall : libs + $(INSTALLEXE) libfpc$(LIBEXT) $(LIBINSTALLDIR) + $(INSTALL) *$(PPLEXT) $(UNITINSTALLDIR) + ldconfig libsclean : clean - -$(DEL) *.$(LIBEXT) *$(PPLEXT) + -$(DEL) *.a *.so *$(PPLEXT) ##################################################################### -# Diffs +# Default targets ##################################################################### -%.dif : %.pp - -$(DIFF) $(DIFFOPTS) $*.pp $(REFPATH)/dos/go32v1/$*.pp > $*.dif - -%.dif : %.inc - -$(DIFF) $(DIFFOPTS) $*.inc $(REFPATH)/dos/go32v1/$*.inc > $*.dif - -%.dif : %.as - -$(DIFF) $(DIFFOPTS) $*.as $(REFPATH)/dos/go32v1/$*.as > $*.dif - -diffclean: - -$(DEL) *.dif - -makefile.dif : makefile - -$(DIFF) $(DIFFOPTS) makefile $(REFPATH)/dos/go32v1/makefile > makefile.dif - -diffs: syswin32.dif os.dif makefile.dif dos.dif base.dif struct.dif \ - winheap.dif messages.dif - -##################################################################### -# Distribution -##################################################################### - -distclean : clean libsclean diffclean - +include $(CFG)/makefile.def diff --git a/rtl/win32/messages.pp b/rtl/win32/messages.pp index fc5f266425..3aaa53ec26 100644 --- a/rtl/win32/messages.pp +++ b/rtl/win32/messages.pp @@ -244,7 +244,7 @@ unit messages; HDM_GETITEM = HDM_GETITEMA; HDM_INSERTITEM = HDM_INSERTITEMA; HDM_SETITEM = HDM_SETITEMA; -{$endifUNICODE} +{$endif UNICODE} HDM_GETITEMCOUNT = 4608; HDM_HITTEST = 4614; { Header control notifications } @@ -371,6 +371,8 @@ unit messages; LVM_INSERTCOLUMNA = 4123; LVM_INSERTITEMA = 4103; LVM_SETCOLUMNA = 4122; + LVM_SETITEMA = 4102; + LVM_SETITEMTEXTA = 4242; {$ifdef UNICODE} LVM_SETITEMA = 4102; LVM_SETITEMTEXTA = 4142; @@ -1048,9 +1050,7 @@ end. { $Log$ - Revision 1.2 1998-05-06 12:36:50 michael - + Removed log from before restored version. + Revision 1.3 1998-06-10 10:39:15 peter + * working w32 rtl - Revision 1.1.1.1 1998/03/25 11:18:46 root - * Restored version } diff --git a/rtl/win32/os.inc b/rtl/win32/os.inc index 91d5fc43b1..3eab4f9235 100644 --- a/rtl/win32/os.inc +++ b/rtl/win32/os.inc @@ -13,16 +13,14 @@ **********************************************************************} {$define win32} +{$undef go32v1} {$undef go32v2} {$undef os2} {$undef linux} -{$undef dos} { $Log$ - Revision 1.2 1998-05-06 12:37:22 michael - + Removed log from before restored version. + Revision 1.3 1998-06-10 10:39:16 peter + * working w32 rtl - Revision 1.1.1.1 1998/03/25 11:18:47 root - * Restored version } diff --git a/rtl/win32/syswin32.pp b/rtl/win32/syswin32.pp index 900a37d380..0977b06059 100644 --- a/rtl/win32/syswin32.pp +++ b/rtl/win32/syswin32.pp @@ -1,11 +1,11 @@ { $Id$ This file is part of the Free Pascal run time library. - FPC Pascal system unit for the Win32 API. - Copyright (c) 1993-98 by Florian Klaempfl and Pavel Ozerski member of the Free Pascal development team. + FPC Pascal system unit for the Win32 API. + See the file COPYING.FPC, included in this distribution, for details about the copyright. @@ -14,245 +14,309 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} +{$S-} unit syswin32; {$I os.inc} - interface +interface - {$I systemh.inc} +{ include system-independent routine headers } - var - hprevinst,hinstance,cmdshow : longint; - heaperror : pointer; +{$I systemh.inc} - { $I heaph.inc} +const +{ Default filehandles } + UnusedHandle : longint = -1; + StdInputHandle : longint = 0; + StdOutputHandle : longint = 0; + StdErrorHandle : longint = 0; - const - UnusedHandle : longint = -1; - StdInputHandle : longint = 0; - StdOutputHandle : longint = 0; - StdErrorHandle : longint = 0; +type + TStartupInfo=packed record + cb : longint; + lpReserved : Pointer; + lpDesktop : Pointer; + lpTitle : Pointer; + dwX : longint; + dwY : longint; + dwXSize : longint; + dwYSize : longint; + dwXCountChars : longint; + dwYCountChars : longint; + dwFillAttribute : longint; + dwFlags : longint; + wShowWindow : Word; + cbReserved2 : Word; + lpReserved2 : Pointer; + hStdInput : longint; + hStdOutput : longint; + hStdError : longint; + end; - implementation +var + startupinfo : tstartupinfo; + hprevinst, + hinstance, + cmdshow : longint; + heaperror : pointer; - { some declarations for Win32 API calls } - {$I Win32.inc} - {$I system.inc} +implementation + +{ include system independent routines } + +{$I system.inc} + +{ some declarations for Win32 API calls } +{$I win32.inc} + +type + plongint = ^longint; + + { misc. functions } + function GetLastError : DWORD; + external 'kernel32' name 'GetLastError'; + function MessageBox(w1:longint;l1,l2:pointer;w2:longint):longint; + external 'user32' name 'MessageBoxA'; + + { command line/enviroment functions } + function GetCommandLine : LPTSTR; + external 'kernel32' name 'GetCommandLineA'; + { time and date functions } + function GetTickCount : longint; + external 'kernel32' name 'GetTickCount'; + { process functions } + procedure ExitProcess(uExitCode : UINT); + external 'kernel32' name 'ExitProcess'; - type - plongint = ^longint; {$ifdef dummy} -{$S-} - procedure st1(stack_size : longint);[public,alias: 'STACKCHECK']; - - begin - { called when trying to get local stack } - { if the compiler directive $S is set } - { this function must preserve esi !!!! } - { because esi is set by the calling } - { proc for methods } - { it must preserve all registers !! } - - asm - pushl %eax - pushl %ebx - movl stack_size,%ebx - movl %esp,%eax - subl %ebx,%eax +procedure int_stackcheck(stack_size:longint);[public,alias: 'STACKCHECK']; +{ + called when trying to get local stack if the compiler directive $S + is set this function must preserve esi !!!! because esi is set by + the calling proc for methods it must preserve all registers !! +} +begin + asm + pushl %eax + pushl %ebx + movl stack_size,%ebx + movl %esp,%eax + subl %ebx,%eax {$ifdef SYSTEMDEBUG} - movl U_SYSTEM_LOWESTSTACK,%ebx - cmpl %eax,%ebx - jb _is_not_lowest - movl %eax,U_SYSTEM_LOWESTSTACK - _is_not_lowest: + movl U_SYSTEM_LOWESTSTACK,%ebx + cmpl %eax,%ebx + jb _is_not_lowest + movl %eax,U_SYSTEM_LOWESTSTACK +_is_not_lowest: {$endif SYSTEMDEBUG} - movl __stkbottom,%ebx - cmpl %eax,%ebx - jae __short_on_stack - popl %ebx - popl %eax - leave - ret $4 - __short_on_stack: - { can be usefull for error recovery !! } - popl %ebx - popl %eax - end['EAX','EBX']; - RunError(202); - { this needs a local variable } - { so the function called itself !! } - { Writeln('low in stack '); - RunError(202); } - end; + movl __stkbottom,%ebx + cmpl %eax,%ebx + jae __short_on_stack + popl %ebx + popl %eax + leave + ret $4 +__short_on_stack: + { can be usefull for error recovery !! } + popl %ebx + popl %eax + end['EAX','EBX']; + RunError(202); +end; {$endif dummy} - procedure halt(errnum : byte); - begin - do_exit; - flush(stderr); - ExitProcess(errnum); - end; +procedure halt(errnum : byte); +begin + do_exit; + flush(stderr); + ExitProcess(errnum); +end; - function paramcount : longint; - - var - count : longint; - cmdline : pchar; - quote : set of char; - - begin - cmdline:=GetCommandLine; - count:=0; - while true do - begin - { skip leading spaces } - while cmdline^ in [' ',#9] do - cmdline:=cmdline+1; - if cmdline^='"' then - begin - quote:=['"']; - cmdline:=cmdline+1; - end - else - quote:=[' ',#9]; - if cmdline^=#0 then - break; - inc(count); - while (cmdline^<>#0) and not(cmdline^ in quote) do - cmdline:=cmdline+1; - { skip quote } - if cmdline^ in quote then - cmdline:=cmdline+1; - end; - paramcount:=count-1; - end; - - function paramstr(l : longint) : string; - - var - s : string; - count : longint; - cmdline : pchar; - quote : set of char; - - begin - s:=''; - if (l>=0) and (l<=paramcount) then - begin - cmdline:=GetCommandLine; - count:=0; - while true do - begin - { skip leading spaces } - while cmdline^ in [' ',#9] do - cmdline:=cmdline+1; - if cmdline^='"' then - begin - quote:=['"']; - cmdline:=cmdline+1; - end - else - quote:=[' ',#9]; - if cmdline^=#0 then - break; - if count=l then - begin - while (cmdline^<>#0) and not(cmdline^ in quote) do - begin - s:=s+cmdline^; - cmdline:=cmdline+1; - end; - break; - end - else - begin - while (cmdline^<>#0) and not(cmdline^ in quote) do - cmdline:=cmdline+1; - end; - { skip quote } - if cmdline^ in quote then - cmdline:=cmdline+1; - inc(count); - end; - - end; - paramstr:=s; - end; - - procedure randomize; - - begin - randseed:=GetTickCount; - end; - -{$i winheap.inc} -{ $I heap.inc} - -{**************************************************************************** - Low Level File Routines - ****************************************************************************} - - procedure AllowSlash(p:pchar); - - var - i : longint; - - begin - { allow slash as backslash } - for i:=0 to strlen(p) do - if p[i]='/' then p[i]:='\'; - end; - - procedure do_close(h : longint); - - begin - closehandle(h); - end; - - procedure do_erase(p : pchar); - - begin - AllowSlash(p); - if DeleteFile(p)=0 then - inoutres:=GetLastError; - end; - - procedure do_rename(p1,p2 : pchar); +function paramcount : longint; +var + count : longint; + cmdline : pchar; + quote : set of char; +begin + cmdline:=GetCommandLine; + count:=0; + while true do + begin + { skip leading spaces } + while cmdline^ in [' ',#9] do + cmdline:=cmdline+1; + if cmdline^='"' then begin - AllowSlash(p1); - AllowSlash(p2); - if MoveFile(p1,p2)=0 then - inoutres:=GetLastError; - end; + quote:=['"']; + cmdline:=cmdline+1; + end + else + quote:=[' ',#9]; + if cmdline^=#0 then + break; + inc(count); + while (cmdline^<>#0) and not(cmdline^ in quote) do + cmdline:=cmdline+1; + { skip quote } + if cmdline^ in quote then + cmdline:=cmdline+1; + end; + paramcount:=count-1; +end; - function do_write(h,addr,len : longint) : longint; - var - size:longint; +function paramstr(l : longint) : string; +var + s : string; + count : longint; + cmdline : pchar; + quote : set of char; +begin + s:=''; + if (l>=0) and (l<=paramcount) then + begin + cmdline:=GetCommandLine; + count:=0; + while true do + begin + { skip leading spaces } + while cmdline^ in [' ',#9] do + cmdline:=cmdline+1; + if cmdline^='"' then + begin + quote:=['"']; + cmdline:=cmdline+1; + end + else + quote:=[' ',#9]; + if cmdline^=#0 then + break; + if count=l then + begin + while (cmdline^<>#0) and not(cmdline^ in quote) do + begin + s:=s+cmdline^; + cmdline:=cmdline+1; + end; + break; + end + else + begin + while (cmdline^<>#0) and not(cmdline^ in quote) do + cmdline:=cmdline+1; + end; + { skip quote } + if cmdline^ in quote then + cmdline:=cmdline+1; + inc(count); + end; + + end; + paramstr:=s; +end; + + +procedure randomize; +begin + randseed:=GetTickCount; +end; + + +{***************************************************************************** + Heap Management +*****************************************************************************} + +{ Include Windows Heap manager } +{$I winheap.inc} + +{***************************************************************************** + Low Level File Routines +*****************************************************************************} + + function WriteFile(fh:longint;buf:pointer;len:longint;var loaded:longint; + overlap:pointer):longint; + external 'kernel32' name 'WriteFile'; + function ReadFile(fh:longint;buf:pointer;len:longint;var loaded:longint; + overlap:pointer):longint; + external 'kernel32' name 'ReadFile'; + function CloseHandle(h : longint) : longint; + external 'kernel32' name 'CloseHandle'; + function DeleteFile(p : pchar) : longint; + external 'kernel32' name 'DeleteFileA'; + function MoveFile(old,_new : pchar) : longint; + external 'kernel32' name 'MoveFileA'; + function SetFilePointer(l1,l2 : longint;l3 : pointer;l4 : longint) : longint; + external 'kernel32' name 'SetFilePointer'; + function GetFileSize(h:longint;p:pointer) : longint; + external 'kernel32' name 'GetFileSize'; + function CreateFile(name : pointer;access,sharing : longint; + security : pointer;how,attr,template : longint) : longint; + external 'kernel32' name 'CreateFileA'; + function SetEndOfFile(h : longint) : boolean; + external 'kernel32' name 'SetEndOfFile'; + + +procedure AllowSlash(p:pchar); +var + i : longint; +begin +{ allow slash as backslash } + for i:=0 to strlen(p) do + if p[i]='/' then p[i]:='\'; +end; + + +procedure do_close(h : longint); +begin + closehandle(h); +end; + + +procedure do_erase(p : pchar); +begin + AllowSlash(p); + if DeleteFile(p)=0 then + inoutres:=GetLastError; +end; + + +procedure do_rename(p1,p2 : pchar); +begin + AllowSlash(p1); + AllowSlash(p2); + if MoveFile(p1,p2)=0 then + inoutres:=GetLastError; +end; + + +function do_write(h,addr,len : longint) : longint; +var + size:longint; +begin + if writefile(h,pointer(addr),len,size,nil)=0 then + inoutres:=GetLastError; + do_write:=size; +end; - begin - if writefile(h,pointer(addr),len,size,nil)=0 then - inoutres:=GetLastError; - do_write:=size; - end; function do_read(h,addr,len : longint) : longint; - var +var result:longint; - begin +begin if readfile(h,pointer(addr),len,result,nil)=0 then inoutres:=GetLastError; do_read:=result; - end; +end; + function do_filepos(handle : longint) : longint; - var +var l:longint; - begin +begin l:=SetFilePointer(handle,0,nil,FILE_CURRENT); if l=-1 then begin @@ -260,7 +324,8 @@ function do_filepos(handle : longint) : longint; inoutres:=GetLastError; end; do_filepos:=l; - end; +end; + procedure do_seek(handle,pos : longint); begin @@ -268,8 +333,8 @@ begin inoutres:=GetLastError; end; -function do_seekend(handle:longint):longint; +function do_seekend(handle:longint):longint; begin do_seekend:=SetFilePointer(handle,0,nil,FILE_END); if do_seekend=-1 then @@ -282,14 +347,14 @@ end; function do_filesize(handle : longint) : longint; var - aktfilepos : longint; + aktfilepos : longint; begin - aktfilepos:=do_filepos(handle); - do_filesize:=do_seekend(handle); - do_seek(handle,aktfilepos); + aktfilepos:=do_filepos(handle); + do_filesize:=do_seekend(handle); + do_seek(handle,aktfilepos); end; -{ truncate at a given position } + procedure do_truncate (handle,pos:longint); begin do_seek(handle,pos); @@ -297,94 +362,85 @@ begin inoutres:=GetLastError; end; + procedure do_open(var f;p : pchar;flags:longint); - { - filerec and textrec have both handle and mode as the first items so - they could use the same routine for opening/creating. - when (flags and $10) the file will be append - when (flags and $100) the file will be truncate/rewritten - when (flags and $1000) there is no check for close (needed for textfiles) - } +{ + filerec and textrec have both handle and mode as the first items so + they could use the same routine for opening/creating. + when (flags and $10) the file will be append + when (flags and $100) the file will be truncate/rewritten + when (flags and $1000) there is no check for close (needed for textfiles) +} - var - oflags,cd : longint; - - begin - AllowSlash(p); - { close first if opened } - if ((flags and $1000)=0) then - begin - case filerec(f).mode of - fminput,fmoutput,fminout: - Do_Close(filerec(f).handle); - fmclosed: - ; - else - begin - {not assigned} - inoutres:=102; - exit; - end; - end; - end; - { reset file handle } - filerec(f).handle:=UnusedHandle; - { convert filemode to filerec modes } - case (flags and 3) of - 0: - begin - filerec(f).mode:=fminput; - oflags:=GENERIC_READ; - end; - 1: - begin - filerec(f).mode:=fmoutput; - oflags:=GENERIC_WRITE; - end; - 2: - begin - filerec(f).mode:=fminout; - oflags:=GENERIC_WRITE or GENERIC_READ; - end; - end; - { standard is opening and existing file } - cd:=OPEN_EXISTING; - - { create it ? } - if (flags and $100)<>0 then - cd:=CREATE_ALWAYS - - { or append ? } - else if (flags and $10)<>0 then - cd:=OPEN_ALWAYS; - - { empty name is special } - if p[0]=#0 then - begin - case filerec(f).mode of - fminput: - filerec(f).handle:=StdInputHandle; - fmappend, - fmoutput: - begin - filerec(f).handle:=StdOutputHandle; - filerec(f).mode:=fmoutput; {fool fmappend} - end; - end; +var + oflags,cd : longint; +begin + AllowSlash(p); +{ close first if opened } + if ((flags and $1000)=0) then + begin + case filerec(f).mode of + fminput,fmoutput,fminout : Do_Close(filerec(f).handle); + fmclosed : ; + else + begin + {not assigned} + inoutres:=102; exit; + end; end; - filerec(f).handle:=CreateFile(p,oflags,0,nil,cd,FILE_ATTRIBUTE_NORMAL,0); - - { append mode } - if (flags and $10)<>0 then - begin - do_seekend(filerec(f).handle); - filerec(f).mode:=fmoutput; {fool fmappend} - end; - if filerec(f).handle=0 then - inoutres:=GetLastError; + end; +{ reset file handle } + filerec(f).handle:=UnusedHandle; +{ convert filemode to filerec modes } + case (flags and 3) of + 0 : begin + filerec(f).mode:=fminput; + oflags:=GENERIC_READ; + end; + 1 : begin + filerec(f).mode:=fmoutput; + oflags:=GENERIC_WRITE; + end; + 2 : begin + filerec(f).mode:=fminout; + oflags:=GENERIC_WRITE or GENERIC_READ; + end; end; +{ standard is opening and existing file } + cd:=OPEN_EXISTING; +{ create it ? } + if (flags and $100)<>0 then + cd:=CREATE_ALWAYS +{ or append ? } + else + if (flags and $10)<>0 then + cd:=OPEN_ALWAYS; +{ empty name is special } + if p[0]=#0 then + begin + case filerec(f).mode of + fminput : filerec(f).handle:=StdInputHandle; + fmappend, + fmoutput : begin + filerec(f).handle:=StdOutputHandle; + filerec(f).mode:=fmoutput; {fool fmappend} + end; + end; + exit; + end; + filerec(f).handle:=CreateFile(p,oflags,0,nil,cd,FILE_ATTRIBUTE_NORMAL,0); +{ append mode } + if (flags and $10)<>0 then + begin + do_seekend(filerec(f).handle); + filerec(f).mode:=fmoutput; {fool fmappend} + end; +{ get errors } + if filerec(f).handle=0 then + inoutres:=GetLastError; +end; {***************************************************************************** UnTyped File Handling @@ -410,6 +466,15 @@ procedure do_open(var f;p : pchar;flags:longint); Directory Handling *****************************************************************************} + function CreateDirectory(name : pointer;sec : pointer) : longint; + external 'kernel32' name 'CreateDirectoryA'; + function RemoveDirectory(name:pointer):longint; + external 'kernel32' name 'RemoveDirectoryA'; + function SetCurrentDirectory(name : pointer) : longint; + external 'kernel32' name 'SetCurrentDirectoryA'; + function GetCurrentDirectory(bufsize : longint;name : pchar) : longint; + external 'kernel32' name 'GetCurrentDirectoryA'; + type TDirFnType=function(name:pointer):word; @@ -468,6 +533,19 @@ procedure getdir(drivenr:byte;var dir:string); SystemUnit Initialization *****************************************************************************} + { Startup } + procedure GetStartupInfo(p : pointer); + external 'kernel32' name 'GetStartupInfoA'; + function GetStdHandle(nStdHandle:DWORD):THANDLE; + external 'kernel32' name 'GetStdHandle'; + + { module functions } + function GetModuleFileName(l1:longint;p:pointer;l2:longint):longint; + external 'kernel32' name 'GetModuleFileNameA'; + function GetModuleHandle(p : pointer) : longint; + external 'kernel32' name 'GetModuleHandleA'; + + {$ASMMODE DIRECT} procedure Entry;[public,alias: '_mainCRTStartup']; @@ -493,32 +571,9 @@ begin TextRec(f).Closefunc:=@fileclosefunc; end; -{$PACKRECORDS 1} + var - s : string; - StartupInfo : record - cb : longint; - lpReserved : Pointer; - lpDesktop : Pointer; - lpTitle : Pointer; - dwX : longint; - dwY : longint; - dwXSize : longint; - dwYSize : longint; - dwXCountChars : longint; - dwYCountChars : longint; - dwFillAttribute : longint; - dwFlags : longint; - wShowWindow : Word; - cbReserved2 : Word; - lpReserved2 : Pointer; - hStdInput : longint; - hStdOutput : longint; - hStdError : longint; - end; - -{$PACKRECORDS NORMAL} - + s : string; begin { get some helpful informations } GetStartupInfo(@startupinfo); @@ -546,7 +601,10 @@ end. { $Log$ - Revision 1.8 1998-06-08 23:07:47 peter + Revision 1.9 1998-06-10 10:39:17 peter + * working w32 rtl + + Revision 1.8 1998/06/08 23:07:47 peter * dos interface is now 100% compatible * fixed call PASCALMAIN which must be direct asm @@ -564,10 +622,4 @@ end. Revision 1.3 1998/04/26 21:49:57 florian + more stuff added (??dir procedures etc.) - - Revision 1.2 1998/03/27 00:50:22 peter - * small fixes so it compiles - - Revision 1.1.1.1 1998/03/25 11:18:47 root - * Restored version } diff --git a/rtl/win32/win32.inc b/rtl/win32/win32.inc index e55d4f181c..9752c22b7a 100644 --- a/rtl/win32/win32.inc +++ b/rtl/win32/win32.inc @@ -1,11 +1,9 @@ { $Id$ - This file contains the Win32-API import declarations - for the system unit and the DOS unit - This file is part of the Free Pascal run time library. - Copyright (c) 1997,98 by Florian Klaempfl, - member of the Free Pascal development team. + Copyright (c) 1998 by the Free Pascal development team. + + Win32 Types and Constants See the file COPYING.FPC, included in this distribution, for details about the copyright. @@ -16,204 +14,97 @@ **********************************************************************} - const - { constants for GetStdHandle } - STD_INPUT_HANDLE = $fffffff6; - STD_OUTPUT_HANDLE = $fffffff5; - STD_ERROR_HANDLE = $fffffff4; - INVALID_HANDLE_VALUE = $ffffffff; +const + { constants for GetStdHandle } + STD_INPUT_HANDLE = $fffffff6; + STD_OUTPUT_HANDLE = $fffffff5; + STD_ERROR_HANDLE = $fffffff4; + INVALID_HANDLE_VALUE = $ffffffff; - { flags for CreateFile } - GENERIC_READ=$80000000; - GENERIC_WRITE=$40000000; - CREATE_NEW = 1; - CREATE_ALWAYS = 2; - OPEN_EXISTING = 3; - OPEN_ALWAYS = 4; - TRUNCATE_EXISTING = 5; + IGNORE = 0; { Ignore signal } + INFINITE = $FFFFFFFF; { Infinite timeout } - FILE_ATTRIBUTE_ARCHIVE = 32; - FILE_ATTRIBUTE_COMPRESSED = 2048; - FILE_ATTRIBUTE_NORMAL = 128; - FILE_ATTRIBUTE_DIRECTORY = 16; - FILE_ATTRIBUTE_HIDDEN = 2; - FILE_ATTRIBUTE_READONLY = 1; - FILE_ATTRIBUTE_SYSTEM = 4; - FILE_ATTRIBUTE_TEMPORARY = 256; + { flags for CreateFile } + GENERIC_READ=$80000000; + GENERIC_WRITE=$40000000; + CREATE_NEW = 1; + CREATE_ALWAYS = 2; + OPEN_EXISTING = 3; + OPEN_ALWAYS = 4; + TRUNCATE_EXISTING = 5; - { flags for SetFilePos } - FILE_BEGIN = 0; - FILE_CURRENT = 1; - FILE_END = 2; + FILE_ATTRIBUTE_ARCHIVE = 32; + FILE_ATTRIBUTE_COMPRESSED = 2048; + FILE_ATTRIBUTE_NORMAL = 128; + FILE_ATTRIBUTE_DIRECTORY = 16; + FILE_ATTRIBUTE_HIDDEN = 2; + FILE_ATTRIBUTE_READONLY = 1; + FILE_ATTRIBUTE_SYSTEM = 4; + FILE_ATTRIBUTE_TEMPORARY = 256; - type - UINT = longint; - LPDWORD = ^DWORD; - BOOL = longint; + { flags for SetFilePos } + FILE_BEGIN = 0; + FILE_CURRENT = 1; + FILE_END = 2; + +type + UINT = longint; + BOOL = longint; + WCHAR = word; {$ifdef UNICODE} - LPTCH = ^word; - LPTSTR = ^word; - LPCTSTR = ^word; + LPTCH = ^word; + LPTSTR = ^word; + LPCTSTR = ^word; {$else UNICODE} - LPTCH = ^char; - LPTSTR = ^char; - LPCTSTR = ^char; + LPTCH = ^char; + LPTSTR = ^char; + LPCTSTR = ^char; {$endif UNICODE} - PVOID = pointer; - LPVOID = pointer; - LPCVOID = pointer; - HANDLE = pointer; - HLOCAL = HANDLE; - PSTR = pchar; + PVOID = pointer; + LPVOID = pointer; + LPCVOID = pointer; + LPDWORD = ^DWORD; + THandle = longint; + HLocal = THandle; + PStr = pchar; + LPStr = pchar; - OVERLAPPED = record - Internal : DWORD; - InternalHigh : DWORD; - Offset : DWORD; - OffsetHigh : DWORD; - hEvent : HANDLE; - end; + PSecurityAttributes = ^TSecurityAttributes; + TSecurityAttributes = record + nLength : DWORD; + lpSecurityDescriptor : Pointer; + bInheritHandle : Boolean; + end; - LPOVERLAPPED = ^OVERLAPPED; + PProcessInformation = ^TProcessInformation; + TProcessInformation = record + hProcess: THandle; + hThread: THandle; + dwProcessId: DWORD; + dwThreadId: DWORD; + end; - SYSTEMTIME = record - wYear,wMonth,wDayOfWeek,wDay, - wHour,wMinute,wSecond,WMilliseconds : word; - end; + PFileTime = ^TFileTime; + TFileTime = record + dwLowDateTime, + dwHighDateTime : DWORD; + end; - FILETIME = record - dwLowDateTime : longint; - dwHighDateTime : longint; - end; - - PFILETIME = ^FILETIME; - - { command line/enviroment functions } - function GetCommandLine : LPTSTR; - external 'kernel32' name 'GetCommandLineA'; - function GetEnvironmentStrings : pchar; - external 'kernel32' name 'GetEnvironmentStringsA'; - function FreeEnvironmentStrings(p : pchar) : boolean; - external 'kernel32' name 'FreeEnvironmentStringsA'; - - { string functions - function lstrlen(lpString:LPCTSTR):longint;external; - function lstrcat(lpString1:LPTSTR; lpString2:LPCTSTR):LPTSTR;external; - function lstrcpy(lpString1:LPTSTR; lpString2:LPCTSTR):LPTSTR;external; - } - - { process functions } - procedure ExitProcess(uExitCode : UINT); - external 'kernel32' name 'ExitProcess'; - - { file functions } - function GetStdHandle(nStdHandle:DWORD):HANDLE; - external 'kernel32' name 'GetStdHandle'; - function WriteFile(fh:longint;buf:pointer;len:longint;var loaded:longint; - overlap:pointer):longint; - external 'kernel32' name 'WriteFile'; - function ReadFile(fh:longint;buf:pointer;len:longint;var loaded:longint; - overlap:pointer):longint; - external 'kernel32' name 'ReadFile'; - function CloseHandle(h : longint) : longint; - external 'kernel32' name 'CloseHandle'; - function DeleteFile(p : pchar) : longint; - external 'kernel32' name 'DeleteFileA'; - function MoveFile(old,_new : pchar) : longint; - external 'kernel32' name 'MoveFileA'; - function SetFilePointer(l1,l2 : longint;l3 : pointer;l4 : longint) : longint; - external 'kernel32' name 'SetFilePointer'; - function GetFileSize(h:longint;p:pointer) : longint; - external 'kernel32' name 'GetFileSize'; - function CreateFile(name : pointer;access,sharing : longint; - security : pointer;how,attr,template : longint) : longint; - external 'kernel32' name 'CreateFileA'; - function CreateDirectory(name : pointer;sec : pointer) : longint; - external 'kernel32' name 'CreateDirectoryA'; - function RemoveDirectory(name:pointer):longint; - external 'kernel32' name 'RemoveDirectoryA'; - function SetCurrentDirectory(name : pointer) : longint; - external 'kernel32' name 'SetCurrentDirectoryA'; - function GetCurrentDirectory(bufsize : longint;name : pchar) : longint; - external 'kernel32' name 'GetCurrentDirectoryA'; - function SetFileAttributes(lpFileName : pchar;dwFileAttributes : longint) : boolean; - external 'kernel32' name 'SetFileAttributesA'; - function GetFileAttributes(lpFileName : pchar) : longint; - external 'kernel32' name 'GetFileAttributesA'; - function GetFileTime(h : longint;creation,lastaccess,lastwrite : PFILETIME) : boolean; - external 'kernel32' name 'GetFileTime'; - function SetFileTime(h : longint;creation,lastaccess,lastwrite : PFILETIME) : boolean; - external 'kernel32' name 'SetFileTime'; - function SetEndOfFile(h : longint) : boolean; - external 'kernel32' name 'SetEndOfFile'; - - { module functions } - function GetModuleFileName(l1:longint;p:pointer;l2:longint):longint; - external 'kernel32' name 'GetModuleFileNameA'; - procedure GetStartupInfo(p : pointer); - external 'kernel32' name 'GetStartupInfoA'; - function GetModuleHandle(p : pointer) : longint; - external 'kernel32' name 'GetModuleHandleA'; - - { memory functions } - function GlobalAlloc(mode,size:longint):longint; - external 'kernel32' name 'GlobalAlloc'; - function GlobalHandle(p:pointer):longint; - external 'kernel32' name 'GlobalHandle'; - function GlobalLock(handle:longint):pointer; - external 'kernel32' name 'GlobalLock'; - function GlobalUnlock(h:longint):longint; - external 'kernel32' name 'GlobalUnlock'; - function GlobalFree(h:longint):longint; - external 'kernel32' name 'GlobalUnlock'; - procedure GlobalMemoryStatus(p:pointer); - external 'kernel32' name 'GlobalMemoryStatus'; - function LocalAlloc(uFlags : UINT;uBytes :UINT) : HLOCAL; - external 'kernel32' name 'LocalAlloc'; - function LocalFree(hMem:HLOCAL):HLOCAL; - external 'kernel32' name 'LocalFree'; - - { time and date functions } - procedure GetLocalTime(var t : SYSTEMTIME); - external 'kernel32' name 'GetLocalTime'; - function SetLocalTime(const t : SYSTEMTIME) : boolean; - external 'kernel32' name 'SetLocalTime'; - function FileTimeToDosDateTime(const ft : FILETIME;var data,time : word) : boolean; - external 'kernel32' name 'FileTimeToDosDateTime'; - function DosDateTimeToFileTime(date,time : word;var ft : FILETIME) : boolean; - external 'kernel32' name 'DosDateTimeToFileTime'; - function GetTickCount : longint; - external 'kernel32' name 'GetTickCount'; - function FileTimeToLocalFileTime(const ft : FILETIME;var lft : FILETIME) : boolean; - external 'kernel32' name 'FileTimeToLocalFileTime'; - function LocalFileTimeToFileTime(const lft : FILETIME;var ft : FILETIME) : boolean; - external 'kernel32' name 'LocalFileTimeToFileTime'; - - { misc. functions } - function GetLastError : DWORD; - external 'kernel32' name 'GetLastError'; - function MessageBox(w1:longint;l1,l2:pointer;w2:longint):longint; - external 'user32' name 'MessageBoxA'; - function GetVersion : longint; - external 'kernel32' name 'GetVersion'; + PSystemTime = ^TSystemTime; + TSystemTime = record + wYear, + wMonth, + wDayOfWeek, + wDay, + wHour, + wMinute, + wSecond, + wMilliseconds: Word; + end; { $Log$ - Revision 1.6 1998-05-06 12:37:22 michael - + Removed log from before restored version. + Revision 1.7 1998-06-10 10:39:18 peter + * working w32 rtl - Revision 1.5 1998/04/27 18:25:36 florian - + constants for CreateFile added - - Revision 1.4 1998/04/26 22:37:22 florian - * some small extensions - - Revision 1.3 1998/04/26 21:49:58 florian - + more stuff added (??dir procedures etc.) - - Revision 1.2 1998/03/27 00:50:22 peter - * small fixes so it compiles - - Revision 1.1.1.1 1998/03/25 11:18:47 root - * Restored version } diff --git a/rtl/win32/winheap.inc b/rtl/win32/winheap.inc index b5c0ae1630..d15e06d79b 100644 --- a/rtl/win32/winheap.inc +++ b/rtl/win32/winheap.inc @@ -1,9 +1,9 @@ { $Id$ This file is part of the Free Pascal run time library. - FPC Pascal system unit for the Win32 API. - Copyright (c) 1998 by Florian Klaempfl and Pavel Ozerski - member of the Free Pascal development team. + Copyright (c) 1998 by the Free Pascal development team. + + Win32 Memory Functions See the file COPYING.FPC, included in this distribution, for details about the copyright. @@ -14,40 +14,58 @@ **********************************************************************} + { memory functions } + function GlobalAlloc(mode,size:longint):longint; + external 'kernel32' name 'GlobalAlloc'; + function GlobalHandle(p:pointer):longint; + external 'kernel32' name 'GlobalHandle'; + function GlobalLock(handle:longint):pointer; + external 'kernel32' name 'GlobalLock'; + function GlobalUnlock(h:longint):longint; + external 'kernel32' name 'GlobalUnlock'; + function GlobalFree(h:longint):longint; + external 'kernel32' name 'GlobalUnlock'; + procedure GlobalMemoryStatus(p:pointer); + external 'kernel32' name 'GlobalMemoryStatus'; + function LocalAlloc(uFlags : UINT;uBytes :UINT) : HLOCAL; + external 'kernel32' name 'LocalAlloc'; + function LocalFree(hMem:HLOCAL):HLOCAL; + external 'kernel32' name 'LocalFree'; + + type - errproc=function(size:longint):integer; + errproc=function(size:longint):integer; procedure MemError(size:longint); - const - message:array[1..21]of char=( - 'A','b','n','o','r','m','a','l',' ', - 'T','e','r','m','i','n','a','t','i','o','n',#0); - caption:array[1..25]of char=( - 'M','e','m','o','r','y',' ', - 'M','a','n','a','g','e','m','e','n','t',' ', - 'E','r','r','o','r','!',#0); - var +const + message:pchar='Abnormal Termination'; + caption:pchar='Memory Management Error!'; +var res:integer; - begin +begin repeat - res:=errproc(heaperror)(size); - if res=0 then - begin; - messagebox(0,@caption,@message,$10); - halt(getlasterror); - end; + res:=errproc(heaperror)(size); + if res=0 then + begin; + messagebox(0,caption,message,$10); + halt(getlasterror); + end; until res<>2; - end; +end; + + procedure getmem(var p:pointer;size:longint);[public,alias: 'GETMEM']; - begin +begin p:=GlobalLock(GlobalAlloc(258,size)); if p=nil then memerror(size) - end; +end; + + procedure freemem(var p:pointer;size:longint);[public,alias: 'FREEMEM']; - var +var h:longint; - begin +begin h:=GlobalHandle(p); if h<>0 then if globalunlock(h)=0 then @@ -58,10 +76,11 @@ procedure freemem(var p:pointer;size:longint);[public,alias: 'FREEMEM']; end; p:=nil; memerror(size); - end; +end; + function memmax(_maxavail:boolean):longint; - const +const status:record dwLength, dwMemoryLoad, @@ -72,31 +91,36 @@ function memmax(_maxavail:boolean):longint; dwTotalVirtual, dwAvailVirtual:longint; end=(dwLength:32); - begin +begin GlobalMemoryStatus(@status); if _maxavail then memmax:=status.dwAvailPageFile else memmax:=status.dwAvailVirtual; - end; +end; + + function memavail:longint; - begin +begin memavail:=memmax(false); - end; +end; + + function maxavail:longint; - begin +begin maxavail:=memmax(true); - end; +end; + + function growheap(size:longint):integer; - begin +begin growheap:=0; - end; +end; { $Log$ - Revision 1.2 1998-05-06 12:37:22 michael - + Removed log from before restored version. + Revision 1.3 1998-06-10 10:39:19 peter + * working w32 rtl - Revision 1.1.1.1 1998/03/25 11:18:47 root - * Restored version } +