+ patch by Sven Barth to add native NT rtl support to the fpc rtl, resolves #14887

git-svn-id: trunk@14568 -

.gitattributes

@@ -6720,6 +6720,19 @@ rtl/morphos/utility.pp svneol=native#text/plain
 rtl/morphos/varutils.pp svneol=native#text/plain
 rtl/morphos/video.pp svneol=native#text/plain
 rtl/morphos/videodata.inc svneol=native#text/plain
+rtl/nativent/Makefile.fpc svneol=native#text/plain
+rtl/nativent/buildrtl.lpi svneol=native#text/plain
+rtl/nativent/buildrtl.pp svneol=native#text/pascal
+rtl/nativent/ddk.pas svneol=native#text/pascal
+rtl/nativent/ddk/ddkex.inc svneol=native#text/plain
+rtl/nativent/ddk/ddktypes.inc svneol=native#text/plain
+rtl/nativent/ndk.pas svneol=native#text/pascal
+rtl/nativent/ndkutils.pas svneol=native#text/pascal
+rtl/nativent/sysheap.inc svneol=native#text/plain
+rtl/nativent/sysndk.inc svneol=native#text/plain
+rtl/nativent/sysos.inc svneol=native#text/plain
+rtl/nativent/sysosh.inc svneol=native#text/plain
+rtl/nativent/system.pp svneol=native#text/pascal
 rtl/nds/Makefile svneol=native#text/plain
 rtl/nds/Makefile.fpc svneol=native#text/plain
 rtl/nds/classes.pp svneol=native#text/plain

rtl/Makefile

@@ -1,8 +1,8 @@
 #
-# Don't edit, this file is generated by FPCMake Version 2.0.0 [2009/12/07]
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2010/01/07]
 #
 default: all
-MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-solaris x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded avr-embedded armeb-linux armeb-embedded mipsel-linux
+MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-solaris x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded avr-embedded armeb-linux armeb-embedded mipsel-linux
 BSDs = freebsd netbsd openbsd darwin
 UNIXs = linux $(BSDs) solaris qnx haiku
 LIMIT83fs = go32v2 os2 emx watcom
@@ -314,6 +314,9 @@ endif
 ifeq ($(FULL_TARGET),i386-symbian)
 override TARGET_DIRS+=symbian
 endif
+ifeq ($(FULL_TARGET),i386-nativent)
+override TARGET_DIRS+=nativent
+endif
 ifeq ($(FULL_TARGET),m68k-linux)
 override TARGET_DIRS+=linux
 endif
@@ -772,6 +775,10 @@ ifeq ($(OS_TARGET),symbian)
 SHAREDLIBEXT=.dll
 SHORTSUFFIX=symbian
 endif
+ifeq ($(OS_TARGET),NativeNT)
+SHAREDLIBEXT=.dll
+SHORTSUFFIX=nativent
+endif
 else
 ifeq ($(OS_TARGET),go32v1)
 PPUEXT=.pp1
@@ -1730,6 +1737,9 @@ endif
 ifeq ($(FULL_TARGET),i386-symbian)
 TARGET_DIRS_SYMBIAN=1
 endif
+ifeq ($(FULL_TARGET),i386-nativent)
+TARGET_DIRS_NATIVENT=1
+endif
 ifeq ($(FULL_TARGET),m68k-linux)
 TARGET_DIRS_LINUX=1
 endif
@@ -2564,6 +2574,51 @@ symbian:
 	$(MAKE) -C symbian all
 .PHONY: symbian_all symbian_debug symbian_smart symbian_release symbian_units symbian_examples symbian_shared symbian_install symbian_sourceinstall symbian_exampleinstall symbian_distinstall symbian_zipinstall symbian_zipsourceinstall symbian_zipexampleinstall symbian_zipdistinstall symbian_clean symbian_distclean symbian_cleanall symbian_info symbian_makefiles symbian
 endif
+ifdef TARGET_DIRS_NATIVENT
+nativent_all:
+	$(MAKE) -C nativent all
+nativent_debug:
+	$(MAKE) -C nativent debug
+nativent_smart:
+	$(MAKE) -C nativent smart
+nativent_release:
+	$(MAKE) -C nativent release
+nativent_units:
+	$(MAKE) -C nativent units
+nativent_examples:
+	$(MAKE) -C nativent examples
+nativent_shared:
+	$(MAKE) -C nativent shared
+nativent_install:
+	$(MAKE) -C nativent install
+nativent_sourceinstall:
+	$(MAKE) -C nativent sourceinstall
+nativent_exampleinstall:
+	$(MAKE) -C nativent exampleinstall
+nativent_distinstall:
+	$(MAKE) -C nativent distinstall
+nativent_zipinstall:
+	$(MAKE) -C nativent zipinstall
+nativent_zipsourceinstall:
+	$(MAKE) -C nativent zipsourceinstall
+nativent_zipexampleinstall:
+	$(MAKE) -C nativent zipexampleinstall
+nativent_zipdistinstall:
+	$(MAKE) -C nativent zipdistinstall
+nativent_clean:
+	$(MAKE) -C nativent clean
+nativent_distclean:
+	$(MAKE) -C nativent distclean
+nativent_cleanall:
+	$(MAKE) -C nativent cleanall
+nativent_info:
+	$(MAKE) -C nativent info
+nativent_makefiles:
+	$(MAKE) -C nativent makefiles
+nativent:
+	$(MAKE) -C nativent all
+.PHONY: nativent_all nativent_debug nativent_smart nativent_release nativent_units nativent_examples nativent_shared nativent_install nativent_sourceinstall nativent_exampleinstall nativent_distinstall nativent_zipinstall nativent_zipsourceinstall nativent_zipexampleinstall nativent_zipdistinstall nativent_clean nativent_distclean nativent_cleanall nativent_info nativent_makefiles nativent
+endif
 ifdef TARGET_DIRS_AMIGA
 amiga_all:
 	$(MAKE) -C amiga all

rtl/Makefile.fpc

@@ -31,6 +31,7 @@ dirs_gba=gba
 dirs_nds=nds
 dirs_symbian=symbian
 dirs_embedded=embedded
+dirs_nativent=nativent
 
 [install]
 fpcpackage=y

rtl/nativent/Makefile.fpc

@@ -0,0 +1,108 @@
+#
+#   Makefile.fpc for Free Pascal NativeNT RTL
+#
+
+[package]
+main=rtl
+
+[target]
+loaders=
+#units=system objpas macpas buildrtl lineinfo lnfodwrf
+units=system objpas buildrtl
+implicitunits=ndk ndkutils ddk
+#      ctypes strings
+#      heaptrc matrix \
+#      windows winsock winsock2 initc cmem dynlibs signals \
+#      dos crt objects messages \
+#      rtlconsts sysconst sysutils math types \
+#      strutils dateutils varutils variants typinfo fgl classes \
+#      convutils stdconvs cpu mmx charset ucomplex getopts \
+#      winevent sockets printer \
+#      video mouse keyboard fmtbcd \
+#      winsysut sharemem exeinfo fpintres
+
+# shared=$(DLLS)
+
+rsts=math varutils typinfo variants classes dateutils sysconst
+
+[require]
+nortl=y
+
+[install]
+fpcpackage=y
+
+[default]
+fpcdir=../..
+target=nativent
+
+[compiler]
+includedir=$(INC) $(PROCINC) $(DDKINC)
+sourcedir=$(INC) $(PROCINC) $(COMMON)
+
+
+[prerules]
+RTL=..
+INC=$(RTL)/inc
+COMMON=$(RTL)/common
+PROCINC=$(RTL)/$(CPU_TARGET)
+DDKINC=ddk
+
+UNITPREFIX=rtl
+
+ifneq ($(findstring 2.0.,$(FPC_VERSION)),)
+#LOADERS=wprt0 wdllprt0 gprt0 wcygprt0
+DLLS=
+else
+DLLS=fpcmemdll
+endif
+
+# Paths
+OBJPASDIR=$(RTL)/objpas
+
+# Files used by windows.pp
+#include $(WININC)/makefile.inc
+
+WINDOWS_SOURCE_FILES=$(addprefix $(WININC)/,$(addsuffix .inc,$(WINDOWS_FILES)))
+
+
+[rules]
+.NOTPARALLEL:
+SYSTEMPPU=$(addsuffix $(PPUEXT),system)
+
+# Get the system independent include file names.
+# 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 :
+# CPUINCNAMES
+include $(PROCINC)/makefile.cpu
+SYSCPUDEPS=$(addprefix $(PROCINC)/,$(CPUINCNAMES))
+
+# Put system unit dependencies together.
+SYSDEPS=$(SYSINCDEPS) $(SYSCPUDEPS)
+
+
+#
+# Loaders
+#
+
+# none
+
+#
+# Unit specific rules
+#
+
+system$(PPUEXT) : system.pp $(SYSDEPS)
+        $(COMPILER) -Us -Sg system.pp
+
+objpas$(PPUEXT): $(OBJPASDIR)/objpas.pp $(INC)/except.inc system$(PPUEXT)
+        $(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/objpas.pp
+
+#macpas$(PPUEXT) : $(INC)/macpas.pp objpas$(PPUEXT) buildrtl$(PPUEXT)
+#        $(COMPILER) $(INC)/macpas.pp $(REDIR)
+
+buildrtl$(PPUEXT): buildrtl.pp system$(PPUEXT) objpas$(PPUEXT)
+        $(COMPILER) -Fi$(OBJPASDIR)/sysutils -Fi$(OBJPASDIR)/classes -Fu$(PROCINC) -I$(OBJPASDIR) -Fi$(DDKINC) -I$(INC) -Fu$(INC) -Fu$(OBJPASDIR) buildrtl

rtl/nativent/buildrtl.lpi

@@ -0,0 +1,67 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <PathDelim Value="\"/>
+    <Version Value="7"/>
+    <General>
+      <Flags>
+        <MainUnitHasUsesSectionForAllUnits Value="False"/>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+        <Runnable Value="False"/>
+        <LRSInOutputDirectory Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <TargetFileExt Value=".exe"/>
+      <Title Value="buildrtl"/>
+    </General>
+    <VersionInfo>
+      <ProjectVersion Value=""/>
+    </VersionInfo>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IgnoreBinaries Value="False"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <Units Count="1">
+      <Unit0>
+        <Filename Value="buildrtl.pp"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="buildrtl"/>
+      </Unit0>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="8"/>
+    <PathDelim Value="\"/>
+    <SearchPaths>
+      <IncludeFiles Value="..\inc\;..\$TargetCPU()\;ddk\;..\objpas\;..\objpas\classes\;..\objpas\sysutils\"/>
+      <UnitOutputDirectory Value="..\units\i386-nativent"/>
+    </SearchPaths>
+    <Parsing>
+      <Style Value="2"/>
+      <SyntaxOptions>
+        <SyntaxMode Value="fpc"/>
+      </SyntaxOptions>
+    </Parsing>
+    <Other>
+      <Verbosity>
+        <ShowNotes Value="False"/>
+        <ShowHints Value="False"/>
+      </Verbosity>
+      <CustomOptions Value="-dKMODE"/>
+      <CompilerPath Value="$(CompPath)"/>
+      <ExecuteBefore>
+        <ShowAllMessages Value="True"/>
+      </ExecuteBefore>
+    </Other>
+  </CompilerOptions>
+</CONFIG>

rtl/nativent/buildrtl.pp

@@ -0,0 +1,10 @@
+unit buildrtl;
+
+  interface
+
+    uses
+      ndk, ndkutils, ddk;
+
+  implementation
+
+end.

rtl/nativent/ddk.pas

@@ -0,0 +1,59 @@
+{
+    Driver Development Kit for Native NT
+
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2009 by Sven Barth
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program 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.
+
+ **********************************************************************}
+
+unit DDK;
+
+interface
+
+uses
+  NDK;
+
+const
+  // we distinguish the user- AND kernel-mode imports (NDK.ntdll) from the pure
+  // kernel mode imports (ntkrnl)
+  ntkrnl = 'ntoskrnl.exe';
+
+{$include ddktypes.inc}
+
+// these two only return not Nil in main routine of a device driver
+function RegistryPath: PNtUnicodeString; inline;
+function DriverObject: PDriverObject; inline;
+
+function DbgPrint(aFormat: PChar): LongWord; cdecl; varargs; external ntkrnl name 'DbgPrint';
+
+function PoolTag(aTag: TTagString): LongWord;
+
+{$include ddkex.inc}
+
+implementation
+
+function RegistryPath: PNtUnicodeString; inline;
+begin
+  RegistryPath := SysRegistryPath;
+end;
+
+function DriverObject: PDriverObject; inline;
+begin
+  DriverObject := SysDriverObject;
+end;
+
+function PoolTag(aTag: TTagString): LongWord;
+begin
+  PoolTag := Ord(aTag[1]) + Ord(aTag[2]) shl 8 +
+         Ord(aTag[3]) shl 16 + Ord(aTag[4]) shl 24;
+end;
+
+end.
+

rtl/nativent/ddk/ddkex.inc

@@ -0,0 +1,20 @@
+{%MainUnit ddk.pas}
+{
+    Driver Development Kit for Native NT
+    Imports for Executive
+
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2009 by Sven Barth
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program 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.
+
+ **********************************************************************}
+
+function ExAllocatePoolWithTag(PoolType: TPoolType; NumberOfBytes: PtrUInt; Tag: LongWord): Pointer; stdcall; external ntkrnl name 'ExAllocatePoolWithTag';
+procedure ExFreePoolWithTag(P: Pointer; Tag: LongWord); stdcall; external ntkrnl name 'ExFreePoolWithTag';
+

rtl/nativent/ddk/ddktypes.inc

@@ -0,0 +1,75 @@
+{%MainUnit ddk.pas}
+{
+    Driver Development Kit for Native NT
+    Basic types used in Kernel Mode
+
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2009 by Sven Barth
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program 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.
+
+ **********************************************************************}
+
+type
+  _DEVICE_OBJECT = packed record
+
+  end;
+  TDeviceObject = _DEVICE_OBJECT;
+  PDeviceObject = ^TDeviceObject;
+
+  _FAST_IO_DISPATCH = packed record
+
+  end;
+  TFastIODispatch = _FAST_IO_DISPATCH;
+  PFastIODispatch = ^TFastIODispatch;
+
+  _DRIVER_EXTENSION = packed record
+
+  end;
+  TDriverExtension = _DRIVER_EXTENSION;
+  PDriverExtension = ^TDriverExtension;
+
+  _DRIVER_OBJECT = packed record
+    _Type: SmallInt;
+    Size: SmallInt;
+    DeviceObject: PDeviceObject;
+    Flags: LongWord;
+    DriverStart: Pointer;
+    DriverSize: LongWord;
+    DriverSection: Pointer;
+    DriverExtension: PDriverExtension;
+    DriverName: TNtUnicodeString;
+    HardwareDatabase: PNtUnicodeString;
+    FastIoDispatch: PFastIODispatch;
+    DriverInit: PLongInt;
+    DriverStartIo: Pointer;
+    DriverUnload: Pointer;
+    MajorFunction: array[0..27] of PLongInt;
+  end;
+  TDriverObject = _Driver_Object;
+  PDriverObject = ^TDriverObject;
+
+  POOL_TYPE = (
+    NonPagedPool,
+    PagedPool,
+    NonPagedPoolMustSucceed,
+    DontUseThisType,
+    NonPagedPoolCacheAligned,
+    PagedPoolCacheAligned,
+    NonPagedPoolCacheAlignedMustS,
+    MaxPoolType,
+    NonPagedPoolSession = 32,
+    PagedPoolSession,
+    NonPagedPoolMustSucceedSession,
+    DontUseThisTypeSession,
+    NonPagedPoolCacheAlignedSession,
+    PagedPoolCacheAlignedSession,
+    NonPagedPoolCacheAlignedMustSSession
+  );
+  TPoolType = POOL_TYPE;
+

rtl/nativent/ndk.pas

@@ -0,0 +1,33 @@
+{
+    Native Development Kit for Native NT
+
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2009 by Sven Barth
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program 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.
+
+ **********************************************************************}
+
+unit NDK;
+
+interface
+
+{$I sysndk.inc}
+
+function NtDelayExecution(aAlertable: Boolean; aInterval: PLargeInteger): NTSTATUS; stdcall; external ntdll;
+
+
+function LdrGetProcedureAddress(hModule: THandle; psName: PNtUnicodeString; dwOrdinal: LongWord; var pProcedure: Pointer): NTSTATUS; stdcall; external ntdll;
+function LdrLoadDll(pwPath : PWord; pdwFlags : LongWord; pusPath : PNtUnicodeString; var phModule : THandle): NTSTATUS; stdcall; external ntdll;
+function LdrUnloadDll(hModule: THandle): NTSTATUS; stdcall; external ntdll;
+
+
+implementation
+
+end.
+

rtl/nativent/ndkutils.pas

@@ -0,0 +1,59 @@
+{
+    FPC Utility Function for Native NT applications
+
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2009 by Sven Barth
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program 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.
+
+ **********************************************************************}
+
+unit NDKUtils;
+
+{.$H+}
+
+interface
+
+uses
+  NDK;
+
+procedure ShortStrToNTStr(aStr: ShortString; var aNTStr: TNtUnicodeString);
+//procedure AnsiStrToNTStr(const aStr: String; var aNTStr: TNtUnicodeString);
+
+implementation
+
+procedure ShortStrToNTStr(aStr: ShortString; var aNTStr: TNtUnicodeString);
+var
+  buf: Pointer;
+  i: Integer;
+begin
+  FillChar(aNTStr, SizeOf(TNtUnicodeString), 0);
+  aNTStr.Length := Length(aStr) * 2;
+  aNTStr.buffer := GetMem(aNTStr.Length);
+  buf := aNTStr.buffer;
+  for i := 1 to Length(aStr) do begin
+    PWord(buf)^ := Word(aStr[i]);
+    buf := Pointer(PtrUInt(buf) + SizeOf(Word));
+  end;
+  aNTStr.MaximumLength := aNTStr.Length;
+end;
+
+procedure InitializeObjectAttributes(var aObjectAttr: TObjectAttributes; aName: PNtUnicodeString; aAttributes: ULONG; aRootDir: THandle; aSecurity: Pointer);
+begin
+  with aObjectAttr do begin
+    Length := SizeOf(TObjectAttributes);
+    RootDirectory := aRootDir;
+    Attributes := aAttributes;
+    ObjectName := aName;
+    SecurityDescriptor := aSecurity;
+    SecurityQualityOfService := Nil;
+  end;
+end;
+
+end.
+

rtl/nativent/sysheap.inc

@@ -0,0 +1,160 @@
+{
+    Basic heap handling for windows platforms
+
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2001-2005 by Free Pascal development team
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program 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.
+
+ **********************************************************************}
+
+
+{*****************************************************************************
+      OS Memory allocation / deallocation
+ ****************************************************************************}
+
+ { In kernel mode we can either use FPC's build in memory manager or we use a
+   custom non-chunking manager. The problem with the build in one is that the
+   driver developer has far less control of the allocated memory blocks. }
+
+   { memory functions }
+{$ifdef KMODE}
+   function ExAllocatePoolWithTag(PoolType: LongInt; NumberOfBytes: PtrUInt; Tag: LongWord): Pointer; stdcall; external ntdll name 'ExAllocatePoolWithTag';
+   procedure ExFreePoolWithTag(P: Pointer; Tag: LongWord); stdcall; external ntdll name 'ExFreePoolWithTag';
+{$else KMODE}
+   function RtlAllocateHeap(hHeap : THandle; dwFlags : LongWord; Size : Longword): Pointer;
+     stdcall; external ntdll name 'RtlAllocateHeap';
+   function  RtlFreeHeap(hHeap : THandle; dwFlags : LongWord; MemoryPointer : Pointer): Boolean;
+     stdcall; external ntdll name 'RtlFreeHeap';
+   function RtlCreateHeap(Flags: LongWord; Base: Pointer; SizeToReserve: PtrUInt;
+     SizeToCommit: PtrUInt; Lock: PVOID; Parameters: Pointer): THandle;
+     stdcall; external ntdll name 'RtlCreateHeap';
+
+var
+  SysHeap: THandle = Nil;
+
+procedure PrepareSysHeap;
+begin
+  if IsLibrary then
+    // create a new heap (flag is HEAP_GROWABLE)
+    SysHeap := RtlCreateHeap(2, Nil, 65534, 65534, Nil, Nil)
+  else
+    // use the heap passed on startup
+    SysHeap := PPEB(CurrentPEB)^.ProcessHeap;
+end;
+
+{$endif KMODE}
+
+{$ifndef KMODE}
+
+// default memory manager
+
+function SysOSAlloc(size: ptruint): pointer;
+begin
+  if SysHeap = Nil then
+    PrepareSysHeap;
+  SysOSAlloc := RtlAllocateHeap(SysHeap, 0, size);
+end;
+
+{$define HAS_SYSOSFREE}
+
+procedure SysOSFree(p: pointer; size: ptruint);
+begin
+  // if heap isn't set, then nothing was allocated
+  if SysHeap <> Nil then
+    RtlFreeHeap(SysHeap, 0, p);
+end;
+
+{$else KMODE}
+
+// custom non-chunking memory manager for kernel mode
+
+// memory layout:
+//   <PtrUInt>: Size of reserved chunk
+//   <Tag>:     Tag that was used in ExAllocateFromPoolWithTag (needed in free)
+//   <...>:     Userdata
+
+function SysGetMem(Size: PtrUInt): Pointer;
+var
+  tag: LongWord;
+  pooltype: LongInt;
+begin
+  if HeapUsePagedPool then
+    pooltype := 1
+  else
+    pooltype := 0;
+  tag := Ord(HeapPoolTag[1]) + Ord(HeapPoolTag[2]) shl 8 +
+         Ord(HeapPoolTag[3]) shl 16 + Ord(HeapPoolTag[4]) shl 24;
+  // the kernel keeps track of our memory, but there's no way to ask it
+  // so we need to track the size by ourself
+  SysGetMem := ExAllocatePoolWithTag(pooltype, Size + SizeOf(PtrUInt) + SizeOf(LongWord), tag);
+  // save the size
+  PPtrUInt(SysGetMem)^ := Size;
+  SysGetMem := SysGetMem + SizeOf(PtrUInt);
+  // save the tag
+  PLongWord(SysGetMem)^ := tag;
+  SysGetMem := SysGetMem + SizeOf(LongWord);
+end;
+
+function SysFreeMem(p: Pointer): PtrUInt;
+var
+  tag: PLongWord;
+begin
+  tag := p - SizeOf(LongWord);
+  // we need to pass the tag we used to allocate the memory (else: BSOD)
+  ExFreePoolWithTag(p - SizeOf(PtrUInt) - SizeOf(LongWord), tag^);
+  SysFreeMem := 0;
+end;
+
+function SysFreeMemSize(p: Pointer; Size: PtrUInt): PtrUInt;
+begin
+  SysFreeMemSize := 0;
+  if (Size > 0) and (p <> nil) then
+    Result := SysFreeMem(p);
+end;
+
+Function SysAllocMem(Size: PtrUInt): Pointer;
+begin
+  SysAllocMem := SysGetMem(Size);
+  if SysAllocMem <> nil then
+    FillChar(SysAllocMem^, Size, 0);
+end;
+
+Function SysReAllocMem (var p: pointer; Size: PtrUInt): Pointer;
+begin
+  SysReAllocMem := SysGetMem(Size);
+  Move(p^, SysReAllocMem^, Size);
+  p := SysReAllocMem;
+end;
+
+function SysTryResizeMem(var p: Pointer; size: PtrUInt): Boolean;
+var
+  res: pointer;
+begin
+  res := SysGetMem(Size);
+  SysTryResizeMem := (res <> Nil) or (Size = 0);
+  if SysTryResizeMem then
+    p := res;
+end;
+
+function SysMemSize(P : pointer): PtrUInt;
+begin
+  SysMemSize := PPtrUInt(P - SizeOf(PtrUInt) - SizeOf(LongWord))^;
+end;
+
+function SysGetHeapStatus: THeapStatus;
+begin
+  FillChar(SysGetHeapStatus, SizeOf(SysGetHeapStatus), 0);
+end;
+
+function SysGetFPCHeapStatus: TFPCHeapStatus;
+begin
+  FillChar(SysGetFPCHeapStatus, SizeOf(SysGetHeapStatus), 0);
+end;
+
+{$endif KMODE}

rtl/nativent/sysndk.inc

@@ -0,0 +1,219 @@
+// These datatypes are used in system.pas and ndk.pas
+
+const
+{$ifdef kmode}
+  ntdll = 'ntoskrnl.exe';
+{$else}
+  ntdll = 'ntdll.dll';
+{$endif}
+
+type
+  //
+  // some basic types
+  //
+  HANDLE = THandle;
+  PVOID = Pointer;
+  LONG = LongInt;
+  ULONG = LongWord;
+
+
+  NTSTATUS = LongInt;
+
+  UNICODE_STRING = packed record
+    Length: Word;        // used characters in buffer
+    MaximumLength: Word; // maximum characters in buffer
+    Buffer: PWideChar;
+  end;
+  PUNICODE_STRING = ^UNICODE_STRING;
+  // alias to differ from TUnicodeString
+  TNtUnicodeString = UNICODE_STRING;
+  PNtUnicodeString = ^TNtUnicodeString;
+
+  // using Int64 is an alternative (QWord might have unintended side effects)
+  LARGE_INTEGER = packed record
+    case Boolean of
+      True:(LowPart: LongWord;
+            HighPart: LongInt);
+      False:(QuadPart: Int64);
+  end;
+  PLARGE_INTEGER = ^LARGE_INTEGER;
+  TLargeInteger = LARGE_INTEGER;
+  PLargeInteger = ^TLargeInteger;
+
+
+//
+// Object Attributes structure
+//
+  POBJECT_ATTRIBUTES = ^OBJECT_ATTRIBUTES;
+  _OBJECT_ATTRIBUTES = record
+    Length: ULONG;
+    RootDirectory: HANDLE;
+    ObjectName: PUNICODE_STRING;
+    Attributes: ULONG;
+    SecurityDescriptor: PVOID;       // Points to type SECURITY_DESCRIPTOR
+    SecurityQualityOfService: PVOID; // Points to type SECURITY_QUALITY_OF_SERVICE
+  end;
+  OBJECT_ATTRIBUTES = _OBJECT_ATTRIBUTES;
+  TObjectAttributes = OBJECT_ATTRIBUTES;
+  PObjectAttributes = POBJECT_ATTRIBUTES;
+
+  TRtlDriveLetterCurDir = packed record
+    Flags: Word;
+    Length: Word;
+    TimeStamp: LongWord;
+    DosPath: TNtUnicodeString;
+  end;
+
+  TCurDir = packed record
+    DosPath: TNtUnicodeString;
+    Handle: THandle;
+  end;
+
+  TRtlUserProcessParameters = packed record
+    MaximumLength: LongWord;
+    Length: LongWord;
+    Flags: LongWord;
+    DebugFlags: LongWord;
+    ConsoleHandle: THandle;
+    ConsoleFlags: LongWord;
+    StandardInput: THandle;
+    StandardOutput: THandle;
+    StandardError: THandle;
+    CurrentDirectory: TCurDir;
+    DllPath: TNtUnicodeString;
+    ImagePathName: TNtUnicodeString;
+    CommandLine: TNtUnicodeString;
+    Environment: ^Word; // PWSTR
+    StartingX: LongWord;
+    StartingY: LongWord;
+    CountX: LongWord;
+    CountY: LongWord;
+    CountCharsX: LongWord;
+    CountCharsY: LongWord;
+    FillAttribute: LongWord;
+    WindowFlags: LongWord;
+    ShowWindowFlags: LongWord;
+    WindowTitle: TNtUnicodeString;
+    DesktopInfo: TNtUnicodeString;
+    ShellInfo: TNtUnicodeString;
+    RuntimeData: TNtUnicodeString;
+    CurrentDirectories: array[0..31] of TRtlDriveLetterCurDir;
+  end;
+  PRtlUserProcessParameters = ^TRtlUserProcessParameters;
+
+  TSimplePEB = packed record
+    InheritedAddressSpace: Byte;
+    ReadImageFileExecOptions: Byte;
+    BeingDebugged: Byte;
+//#if (NTDDI_VERSION >= NTDDI_WS03)
+//    struct
+    {
+        UCHAR ImageUsesLargePages:1;
+    #if (NTDDI_VERSION >= NTDDI_LONGHORN)
+        UCHAR IsProtectedProcess:1;
+        UCHAR IsLegacyProcess:1;
+        UCHAR SpareBits:5;
+    #else
+        UCHAR SpareBits:7;
+    #endif
+    }//;
+//#else
+    SpareBool: Byte;
+//#endif
+    Mutant: THandle;
+    ImageBaseAddress: Pointer;
+    Ldr: Pointer; // PPEB_LDR_DATA
+    ProcessParameters: PRtlUserProcessParameters;
+    SubSystemData: Pointer;
+    ProcessHeap: Pointer;
+//#if (NTDDI_VERSION >= NTDDI_LONGHORN)
+(*    struct _RTL_CRITICAL_SECTION *FastPebLock;
+    PVOID AltThunkSListPtr;
+    PVOID IFEOKey;
+    ULONG Spare;
+    union
+    {
+        PVOID* KernelCallbackTable;
+        PVOID UserSharedInfoPtr;
+    };
+    ULONG SystemReserved[1];
+    ULONG SpareUlong;*)
+//#else
+    FastPebLock: Pointer;
+    FastPebLockRoutine: Pointer; // PPEBLOCKROUTINE
+    FastPebUnlockRoutine: Pointer; // PPEBLOCKROUTINE
+    EnvironmentUpdateCount: LongWord;
+    KernelCallbackTable: Pointer; // PVOID*
+    EventLogSection: Pointer;
+    EventLog: Pointer;
+//#endif
+    FreeList: Pointer; // PPEB_FREE_BLOCK
+    TlsExpansionCounter: LongWord;
+    TlsBitmap: Pointer;
+    TlsBitmapBits: array[0..1] of LongWord; //TlsBitmapBits[0x2]
+    ReadOnlySharedMemoryBase: Pointer;
+    ReadOnlySharedMemoryHeap: Pointer;
+    ReadOnlyStaticServerData: Pointer; //PVOID*
+    AnsiCodePageData: Pointer;
+    OemCodePageData: Pointer;
+    UnicodeCaseTableData: Pointer;
+    NumberOfProcessors: LongWord;
+    NtGlobalFlag: LongWord;
+    CriticalSectionTimeout: Int64; // LARGE_INTEGER
+    HeapSegmentReserve: LongWord;
+    HeapSegmentCommit: LongWord;
+    HeapDeCommitTotalFreeThreshold: LongWord;
+    HeapDeCommitFreeBlockThreshold: LongWord;
+    NumberOfHeaps: LongWord;
+    MaximumNumberOfHeaps: LongWord;
+    ProcessHeaps: Pointer; // PVOID*
+    GdiSharedHandleTable: Pointer;
+    ProcessStarterHelper: Pointer;
+    GdiDCAttributeList: LongWord;
+//#if (NTDDI_VERSION >= NTDDI_LONGHORN)
+//    struct _RTL_CRITICAL_SECTION *LoaderLock;
+//#else
+    LoaderLock: Pointer;
+//#endif
+    OSMajorVersion: LongWord;
+    OSMinorVersion: LongWord;
+    OSBuildNumber: Word; // USHORT
+    OSCSDVersion: Word; // USHORT
+    OSPlatformId: LongWord;
+    ImageSubSystem: LongWord;
+    ImageSubSystemMajorVersion: LongWord;
+    ImageSubSystemMinorVersion: LongWord;
+    ImageProcessAffinityMask: LongWord;
+    GdiHandleBuffer: array[0..$21] of LongWord; // GdiHandleBuffer[0x22]
+    PostProcessInitRoutine: Pointer; //PPOST_PROCESS_INIT_ROUTINE
+    TlsExpansionBitmap: Pointer; //struct _RTL_BITMAP *TlsExpansionBitmap
+    TlsExpansionBitmapBits: array[0..$19] of Word; //TlsExpansionBitmapBits[0x20]
+    SessionId: LongWord;
+{#if (NTDDI_VERSION >= NTDDI_WINXP)
+    ULARGE_INTEGER AppCompatFlags;
+    ULARGE_INTEGER AppCompatFlagsUser;
+    PVOID pShimData;
+    PVOID AppCompatInfo;
+    UNICODE_STRING CSDVersion;
+    struct _ACTIVATION_CONTEXT_DATA *ActivationContextData;
+    struct _ASSEMBLY_STORAGE_MAP *ProcessAssemblyStorageMap;
+    struct _ACTIVATION_CONTEXT_DATA *SystemDefaultActivationContextData;
+    struct _ASSEMBLY_STORAGE_MAP *SystemAssemblyStorageMap;
+    ULONG MinimumStackCommit;
+#endif
+#if (NTDDI_VERSION >= NTDDI_WS03)
+    PVOID *FlsCallback;
+    LIST_ENTRY FlsListHead;
+    struct _RTL_BITMAP *FlsBitmap;
+    ULONG FlsBitmapBits[4];
+    ULONG FlsHighIndex;
+#endif
+#if (NTDDI_VERSION >= NTDDI_LONGHORN)
+    PVOID WerRegistrationData;
+    PVOID WerShipAssertPtr;
+#endif}
+  end;
+  PPEB = ^TSimplePEB;
+
+function NtDisplayString(aString: PNtUnicodeString): NTSTATUS; stdcall; external ntdll;
+

rtl/nativent/sysos.inc

@@ -0,0 +1,18 @@
+{
+    Basic stuff for NativeNT RTLs
+
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2009 by Sven Barth
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program 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.
+
+ **********************************************************************}
+
+// some needed types from NDK.pas
+{$include sysndk.inc}
+

rtl/nativent/sysosh.inc

@@ -0,0 +1,58 @@
+{
+    Basic Native NT stuff
+
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2009 by Sven Barth
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program 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.
+
+ **********************************************************************}
+
+{ Platform specific information }
+type
+  THandle = Pointer;
+  ULONG_PTR = PtrUInt;
+  TThreadID = THandle;
+  SIZE_T = ULONG_PTR;
+
+  { the fields of this record are os dependent  }
+  { and they shouldn't be used in a program     }
+  { only the type TCriticalSection is important }
+  PRTLCriticalSection = ^TRTLCriticalSection;
+  TRTLCriticalSection = packed record
+    DebugInfo : pointer;
+    LockCount : longint;
+    RecursionCount : longint;
+    OwningThread : THandle;
+    LockSemaphore : THandle;
+    SpinCount : ULONG_PTR;
+  end;
+
+var
+  { the following variables are only set if apptype=native and the RTL is
+    compiled with -dKMODE (device driver)
+    they are exported with their real types in unit DDK }
+  // real type: PNtUnicodeString; only valid during PascalMain
+  SysRegistryPath: Pointer = Nil;
+  // real type: PDriverObject; only valid during PascalMain
+  SysDriverObject: Pointer = Nil;
+
+type
+  TTagString = String[4];
+
+{$ifdef KMODE}
+const
+  DefaultPoolTag = 'fpc';
+
+var
+  // tells the heap whether to use paged memory or not
+  HeapUsePagedPool: Boolean = True;
+  // the tag is a four byte string to identify the memory allocated by our
+  // driver, which must not be empty
+  HeapPoolTag: TTagString = DefaultPoolTag;
+{$endif KMODE}

rtl/nativent/system.pp

@@ -0,0 +1,218 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2009 by Sven Barth
+
+    FPC Pascal system unit for the WinNT API.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program 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.
+
+ **********************************************************************}
+unit System;
+interface
+
+{$ifdef SYSTEMDEBUG}
+  {$define SYSTEMEXCEPTIONDEBUG}
+{$endif SYSTEMDEBUG}
+
+{.$define FPC_HAS_INDIRECT_MAIN_INFORMATION}
+
+{$ifdef cpui386}
+  {$define Set_i386_Exception_handler}
+{$endif cpui386}
+
+{.$define DISABLE_NO_THREAD_MANAGER}
+
+{$ifdef KMODE}
+  {$define HAS_MEMORYMANAGER}
+{$endif KMODE}
+
+{ include system-independent routine headers }
+{$I systemh.inc}
+
+var
+  CurrentPeb: Pointer;
+  IsDeviceDriver: Boolean = False;
+
+const
+ LineEnding = #13#10;
+ LFNSupport = true;
+ DirectorySeparator = '\';
+ DriveSeparator = '\';
+ ExtensionSeparator = '.';
+ PathSeparator = ';';
+ AllowDirectorySeparators : set of char = ['\'];
+ AllowDriveSeparators : set of char = [];
+
+{ FileNameCaseSensitive is defined separately below!!! }
+ maxExitCode = High(LongInt);
+ MaxPathLen = High(Word);
+ AllFilesMask = '*';
+
+type
+   PEXCEPTION_FRAME = ^TEXCEPTION_FRAME;
+   TEXCEPTION_FRAME = record
+     next : PEXCEPTION_FRAME;
+     handler : pointer;
+   end;
+
+{$ifndef kmode}
+type
+  TDLL_Entry_Hook = procedure (dllparam : longint);
+
+const
+  Dll_Process_Detach_Hook : TDLL_Entry_Hook = nil;
+  Dll_Thread_Attach_Hook : TDLL_Entry_Hook = nil;
+  Dll_Thread_Detach_Hook : TDLL_Entry_Hook = nil;
+{$endif}
+
+const
+  // NT is case sensitive
+  FileNameCaseSensitive : boolean = true;
+  // todo: check whether this is really the case on NT
+  CtrlZMarksEOF: boolean = true; (* #26 is considered as end of file *)
+
+  sLineBreak = LineEnding;
+
+  { Thread count for DLL }
+  Thread_count : longint = 0;
+  System_exception_frame : PEXCEPTION_FRAME =nil;
+
+implementation
+
+{ include system independent routines }
+{$I system.inc}
+
+procedure KeQueryTickCount(TickCount: PLargeInteger); stdcall; external ntdll name 'KeQueryTickCount';
+
+procedure randomize;
+var
+  tc: PLargeInteger;
+begin
+  FillChar(tc, SizeOf(TLargeInteger), 0);
+  KeQueryTickCount(@tc);
+  // the lower part should differ most on system startup
+  randseed := tc^.LowPart;
+end;
+
+{*****************************************************************************
+                         System Dependent Exit code
+*****************************************************************************}
+
+procedure PascalMain;stdcall;external name 'PASCALMAIN';
+
+{$ifndef KMODE}
+function NtTerminateProcess(aProcess: THandle; aStatus: NTSTATUS): NTSTATUS; stdcall; external ntdll name 'NtTerminateProcess';
+{$endif KMODE}
+
+Procedure system_exit;
+begin
+  if IsLibrary or IsDeviceDriver then
+    Exit;
+{$ifndef KMODE}
+  NtTerminateProcess(THandle(-1), ExitCode);
+{$endif KMODE}
+end;
+
+{$ifdef kmode}
+function FPCDriverStartup(aDriverObject: Pointer; aRegistryPath: Pointer): NTSTATUS; [public, alias: 'FPC_DriverStartup'];
+begin
+  IsDeviceDriver := True;
+  IsConsole := True;
+  IsLibrary := True;
+
+  SysDriverObject := aDriverObject;
+  SysRegistryPath := aRegistryPath;
+
+  PASCALMAIN;
+
+  SysDriverObject := Nil;
+  SysRegistryPath := Nil;
+
+  Result := ExitCode;
+end;
+{$else}
+
+const
+   DLL_PROCESS_ATTACH = 1;
+   DLL_THREAD_ATTACH = 2;
+   DLL_PROCESS_DETACH = 0;
+   DLL_THREAD_DETACH = 3;
+
+function FPCDLLEntry(aHInstance: Pointer; aDLLReason: LongInt; aDLLParam: LongInt): LongBool; [public, alias: 'FPC_DLLEntry'];
+begin
+  IsLibrary := True;
+  FPCDLLEntry := True;
+  case aDLLReason of
+    DLL_PROCESS_ATTACH: begin
+      PascalMain;
+      FPCDLLEntry := ExitCode = 0;
+    end;
+    DLL_THREAD_ATTACH: begin
+      if Dll_Thread_Attach_Hook <> Nil then
+        Dll_Thread_Attach_Hook(aDllParam);
+    end;
+    DLL_THREAD_DETACH: begin
+      if Dll_Thread_Detach_Hook <> Nil then
+        Dll_Thread_Detach_Hook(aDllParam);
+    end;
+    DLL_PROCESS_DETACH: begin
+      if Dll_Process_Detach_Hook <> Nil then
+        Dll_Process_Detach_Hook(aDllParam);
+      // finalize units
+      do_exit;
+    end;
+  end;
+end;
+
+procedure FPCProcessStartup(aArgument: Pointer);[public, alias: 'FPC_ProcessStartup'];
+begin
+  IsConsole := True;
+  IsLibrary := False;
+  CurrentPeb := aArgument;
+
+  PASCALMAIN;
+
+  system_exit;
+end;
+{$endif}
+
+{$ifdef kmode}
+
+// Kernel Mode Entry Point
+
+function NtDriverEntry( aDriverObject: Pointer; aRegistryPath: Pointer ): LongInt; stdcall; [public, alias: '_NtDriverEntry'];
+begin
+  NtDriverEntry := FPCDriverStartup(aDriverObject, aRegistryPath);
+end;
+{$else}
+
+// User Mode Entry Points
+
+procedure NtProcessStartup( aArgument: Pointer ); stdcall; [public, alias: '_NtProcessStartup'];
+begin
+  FPCProcessStartup(aArgument);
+end;
+
+function DLLMainStartup( aHInstance: Pointer; aDLLReason, aDLLParam: LongInt ): LongBool; stdcall; [public, alias: '_DLLMainStartup'];
+begin
+  DLLMainStartup := FPCDLLEntry(aHInstance, aDLLReason, aDLLParam);
+end;
+{$endif}
+
+begin
+{$if not defined(KMODE) and not defined(HAS_MEMORYMANAGER)}
+  { Setup heap }
+  InitHeap;
+{$endif ndef KMODE and ndef HAS_MEMORYMANAGER}
+  SysInitExceptions;
+  initvariantmanager;
+  { we do not use winlike widestrings and also the RTL can't be compiled with
+    2.2, so we can savely use the UnicodeString manager only. }
+  initunicodestringmanager;
+end.
+