sdongles/kolibrios
1
0
Fork 0
forked from KolibriOS/kolibrios
Code Pull Requests Activity

FreePascal RTL

Browse Source 
git-svn-id: svn://kolibrios.org@616 a494cfbc-eb01-0410-851d-a64ba20cac60
This commit is contained in:
bw 2007-08-29 09:16:31 +00:00
parent 34c712de5d
commit f23fc38433
27 changed files with 4758 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

346
programs/develop/fp/exe2kos/exe2kos.pp Normal file
View File

@ -0,0 +1,346 @@
{$mode objfpc}
{$apptype console}
program exe2kos;
uses
SysUtils, Classes, ExeTypes, KosTypes;
const
ARGS_SIZE = 512;
PATH_SIZE = 512;
type
EExeError = class(Exception);
TExeImage = class;
TExeImageSection = class;
TExeImageSection = class
private
FExeImage: TExeImage;
FHeader: IMAGE_SECTION_HEADER;
FName: String;
procedure Read(var Buffer);
public
constructor Create(AExeImage: TExeImage; APosition: DWord);
property Name: String read FName;
property VirtualSize: DWord read FHeader.PhysicalAddress;
property SectionRVA: DWord read FHeader.VirtualAddress;
property PhysicalSize: DWord read FHeader.SizeOfRawData;
property PhysicalOffset: DWord read FHeader.PointerToRawData;
property ObjectFlags: DWord read FHeader.Characteristics;
end;
TExeImageSections = class
private
FCount: DWord;
FItems: array of TExeImageSection;
function GetItem(Index: DWord): TExeImageSection;
public
constructor Create(AExeImage: TExeImage; APosition, ACount: DWord);
destructor Destroy; override;
function ByName(AName: String): TExeImageSection;
property Count: DWord read FCount;
property Items[Index: DWord]: TExeImageSection read GetItem; default;
end;
TExeImage = class
private
FFileName: String;
FFileStream: TStream;
FDosHeader: IMAGE_DOS_HEADER;
FNTHeader: IMAGE_NT_HEADERS;
FSections: TExeImageSections;
procedure Read(var Buffer; Position, Size: Longint);
function GetSizeOfCode(): DWord;
function GetSizeOfInitData(): DWord;
function GetSizeOfUnInitData(): DWord;
function GetEntryPoint(): DWord;
function GetImageBase(): DWord;
function GetObjectAlign(): DWord;
function GetFileAlign(): DWord;
function GetImageSize(): DWord;
function GetHeaderSize(): DWord;
function GetStackReserveSize(): DWord;
function GetStackCommitSize(): DWord;
function GetHeapReserveSize(): DWord;
function GetHeapCommitSize(): DWord;
public
constructor Create(AFileName: String);
destructor Destroy; override;
property FileName: String read FFileName;
property Sections: TExeImageSections read FSections;
property SizeOfCode: DWord read GetSizeOfCode;
property SizeOfInitializedData: DWord read GetSizeOfInitData;
property SizeOfUninitializedData: DWord read GetSizeOfUnInitData;
property EntryPoint: DWord read FNTHeader.OptionalHeader.AddressOfEntryPoint{GetEntryPoint};
property ImageBase: DWord read FNTHeader.OptionalHeader.ImageBase{GetImageBase};
property ObjectAlign: DWord read GetObjectAlign;
property FileAlign: DWord read GetFileAlign;
property ImageSize: DWord read GetImageSize;
property HeaderSize: DWord read GetHeaderSize;
property StackReserveSize: DWord read GetStackReserveSize;
property StackCommitSize: DWord read GetStackCommitSize;
property HeapReserveSize: DWord read GetHeapReserveSize;
property HeapCommitSize: DWord read GetHeapCommitSize;
end;
constructor TExeImage.Create(AFileName: String);
begin
FFileName := AFileName;
FFileStream := TFileStream.Create(FFileName, fmOpenRead);
Read(FDosHeader, 0, SizeOf(FDosHeader));
if not FDosHeader.e_magic = IMAGE_DOS_SIGNATURE then
EExeError.Create('Unrecognized file format');
Read(FNTHeader, FDosHeader.e_lfanew, SizeOf(FNTHeader));
if FNTHeader.Signature <> IMAGE_NT_SIGNATURE then
EExeError.Create('Not a PE (WIN32 Executable) file');
FSections := TExeImageSections.Create(Self,
FDosHeader.e_lfanew + SizeOf(FNTHeader), FNTHeader.FileHeader.NumberOfSections);
end;
destructor TExeImage.Destroy;
begin
FSections.Free;
FFileStream.Free;
end;
procedure TExeImage.Read(var Buffer; Position, Size: Longint);
begin
FFileStream.Position := Position;
if FFileStream.Read(Buffer, Size) <> Size then
EExeError.Create('Damaged or unrecognized file');
end;
function TExeImage.GetSizeOfCode(): DWord;
begin
Result := FNTHeader.OptionalHeader.SizeOfCode;
end;
function TExeImage.GetSizeOfInitData(): DWord;
begin
Result := FNTHeader.OptionalHeader.SizeOfInitializedData;
end;
function TExeImage.GetSizeOfUnInitData(): DWord;
begin
Result := FNTHeader.OptionalHeader.SizeOfUninitializedData;
end;
function TExeImage.GetEntryPoint(): DWord;
begin
Result := FNTHeader.OptionalHeader.AddressOfEntryPoint;
end;
function TExeImage.GetImageBase(): DWord;
begin
Result := FNTHeader.OptionalHeader.ImageBase;
end;
function TExeImage.GetObjectAlign(): DWord;
begin
Result := FNTHeader.OptionalHeader.SectionAlignment;
end;
function TExeImage.GetFileAlign(): DWord;
begin
Result := FNTHeader.OptionalHeader.FileAlignment;
end;
function TExeImage.GetImageSize(): DWord;
begin
Result := FNTHeader.OptionalHeader.SizeOfImage;
end;
function TExeImage.GetHeaderSize(): DWord;
begin
Result := FNTHeader.OptionalHeader.SizeOfHeaders;
end;
function TExeImage.GetStackReserveSize(): DWord;
begin
Result := FNTHeader.OptionalHeader.SizeOfStackReserve;
end;
function TExeImage.GetStackCommitSize(): DWord;
begin
Result := FNTHeader.OptionalHeader.SizeOfStackCommit;
end;
function TExeImage.GetHeapReserveSize(): DWord;
begin
Result := FNTHeader.OptionalHeader.SizeOfHeapReserve;
end;
function TExeImage.GetHeapCommitSize(): DWord;
begin
Result := FNTHeader.OptionalHeader.SizeOfHeapCommit;
end;
constructor TExeImageSections.Create(AExeImage: TExeImage; APosition, ACount: DWord);
var
i: Integer;
begin
FCount := ACount;
SetLength(FItems, ACount);
for i := 0 to ACount - 1 do
begin
FItems[i] := TExeImageSection.Create(AExeImage, APosition);
Inc(APosition, SizeOf(IMAGE_SECTION_HEADER));
end;
end;
destructor TExeImageSections.Destroy;
var
i: Integer;
begin
for i := 0 to Length(FItems) - 1 do FItems[i].Free;
SetLength(FItems, 0);
end;
function TExeImageSections.GetItem(Index: DWord): TExeImageSection;
begin
Result := FItems[Index];
end;
function TExeImageSections.ByName(AName: String): TExeImageSection;
var
i: Integer;
begin
for i := 0 to Length(FItems) - 1 do
if FItems[i].Name = AName then
begin
Result := FItems[i];
Exit;
end;
Result := nil;
end;
constructor TExeImageSection.Create(AExeImage: TExeImage; APosition: DWord);
begin
FExeImage := AExeImage;
FExeImage.Read(FHeader, APosition, SizeOf(FHeader));
FName := FHeader.Name;
end;
procedure TExeImageSection.Read(var Buffer);
begin
FExeImage.Read(Buffer, PhysicalOffset, PhysicalSize);
end;
procedure WriteHead(s: String);
var
i: Integer;
begin
WriteLn;
WriteLn(s);
for i:=1 to Length(s) do Write('-');
WriteLn;
end;
procedure Convert(InputFile, OutputFile: String);
var
ExeImage: TExeImage;
KosHeader: TKosHeader;
FileStream: TStream;
ImageBase, ImageSize, Size: DWord;
Buffer: Pointer;
i: Integer;
begin
ExeImage := TExeImage.Create(InputFile);
WriteHead('NT Header');
WriteLn(Format('Size of Code: %d', [ExeImage.SizeOfCode]));
WriteLn(Format('Size of Init Data: %d', [ExeImage.SizeOfInitializedData]));
WriteLn(Format('Size of UnInit Data: %d', [ExeImage.SizeOfUninitializedData]));
WriteLn(Format('Entry Point: 0x%x', [ExeImage.EntryPoint]));
WriteLn(Format('Image Base: 0x%x', [ExeImage.ImageBase]));
WriteLn(Format('Object Align: %d; File Align: %d', [ExeImage.ObjectAlign, ExeImage.FileAlign]));
WriteLn(Format('Image Size: %d; Header Size: %d', [ExeImage.ImageSize, ExeImage.HeaderSize]));
WriteLn(Format('Stack Reserve Size: %d; Stack Commit Size: %d', [ExeImage.StackReserveSize, ExeImage.StackCommitSize]));
WriteLn(Format('Heap Reserve Size: %d; Heap Comit Size: %d', [ExeImage.HeapReserveSize, ExeImage.HeapCommitSize]));
ImageBase := ExeImage.ImageBase;
ImageSize := 0;
{ çàïèñü ñåêöèé }
FileStream := TFileStream.Create(OutputFile, fmCreate);
for i:=0 to ExeImage.Sections.Count-1 do
with ExeImage.Sections[i] do
begin
WriteHead(Format('Section %s (0x%x)', [Name, ObjectFlags]));
WriteLn(Format('Section RVA/Size: 0x%x / %d', [SectionRVA, VirtualSize]));
WriteLn(Format('Physical Offset/Size: 0x%x / %d', [PhysicalOffset, PhysicalSize]));
Size := ImageBase + SectionRVA;
FileStream.Position := Size;
Inc(Size, VirtualSize);
if Size > ImageSize then ImageSize := Size;
if PhysicalSize > 0 then
begin
GetMem(Buffer, PhysicalSize);
Read(Buffer^);
FileStream.Write(Buffer^, PhysicalSize);
FreeMem(Buffer);
end;
{if VirtualSize - PhysicalSize > 0 then
begin
GetMem(Buffer, VirtualSize - PhysicalSize);
FillByte(Buffer^, VirtualSize - PhysicalSize, 0);
FileStream.Write(Buffer^, VirtualSize - PhysicalSize);
FreeMem(Buffer);
end;}
end;
FillByte(KosHeader, SizeOf(KosHeader), 0);
with KosHeader do
begin
sign := KOS_SIGN;
version := 1;
start := ImageBase + ExeImage.EntryPoint;
size := FileStream.Size;
args := ImageSize;
path := args + ARGS_SIZE;
stack := path + PATH_SIZE + ExeImage.StackReserveSize;
memory := stack;
end;
FileStream.Position := 0;
FileStream.Write(KosHeader, SizeOf(KosHeader));
FileStream.Free();
end;
var
InputFile, OutputFile: String;
begin
if ParamCount < 1 then
begin
WriteLn(Format('%s <exe input file> [kos output file]', [ExtractFileName(ParamStr(0))]));
Exit;
end;
InputFile := ParamStr(1);
if ParamCount <2 then
OutputFile := ChangeFileExt(InputFile, '') else
OutputFile := ParamStr(2);
if InputFile = OutputFile then
WriteLn(Format('Cannot convert the file "%s" onto itself.', [InputFile])) else
if not FileExists(InputFile) then
WriteLn(Format('Input the file "%s", not found.', [InputFile])) else
begin
WriteLn(Format('Converting "%s" to "%s"...', [InputFile, OutputFile]));
Convert(InputFile, OutputFile);
end;
end.

827
programs/develop/fp/exe2kos/exeimage.pp Normal file
View File

@ -0,0 +1,827 @@
{$mode delphi}
unit ExeImage;
interface
uses
TypInfo, Classes, SysUtils, Windows, RXTypes;
const
MF_END = $80;
type
{ Exceptions }
EExeError = class(Exception);
ENotImplemented = class(Exception)
public
constructor Create();
end;
{ Forward Declarations }
TResourceItem = class;
TResourceClass = class of TResourceItem;
TResourceList = class;
{ TExeImage }
TExeImage = class(TComponent)
private
FFileName: string;
FFileHandle: THandle;
FFileMapping: THandle;
FFileBase: Pointer;
FDosHeader: PIMAGE_DOS_HEADER;
FNTHeader: PIMAGE_NT_HEADERS;
FResourceList: TResourceList;
FIconResources: TResourceItem;
FCursorResources: TResourceItem;
FResourceBase: Longint;
FResourceRVA: Longint;
function GetResourceList: TResourceList;
function GetSectionHdr(const SectionName: string;
var Header: PIMAGE_SECTION_HEADER): Boolean;
public
constructor CreateImage(AOwner: TComponent; const AFileName: string);
destructor Destroy; override;
property FileName: string read FFileName;
property Resources: TResourceList read GetResourceList;
end;
{ TResourceItem }
TResourceItem = class(TComponent)
private
FList: TResourceList;
FDirEntry: PIMAGE_RESOURCE_DIRECTORY_ENTRY;
function DataEntry: PIMAGE_RESOURCE_DATA_ENTRY;
function FExeImage: TExeImage;
function FirstChildDirEntry: PIMAGE_RESOURCE_DIRECTORY_ENTRY;
function GetResourceItem(Index: Integer): TResourceItem;
function GetResourceType: TResourceType;
protected
function GetName: string; virtual;
function GetResourceList: TResourceList; virtual;
public
constructor CreateItem(AOwner: TComponent; ADirEntry: Pointer);
function IsList: Boolean; virtual;
function Offset: Integer;
function Size: Integer;
function RawData: Pointer;
function ResTypeStr: string;
procedure SaveToFile(const FileName: string);
procedure SaveToStream(Stream: TStream); virtual;
property Items[Index: Integer]: TResourceItem read GetResourceItem; default;
property List: TResourceList read GetResourceList;
property Name: string read GetName;
property ResType: TResourceType read GetResourceType;
end;
{ TIconResource }
TIconResource = class(TResourceItem)
protected
function GetResourceList: TResourceList; override;
public
function IsList: Boolean; override;
end;
{ TIconResEntry }
TIconResEntry = class(TResourceItem)
protected
FResInfo: PIconResInfo;
function GetName: string; override;
procedure AssignTo(Dest: TPersistent); override;
public
procedure SaveToStream(Stream: TStream); override;
end;
{ TCursorResource }
TCursorResource = class(TIconResource)
protected
function GetResourceList: TResourceList; override;
end;
{ TCursorResEntry }
TCursorResEntry = class(TIconResEntry)
protected
FResInfo: PCursorResInfo;
function GetName: string; override;
end;
{ TBitmapResource }
TBitmapResource = class(TResourceItem)
protected
procedure AssignTo(Dest: TPersistent); override;
public
procedure SaveToStream(Stream: TStream); override;
end;
{ TStringResource }
TStringResource = class(TResourceItem)
protected
procedure AssignTo(Dest: TPersistent); override;
end;
{ TMenuResource }
TMenuResource = class(TResourceItem)
private
FNestStr: string;
FNestLevel: Integer;
procedure SetNestLevel(Value: Integer);
protected
procedure AssignTo(Dest: TPersistent); override;
property NestLevel: Integer read FNestLevel write SetNestLevel;
property NestStr: string read FNestStr;
end;
{ TResourceList }
TResourceList = class(TComponent)
protected
FList: TList;
FResDir: PIMAGE_RESOURCE_DIRECTORY;
FExeImage: TExeImage;
FResType: Integer;
function List: TList; virtual;
function GetResourceItem(Index: Integer): TResourceItem;
public
constructor CreateList(AOwner: TComponent; ResDirOfs: Longint;
AExeImage: TExeImage);
destructor Destroy; override;
function Count: Integer;
property Items[Index: Integer]: TResourceItem read GetResourceItem; default;
end;
{ TIconResourceList }
TIconResourceList = class(TResourceList)
protected
function List: TList; override;
end;
{ TCursorResourceList }
TCursorResourceList = class(TResourceList)
protected
function List: TList; override;
end;
implementation
constructor ENotImplemented.Create();
begin
inherited Create('Not Implemented');
end;
{ This function maps a resource type to the associated resource class }
function GetResourceClass(ResType: Integer): TResourceClass;
const
TResourceClasses: array[TResourceType] of TResourceClass = (
TResourceItem, { rtUnknown0 }
TCursorResEntry, { rtCursorEntry }
TBitmapResource, { rtBitmap }
TIconResEntry, { rtIconEntry }
TMenuResource, { rtMenu }
TResourceItem, { rtDialog }
TStringResource, { rtString }
TResourceItem, { rtFontDir }
TResourceItem, { rtFont }
TResourceItem, { rtAccelerators }
TResourceItem, { rtRCData }
TResourceItem, { rtMessageTable }
TCursorResource, { rtGroupCursor }
TResourceItem, { rtUnknown13 }
TIconResource, { rtIcon }
TResourceItem, { rtUnknown15 }
TResourceItem); { rtVersion }
begin
if (ResType >= Integer(Low(TResourceType))) and
(ResType <= Integer(High(TResourceType))) then
Result := TResourceClasses[TResourceType(ResType)] else
Result := TResourceItem;
end;
{ Utility Functions }
function Min(A, B: Integer): Integer;
begin
if A < B then Result := A
else Result := B;
end;
{ This function checks if an offset is a string name, or a directory }
{Assumes: IMAGE_RESOURCE_NAME_IS_STRING = IMAGE_RESOURCE_DATA_IS_DIRECTORY}
function HighBitSet(L: Longint): Boolean;
begin
Result := (L and IMAGE_RESOURCE_DATA_IS_DIRECTORY) <> 0;
end;
function StripHighBit(L: Longint): Longint;
begin
Result := L and IMAGE_OFFSET_STRIP_HIGH;
end;
function StripHighPtr(L: Longint): Pointer;
begin
Result := Pointer(L and IMAGE_OFFSET_STRIP_HIGH);
end;
{ This function converts a pointer to a wide char string into a pascal string }
function WideCharToStr(WStr: PWChar; Len: Integer): string;
begin
if Len = 0 then Len := -1;
Len := WideCharToMultiByte(CP_ACP, 0, WStr, Len, nil, 0, nil, nil);
SetLength(Result, Len);
WideCharToMultiByte(CP_ACP, 0, WStr, Len, PChar(Result), Len, nil, nil);
end;
{ Exceptions }
procedure ExeError(const ErrMsg: string);
begin
raise EExeError.Create(ErrMsg);
end;
{ TExeImage }
constructor TExeImage.CreateImage(AOwner: TComponent; const AFileName: string);
begin
inherited Create(AOwner);
FFileName := AFileName;
FFileHandle := CreateFile(PChar(FFileName), GENERIC_READ, FILE_SHARE_READ,
nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if FFileHandle = INVALID_HANDLE_VALUE then ExeError('Couldn''t open: '+FFileName);
FFileMapping := CreateFileMapping(FFileHandle, nil, PAGE_READONLY, 0, 0, nil);
if FFileMapping = 0 then ExeError('CreateFileMapping failed');
FFileBase := MapViewOfFile(FFileMapping, FILE_MAP_READ, 0, 0, 0);
if FFileBase = nil then ExeError('MapViewOfFile failed');
FDosHeader := PIMAGE_DOS_HEADER(FFileBase);
if not FDosHeader.e_magic = IMAGE_DOS_SIGNATURE then
ExeError('unrecognized file format');
FNTHeader := PIMAGE_NT_HEADERS(Longint(FDosHeader) + FDosHeader.e_lfanew);
if IsBadReadPtr(FNTHeader, sizeof(IMAGE_NT_HEADERS)) or
(FNTHeader.Signature <> IMAGE_NT_SIGNATURE) then
ExeError('Not a PE (WIN32 Executable) file');
end;
destructor TExeImage.Destroy;
begin
if FFileHandle <> INVALID_HANDLE_VALUE then
begin
UnmapViewOfFile(FFileBase);
CloseHandle(FFileMapping);
CloseHandle(FFileHandle);
end;
inherited Destroy;
end;
function TExeImage.GetSectionHdr(const SectionName: string;
var Header: PIMAGE_SECTION_HEADER): Boolean;
var
I: Integer;
begin
Header := PIMAGE_SECTION_HEADER(FNTHeader);
Inc(PIMAGE_NT_HEADERS(Header));
Result := True;
for I := 0 to FNTHeader.FileHeader.NumberOfSections - 1 do
begin
if Strlicomp(Header.Name, PChar(SectionName), IMAGE_SIZEOF_SHORT_NAME) = 0 then Exit;
Inc(Header);
end;
Result := False;
end;
function TExeImage.GetResourceList: TResourceList;
var
ResSectHdr: PIMAGE_SECTION_HEADER;
begin
if not Assigned(FResourceList) then
begin
if GetSectionHdr('.rsrc', ResSectHdr) then
begin
FResourceBase := ResSectHdr.PointerToRawData + LongWord(FDosHeader);
FResourceRVA := ResSectHdr.VirtualAddress;
FResourceList := TResourceList.CreateList(Self, FResourceBase, Self);
end
else
ExeError('No resources in this file.');
end;
Result := FResourceList;
end;
{ TResourceItem }
constructor TResourceItem.CreateItem(AOwner: TComponent; ADirEntry: Pointer);
begin
inherited Create(AOwner);
FDirEntry := ADirEntry;
end;
function TResourceItem.DataEntry: PIMAGE_RESOURCE_DATA_ENTRY;
begin
Result := PIMAGE_RESOURCE_DATA_ENTRY(FirstChildDirEntry.OffsetToData
+ Cardinal(FExeImage.FResourceBase));
end;
function TResourceItem.FirstChildDirEntry: PIMAGE_RESOURCE_DIRECTORY_ENTRY;
begin
Result := PIMAGE_RESOURCE_DIRECTORY_ENTRY(StripHighBit(FDirEntry.OffsetToData) +
FExeImage.FResourceBase + SizeOf(IMAGE_RESOURCE_DIRECTORY));
end;
function TResourceItem.FExeImage: TExeImage;
begin
Result := (Owner as TResourceList).FExeImage;
end;
function TResourceItem.GetResourceItem(Index: Integer): TResourceItem;
begin
Result := List[Index];
end;
function TResourceItem.GetResourceType: TResourceType;
begin
Result := TResourceType((Owner as TResourceList).FResType);
end;
function TResourceItem.IsList: Boolean;
begin
Result := HighBitSet(FirstChildDirEntry.OffsetToData);
end;
function TResourceItem.GetResourceList: TResourceList;
begin
if not IsList then ExeError('ResourceItem is not a list');
if not Assigned(FList) then
FList := TResourceList.CreateList(Self, StripHighBit(FDirEntry.OffsetToData) +
FExeImage.FResourceBase, FExeImage);
Result := FList;
end;
function TResourceItem.GetName: string;
var
PDirStr: PIMAGE_RESOURCE_DIR_STRING_U;
begin
{ Check for Level1 entries, these are resource types. }
if (Owner.Owner = FExeImage) and not HighBitSet(FDirEntry.Name) and
(FDirEntry.Name <= 16) then
begin
Result := Copy(GetEnumName(TypeInfo(TResourceType), FDirEntry.Name), 3, 20);
Exit;
end;
if HighBitSet(FDirEntry.Name) then
begin
PDirStr := PIMAGE_RESOURCE_DIR_STRING_U(StripHighBit(FDirEntry.Name) +
FExeImage.FResourceBase);
Result := WideCharToStr(@PDirStr.NameString, PDirStr.Length);
Exit;
end;
Result := Format('%d', [FDirEntry.Name]);
end;
function TResourceItem.Offset: Integer;
begin
if IsList then
Result := StripHighBit(FDirEntry.OffsetToData)
else
Result := DataEntry.OffsetToData;
end;
function TResourceItem.RawData: Pointer;
begin
with FExeImage do
Result := pointer(FResourceBase - FResourceRVA + LongInt(DataEntry.OffsetToData));
end;
function TResourceItem.ResTypeStr: string;
begin
Result := Copy(GetEnumName(TypeInfo(TResourceType), Ord(ResType)), 3, 20);
end;
procedure TResourceItem.SaveToFile(const FileName: string);
var
FS: TFileStream;
begin
FS := TFileStream.Create(FileName, fmCreate);
try
Self.SaveToStream(FS);
finally
FS.Free;
end;
end;
procedure TResourceItem.SaveToStream(Stream: TStream);
begin
Stream.Write(RawData^, Size);
end;
function TResourceItem.Size: Integer;
begin
if IsList then
Result := 0
else
Result := DataEntry.Size;
end;
{ TBitmapResource }
procedure TBitmapResource.AssignTo(Dest: TPersistent);
{var
MemStr: TMemoryStream;
BitMap: TBitMap;}
begin
raise ENotImplemented.Create();
{if (Dest is TPicture) then
begin
BitMap := TPicture(Dest).Bitmap;
MemStr := TMemoryStream.Create;
try
SaveToStream(MemStr);
MemStr.Seek(0,0);
BitMap.LoadFromStream(MemStr);
finally
MemStr.Free;
end
end
else
inherited AssignTo(Dest);}
end;
procedure TBitmapResource.SaveToStream(Stream: TStream);
{function GetDInColors(BitCount: Word): Integer;
begin
case BitCount of
1, 4, 8: Result := 1 shl BitCount;
else
Result := 0;
end;
end;
var
BH: TBitmapFileHeader;
BI: PBitmapInfoHeader;
BC: PBitmapCoreHeader;
ClrUsed: Integer;}
begin
raise ENotImplemented.Create();
{FillChar(BH, sizeof(BH), #0);
BH.bfType := $4D42;
BH.bfSize := Self.Size + sizeof(BH);
BI := PBitmapInfoHeader(RawData);
if BI.biSize = sizeof(TBitmapInfoHeader) then
begin
ClrUsed := BI.biClrUsed;
if ClrUsed = 0 then
ClrUsed := GetDInColors(BI.biBitCount);
BH.bfOffBits := ClrUsed * SizeOf(TRgbQuad) +
sizeof(TBitmapInfoHeader) + sizeof(BH);
end
else
begin
BC := PBitmapCoreHeader(RawData);
ClrUsed := GetDInColors(BC.bcBitCount);
BH.bfOffBits := ClrUsed * SizeOf(TRGBTriple) +
sizeof(TBitmapCoreHeader) + sizeof(BH);
end;
Stream.Write(BH, SizeOf(BH));
Stream.Write(RawData^, Self.Size);}
end;
{ TIconResource }
function TIconResource.GetResourceList: TResourceList;
begin
if not Assigned(FList) then
FList := TIconResourceList.CreateList(Owner, LongInt(RawData), FExeImage);
Result := FList;
end;
function TIconResource.IsList: Boolean;
begin
Result := True;
end;
{ TIconResEntry }
procedure TIconResEntry.AssignTo(Dest: TPersistent);
{var
hIco: HIcon;}
begin
raise ENotImplemented.Create();
{if Dest is TPicture then
begin
hIco := CreateIconFromResource(RawData, Size, (ResType = rtIconEntry), $30000);
TPicture(Dest).Icon.Handle := hIco;
end
else
inherited AssignTo(Dest);}
end;
function TIconResEntry.GetName: string;
begin
if Assigned(FResInfo) then
with FResInfo^ do
Result := Format('%d X %d %d Colors', [bWidth, bHeight, bColorCount])
else
Result := inherited GetName;
end;
procedure TIconResEntry.SaveToStream(Stream: TStream);
begin
raise ENotImplemented.Create();
{with TIcon.Create do
try
Handle := CreateIconFromResource(RawData, Self.Size, (ResType <> rtIcon), $30000);
SaveToStream(Stream);
finally
Free;
end;}
end;
{ TCursorResource }
function TCursorResource.GetResourceList: TResourceList;
begin
if not Assigned(FList) then
FList := TCursorResourceList.CreateList(Owner, LongInt(RawData), FExeImage);
Result := FList;
end;
{ TCursorResEntry }
function TCursorResEntry.GetName: string;
begin
if Assigned(FResInfo) then
with FResInfo^ do
Result := Format('%d X %d %d Bit(s)', [wWidth, wWidth, wBitCount])
else
Result := inherited GetName;
end;
{ TStringResource }
procedure TStringResource.AssignTo(Dest: TPersistent);
var
P: PWChar;
ID: Integer;
Cnt: Cardinal;
Len: Word;
begin
if (Dest is TStrings) then
with TStrings(Dest) do
begin
BeginUpdate;
try
Clear;
P := RawData;
Cnt := 0;
while Cnt < StringsPerBlock do
begin
Len := Word(P^);
if Len > 0 then
begin
Inc(P);
ID := ((FDirEntry.Name - 1) shl 4) + Cnt;
Add(Format('%d, "%s"', [ID, WideCharToStr(P, Len)]));
Inc(P, Len);
end;
Inc(Cnt);
end;
finally
EndUpdate;
end;
end
else
inherited AssignTo(Dest);
end;
{ TMenuResource }
procedure TMenuResource.SetNestLevel(Value: Integer);
begin
FNestLevel := Value;
SetLength(FNestStr, Value * 2);
FillChar(FNestStr[1], Value * 2, ' ');
end;
procedure TMenuResource.AssignTo(Dest: TPersistent);
var
IsPopup: Boolean;
Len: Word;
MenuData: PWord;
MenuEnd: PChar;
MenuText: PWChar;
MenuID: Word;
MenuFlags: Word;
S: string;
begin
if (Dest is TStrings) then
with TStrings(Dest) do
begin
BeginUpdate;
try
Clear;
MenuData := RawData;
MenuEnd := PChar(RawData) + Size;
Inc(MenuData, 2);
NestLevel := 0;
while PChar(MenuData) < MenuEnd do
begin
MenuFlags := MenuData^;
Inc(MenuData);
IsPopup := (MenuFlags and MF_POPUP) = MF_POPUP;
MenuID := 0;
if not IsPopup then
begin
MenuID := MenuData^;
Inc(MenuData);
end;
MenuText := PWChar(MenuData);
Len := lstrlenw(MenuText);
if Len = 0 then
S := 'MENUITEM SEPARATOR'
else
begin
S := WideCharToStr(MenuText, Len);
if IsPopup then
S := Format('POPUP "%s"', [S]) else
S := Format('MENUITEM "%s", %d', [S, MenuID]);
end;
Inc(MenuData, Len + 1);
Add(NestStr + S);
if (MenuFlags and MF_END) = MF_END then
begin
NestLevel := NestLevel - 1;
Add(NestStr + 'ENDPOPUP');
end;
if IsPopup then
NestLevel := NestLevel + 1;
end;
finally
EndUpdate;
end;
end
else
inherited AssignTo(Dest);
end;
{ TResourceList }
constructor TResourceList.CreateList(AOwner: TComponent; ResDirOfs: Longint;
AExeImage: TExeImage);
var
DirEntry: PIMAGE_RESOURCE_DIRECTORY_ENTRY;
begin
inherited Create(AOwner);
FExeImage := AExeImage;
FResDir := Pointer(ResDirOfs);
if AOwner <> AExeImage then
if AOwner.Owner.Owner = AExeImage then
begin
DirEntry := PIMAGE_RESOURCE_DIRECTORY_ENTRY(FResDir);
inc(PIMAGE_RESOURCE_DIRECTORY(DirEntry));
FResType := TResourceItem(Owner).FDirEntry.Name;
end
else
FResType := (AOwner.Owner.Owner as TResourceList).FResType;
end;
destructor TResourceList.Destroy;
begin
inherited Destroy;
FList.Free;
end;
function TResourceList.List: TList;
var
I: Integer;
DirEntry: PIMAGE_RESOURCE_DIRECTORY_ENTRY;
DirCnt: Integer;
ResItem: TResourceItem;
begin
if not Assigned(FList) then
begin
FList := TList.Create;
DirEntry := PIMAGE_RESOURCE_DIRECTORY_ENTRY(FResDir);
inc(PIMAGE_RESOURCE_DIRECTORY(DirEntry));
DirCnt := FResDir.NumberOfNamedEntries + FResDir.NumberOfIdEntries - 1;
for I := 0 to DirCnt do
begin
{ Handle Cursors and Icons specially }
ResItem := GetResourceClass(FResType).CreateItem(Self, DirEntry);
if Owner = FExeImage then
if (TResourceType(DirEntry.Name) in [rtCursorEntry, rtIconEntry]) then
begin
if TResourceType(DirEntry.Name) = rtCursorEntry then
FExeImage.FCursorResources := ResItem else
FExeImage.FIconResources := ResItem;
Inc(DirEntry);
Continue;
end;
FList.Add(ResItem);
Inc(DirEntry);
end;
end;
Result := FList;
end;
function TResourceList.Count: Integer;
begin
Result := List.Count;
end;
function TResourceList.GetResourceItem(Index: Integer): TResourceItem;
begin
Result := List[Index];
end;
{ TIconResourceList }
function TIconResourceList.List: TList;
var
I, J, Cnt: Integer;
ResData: PIconResInfo;
ResList: TResourceList;
ResOrd: Cardinal;
IconResource: TIconResEntry;
begin
if not Assigned(FList) then
begin
FList := TList.Create;
Cnt := PIconHeader(FResDir).wCount;
PChar(ResData) := PChar(FResDir) + SizeOf(TIconHeader);
ResList := FExeImage.FIconResources.List;
for I := 0 to Cnt - 1 do
begin
ResOrd := ResData.wNameOrdinal;
for J := 0 to ResList.Count - 1 do
begin
if ResOrd = ResList[J].FDirEntry.Name then
begin
IconResource := ResList[J] as TIconResEntry;
IconResource.FResInfo := ResData;
FList.Add(IconResource);
end;
end;
Inc(ResData);
end;
end;
Result := FList;
end;
{ TCursorResourceList }
function TCursorResourceList.List: TList;
var
I, J, Cnt: Integer;
ResData: PCursorResInfo;
ResList: TResourceList;
ResOrd: Cardinal;
CursorResource: TCursorResEntry;
begin
if not Assigned(FList) then
begin
FList := TList.Create;
Cnt := PIconHeader(FResDir).wCount;
PChar(ResData) := PChar(FResDir) + SizeOf(TIconHeader);
ResList := FExeImage.FCursorResources.List;
for I := 0 to Cnt - 1 do
begin
ResOrd := ResData.wNameOrdinal;
for J := 0 to ResList.Count - 1 do
begin
if ResOrd = ResList[J].FDirEntry.Name then
begin
CursorResource := ResList[J] as TCursorResEntry;
CursorResource.FResInfo := ResData;
FList.Add(CursorResource);
end;
end;
Inc(ResData);
end;
end;
Result := FList;
end;
end.

235
programs/develop/fp/exe2kos/exetypes.pp Normal file
View File

@ -0,0 +1,235 @@
unit EXETypes;
interface
const
IMAGE_DOS_SIGNATURE = $5A4D; { MZ }
IMAGE_OS2_SIGNATURE = $454E; { NE }
IMAGE_OS2_SIGNATURE_LE = $454C; { LE }
IMAGE_VXD_SIGNATURE = $454C; { LE }
IMAGE_NT_SIGNATURE = $00004550; { PE00 }
IMAGE_SIZEOF_SHORT_NAME = 8;
IMAGE_SIZEOF_SECTION_HEADER = 40;
IMAGE_NUMBEROF_DIRECTORY_ENTRIES = 16;
IMAGE_RESOURCE_NAME_IS_STRING = $80000000;
IMAGE_RESOURCE_DATA_IS_DIRECTORY = $80000000;
IMAGE_OFFSET_STRIP_HIGH = $7FFFFFFF;
type
PIMAGE_DOS_HEADER = ^IMAGE_DOS_HEADER;
IMAGE_DOS_HEADER = packed record { DOS .EXE header }
e_magic : WORD; { Magic number }
e_cblp : WORD; { Bytes on last page of file }
e_cp : WORD; { Pages in file }
e_crlc : WORD; { Relocations }
e_cparhdr : WORD; { Size of header in paragraphs }
e_minalloc : WORD; { Minimum extra paragraphs needed }
e_maxalloc : WORD; { Maximum extra paragraphs needed }
e_ss : WORD; { Initial (relative) SS value }
e_sp : WORD; { Initial SP value }
e_csum : WORD; { Checksum }
e_ip : WORD; { Initial IP value }
e_cs : WORD; { Initial (relative) CS value }
e_lfarlc : WORD; { File address of relocation table }
e_ovno : WORD; { Overlay number }
e_res : packed array [0..3] of WORD; { Reserved words }
e_oemid : WORD; { OEM identifier (for e_oeminfo) }
e_oeminfo : WORD; { OEM information; e_oemid specific }
e_res2 : packed array [0..9] of WORD; { Reserved words }
e_lfanew : Longint; { File address of new exe header }
end;
PIMAGE_FILE_HEADER = ^IMAGE_FILE_HEADER;
IMAGE_FILE_HEADER = packed record
Machine : WORD;
NumberOfSections : WORD;
TimeDateStamp : DWORD;
PointerToSymbolTable : DWORD;
NumberOfSymbols : DWORD;
SizeOfOptionalHeader : WORD;
Characteristics : WORD;
end;
PIMAGE_DATA_DIRECTORY = ^IMAGE_DATA_DIRECTORY;
IMAGE_DATA_DIRECTORY = packed record
VirtualAddress : DWORD;
Size : DWORD;
end;
PIMAGE_OPTIONAL_HEADER = ^IMAGE_OPTIONAL_HEADER;
IMAGE_OPTIONAL_HEADER = packed record
{ Standard fields. }
Magic : WORD;
MajorLinkerVersion : Byte;
MinorLinkerVersion : Byte;
SizeOfCode : DWORD;
SizeOfInitializedData : DWORD;
SizeOfUninitializedData : DWORD;
AddressOfEntryPoint : DWORD;
BaseOfCode : DWORD;
BaseOfData : DWORD;
{ NT additional fields. }
ImageBase : DWORD;
SectionAlignment : DWORD;
FileAlignment : DWORD;
MajorOperatingSystemVersion : WORD;
MinorOperatingSystemVersion : WORD;
MajorImageVersion : WORD;
MinorImageVersion : WORD;
MajorSubsystemVersion : WORD;
MinorSubsystemVersion : WORD;
Reserved1 : DWORD;
SizeOfImage : DWORD;
SizeOfHeaders : DWORD;
CheckSum : DWORD;
Subsystem : WORD;
DllCharacteristics : WORD;
SizeOfStackReserve : DWORD;
SizeOfStackCommit : DWORD;
SizeOfHeapReserve : DWORD;
SizeOfHeapCommit : DWORD;
LoaderFlags : DWORD;
NumberOfRvaAndSizes : DWORD;
DataDirectory : packed array [0..IMAGE_NUMBEROF_DIRECTORY_ENTRIES-1] of IMAGE_DATA_DIRECTORY;
end;
PIMAGE_SECTION_HEADER = ^IMAGE_SECTION_HEADER;
IMAGE_SECTION_HEADER = packed record
Name : packed array [0..IMAGE_SIZEOF_SHORT_NAME-1] of Char;
PhysicalAddress : DWORD; // or VirtualSize (union);
VirtualAddress : DWORD;
SizeOfRawData : DWORD;
PointerToRawData : DWORD;
PointerToRelocations : DWORD;
PointerToLinenumbers : DWORD;
NumberOfRelocations : WORD;
NumberOfLinenumbers : WORD;
Characteristics : DWORD;
end;
PIMAGE_NT_HEADERS = ^IMAGE_NT_HEADERS;
IMAGE_NT_HEADERS = packed record
Signature : DWORD;
FileHeader : IMAGE_FILE_HEADER;
OptionalHeader : IMAGE_OPTIONAL_HEADER;
end;
{ Resources }
PIMAGE_RESOURCE_DIRECTORY = ^IMAGE_RESOURCE_DIRECTORY;
IMAGE_RESOURCE_DIRECTORY = packed record
Characteristics : DWORD;
TimeDateStamp : DWORD;
MajorVersion : WORD;
MinorVersion : WORD;
NumberOfNamedEntries : WORD;
NumberOfIdEntries : WORD;
end;
PIMAGE_RESOURCE_DIRECTORY_ENTRY = ^IMAGE_RESOURCE_DIRECTORY_ENTRY;
IMAGE_RESOURCE_DIRECTORY_ENTRY = packed record
Name: DWORD; // Or ID: Word (Union)
OffsetToData: DWORD;
end;
PIMAGE_RESOURCE_DATA_ENTRY = ^IMAGE_RESOURCE_DATA_ENTRY;
IMAGE_RESOURCE_DATA_ENTRY = packed record
OffsetToData : DWORD;
Size : DWORD;
CodePage : DWORD;
Reserved : DWORD;
end;
PIMAGE_RESOURCE_DIR_STRING_U = ^IMAGE_RESOURCE_DIR_STRING_U;
IMAGE_RESOURCE_DIR_STRING_U = packed record
Length : WORD;
NameString : array [0..0] of WCHAR;
end;
{
/* Predefined resource types */
#define RT_NEWRESOURCE 0x2000
#define RT_ERROR 0x7fff
#define RT_CURSOR 1
#define RT_BITMAP 2
#define RT_ICON 3
#define RT_MENU 4
#define RT_DIALOG 5
#define RT_STRING 6
#define RT_FONTDIR 7
#define RT_FONT 8
#define RT_ACCELERATORS 9
#define RT_RCDATA 10
#define RT_MESSAGETABLE 11
#define RT_GROUP_CURSOR 12
#define RT_GROUP_ICON 14
#define RT_VERSION 16
#define RT_NEWBITMAP (RT_BITMAP|RT_NEWRESOURCE)
#define RT_NEWMENU (RT_MENU|RT_NEWRESOURCE)
#define RT_NEWDIALOG (RT_DIALOG|RT_NEWRESOURCE)
}
type
TResourceType = (
rtUnknown0,
rtCursorEntry,
rtBitmap,
rtIconEntry,
rtMenu,
rtDialog,
rtString,
rtFontDir,
rtFont,
rtAccelerators,
rtRCData,
rtMessageTable,
rtCursor,
rtUnknown13,
rtIcon,
rtUnknown15,
rtVersion);
{ Resource Type Constants }
const
StringsPerBlock = 16;
{ Resource Related Structures from RESFMT.TXT in WIN32 SDK }
type
PIconHeader = ^TIconHeader;
TIconHeader = packed record
wReserved: Word; { Currently zero }
wType: Word; { 1 for icons }
wCount: Word; { Number of components }
end;
PIconResInfo = ^TIconResInfo;
TIconResInfo = packed record
bWidth: Byte;
bHeight: Byte;
bColorCount: Byte;
bReserved: Byte;
wPlanes: Word;
wBitCount: Word;
lBytesInRes: DWORD;
wNameOrdinal: Word; { Points to component }
end;
PCursorResInfo = ^TCursorResInfo;
TCursorResInfo = packed record
wWidth: Word;
wHeight: Word;
wPlanes: Word;
wBitCount: Word;
lBytesInRes: DWORD;
wNameOrdinal: Word; { Points to component }
end;
implementation
end.

23
programs/develop/fp/exe2kos/kostypes.pp Normal file
View File

@ -0,0 +1,23 @@
unit KOSTypes;
interface
type
TKosSign = array[0..7] of Byte;
TKosHeader = packed record
sign : TKOSSign;
version: DWord;
start : DWord;
size : DWord;
memory : DWord;
stack : DWord;
args : DWord;
path : DWord;
end;
const
KOS_SIGN: TKOSSign = ($4D, $45, $4E, $55, $45, $54, $30, $31);
implementation
end.

3
programs/develop/fp/readme-ru.txt Normal file
View File

@ -0,0 +1,3 @@
Codepage: koi8-r
Комментарии будут позже.

9
programs/develop/fp/rtl/_defines.inc Normal file
View File

@ -0,0 +1,9 @@
{$undef mswindows}
{$undef windows}
{$undef Windows}
{$undef win32}
{$undef os2}
{$undef linux}
{$define EMULATOR}
{$undef debug_mt}

20
programs/develop/fp/rtl/build.bat Normal file
View File

@ -0,0 +1,20 @@
@echo off
set FPRTL={path to original freepascal rtl source code, example ... \fp\src\rtl}
set INCS=-Fi%FPRTL%\inc;%FPRTL%\i386;%FPRTL%\objpas;%FPRTL%\objpas\sysutils;%FPRTL%\objpas\classes
set UNTS=-Fu%FPRTL%\inc;%FPRTL%\i386;%FPRTL%\objpas
set FPCARGS=-Twin32 -Se5 -Sg -n -O3pPENTIUM3 -CfSSE -di386 -FU..\units %INCS% %UNTS%
fpc system.pp -Us %FPCARGS%
if errorlevel 1 goto error
fpc %FPRTL%\objpas\objpas.pp %FPCARGS%
if errorlevel 1 goto error
fpc buildrtl.pp %FPCARGS%
if errorlevel 0 goto end
:error
echo An error occured while building RTL
:end

20
programs/develop/fp/rtl/buildrtl.pp Normal file
View File

@ -0,0 +1,20 @@
unit buildrtl;
interface
uses
sysinitpas, {sysinitcyg, sysinitgprof,}
ctypes, strings,
lineinfo, lnfodwrf, 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};
implementation
end.

26
programs/develop/fp/rtl/classes.pp Normal file
View File

@ -0,0 +1,26 @@
{$mode objfpc}
unit Classes;
{$i _defines.inc}
interface
uses
RTLConsts, SysUtils, Types, TypInfo;
{$i classesh.inc}
implementation
uses
SysConst;
{ OS - independent class implementations are in /inc directory. }
{$i classes.inc}
initialization
CommonInit;
finalization
CommonCleanup;
end.

7
programs/develop/fp/rtl/crt.pp Normal file
View File

@ -0,0 +1,7 @@
unit Crt;
interface
implementation
end.

9
programs/develop/fp/rtl/dos.pp Normal file
View File

@ -0,0 +1,9 @@
unit Dos;
interface
{$i filerec.inc}
implementation
end.

708
programs/develop/fp/rtl/kos.inc Normal file
View File

@ -0,0 +1,708 @@
{cp866}
{ User interface }
procedure kos_definewindow(x, y, w, h: Word; style, header, clframe: DWord); assembler; register;
asm
pushl %ebx
pushl %ecx
pushl %edx
pushl %esi
pushl %edi
movl %eax, %ebx
xchgl %edx, %ecx
movl header, %esi
shll $16, %ebx
shll $16, %ecx
movl clframe, %edi
movw %dx, %bx
movw h, %cx
xorl %eax, %eax
movl style, %edx
decl %ebx {㬥­ìè¨âì è¨à¨­ã ­  1}
decl %ecx {㬥­ìè¨âì ¢ëá®âã ­  1}
int $0x40
popl %edi
popl %esi
popl %edx
popl %ecx
popl %ebx
end;
procedure kos_movewindow(x, y, w, h: DWord); assembler; register;
asm
pushl %eax
pushl %ebx
pushl %ecx
pushl %edx
pushl %esi
movl %eax, %ebx
xchgl %ecx, %edx
movl $67, %eax
movl h, %esi
decl %edx {㬥­ìè¨âì è¨à¨­ã ­  1}
decl %esi {㬥­ìè¨âì ¢ëá®âã ­  1}
int $0x40
popl %esi
popl %edx
popl %ecx
popl %ebx
popl %eax
end;
function kos_getkey(): DWord; assembler; register;
asm
movl $2, %eax
int $0x40
end;
function kos_getevent(wait: Boolean = True): DWord; assembler; register;
asm
andl $1, %eax
xorb $1, %al
addl $10, %eax
int $0x40
end;
function kos_waitevent(timeout: DWord): DWord; assembler; register;
asm
pushl %ebx
movl $23, %ebx
xchgl %eax, %ebx
int $0x40
popl %ebx
end;
function kos_getbutton(): DWord; assembler; register;
asm
movl $17, %eax
int $0x40
shrl $8, %eax
andl $0xFF, %eax
end;
function kos_getmousepos(): TKosPoint; assembler; register;
{@return: x*65536 + y}
asm
pushl %eax
pushl %ebx
pushl %ecx
pushl %eax
movl $37, %eax
xorl %ebx, %ebx
int $0x40
movswl %ax, %ecx
popl %ebx
shrl $16, %eax
movl %ecx, TKosPoint.Y(%ebx)
movl %eax, TKosPoint.X(%ebx)
popl %ecx
popl %ebx
popl %eax
end;
function kos_getmousewinpos(): TKosPoint; assembler; register;
{@return: x*65536 + y}
asm
pushl %eax
pushl %ebx
pushl %ecx
pushl %eax
movl $37, %eax
movl $1, %ebx
int $0x40
movswl %ax, %ecx
popl %ebx
shrl $16, %eax
movl %ecx, TKosPoint.Y(%ebx)
movl %eax, TKosPoint.X(%ebx)
popl %ecx
popl %ebx
popl %eax
end;
function kos_getmousebuttons(): DWord; assembler; register;
{@return:
¡¨â 0 ãáâ ­®¢«¥­ = «¥¢ ï ª­®¯ª  ­ ¦ â 
¡¨â 1 ãáâ ­®¢«¥­ = ¯à ¢ ï ª­®¯ª  ­ ¦ â 
¡¨â 2 ãáâ ­®¢«¥­ = á।­ïï ª­®¯ª  ­ ¦ â 
¡¨â 3 ãáâ ­®¢«¥­ = 4-ï ª­®¯ª  ­ ¦ â 
¡¨â 4 ãáâ ­®¢«¥­ = 5-ï ª­®¯ª  ­ ¦ â }
asm
pushl %ebx
movl $37, %eax
movl $2, %ebx
int $0x40
popl %ebx
end;
procedure kos_maskevents(mask: DWord); assembler; register;
asm
pushl %ebx
xchgl %eax, %ebx
movl $40, %eax
int $0x40
xchgl %eax, %ebx
popl %ebx
end;
procedure kos_setcaption(caption: PChar); assembler; register;
asm
pushl %ecx
pushl %ebx
xchgl %eax, %ecx
movl $1, %ebx
movl $71, %eax
int $0x40
xchgl %eax, %ecx
popl %ebx
popl %ecx
end;
{ Graphics }
procedure kos_begindraw(); assembler; register;
asm
pushl %ebx
movl $12, %eax
movl $1, %ebx
int $0x40
popl %ebx
end;
procedure kos_enddraw(); assembler; register;
asm
pushl %ebx
movl $12, %eax
movl $2, %ebx
int $0x40
popl %ebx
end;
procedure kos_putpixel(x, y: Word; color: DWord); assembler; register;
asm
pushl %ebx
movl %eax, %ebx
xchgl %edx, %ecx
movl $1, %eax
int $0x40
xchgl %edx, %ecx
popl %ebx
end;
procedure kos_drawtext(x, y: Word; text: String; flags, bgcolor: DWord); assembler; register;
label nobg;
asm
pusha
shll $16, %eax
pushl %ecx
movl flags, %ecx {ä« £¨, 梥â}
movl bgcolor, %edi
movw %dx, %ax
andl $0x7FFFFFFF, %ecx
btl $31, %edi
jnc nobg
orl $0x40000000, %ecx
nobg:
popl %edx
movl %eax, %ebx {ª®®à¤¨­ âë}
movzbl (%edx), %esi {¤«¨­  áâப¨}
movl $4, %eax {­®¬¥à ä㭪樨}
incl %edx {㪠§ â¥«ì ­  áâபã}
andl $0xFFFFFF, %edi
int $0x40
popa
end;
procedure kos_drawrect(x, y, w, h: Word; color: DWord); assembler; register;
asm
pushl %eax
pushl %ebx
pushl %ecx
pushl %edx
movl %eax, %ebx
xchgl %edx, %ecx
shll $16, %ebx
shll $16, %ecx
movl $13, %eax
movw %dx, %bx
movw h, %cx
movl color, %edx
int $0x40
popl %edx
popl %ecx
popl %ebx
popl %eax
end;
procedure kos_drawline(x1, y1, x2, y2: Word; color: DWord = $000000); assembler; register;
asm
pushl %eax
pushl %ebx
pushl %ecx
pushl %edx
xchgl %eax, %ecx
xchgl %ecx, %edx
movl color, %ebx
{eax - x2, ebx - color, ecx - y1, edx - x1}
shll $16, %ecx
shll $16, %edx
movw %ax, %dx
movw y2, %cx
movl $38, %eax
xchgl %ebx, %edx
int $0x40
popl %edx
popl %ecx
popl %ebx
popl %eax
end;
procedure kos_drawimage(x, y, w, h, depth: DWord; image: Pointer; palette: Pointer; xoffset: DWord); assembler; register;
asm
pusha
shll $16, %eax
shll $16, %ecx
orl %eax, %edx
orl h, %ecx
movl depth, %esi
movl image, %ebx
movl palette, %edi
movl xoffset, %ebp
movl $65, %eax
int $0x40
popa
end;
procedure kos_drawimage24(x, y, w, h: DWord; image: Pointer); assembler; register;
asm
pushl %eax
pushl %ebx
pushl %ecx
pushl %edx
shll $16, %eax
shll $16, %ecx
orl %eax, %edx
orl h, %ecx
movl image, %ebx
movl $7, %eax
int $0x40
popl %edx
popl %ecx
popl %ebx
popl %eax
end;
{ Work with system }
{ Work with system - System services }
function kos_killthread(tid: TThreadID): Boolean; assembler; register;
asm
pushl %ecx
pushl %ebx
movl $18, %ecx
movl $18, %ebx
xchgl %eax, %ecx
int $0x40
andl $1, %eax
popl %ebx
popl %ecx
xorb $1, %al
end;
procedure kos_setactivewindow(slot: TThreadSlot); assembler; register;
asm
pushl %ecx
pushl %ebx
movl $18, %ecx
movl $3, %ebx
xchgl %eax, %ecx
int $0x40
xchgl %eax, %ecx
popl %ebx
popl %ecx
end;
{$ifdef EMULATOR}
function kos_getthreadslot(tid: TThreadID): TThreadSlot;
var
ThreadInfo: TKosThreadInfo;
HighThreadSlot: TThreadSlot;
begin
Result := 0;
repeat
Inc(Result);
HighThreadSlot := kos_threadinfo(@ThreadInfo, Result);
until (Result > HighThreadSlot) or (ThreadInfo.ThreadID = tid);
end;
{$else}
function kos_getthreadslot(tid: TThreadID): TThreadSlot; assembler; register;
asm
pushl %ecx
pushl %ebx
movl $18, %ecx
movl $21, %ebx
xchgl %eax, %ecx
int $0x40
popl %ebx
popl %ecx
end;
{$endif}
{ Work with system - Set system parameters }
procedure kos_enablepci(); assembler; register;
asm
pushl %eax
pushl %ebx
pushl %ecx
movl $21, %eax
movl $12, %ebx
movl $1, %ecx
int $0x40
popl %ecx
popl %ebx
popl %eax
end;
{ Work with system - Internal system services }
procedure kos_switchthread(); assembler; register;
asm
pushl %eax
pushl %ebx
movl $68, %eax
movl $1, %ebx
int $0x40
popl %ebx
popl %eax
end;
function kos_initheap(): DWord; assembler; register;
asm
pushl %ebx
movl $68, %eax
movl $11, %ebx
int $0x40
popl %ebx
end;
function kos_alloc(size: DWord): Pointer; assembler; register;
asm
pushl %ebx
pushl %ecx
movl %eax, %ecx
movl $68, %eax
movl $12, %ebx
int $0x40
popl %ecx
popl %ebx
end;
function kos_free(ptr: Pointer): Boolean; assembler; register;
asm
pushl %ebx
pushl %ecx
movl %eax, %ecx
movl $68, %eax
movl $13, %ebx
int $0x40
popl %ecx
popl %ebx
end;
function kos_loaddriver(name: PChar): THandle; assembler; register;
asm
pushl %ebx
pushl %ecx
movl %eax, %ecx
movl $68, %eax
movl $16, %ebx
int $0x40
popl %ecx
popl %ebx
end;
{ Processes and threads }
function kos_threadinfo(info: PKosThreadInfo; slot: TThreadSlot): DWord; assembler; register;
asm
pushl %ebx
movl %eax, %ebx
xchgl %edx, %ecx
movl $9, %eax
int $0x40
xchgl %edx, %ecx
popl %ebx
end;
function kos_newthread(entry, stack: Pointer): TThreadID; assembler; register;
asm
pushl %ebx
pushl %ecx
movl $1, %ebx
movl %eax, %ecx
movl $51, %eax
int $0x40
popl %ecx
popl %ebx
end;
procedure kos_initipc(ipc: PKosIPC; size: DWord); assembler; register;
asm
pushl %ebx
pushl %ecx
movl $60, %ecx
movl $1, %ebx
xchgl %eax, %ecx
int $0x40
popl %ecx
popl %ebx
end;
function kos_sendmsg(tid: TThreadID; msg: Pointer; size: DWord): DWord; assembler; register;
{@return:
0 - ãᯥ譮
1 - ¯à¨ñ¬­¨ª ­¥ ®¯à¥¤¥«¨« ¡ãä¥à ¤«ï IPC-á®®¡é¥­¨©
(¬®¦¥â ¡ëâì, ¥éñ ­¥ ãᯥ«,   ¬®¦¥â ¡ëâì, íâ® ­¥ â®â ¯®â®ª, ª®â®àë© ­ã¦¥­)
2 - ¯à¨ñ¬­¨ª § ¡«®ª¨à®¢ « IPC-¡ãä¥à; ¯®¯à®¡ã©â¥ ­¥¬­®£® ¯®¤®¦¤ âì
3 - ¯¥à¥¯®«­¥­¨¥ IPC-¡ãä¥à  ¯à¨ñ¬­¨ª 
4 - ¯à®æ¥áá /¯®â®ª  á â ª¨¬ PID ­¥ áãé¥áâ¢ã¥â}
asm
pushl %esi
pushl %ebx
movl $60, %esi
movl $2, %ebx
xchgl %ecx, %esi
xchgl %eax, %ecx
int $0x40
xchgl %ecx, %esi
popl %ebx
popl %esi
end;
function kos_resizemem(size: DWord): Boolean; assembler; register;
asm
pushl %ebx
pushl %ecx
movl %eax, %ecx
movl $64, %eax
movl $1, %ebx
int $0x40
xorb $1, %al
popl %ecx
popl %ebx
end;
{ File system }
{ File system - Work with the current folder }
procedure kos_setdir(path: PChar); assembler; register;
asm
pushl %ecx
pushl %ebx
movl $30, %ecx
movl $1, %ebx
xchgl %eax, %ecx
int $0x40
popl %ebx
popl %ecx
end;
function kos_getdir(path: PChar; size: DWord): DWord; assembler; register;
asm
pushl %ecx
pushl %ebx
movl $30, %ecx
movl $2, %ebx
xchgl %eax, %ecx
int $0x40
popl %ebx
popl %ecx
end;
{ File system - Work with file system with long names support }
function kos_readfile(kosfile: PKosFile; var readed: Longint): DWord; assembler; register;
asm
pushl %ebx
movl $70, %ebx
xchgl %eax, %ebx
movl $0, (%ebx)
int $0x40
movl %ebx, (%edx)
popl %ebx
end;
function kos_rewritefile(kosfile: PKosFile; var writed: Longint): DWord; assembler; register;
asm
pushl %ebx
movl $70, %ebx
xchgl %eax, %ebx
movl $2, (%ebx)
int $0x40
movl %ebx, (%edx)
popl %ebx
end;
function kos_writefile(kosfile: PKosFile; var writed: Longint): DWord; assembler; register;
asm
pushl %ebx
movl $70, %ebx
xchgl %eax, %ebx
movl $3, (%ebx)
int $0x40
movl %ebx, (%edx)
popl %ebx
end;
function kos_fileinfo(kosfile: PKosFile): DWord; assembler; register;
asm
pushl %ebx
movl $70, %ebx
xchgl %eax, %ebx
movl $5, (%ebx)
int $0x40
popl %ebx
end;
{ Work with hardware }
function kos_readport(index: DWord): DWord; assembler; register;
label ok, exit;
asm
pushl %ecx
pushl %ebx
xchgl %eax, %ecx {index}
movl $43, %eax
orl $0x80000000, %ecx {index}
int $0x40
orl %eax, %eax
jzl ok
movl $-1, %eax
jmp exit
ok:
movl %ebx, %eax
exit:
popl %ebx
popl %ecx
end;
procedure kos_writeport(index, value: DWord); assembler; register;
asm
pushl %eax
pushl %ebx
pushl %ecx
xchgl %edx, %ebx {value}
xchgl %eax, %ecx {index}
movl $43, %eax
int $0x40
xchgl %edx, %ebx
popl %ecx
popl %ebx
popl %eax
end;
function kos_reserveport(port: DWord): Boolean; assembler; register;
asm
pushl %ebx
pushl %ecx
pushl %edx
movl %eax, %ecx {port}
movl $46, %eax
movl %ecx, %edx {port}
xorl %ebx, %ebx
int $0x40
xorb $1, %al
popl %edx
popl %ecx
popl %ebx
end;
{ Work with hardware - Low-level access to PCI}
function kos_lastpcibus(): Byte; assembler; register;
asm
pushl %ebx
movl $62, %eax
movl $1, %ebx
int $0x40
popl %ebx
end;
function kos_readpcib(bus, dev, func, reg: Byte): Byte; assembler; register;
asm
pushl %ebx
pushl %ecx
pushl %edx
shlb $3, %dl {dev}
movb %al, %bh {bus}
shlw $8, %cx {func}
movb $4, %bl
movb reg, %cl {func}
andb $7, %ch {func}
movl $62, %eax
orb %dl, %ch {dev/func}
int $0x40
popl %edx
popl %ecx
popl %ebx
end;
function kos_readpciw(bus, dev, func, reg: Byte): Word; assembler; register;
asm
pushl %ebx
pushl %ecx
pushl %edx
shlb $3, %dl {dev}
movb %al, %bh {bus}
shlw $8, %cx {func}
movb $5, %bl
movb reg, %cl {reg}
andb $7, %ch {func}
movl $62, %eax
orb %dl, %ch {dev/func}
int $0x40
popl %edx
popl %ecx
popl %ebx
end;
function kos_readpcid(bus, dev, func, reg: Byte): DWord; assembler; register;
asm
pushl %ebx
pushl %ecx
pushl %edx
shlb $3, %dl {dev}
movb %al, %bh {bus}
shlw $8, %cx {func}
movb $6, %bl
movb reg, %cl {reg}
andb $7, %ch {func}
movl $62, %eax
orb %dl, %ch {dev/func}
int $0x40
popl %edx
popl %ecx
popl %ebx
end;
{ Other }
procedure kos_delay(ms: DWord); assembler; register;
asm
pushl %ebx
movl %eax, %ebx
movl $5, %eax
int $0x40
popl %ebx
end;

115
programs/develop/fp/rtl/kos_def.inc Normal file
View File

@ -0,0 +1,115 @@
{Ž¯à¥¤¥«¥­¨ï, ª®­áâ ­âë}
const
{‘¨á⥬­ë¥ ᮡëâ¨ï}
SE_PAINT = 1;
SE_KEYBOARD = 2;
SE_BUTTON = 3;
SE_MOUSE = 6;
SE_IPC = 7;
{Œ áª¨ ᮡë⨩}
ME_PAINT = 1 shl (SE_PAINT - 1);
ME_KEYBOARD = 1 shl (SE_KEYBOARD - 1);
ME_BUTTON = 1 shl (SE_BUTTON - 1);
ME_MOUSE = 1 shl (SE_MOUSE - 1);
ME_IPC = 1 shl (SE_IPC - 1);
{Š®¤ë ª« ¢¨è}
VK_LBUTTON = 1;
VK_RBUTTON = 2;
VK_CANCEL = 3;
VK_MBUTTON = 4;
VK_BACK = 8;
VK_TAB = 9;
VK_CLEAR = 12;
VK_RETURN = 13;
VK_SHIFT = 16;
VK_CONTROL = 17;
VK_MENU = 18;
VK_PAUSE = 19;
VK_CAPITAL = 20;
VK_ESCAPE = 27;
VK_SPACE = 32;
VK_PRIOR = 33;
VK_NEXT = 34;
VK_END = 35;
VK_HOME = 36;
VK_LEFT = 37;
VK_UP = 38;
VK_RIGHT = 39;
VK_DOWN = 40;
VK_SELECT = 41;
VK_PRINT = 42;
VK_EXECUTE = 43;
VK_SNAPSHOT = 44;
VK_INSERT = 45;
VK_DELETE = 46;
VK_HELP = 47;
VK_0 = 48;
VK_1 = 49;
VK_2 = 50;
VK_3 = 51;
VK_4 = 52;
VK_5 = 53;
VK_6 = 54;
VK_7 = 55;
VK_8 = 56;
VK_9 = 57;
VK_A = 65;
VK_B = 66;
VK_C = 67;
VK_D = 68;
VK_E = 69;
VK_F = 70;
VK_G = 71;
VK_H = 72;
VK_I = 73;
VK_J = 74;
VK_K = 75;
VK_L = 76;
VK_M = 77;
VK_N = 78;
VK_O = 79;
VK_P = 80;
VK_Q = 81;
VK_R = 82;
VK_S = 83;
VK_T = 84;
VK_U = 85;
VK_V = 86;
VK_W = 87;
VK_X = 88;
VK_Y = 89;
VK_Z = 90;
VK_LWIN = 91;
VK_RWIN = 92;
VK_APPS = 93;
VK_NUMPAD0 = 96;
VK_NUMPAD1 = 97;
VK_NUMPAD2 = 98;
VK_NUMPAD3 = 99;
VK_NUMPAD4 = 100;
VK_NUMPAD5 = 101;
VK_NUMPAD6 = 102;
VK_NUMPAD7 = 103;
VK_NUMPAD8 = 104;
VK_NUMPAD9 = 105;
VK_MULTIPLY = 106;
VK_ADD = 107;
VK_SEPARATOR = 108;
VK_SUBTRACT = 109;
VK_DECIMAL = 110;
VK_DIVIDE = 111;
VK_F1 = 112;
VK_F2 = 113;
VK_F3 = 114;
VK_F4 = 115;
VK_F5 = 116;
VK_F6 = 117;
VK_F7 = 118;
VK_F8 = 119;
VK_F9 = 120;
VK_F10 = 121;
VK_F11 = 122;
VK_F12 = 123;

355
programs/develop/fp/rtl/kos_stdio.inc Normal file
View File

@ -0,0 +1,355 @@
{}
procedure OpenStdout(var f: TextRec); forward;
procedure WriteStdout(var f: TextRec); forward;
procedure CloseStdout(var f: TextRec); forward;
procedure OpenStdin(var f: TextRec); forward;
procedure ReadStdin(var f: TextRec); forward;
procedure CloseStdin(var f: TextRec); forward;
procedure AssignStdout(var f: Text);
begin
Assign(f, '');
TextRec(f).OpenFunc := @OpenStdout;
Rewrite(f);
end;
procedure OpenStdout(var f: TextRec);
begin
TextRec(f).InOutFunc := @WriteStdout;
TextRec(f).FlushFunc := @WriteStdout;
TextRec(f).CloseFunc := @CloseStdout;
end;
procedure WriteStdout(var f: TextRec);
var
msg: String;
begin
msg := StrPas(PChar(f.bufptr));
SetLength(msg, f.bufpos);
f.bufpos := 0;
Konsole.Write(msg);
end;
procedure CloseStdout(var f: TextRec);
begin
end;
procedure AssignStdin(var f: Text);
begin
Assign(f, '');
TextRec(f).OpenFunc := @OpenStdin;
Reset(f);
end;
procedure OpenStdin(var f: TextRec);
begin
TextRec(f).InOutFunc := @ReadStdin;
TextRec(f).FlushFunc := nil;
TextRec(f).CloseFunc := @CloseStdin;
end;
procedure ReadStdin(var f: TextRec);
var
max, curpos: Longint;
c: Longint;
begin
max := f.bufsize - Length(LineEnding);
curpos := 0;
repeat
c := 13{l4_getc()};
case c of
13:
begin
{f.bufptr^[curpos] := LineEnding;}
Inc(curpos);
f.bufpos := 0;
f.bufend := curpos;
{l4_putc(Longint(LineEnding));}
break;
end;
32..126: if curpos < max then
begin
f.bufptr^[curpos] := Char(c);
Inc(curpos);
{l4_putc(c);}
end;
end;
until False;
end;
procedure CloseStdin(var f: TextRec);
begin
end;
{ TKonsole }
procedure KonsoleThreadMain(Console: PKonsole);
{<EFBFBD> ¡®ç¨© 横« ª®­á®«¨}
var
ThreadInfo: TKosThreadInfo;
Message: ShortString;
Event: DWord;
begin
kos_maskevents(ME_PAINT or ME_KEYBOARD or ME_IPC);
kos_threadinfo(@ThreadInfo);
Console^.FThreadSlot := kos_getthreadslot(ThreadInfo.ThreadID);
kos_initipc(Console^.FIPCBuffer, Console^.FIPCBufferSize);
{áࠧ㠮⮡ࠧ¨âì ¨  ªâ¨¢¨à®¢ âì ®ª­®}
Console^.Paint();
{$ifndef EMULATOR}
kos_setactivewindow(Console^.FThreadSlot);
{$endif}
{£®â®¢ ª ®¡à ¡®âª¥ ᮡë⨩}
Console^.FOpened := True;
while not Console^.FTerminate do
begin
Event := kos_getevent();
if Console^.FTerminate then
{Console^.ProcessMessage('[CONSOLE] Terminate...'#13#10)} else
case Event of
SE_PAINT: Console^.Paint();
SE_KEYBOARD: Console^.ProcessKeyboard(kos_getkey());
SE_IPC: while Console^.ReceiveMessage(Message) do Console^.ProcessMessage(Message);
end;
end;
Console^.FOpened := False;
end;
constructor TKonsole.Init(ACaption: String);
const
IPC_SIZE = 4096;
var
ThreadInfo: TKosThreadInfo;
begin
if ACaption <> '' then
FCaption := ACaption else
begin
kos_threadinfo(@ThreadInfo);
FCaption := StrPas(ThreadInfo.AppName);
end;
SetLength(FLines, 1);
FLines[0] := ' ';
FCursor.X := 1;
FCursor.Y := 0;
FMaxLines := 150;
FTerminate := False;
FOpened := False;
FIPCBufferSize := SizeOf(TKosIPC) + IPC_SIZE;
FIPCBuffer := GetMem(FIPCBufferSize);
{FIPCBufferSize := SizeOf(KonsoleIPCBuffer);
FIPCBuffer := @KonsoleIPCBuffer;}
FIPCBuffer^.Lock := False;
FIPCBuffer^.Size := 0;
FThreadSlot := -1;
FThreadID := BeginThread(TThreadFunc(@KonsoleThreadMain), @Self);
if FThreadID <> 0 then
while not FOpened do kos_delay(1);
end;
destructor TKonsole.Done();
begin
FTerminate := True;
Self.Write(#0);
if FOpened then kos_delay(1);
if FOpened then kos_delay(10);
if FOpened then kos_delay(20);
if FOpened then
begin
FOpened := False;
KillThread(FThreadID);
end;
FreeMem(FIPCBuffer);
SetLength(FLines, 0);
end;
function TKonsole.ReceiveMessage(var Message: ShortString): Boolean;
{ˆ§¢«¥çì ¯¥à¢®¥ á®®¡é¥­¨¥ ¨§ ¡ãä¥à }
var
PMsg: PKosMessage;
Size: Longword;
begin
if FIPCBuffer^.Size > 0 then
begin
FIPCBuffer^.Lock := True;
PMsg := Pointer(Longword(FIPCBuffer) + SizeOf(TKosIPC));
{TODO: ¯à®¢¥àª  PMsg^.SenderID}
{Size := PMsg^.Size;
Dec(FIPCBuffer^.Size, Size + SizeOf(TKosMessage));
if Size > 255 then Size := 255;
SetLength(Message, Size);
Move(Pointer(Longword(PMsg) + SizeOf(TKosMessage))^, Message[1], Size);
if FIPCBuffer^.Size > 0 then
Move(Pointer(Longword(PMsg) + SizeOf(TKosMessage) + PMsg^.Size)^, PMsg^, FIPCBuffer^.Size);}
{XXX}
Size := FIPCBuffer^.Size;
Dec(FIPCBuffer^.Size, Size);
if Size > 255 then Size := 255;
SetLength(Message, Size);
Move(PMsg^, Message[1], Size);
Result := True;
end else
begin
Message := '';
Result := False;
end;
{FIXME: ¥á«¨ FIPCBuffer^.Size = 0, â® FIPCBuffer^.Lock ¢á¥ à ¢­® > 0}
FIPCBuffer^.Lock := False;
end;
procedure TKonsole.ProcessMessage(Message: ShortString);
{‚뢥á⨠ᮮ¡é¥­¨¥ ­  ª®­á®«ì}
var
S: String;
LinesCount: Word;
CR, LF, W: Word;
BottomRow: Boolean = True;
begin
if Length(Message) < 1 then Exit;
repeat
CR := Pos(#13, Message);
LF := Pos(#10, Message);
if (CR > 0) and ((CR < LF) or (LF <= 0)) then
W := CR else
if LF > 0 then
W := LF else
W := Length(Message) + 1;
if W > 0 then
begin
if W > 1 then
begin
S := Copy(Message, 1, W - 1);
Delete(FLines[FCursor.Y], FCursor.X, Length(FLines[FCursor.Y]) - FCursor.X);
Insert(S, FLines[FCursor.Y], FCursor.X);
Inc(FCursor.X, Length(S));
end;
Delete(Message, 1, W);
if W = CR then
{¯¥à¥¢®¤ ª®à¥âª¨ ¢ ­ ç «® áâப¨}
FCursor.X := 1 else
if W = LF then
begin
{¯¥à¥¢®¤ ª®à¥âª¨ ­  á«¥¤ãîéãî áâபã}
BottomRow := False;
Inc(FCursor.Y);
LinesCount := Length(FLines);
while FCursor.Y >= FMaxLines do Dec(FCursor.Y, FMaxLines);
if FCursor.Y < LinesCount then FLines[FCursor.Y] := '';
while FCursor.Y >= LinesCount do
begin
SetLength(FLines, LinesCount + 1);
FLines[LinesCount] := '';
Inc(LinesCount);
end;
end;
end;
until Length(Message) <= 0;
Paint(BottomRow);
end;
procedure TKonsole.ProcessKeyboard(Key: Word);
begin
FKeyPressed := Key;
end;
function TKonsole.GetRect(): TKosRect;
var
ThreadInfo: TKosThreadInfo;
begin
kos_threadinfo(@ThreadInfo, FThreadSlot);
Result := ThreadInfo.WindowRect;
end;
function TKonsole.GetKeyPressed(): Word;
begin
Result := FKeyPressed;
FKeyPressed := 0;
end;
procedure TKonsole.Paint(BottomRow: Boolean);
var
Buffer: array[Byte] of Char;
Rect: TKosRect;
J: Longint;
Width, Height, Row: Longint;
CaptionHeight, BorderWidth, FontWidth, FontHeight: Longint;
begin
CaptionHeight := 16;
BorderWidth := 5;
FontWidth := 6;
FontHeight := 9;
kos_begindraw();
if not BottomRow then
begin
{®âà¨á®¢ª  ®ª­ }
kos_definewindow(60, 60, 400, 400, $63000000);
{¢ë¢®¤ § £®«®¢ª }
Move(FCaption[1], Buffer, Length(FCaption));
Buffer[Length(FCaption)] := #0;
kos_setcaption(Buffer);
end;
{¯®¤£®â®¢ª  ª ¢ë¢®¤ã áâப}
Rect := GetRect();
Dec(Rect.Width, BorderWidth * 2);
Dec(Rect.Height, CaptionHeight + BorderWidth * 2);
Width := Rect.Width div FontWidth;
Height := Rect.Height - FontHeight;
Row := FCursor.Y;
while Height > 0 do
begin
{¢ë¢®¤ ®¤­®© áâப¨}
J := Length(FLines[Row]);
if J > Width then J := Width;
kos_drawtext(0, Height, Copy(FLines[Row], 1, J), $00DD00, $FF000000);
{§ «¨¢ª  ®á⠢襣®áï ¯à®áâà ­á⢠ ¢ áâப¥}
J := J * FontWidth;
kos_drawrect(J, Height, Rect.Width - J + 1, FontHeight, $000000);
{¯®¤£®â®¢ª  ª ¢ë¢®¤ã á«¥¤ãî饩 áâப¨}
Dec(Height, FontHeight);
Dec(Row);
if BottomRow or ((Row < 0) and (Length(FLines) < FMaxLines)) then Break;
while Row < 0 do Inc(Row, FMaxLines);
end;
if FCursor.X <= Width then
{®âà¨á®¢ª  ªãàá®à }
kos_drawrect((FCursor.X - 1) * FontWidth, Rect.Height - 2, FontWidth, 2, $FFFFFF);
if not BottomRow then
{§ «¨¢ª  ®á⠢襩áï ç á⨠®ª­ }
kos_drawrect(0, 0, Rect.Width + 1, Height + FontHeight, $000000);
kos_enddraw();
end;
procedure TKonsole.Write(Message: ShortString);
var
I: Integer;
begin
{XXX: ¢®§¬®¦­  á¨âã æ¨ï ¯à¨ ª®â®à®© á®®¡é¥­¨¥ ­¥ ¡ã¤¥â ®â¯à ¢«¥­®}
if FOpened then
begin
I := 20;
while (kos_sendmsg(FThreadID, @Message[1], Length(Message)) = 2) and (I > 0) do
begin
Dec(I);
ThreadSwitch;
end;
end;
end;

208
programs/develop/fp/rtl/kosh.inc Normal file
View File

@ -0,0 +1,208 @@
{}
type
TKosPoint = packed record
X: Longint;
Y: Longint;
end;
TKosRect = packed record
case Integer of
0: (Left, Top, Width, Height: Longint);
1: (TopLeft, HeightWidth: TKosPoint);
end;
{ User interface }
procedure kos_definewindow(x, y, w, h: Word; style: DWord = $23FFFFFF; header: DWord = $008899FF; clframe: DWord = $008899FF);
procedure kos_movewindow(x, y, w, h: DWord);
function kos_getkey(): DWord;
function kos_getevent(wait: Boolean = True): DWord;
function kos_waitevent(timeout: DWord): DWord;
function kos_getbutton(): DWord;
function kos_getmousepos(): TKosPoint;
function kos_getmousewinpos(): TKosPoint;
function kos_getmousebuttons(): DWord;
procedure kos_maskevents(mask: DWord);
procedure kos_setcaption(caption: PChar);
{ Graphics }
procedure kos_begindraw();
procedure kos_enddraw();
procedure kos_putpixel(x, y: Word; color: DWord = $000000);
procedure kos_drawtext(x, y: Word; text: String; flags: DWord = $000000; bgcolor: DWord = $00FFFFFF);
procedure kos_drawrect(x, y, w, h: Word; color: DWord = $000000);
procedure kos_drawline(x1, y1, x2, y2: Word; color: DWord = $000000);
procedure kos_drawimage(x, y, w, h, depth: DWord; image: Pointer; palette: Pointer = nil; xoffset: DWord = 0);
procedure kos_drawimage24(x, y, w, h: DWord; image: Pointer);
{ Work with system }
{ Work with system - System services }
function kos_killthread(tid: TThreadID): Boolean;
procedure kos_setactivewindow(slot: TThreadSlot);
function kos_getthreadslot(tid: TThreadID): TThreadSlot;
{ Work with system - Set system parameters }
procedure kos_enablepci();
{ Work with system - Internal system services }
procedure kos_switchthread();
function kos_initheap(): DWord;
function kos_alloc(size: DWord): Pointer;
function kos_free(ptr: Pointer): Boolean;
function kos_loaddriver(name: PChar): THandle;
{ Processes and threads }
type
PKosThreadInfo = ^TKosThreadInfo;
TKosThreadInfo = packed record
Speed: DWord;
WindowID: Word;
ThreadSlot: Word;
Reserved1: Word;
AppName: array[0..10] of Char;
Reserved2: Byte;
ProcessBase: Pointer;
MemoryUsage: DWord;
ThreadID: TThreadID;
WindowRect: TKosRect;
Unknown0: array[1..1066] of Byte;
end;
{<EFBFBD>ãä¥à IPC}
PKosIPC = ^TKosIPC;
TKosIPC = packed record
Lock: LongBool;
Size: DWord;
{á®®¡é¥­¨¥ #1...}
{á®®¡é¥­¨¥ #2...}
{...}
end;
{‘®®¡é¥­¨¥ IPC}
PKosMessage = ^TKosMessage;
TKosMessage = packed record
SenderID: TThreadID;
Size: DWord;
{⥫® á®®¡é¥­¨ï...}
end;
function kos_threadinfo(info: PKosThreadInfo; slot: TThreadSlot = -1): DWord;
function kos_newthread(entry, stack: Pointer): TThreadID;
procedure kos_initipc(ipc: PKosIPC; size: DWord);
function kos_sendmsg(tid: TThreadID; msg: Pointer; size: DWord): DWord;
function kos_resizemem(size: DWord): Boolean;
{ File system }
{ File system - Work with the current folder }
procedure kos_setdir(path: PChar);
function kos_getdir(path: PChar; size: DWord): DWord;
{ File system - Work with file system with long names support }
const
kfReadOnly = $01;
kfHidden = $02;
kfSystem = $04;
kfLabel = $08;
kfFolder = $10;
kfNotArchive = $20;
type
PKosFile = ^TKosFile;
TKosFile = packed record
SubFunc: DWord;
Position, PositionReserved: DWord;
Size: DWord;
Data: Pointer;
Name: array[0..0] of Char; {...ASCIIZ}
end;
PKosBDFE = ^TKosBDFE;
TKosBDFE = packed record
Attributes: DWord;
NameType: Byte; {bit0 - 0:ascii, 1:unicode}
Reserved: array[0..2] of Byte;
CTime: DWord; {ss,mm,hh,00}
CDate: DWord; {dd,mm,yyyy}
ATime: DWord;
ADate: DWord;
MTime: DWord;
MDate: DWord;
Size: QWord;
Name: array[0..519] of Char;
end;
function kos_readfile(kosfile: PKosFile; var readed: Longint): DWord;
function kos_rewritefile(kosfile: PKosFile; var writed: Longint): DWord;
function kos_writefile(kosfile: PKosFile; var writed: Longint): DWord;
function kos_fileinfo(kosfile: PKosFile): DWord;
{ Work with hardware }
function kos_readport(index: DWord): DWord;
procedure kos_writeport(index, value: DWord);
function kos_reserveport(port: DWord): Boolean;
{ Work with hardware - Low-level access to PCI}
function kos_lastpcibus(): Byte;
function kos_readpcib(bus, dev, func, reg: Byte): Byte;
function kos_readpciw(bus, dev, func, reg: Byte): Word;
function kos_readpcid(bus, dev, func, reg: Byte): DWord;
{ Other }
procedure kos_delay(ms: DWord); {1/100 s}
{ my }
type
TKosSign = array[0..7] of Byte;
PKosHeader = ^TKosHeader;
TKosHeader = packed record
sign : TKOSSign;
version: DWord;
start : DWord;
size : DWord;
memory : DWord;
stack : DWord;
args : PChar;
path : PChar;
end;
{var
KonsoleIPCBuffer: array[0..4096] of Byte;}
type
PKonsole = ^TKonsole;
TKonsole = object
private
FCaption: String;
FLines: array of String;
FCursor: TKosPoint;
FMaxLines: Word;
FThreadID: TThreadID;
FThreadSlot: TThreadSlot;
FIPCBuffer: PKosIPC;
FIPCBufferSize: DWord;
FTerminate: Boolean;
FOpened: Boolean;
FKeyPressed: Word;
function ReceiveMessage(var Message: ShortString): Boolean;
procedure ProcessMessage(Message: ShortString);
procedure ProcessKeyboard(Key: Word);
function GetRect(): TKosRect;
function GetKeyPressed(): Word;
procedure Paint(BottomRow: Boolean = False);
public
constructor Init(ACaption: String = '');
destructor Done();
procedure Write(Message: ShortString);
property KeyPressed: Word read GetKeyPressed;
property Opened: Boolean read FOpened;
property ThreadID: TThreadID read FThreadID; {JustForFun, must be hidden, do not use}
property ThreadSlot: TThreadSlot read FThreadSlot; {JustForFun, must be hidden, do not use}
end;
IStreamIO = interface
function Read(Size: DWord = 0): AnsiString;
procedure Write(Str: AnsiString; Error: Boolean = False);
end;

35
programs/develop/fp/rtl/sysdir.inc Normal file
View File

@ -0,0 +1,35 @@
{TODO}
procedure mkdir(const s: String); [IOCHECK];
begin
InOutRes := 211;
end;
procedure rmdir(const s: String); [IOCHECK];
begin
InOutRes := 211;
end;
procedure chdir(const s: String); [IOCHECK];
var
Path: array[Byte] of Char;
begin
Path := s;
kos_setdir(Path);
InOutRes := 0;
end;
procedure getdir(DriveNr: Byte; var Dir: ShortString);
{ DriveNr ­¥ ¨á¯®«ì§ã¥âáï, ­® ¢á¥£¤  ¤®«¦¥­ ¡ëâì à ¢¥­ 0 }
var
Path: array[Byte] of Char;
Size: Longword;
begin
if DriveNr <> 0 then
InOutRes := 15 { Invalid drive number (­¥¯à ¢¨«ì­ë© ­®¬¥à ãáâனá⢠) } else
begin
Size := kos_getdir(@Path, SizeOf(Path));
Dir := StrPas(Path);
InOutRes := 0;
end;
end;

145
programs/develop/fp/rtl/sysfile.inc Normal file
View File

@ -0,0 +1,145 @@
{cp866}
function DecodeErrNo(ErrNo: DWord): Word;
{0 = ãᯥ譮
1 = ­¥ ®¯à¥¤¥«¥­  ¡ §  ¨/¨«¨ à §¤¥« ¦ñá⪮£® ¤¨áª  (¯®¤äã­ªæ¨ï¬¨ 7, 8 ä㭪樨 21)
2 = äã­ªæ¨ï ­¥ ¯®¤¤¥à¦¨¢ ¥âáï ¤«ï ¤ ­­®© ä ©«®¢®© á¨á⥬ë
3 = ­¥¨§¢¥áâ­ ï ä ©«®¢ ï á¨á⥬ 
4 = § à¥§¥à¢¨à®¢ ­®, ­¨ª®£¤  ­¥ ¢®§¢à é ¥âáï ¢ ⥪ã饩 ॠ«¨§ æ¨¨
5 = ä ©« ­¥ ­ ©¤¥­
6 = ä ©« § ª®­ç¨«áï
7 = 㪠§ â¥«ì ¢­¥ ¯ ¬ï⨠¯à¨«®¦¥­¨ï
8 = ¤¨áª § ¯®«­¥­
9 = â ¡«¨æ  FAT à §àã襭 
10 = ¤®áâ㯠§ ¯à¥éñ­
11 = ®è¨¡ª  ãáâனá⢠}
begin
case ErrNo of
0: Result := 0;
1: Result := 152;
2: Result := 153;
3: Result := 151;
4: Result := 1;
5: Result := 2;
6: Result := 0;
8: Result := 101;
else
Result := 153; { Unknown command (­¥¨§¢¥áâ­ ï ª®¬ ­¤ ) }
end;
end;
function do_isdevice(handle:thandle): Boolean;
begin
InOutRes := 211;
Result := False;
end;
procedure do_close(handle: THandle);
begin
FreeMem(PKosFile(handle));
InOutRes := 0;
end;
procedure do_erase(p : pchar);
begin
InOutRes := 211;
end;
procedure do_rename(p1,p2 : pchar);
begin
InOutRes := 211;
end;
function do_write(handle: THandle; addr: Pointer; len: Longint): Longint;
begin
PKosFile(handle)^.Size := len;
PKosFile(handle)^.Data := addr;
InOutRes := DecodeErrNo(kos_writefile(PKosFile(handle), Result));
Inc(PKosFile(handle)^.Position, Result);
end;
function do_read(handle: THandle; addr: Pointer; len: Longint): Longint;
begin
PKosFile(handle)^.Size := len;
PKosFile(handle)^.Data := addr;
InOutRes := DecodeErrNo(kos_readfile(PKosFile(handle), Result));
Inc(PKosFile(handle)^.Position, Result);
end;
function do_filepos(handle: THandle): Int64;
begin
Result := PKosFile(handle)^.Position;
end;
procedure do_seek(handle: THandle; pos: Int64);
begin
PKosFile(handle)^.Position := pos;
end;
function do_seekend(handle: THandle): Int64;
begin
InOutRes := 211;
Result := 0;
end;
function do_filesize(handle: THandle): Int64;
var
BDFE: TKosBDFE;
begin
PKosFile(handle)^.Data := @BDFE;
InOutRes := DecodeErrNo(kos_fileinfo(PKosFile(handle)));
Result := BDFE.Size;
end;
procedure do_truncate(handle: THandle; pos: Int64);
begin
InOutRes := 211;
end;
procedure do_open(var f; p: PChar; flags: Longint);
var
KosFile: PKosFile;
FilePath: PChar;
FilePathLen: Longint;
RecSize: Longint;
CurrDir: array[0..2048] of Char;
CurrDirLen: Longint;
begin
case flags and 3 of
0: FileRec(f).Mode := fmInput;
1: FileRec(f).Mode := fmOutput;
2: FileRec(f).Mode := fmInOut;
end;
{”®à¬¨à®¢ ­¨¥ ¨¬¥­¨  ¡á®«îâ­®£® ¯ãâ¨}
FilePathLen := Length(p);
if p^ <> DirectorySeparator then
begin
{XXX: à §¬¥à ¡ãä¥à  CurrDir ¬®¦¥â ®ª § âìáï ­¥¤®áâ â®ç­ë¬}
CurrDirLen := kos_getdir(@CurrDir, SizeOf(CurrDir) - FilePathLen - 1) - 1;
FilePath := @CurrDir;
if FilePath[CurrDirLen - 1] <> DirectorySeparator then
begin
FilePath[CurrDirLen] := DirectorySeparator;
Inc(CurrDirLen);
end;
Move(p^, FilePath[CurrDirLen], FilePathLen + 1);
Inc(FilePathLen, CurrDirLen);
end else
FilePath := p;
{‘®§¤ ­¨¥ áâàãªâãàë TKosFile}
RecSize := SizeOf(TKosFile) + FilePathLen;
KosFile := GetMem(RecSize);
FillChar(KosFile^, RecSize, 0);
Move(FilePath^, KosFile^.Name, FilePathLen);
FileRec(f).Handle := DWord(KosFile);
if flags and $1000 <> 0 then
begin
{ ᮧ¤ âì ä ©« }
InOutRes := DecodeErrNo(kos_rewritefile(KosFile, RecSize));
end else
InOutRes := 0;
end;

56
programs/develop/fp/rtl/sysheap.inc Normal file
View File

@ -0,0 +1,56 @@
{TODO}
function SysOSAlloc(Size: PtrInt): Pointer;
begin
Result := kos_alloc(Size);
end;
{$define HAS_SYSOSFREE}
procedure SysOSFree(P: Pointer; Size: PtrInt);
begin
kos_free(P);
end;
(*
{DEBUG version}
var
SysMemoryBlocks: array[Byte] of record
Used: Boolean;
Address: Pointer;
Size: Longint;
end;
function SysOSAlloc(Size: PtrInt): Pointer;
var
I: Longint;
begin
Result := kos_alloc(Size);
for I := 0 to High(SysMemoryBlocks) do
if not SysMemoryBlocks[I].Used then
begin
SysMemoryBlocks[I].Used := True;
SysMemoryBlocks[I].Address := Result;
SysMemoryBlocks[I].Size := Size;
Break;
end;
end;
{$define HAS_SYSOSFREE}
procedure SysOSFree(P: Pointer; Size: PtrInt);
var
B: Byte;
I: Longint;
begin
B := 0;
for I := 0 to High(SysMemoryBlocks) do
if SysMemoryBlocks[I].Address = P then
begin
SysMemoryBlocks[I].Used := False;
if SysMemoryBlocks[I].Size <> Size then B := 1 div B;
Break;
end;
kos_free(P);
end;*)

52
programs/develop/fp/rtl/sysinitpas.pp Normal file
View File

@ -0,0 +1,52 @@
{}
unit sysinitpas;
interface
implementation
var
SysInstance: Longint; external name '_FPC_SysInstance';
procedure PascalMain; stdcall; external name 'PASCALMAIN';
procedure SystemExit; external name 'SystemExit';
procedure EntryConsole; [public, alias:'_mainCRTStartup'];
var
ESP_: Pointer;
begin
asm movl %esp, ESP_; end;
StackTop := ESP_ + 8;
IsConsole := True;
PascalMain;
SystemExit;
end;
procedure EntryWindow; [public, alias:'_WinMainCRTStartup'];
var
ESP_: Pointer;
begin
asm movl %esp, ESP_; end;
StackTop := ESP_ + 8;
IsConsole := False;
PascalMain;
SystemExit;
end;
procedure _FPC_DLLMainCRTStartup(_hinstance, _dllreason, _dllparam: Longint); stdcall; public name '_DLLMainCRTStartup';
begin
{TODO}
IsConsole := True;
SysInstance := _hinstance;
end;
procedure _FPC_DLLWinMainCRTStartup(_hinstance, _dllreason, _dllparam: Longint); stdcall; public name '_DLLWinMainCRTStartup';
begin
{TODO}
IsConsole := False;
SysInstance := _hinstance;
end;
end.

11
programs/develop/fp/rtl/sysos.inc Normal file
View File

@ -0,0 +1,11 @@
{}
const
{ flags for CreateFile }
GENERIC_READ=$80000000;
GENERIC_WRITE=$40000000;
CREATE_NEW = 1;
CREATE_ALWAYS = 2;
OPEN_EXISTING = 3;
OPEN_ALWAYS = 4;
TRUNCATE_EXISTING = 5;

15
programs/develop/fp/rtl/sysosh.inc Normal file
View File

@ -0,0 +1,15 @@
{}
type
THandle = DWord;
TThreadID = Longint;
TThreadSlot = Longint;
UINT = Cardinal;
BOOL = Longbool;
ULONG_PTR = DWord;
SIZE_T = ULONG_PTR;
PRTLCriticalSection = ^TRTLCriticalSection;
TRTLCriticalSection = packed record
OwningThread: TThreadID;
end;

201
programs/develop/fp/rtl/system.pp Normal file
View File

@ -0,0 +1,201 @@
{cp866}
unit System;
{$i _defines.inc}
{$define HAS_CMDLINE}
interface
{$i systemh.inc}
{$i kos_def.inc}
{$i kosh.inc}
const
LineEnding = #13#10;
LFNSupport = True;
DirectorySeparator = '/';
DriveSeparator = '/';
PathSeparator = ';';
MaxExitCode = 65535;
MaxPathLen = 512;
UnusedHandle : THandle = -1;
StdInputHandle : THandle = 0;
StdOutputHandle: THandle = 0;
StdErrorHandle : THandle = 0;
FileNameCaseSensitive: Boolean = True;
CtrlZMarksEOF: Boolean = True;
sLineBreak = LineEnding;
DefaultTextLineBreakStyle: TTextLineBreakStyle = tlbsCRLF;
var
Argc: Longint = 0;
Argv: PPChar = nil;
Konsole: TKonsole;
implementation
var
SysInstance: Longint; public name '_FPC_SysInstance';
{$i system.inc}
procedure SetupCmdLine;
var
Ptrs: array of PChar;
Args: PChar;
InQuotes: Boolean;
I, L: Longint;
begin
Argc := 1;
Args := PKosHeader(0)^.args;
if Assigned(Args) then
begin
while Args^ <> #0 do
begin
{<7B>யãáâ¨âì «¨¤¨àãî騥 ¯à®¡¥«ë}
while Args^ in [#1..#32] do Inc(Args);
if Args^ = #0 then Break;
{‡ ¯®¬­¨âì 㪠§ â¥«ì ­  ¯ à ¬¥âà}
SetLength(Ptrs, Argc);
Ptrs[Argc - 1] := Args;
Inc(Argc);
{<7B>யãáâ¨âì ⥪ã騩 ¯ à ¬¥âà}
InQuotes := False;
while (Args^ <> #0) and (not (Args^ in [#1..#32]) or InQuotes) do
begin
if Args^ = '"' then InQuotes := not InQuotes;
Inc(Args);
end;
{“áâ ­®¢¨âì ®ª®­ç ­¨¥ ¯ à ¬¥âà }
if Args^ in [#1..#32] then
begin
Args^ := #0;
Inc(Args);
end;
end;
end;
Argv := GetMem(Argc * SizeOf(PChar)); {XXX: ¯ ¬ïâì ­¥ ®á¢®¡®¦¤ ¥âáï}
Argv[0] := PKosHeader(0)^.path;
for I := 1 to Argc - 1 do
begin
Argv[I] := Ptrs[I - 1];
{ˆáª«îç¨âì ª ¢ë窨 ¨§ áâப¨}
Args := Argv[I];
L := 0;
while Args^ <> #0 do begin Inc(Args); Inc(L); end;
Args := Argv[I];
while Args^ <> #0 do
begin
if Args^ = '"' then
begin
Move(PChar(Args + 1)^, Args^, L);
Dec(L);
end;
Inc(Args);
Dec(L);
end;
end;
end;
function ParamCount: Longint;
begin
Result := Argc - 1;
end;
function ParamStr(L: Longint): String;
begin
if (L >= 0) and (L < Argc) then
Result := StrPas(Argv[L]) else
Result := '';
end;
procedure Randomize;
begin
randseed := 0; {GetTickCount()}
end;
const
ProcessID: SizeUInt = 0;
function GetProcessID: SizeUInt;
begin
GetProcessID := ProcessID;
end;
function CheckInitialStkLen(stklen: SizeUInt): SizeUInt;
begin
{TODO}
Result := stklen;
end;
{$i kos_stdio.inc}
procedure SysInitStdIO;
begin
if IsConsole then
begin
AssignStdin(Input);
AssignStdout(Output);
AssignStdout(ErrOutput);
AssignStdout(StdOut);
AssignStdout(StdErr);
end;
end;
procedure System_Exit; [public, alias: 'SystemExit'];
var
event, count: DWord;
begin
if IsConsole then
begin
if ExitCode <> 0 then
begin
{XXX: ®¡ï§ â¥«ì­®¥ ãá«®¢¨¥ ­  ®¤­®¯®â®ç­ë© Konsole}
Write(StdErr, '[Error #', ExitCode,', press any key]');
{®¦¨¤ âì ­ ¦ â¨ï ª« ¢¨è¨}
Konsole.KeyPressed;
while Konsole.KeyPressed = 0 do kos_delay(2);
{TODO: ¨á¯à ¢¨âì ª®áïª ¯à¨ ¯¥à¥à¨á®¢ª¥ Konsole}
{íâ® ­¥¢®§¬®¦­®, â ª ª ª ªãç  ®á¢®¡®¦¤ ¥âáï ¥é¥ ¤® ¢ë§®¢  í⮩ ¯à®æ¥¤ãàë}
{¬®¦­® ­ ¯¨á âì ᢮© ¤¨á¯¥âç¥à ¯ ¬ïâ¨, ­® íâ® á«®¦­®}
{  ¥á«¨ ¢ Konsole ¨á¯®«ì§®¢ âì ¢ë¤¥«¥­¨¥ ¯ ¬ï⨠­ ¯àï¬ãî ç¥à¥§ KosAPI?!}
end;
Close(StdErr);
Close(StdOut);
Close(ErrOutput);
Close(Input);
Close(Output);
Konsole.Done();
end;
asm
movl $-1, %eax
int $0x40
end;
end;
{$i kos.inc}
begin
SysResetFPU;
StackLength := CheckInitialStkLen(InitialStkLen);
StackBottom := Pointer(StackTop - StackLength);
InitHeap;
kos_initheap();
SysInitExceptions;
FPC_CpuCodeInit();
InOutRes := 0;
InitSystemThreads;
Konsole.Init();
SysInitStdIO;
SetupCmdLine;
InitVariantManager;
{InitWideStringManager;}
DispCallByIDProc := @DoDispCallByIDError;
end.

386
programs/develop/fp/rtl/systhrd.inc Normal file
View File

@ -0,0 +1,386 @@
{}
{XXX: Thread vars & TLS}
const
ThreadVarBlockSize: DWord = 0;
TLSGrowFor = 4096;
type
PTLSIndex = ^TTLSIndex;
TTLSIndex = record
CS: TRTLCriticalSection;
Slots: array[0..TLSGrowFor - 1] of record
TID: DWord;
Value: Pointer;
end;
end;
var
TLSKey: PTLSIndex;
function TLSAlloc(): PTLSIndex;
var
I: DWord;
begin
{New(Result);}
Result := kos_alloc(SizeOf(TTLSIndex));
InitCriticalSection(Result^.CS);
{SetLength(Result^.Slots, TLSGrowFor);}
for I := 0 to TLSGrowFor - 1 do
Result^.Slots[I].TID := 0;
end;
function TLSFree(TLSIndex: PTLSIndex): Boolean;
begin
DoneCriticalSection(TLSIndex^.CS);
{SetLength(TLSIndex^.Slots, 0);
Dispose(TLSIndex);}
kos_free(TLSIndex);
Result := True;
end;
procedure TLSSetValue(TLSIndex: PTLSIndex; Value: Pointer);
var
TID, I, Count, Slot: DWord;
begin
TID := GetCurrentThreadID();
EnterCriticalSection(TLSIndex^.CS);
Count := Length(TLSIndex^.Slots);
Slot := Count;
for I := 0 to Count - 1 do
if TLSIndex^.Slots[I].TID = TID then
begin
Slot := I;
Break;
end else
if TLSIndex^.Slots[I].TID = 0 then
Slot := I;
if Slot >= Count then
begin
Halt(123);
{SetLength(TLSIndex^.Slots, Count + TLSGrowFor);
FillChar(TLSIndex^.Slots[Count], TLSGrowFor * SizeOf(TLSIndex^.Slots[0]), #0);
Slot := Count;}
end;
TLSIndex^.Slots[Slot].TID := TID;
TLSIndex^.Slots[Slot].Value := Value;
LeaveCriticalSection(TLSIndex^.CS);
end;
function TLSGetValue(TLSIndex: PTLSIndex): Pointer;
var
TID, I, Count: DWord;
begin
Result := nil;
TID := GetCurrentThreadID();
EnterCriticalSection(TLSIndex^.CS);
Count := Length(TLSIndex^.Slots);
for I := 0 to Count - 1 do
if TLSIndex^.Slots[I].TID = TID then
begin
Result := TLSIndex^.Slots[I].Value;
break;
end;
LeaveCriticalSection(TLSIndex^.CS);
end;
procedure SysInitThreadVar(var Offset: DWord; Size: DWord);
begin
Offset := ThreadVarBlockSize;
Inc(ThreadVarBlockSize, Size);
end;
procedure SysAllocateThreadVars;
var
DataIndex: Pointer;
begin
{DataIndex := GetMem(ThreadVarBlockSize);}
DataIndex := kos_alloc(ThreadVarBlockSize);
FillChar(DataIndex^, ThreadVarBlockSize, #0);
TLSSetValue(TLSKey, DataIndex);
end;
function SysRelocateThreadVar(Offset: DWord): Pointer;
var
DataIndex: Pointer;
begin
DataIndex := TLSGetValue(TLSKey);
if DataIndex = nil then
begin
SysAllocateThreadVars;
DataIndex := TLSGetValue(TLSKey);
end;
Result := DataIndex + Offset;
end;
procedure SysReleaseThreadVars;
begin
{FreeMem(TLSGetValue(TLSKey));}
kos_free(TLSGetValue(TLSKey));
end;
{XXX: Thread}
type
PThreadInfo = ^TThreadInfo;
TThreadInfo = record
Func: TThreadFunc;
Arg: Pointer;
StackSize: PtrUInt;
Stack: Pointer;
end;
procedure DoneThread;
begin
SysReleaseThreadVars;
end;
procedure ThreadMain(ThreadInfo: PThreadInfo);
var
Result: PtrInt;
begin
SysAllocateThreadVars;
with ThreadInfo^ do
begin
InitThread(StackSize);
try
Result := Func(Arg);
except
{TODO: Ž¡à ¡®â âì ®è¨¡ª¨}
WriteLn(StdErr, 'Exception in thread');
end;
FreeMem(Stack);
end;
asm
movl $-1, %eax
int $0x40
end;
end;
function SysBeginThread(sa: Pointer; StackSize: PtrUInt; ThreadFunction: TThreadFunc; Arg: Pointer; CreationFlags: DWord; var ThreadID: TThreadID): TThreadID;
{Stack, esp, ThreadInfo}
procedure EntryThreadMain; assembler;
asm
movl %esp, %eax
jmp ThreadMain
end;
var
Stack: Pointer;
ThreadInfo: PThreadInfo;
begin
if not IsMultiThread then
begin
TLSKey := TLSAlloc();
InitThreadVars(@SysRelocateThreadVar); {XXX: must be @SysRelocateThreadvar}
IsMultiThread := True;
end;
StackSize := (StackSize + 3) div 4;
Stack := GetMem(StackSize + SizeOf(TThreadInfo));
ThreadInfo := PThreadInfo(PByte(Stack) + StackSize);
ThreadInfo^.Func := ThreadFunction;
ThreadInfo^.Arg := Arg;
ThreadInfo^.StackSize := StackSize;
ThreadInfo^.Stack := Stack;
ThreadID := kos_newthread(@EntryThreadMain, ThreadInfo);
Result := ThreadID;
end;
procedure SysEndThread(ExitCode: DWord);
begin
WriteLn('..SysEndThread');
{TODO: SysEndThread}
SysReleaseThreadVars;
end;
function SysSuspendThread(ThreadHandle: TThreadID): DWord;
begin
{TODO: SysSuspendThread}
Result := -1;
end;
function SysResumeThread(ThreadHandle: TThreadID): DWord;
begin
{TODO: SysResumeThread}
Result := -1;
end;
function SysKillThread(ThreadHandle: TThreadID): DWord;
begin
if kos_killthread(ThreadHandle) then
Result := 0 else
Result := -1;
end;
procedure SysThreadSwitch;
begin
{$ifdef EMULATOR}
kos_delay(0);{$else}
kos_switchthread();{$endif}
end;
function SysGetCurrentThreadID: TThreadID;
var
ThreadInfo: TKosThreadInfo;
begin
kos_threadinfo(@ThreadInfo);
Result := ThreadInfo.ThreadID;
end;
{XXX: CriticalSection}
procedure SysInitCriticalSection(var CS);
begin
PRTLCriticalSection(CS)^.OwningThread := -1;
end;
procedure SysDoneCriticalSection(var CS);
begin
PRTLCriticalSection(CS)^.OwningThread := -1;
end;
procedure SysEnterCriticalSection(var CS);
var
ThisThread: TThreadID;
begin
ThisThread := GetCurrentThreadId();
if PRTLCriticalSection(CS)^.OwningThread <> ThisThread then
while PRTLCriticalSection(CS)^.OwningThread <> -1 do;
PRTLCriticalSection(CS)^.OwningThread := ThisThread;
end;
procedure SysLeaveCriticalSection(var CS);
begin
if PRTLCriticalSection(CS)^.OwningThread = GetCurrentThreadId() then
PRTLCriticalSection(CS)^.OwningThread := -1;
end;
{TODO: RTLEvent}
function SysRTLEventCreate: PRTLEvent;
begin
Result := nil;
end;
procedure SysRTLEventDestroy(State: PRTLEvent);
begin
end;
{$ifndef HAS_MT_MEMORYMANAGER}
var
HeapMutex: TRTLCriticalSection;
procedure KosHeapMutexInit;
begin
InitCriticalSection(HeapMutex);
end;
procedure KosHeapMutexDone;
begin
DoneCriticalSection(HeapMutex);
end;
procedure KosHeapMutexLock;
begin
EnterCriticalSection(HeapMutex);
end;
procedure KosHeapMutexUnlock;
begin
LeaveCriticalSection(HeapMutex);
end;
const
KosMemoryMutexManager: TMemoryMutexManager = (
MutexInit: @KosHeapMutexInit;
MutexDone: @KosHeapMutexDone;
MutexLock: @KosHeapMutexLock;
MutexUnlock: @KosHeapMutexUnlock);
procedure InitHeapMutexes;
begin
SetMemoryMutexManager(KosMemoryMutexManager);
end;
{$endif HAS_MT_MEMORYMANAGER}
var
KosThreadManager: TThreadManager;
procedure InitSystemThreads;
begin
ThreadID := TThreadID(1);
with KosThreadManager do
begin
InitManager := nil;
DoneManager := nil;
BeginThread := @SysBeginThread;
EndThread := @SysEndThread;
SuspendThread := @SysSuspendThread;
ResumeThread := @SysResumeThread;
KillThread := @SysKillThread;
ThreadSwitch := @SysThreadSwitch;
WaitForThreadTerminate := nil; //@NoWaitForThreadTerminate;
ThreadSetPriority := nil; //@NoThreadSetPriority;
ThreadGetPriority := nil; //@NoThreadGetPriority;
GetCurrentThreadID := @SysGetCurrentThreadID;
InitCriticalSection := @SysInitCriticalSection;
DoneCriticalSection := @SysDoneCriticalSection;
EnterCriticalSection := @SysEnterCriticalSection;
LeaveCriticalSection := @SysLeaveCriticalSection;
InitThreadVar := @SysInitThreadVar;
RelocateThreadVar := @SysRelocateThreadVar;
AllocateThreadVars := @SysAllocateThreadVars;
ReleaseThreadVars := @SysReleaseThreadVars;
BasicEventCreate := @NoBasicEventCreate;
BasicEventDestroy := @NoBasicEventDestroy;
BasicEventResetEvent := @NoBasicEventResetEvent;
BasicEventSetEvent := @NoBasicEventSetEvent;
BasicEventWaitFor := @NoBasicEventWaitFor;
RTLEventCreate := @SysRTLEventCreate;
RTLEventDestroy := @SysRTLEventDestroy;
RTLEventSetEvent := @NoRTLEventSetEvent;
RTLEventWaitFor := @NoRTLEventWaitFor;
RTLEventSync := @NoRTLEventSync;
RTLEventWaitForTimeout := @NoRTLEventWaitForTimeout;
SemaphoreInit := @NoSemaphoreInit;
SemaphoreDestroy := @NoSemaphoreDestroy;
SemaphoreWait := @NoSemaphoreWait;
SemaphorePost := @NoSemaphorePost;
end;
SetThreadManager(KosThreadManager);
{$ifndef HAS_MT_MEMORYMANAGER}
InitHeapMutexes;
{$endif HAS_MT_MEMORYMANAGER}
ThreadID := GetCurrentThreadID;
end;

448
programs/develop/fp/rtl/sysutils.pp Normal file
View File

@ -0,0 +1,448 @@
unit sysutils;
{$i _defines.inc}
interface
{$mode objfpc}
{ force ansistrings }
{$h+}
{$DEFINE HAS_SLEEP}
{-$DEFINE HAS_OSERROR}
{-$DEFINE HAS_OSCONFIG}
{-$DEFINE HAS_CREATEGUID}
{ Include platform independent interface part }
{$i sysutilh.inc}
implementation
uses
SysConst;
{-$define HASCREATEGUID}
{-$define HASEXPANDUNCFILENAME}
{-$DEFINE FPC_NOGENERICANSIROUTINES}
{-$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
{-$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
{ Include platform independent implementation part }
{$i sysutils.inc}
{****************************************************************************
File Functions
****************************************************************************}
const
FILEHANDLEPREFIX = $4000;
type
PFileRecord = ^TFileRecord;
TFileRecord = record
Filled: Boolean;
F: File;
end;
var
FileHandles: array of TFileRecord;
function FileRecordByHandle(Handle: THandle): PFileRecord;
begin
Dec(Handle, FILEHANDLEPREFIX);
Result := @FileHandles[Handle];
end;
function CreateFileRecord(): THandle;
var
I, C: Longword;
begin
Result := -1;
C := Length(FileHandles);
for I := 0 to C - 1 do
if not FileHandles[I].Filled then
begin
Result := I;
Break;
end;
if Result < 0 then
begin
SetLength(FileHandles, C + 1);
Result := C;
end;
FileHandles[Result].Filled := True;
FillChar(FileHandles[Result].F, SizeOf(FileRec), 0);
Inc(Result, FILEHANDLEPREFIX);
end;
procedure ReleaseFileRecord(Handle: THandle);
begin
FileRecordByHandle(Handle)^.Filled := False;
end;
function FileOpen(const FileName: String; Mode: Integer): THandle;
var
F: File;
begin
Filemode := Mode;
Assign(F, FileName);
Reset(F, 1);
if InOutRes = 0 then
begin
Result := CreateFileRecord();
FileRecordByHandle(Result)^.F := F;
end else
Result := feInvalidHandle;
end;
function FileCreate(const FileName: String): THandle;
var
F: File;
begin
Assign(F, FileName);
Rewrite(F, 1);
if InOutRes = 0 then
begin
Result := CreateFileRecord();
FileRecordByHandle(Result)^.F := F;
end else
Result := feInvalidHandle;
end;
function FileCreate(const FileName: String; Mode: Integer): THandle;
var
F: File;
begin
Filemode := Mode;
Assign(F, FileName);
Rewrite(F, 1);
if InOutRes = 0 then
begin
Result := CreateFileRecord();
FileRecordByHandle(Result)^.F := F;
end else
Result := feInvalidHandle;
end;
function FileRead(Handle: THandle; var Buffer; Count: Longint): Longint;
begin
BlockRead(FileRecordByHandle(Handle)^.F, Buffer, Count, Result);
end;
function FileWrite(Handle: THandle; const Buffer; Count: Longint): Longint;
begin
BlockWrite(FileRecordByHandle(Handle)^.F, Buffer, Count, Result);
end;
function FileSeek(Handle: THandle; FOffset, Origin: Longint): Longint;
begin
Result := FileSeek(Handle, Int64(FOffset), Origin);
end;
function FileSeek(Handle: THandle; FOffset: Int64; Origin: Longint): Int64;
var
Position: Int64;
begin
case Origin of
fsFromBeginning: Position := FOffset;
fsFromCurrent: Position := FilePos(FileRecordByHandle(Handle)^.F) + FOffset;
fsFromEnd: Position := FileSize(FileRecordByHandle(Handle)^.F) + FOffset;
end;
{TODO: ¯à®¢¥àª  ᮮ⢥âá⢨ï [0..filesize]}
Seek(FileRecordByHandle(Handle)^.F, Position);
Result := Position;
end;
procedure FileClose(Handle: THandle);
begin
Close(FileRecordByHandle(Handle)^.F);
ReleaseFileRecord(Handle);
end;
function FileTruncate(Handle: THandle; Size: Longint): Boolean;
begin
Result := False;
end;
function FileAge(const FileName: String): Longint;
begin
Result := 0;
end;
function FileExists(const FileName: String): Boolean;
var
F: File;
begin
Assign(F, FileName);
try
Reset(F);
FileSize(F);
Result := True;
except
Result := False;
end;
Close(F);
end;
function DirectoryExists(const Directory: String): Boolean;
begin
Result := False;
end;
function FindMatch(var f: TSearchRec): Longint;
begin
Result := feInvalidHandle;
end;
function FindFirst(const Path: String; Attr: Longint; out Rslt: TSearchRec): Longint;
begin
Result := feInvalidHandle;
end;
function FindNext(var Rslt: TSearchRec): Longint;
begin
Result := feInvalidHandle;
end;
procedure FindClose(var F: TSearchrec);
begin
end;
function FileGetDate(Handle: THandle): Longint;
begin
Result := feInvalidHandle;
end;
function FileSetDate(Handle: THandle; Age: Longint): Longint;
begin
Result := feInvalidHandle;
end;
function FileGetAttr(const FileName: String): Longint;
begin
Result := feInvalidHandle;
end;
function FileSetAttr(const Filename: String; Attr: longint): Longint;
begin
Result := feInvalidHandle;
end;
function DeleteFile(const FileName: String): Boolean;
begin
Result := False;
end;
function RenameFile(const OldName, NewName: String): Boolean;
begin
Result := False;
end;
{****************************************************************************
Disk Functions
****************************************************************************}
function DiskFree(drive: Byte): Int64;
begin
Result := 0;
end;
function DiskSize(drive: Byte): Int64;
begin
Result := 0;
end;
function GetCurrentDir: String;
begin
GetDir(0, Result);
end;
function SetCurrentDir(const NewDir: String): Boolean;
var
Path: String;
begin
ChDir(NewDir);
GetDir(0, Path);
Result := Path = NewDir;
end;
function CreateDir(const NewDir: String): Boolean;
begin
Result := False;
end;
function RemoveDir(const Dir: String): Boolean;
begin
Result := False;
end;
{****************************************************************************
Time Functions
****************************************************************************}
procedure GetLocalTime(var SystemTime: TSystemTime);
begin
end;
{****************************************************************************
Misc Functions
****************************************************************************}
procedure Beep;
begin
end;
{****************************************************************************
Locale Functions
****************************************************************************}
procedure GetFormatSettings;
var
HF: String;
begin
ShortMonthNames[1] := SShortMonthNameJan;
ShortMonthNames[2] := SShortMonthNameFeb;
ShortMonthNames[3] := SShortMonthNameMar;
ShortMonthNames[4] := SShortMonthNameApr;
ShortMonthNames[5] := SShortMonthNameMay;
ShortMonthNames[6] := SShortMonthNameJun;
ShortMonthNames[7] := SShortMonthNameJul;
ShortMonthNames[8] := SShortMonthNameAug;
ShortMonthNames[9] := SShortMonthNameSep;
ShortMonthNames[10] := SShortMonthNameOct;
ShortMonthNames[11] := SShortMonthNameNov;
ShortMonthNames[12] := SShortMonthNameDec;
LongMonthNames[1] := SLongMonthNameJan;
LongMonthNames[2] := SLongMonthNameFeb;
LongMonthNames[3] := SLongMonthNameMar;
LongMonthNames[4] := SLongMonthNameApr;
LongMonthNames[5] := SLongMonthNameMay;
LongMonthNames[6] := SLongMonthNameJun;
LongMonthNames[7] := SLongMonthNameJul;
LongMonthNames[8] := SLongMonthNameAug;
LongMonthNames[9] := SLongMonthNameSep;
LongMonthNames[10] := SLongMonthNameOct;
LongMonthNames[11] := SLongMonthNameNov;
LongMonthNames[12] := SLongMonthNameDec;
ShortDayNames[1] := SShortDayNameMon;
ShortDayNames[2] := SShortDayNameTue;
ShortDayNames[3] := SShortDayNameWed;
ShortDayNames[4] := SShortDayNameThu;
ShortDayNames[5] := SShortDayNameFri;
ShortDayNames[6] := SShortDayNameSat;
ShortDayNames[7] := SShortDayNameSun;
LongDayNames[1] := SLongDayNameMon;
LongDayNames[2] := SLongDayNameTue;
LongDayNames[3] := SLongDayNameWed;
LongDayNames[4] := SLongDayNameThu;
LongDayNames[5] := SLongDayNameFri;
LongDayNames[6] := SLongDayNameSat;
LongDayNames[7] := SShortDayNameSun;
DateSeparator := '/';
ShortDateFormat := 'd/mm/yy';
LongDateFormat := 'd mmmm yyyy';
{ Time stuff }
TimeSeparator := ':';
TimeAMString := 'AM';
TimePMString := 'PM';
HF := 'hh';
// No support for 12 hour stuff at the moment...
ShortTimeFormat := HF + ':nn';
LongTimeFormat := HF + ':nn:ss';
{ Currency stuff }
CurrencyString := '';
CurrencyFormat := 0;
NegCurrFormat := 0;
{ Number stuff }
ThousandSeparator := ',';
DecimalSeparator := '.';
CurrencyDecimals := 2;
end;
Procedure InitInternational;
begin
InitInternationalGeneric;
GetFormatSettings;
end;
{****************************************************************************
Target Dependent
****************************************************************************}
function SysErrorMessage(ErrorCode: Integer): String;
const
MaxMsgSize = 255;
var
MsgBuffer: PChar;
begin
GetMem(MsgBuffer, MaxMsgSize);
FillChar(MsgBuffer^, MaxMsgSize, #0);
{TODO}
Result := StrPas(MsgBuffer);
FreeMem(MsgBuffer, MaxMsgSize);
end;
{****************************************************************************
Initialization code
****************************************************************************}
Function GetEnvironmentVariable(Const EnvVar: String): String;
begin
Result := '';
end;
Function GetEnvironmentVariableCount: Integer;
begin
Result := 0;
end;
Function GetEnvironmentString(Index : Integer) : String;
begin
Result := '';
end;
function ExecuteProcess(Const Path: AnsiString; Const ComLine: AnsiString): Integer;
begin
Result := 0;
end;
function ExecuteProcess(Const Path: AnsiString; Const ComLine: Array of AnsiString): Integer;
var
CommandLine: AnsiString;
i: Integer;
begin
Commandline:='';
For i:=0 to high(ComLine) Do
Commandline:=CommandLine+' '+Comline[i];
ExecuteProcess:=ExecuteProcess(Path,CommandLine);
end;
procedure Sleep(Milliseconds: Cardinal);
begin
kos_delay(Milliseconds div 10);
end;
function GetLastOSError: Integer;
begin
Result := -1;
end;
initialization
InitExceptions;
InitInternational;
finalization
DoneExceptions;
end.

95
programs/develop/fp/rtl/tthread.inc Normal file
View File

@ -0,0 +1,95 @@
{ TODO }
{ Thread management routines }
type
PRaiseFrame = ^TRaiseFrame;
TRaiseFrame = record
NextRaise: PRaiseFrame;
ExceptAddr: Pointer;
ExceptObject: TObject;
ExceptionRecord: pointer; {PExceptionRecord}
end;
var
ThreadCount: Integer;
procedure AddThread;
begin
InterlockedIncrement(ThreadCount);
end;
procedure RemoveThread;
begin
InterlockedDecrement(ThreadCount);
end;
constructor TThread.Create(CreateSuspended: Boolean; const StackSize: SizeUInt = DefaultStackSize);
begin
inherited Create;
AddThread;
FSuspended := CreateSuspended;
{TODO}
FFatalException := nil;
end;
destructor TThread.Destroy;
begin
if not FFinished and not Suspended then
begin
Terminate;
WaitFor;
end;
FFatalException.Free;
FFatalException := nil;
inherited Destroy;
RemoveThread;
end;
procedure TThread.CallOnTerminate;
begin
FOnTerminate(Self);
end;
procedure TThread.DoTerminate;
begin
if Assigned(FOnTerminate) then
Synchronize(@CallOnTerminate);
end;
function TThread.GetPriority: TThreadPriority;
begin
{TODO}
end;
procedure TThread.SetPriority(Value: TThreadPriority);
begin
{TODO}
end;
procedure TThread.SetSuspended(Value: Boolean);
begin
if Value <> FSuspended then
if Value then Suspend else Resume;
end;
procedure TThread.Suspend;
begin
FSuspended := True;
SuspendThread(FHandle);
end;
procedure TThread.Resume;
begin
if ResumeThread(FHandle) = 1 then FSuspended := False;
end;
procedure TThread.Terminate;
begin
FTerminated := True;
end;
function TThread.WaitFor: Integer;
begin
{TODO}
end;

396
programs/develop/fp/rtl/types.pp Normal file
View File

@ -0,0 +1,396 @@
{$mode objfpc}
unit Types;
interface
type
PLongint = System.PLongint;
PSmallInt = System.PSmallInt;
PDouble = System.PDouble;
PByte = System.PByte;
TIntegerDynArray = array of Integer;
TCardinalDynArray = array of Cardinal;
TWordDynArray = array of Word;
TSmallIntDynArray = array of SmallInt;
TByteDynArray = array of Byte;
TShortIntDynArray = array of ShortInt;
TInt64DynArray = array of Int64;
TQWordDynArray = array of QWord;
TLongWordDynArray = array of LongWord;
TSingleDynArray = array of Single;
TDoubleDynArray = array of Double;
TBooleanDynArray = array of Boolean;
TStringDynArray = array of AnsiString;
TWideStringDynArray = array of WideString;
TPointerDynArray = array of Pointer;
TPoint =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
X : Longint;
Y : Longint;
end;
PPoint = ^TPoint;
tagPOINT = TPoint;
TRect =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
case Integer of
0: (Left,Top,Right,Bottom : Longint);
1: (TopLeft,BottomRight : TPoint);
end;
PRect = ^TRect;
TSize =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
cx : Longint;
cy : Longint;
end;
PSize = ^TSize;
tagSIZE = TSize;
// SIZE = TSize;
TSmallPoint =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
x : SmallInt;
y : SmallInt;
end;
PSmallPoint = ^TSmallPoint;
TDuplicates = (dupIgnore, dupAccept, dupError);
type
TOleChar = WideChar;
POleStr = PWideChar;
PPOleStr = ^POleStr;
TListCallback = procedure(data,arg:pointer) of object;
TListStaticCallback = procedure(data,arg:pointer);
const
GUID_NULL: TGUID = '{00000000-0000-0000-0000-000000000000}';
STGTY_STORAGE = 1;
STGTY_STREAM = 2;
STGTY_LOCKBYTES = 3;
STGTY_PROPERTY = 4;
STREAM_SEEK_SET = 0;
STREAM_SEEK_CUR = 1;
STREAM_SEEK_END = 2;
LOCK_WRITE = 1;
LOCK_EXCLUSIVE = 2;
LOCK_ONLYONCE = 4;
E_FAIL = HRESULT($80004005);
STG_E_INVALIDFUNCTION = HRESULT($80030001);
STG_E_FILENOTFOUND = HRESULT($80030002);
STG_E_PATHNOTFOUND = HRESULT($80030003);
STG_E_TOOMANYOPENFILES = HRESULT($80030004);
STG_E_ACCESSDENIED = HRESULT($80030005);
STG_E_INVALIDHANDLE = HRESULT($80030006);
STG_E_INSUFFICIENTMEMORY = HRESULT($80030008);
STG_E_INVALIDPOINTER = HRESULT($80030009);
STG_E_NOMOREFILES = HRESULT($80030012);
STG_E_DISKISWRITEPROTECTED = HRESULT($80030013);
STG_E_SEEKERROR = HRESULT($80030019);
STG_E_WRITEFAULT = HRESULT($8003001D);
STG_E_READFAULT = HRESULT($8003001E);
STG_E_SHAREVIOLATION = HRESULT($80030020);
STG_E_LOCKVIOLATION = HRESULT($80030021);
STG_E_FILEALREADYEXISTS = HRESULT($80030050);
STG_E_INVALIDPARAMETER = HRESULT($80030057);
STG_E_MEDIUMFULL = HRESULT($80030070);
STG_E_PROPSETMISMATCHED = HRESULT($800300F0);
STG_E_ABNORMALAPIEXIT = HRESULT($800300FA);
STG_E_INVALIDHEADER = HRESULT($800300FB);
STG_E_INVALIDNAME = HRESULT($800300FC);
STG_E_UNKNOWN = HRESULT($800300FD);
STG_E_UNIMPLEMENTEDFUNCTION = HRESULT($800300FE);
STG_E_INVALIDFLAG = HRESULT($800300FF);
STG_E_INUSE = HRESULT($80030100);
STG_E_NOTCURRENT = HRESULT($80030101);
STG_E_REVERTED = HRESULT($80030102);
STG_E_CANTSAVE = HRESULT($80030103);
STG_E_OLDFORMAT = HRESULT($80030104);
STG_E_OLDDLL = HRESULT($80030105);
STG_E_SHAREREQUIRED = HRESULT($80030106);
STG_E_EXTANTMARSHALLINGS = HRESULT($80030108);
STG_E_DOCFILECORRUPT = HRESULT($80030109);
STG_E_BADBASEADDRESS = HRESULT($80030110);
STG_E_INCOMPLETE = HRESULT($80030201);
STG_E_TERMINATED = HRESULT($80030202);
STG_S_CONVERTED = $00030200;
STG_S_BLOCK = $00030201;
STG_S_RETRYNOW = $00030202;
STG_S_MONITORING = $00030203;
type
PCLSID = PGUID;
TCLSID = TGUID;
LARGE_INT = Int64;
Largeint = LARGE_INT;
PDWord = ^DWord;
PDisplay = Pointer;
PEvent = Pointer;
TXrmOptionDescRec = record
end;
XrmOptionDescRec = TXrmOptionDescRec;
PXrmOptionDescRec = ^TXrmOptionDescRec;
Widget = Pointer;
WidgetClass = Pointer;
ArgList = Pointer;
Region = Pointer;
_FILETIME =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
dwLowDateTime : DWORD;
dwHighDateTime : DWORD;
end;
TFileTime = _FILETIME;
FILETIME = _FILETIME;
PFileTime = ^TFileTime;
tagSTATSTG =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
pwcsName : POleStr;
dwType : Longint;
cbSize : Largeint;
mtime : TFileTime;
ctime : TFileTime;
atime : TFileTime;
grfMode : Longint;
grfLocksSupported : Longint;
clsid : TCLSID;
grfStateBits : Longint;
reserved : Longint;
end;
TStatStg = tagSTATSTG;
STATSTG = TStatStg;
PStatStg = ^TStatStg;
IClassFactory = Interface(IUnknown) ['{00000001-0000-0000-C000-000000000046}']
Function CreateInstance(Const unkOuter : IUnknown;Const riid : TGUID;Out vObject) : HResult;StdCall;
Function LockServer(fLock : LongBool) : HResult;StdCall;
End;
ISequentialStream = interface(IUnknown) ['{0c733a30-2a1c-11ce-ade5-00aa0044773d}']
function Read(pv : Pointer;cb : DWord;pcbRead : PDWord) : HRESULT;stdcall;
function Write(pv : Pointer;cb : DWord;pcbWritten : PDWord) : HRESULT;stdcall;
end;
IStream = interface(ISequentialStream) ['{0000000C-0000-0000-C000-000000000046}']
function Seek(dlibMove : LargeInt; dwOrigin : Longint;
out libNewPosition : LargeInt) : HResult;stdcall;
function SetSize(libNewSize : LargeInt) : HRESULT;stdcall;
function CopyTo(stm: IStream;cb : LargeInt;out cbRead : LargeInt;
out cbWritten : LargeInt) : HRESULT;stdcall;
function Commit(grfCommitFlags : Longint) : HRESULT;stdcall;
function Revert : HRESULT;stdcall;
function LockRegion(libOffset : LargeInt;cb : LargeInt;
dwLockType : Longint) : HRESULT;stdcall;
function UnlockRegion(libOffset : LargeInt;cb : LargeInt;
dwLockType : Longint) : HRESULT;stdcall;
Function Stat(out statstg : TStatStg;grfStatFlag : Longint) : HRESULT;stdcall;
function Clone(out stm : IStream) : HRESULT;stdcall;
end;
function EqualRect(const r1,r2 : TRect) : Boolean;
function Rect(Left,Top,Right,Bottom : Integer) : TRect;
function Bounds(ALeft,ATop,AWidth,AHeight : Integer) : TRect;
function Point(x,y : Integer) : TPoint;
function PtInRect(const Rect : TRect; const p : TPoint) : Boolean;
function IntersectRect(var Rect : TRect; const R1,R2 : TRect) : Boolean;
function UnionRect(var Rect : TRect; const R1,R2 : TRect) : Boolean;
function IsRectEmpty(const Rect : TRect) : Boolean;
function OffsetRect(var Rect : TRect;DX : Integer;DY : Integer) : Boolean;
function CenterPoint(const Rect: TRect): TPoint;
function InflateRect(var Rect: TRect; dx: Integer; dy: Integer): Boolean;
function Size(AWidth, AHeight: Integer): TSize;
function Size(ARect: TRect): TSize;
implementation
function EqualRect(const r1,r2 : TRect) : Boolean;
begin
EqualRect:=(r1.left=r2.left) and (r1.right=r2.right) and (r1.top=r2.top) and (r1.bottom=r2.bottom);
end;
function Rect(Left,Top,Right,Bottom : Integer) : TRect;
begin
Rect.Left:=Left;
Rect.Top:=Top;
Rect.Right:=Right;
Rect.Bottom:=Bottom;
end;
function Bounds(ALeft,ATop,AWidth,AHeight : Integer) : TRect;
begin
Bounds.Left:=ALeft;
Bounds.Top:=ATop;
Bounds.Right:=ALeft+AWidth;
Bounds.Bottom:=ATop+AHeight;
end;
function Point(x,y : Integer) : TPoint;
begin
Point.x:=x;
Point.y:=y;
end;
function PtInRect(const Rect : TRect;const p : TPoint) : Boolean;
begin
PtInRect:=(p.y>=Rect.Top) and
(p.y<Rect.Bottom) and
(p.x>=Rect.Left) and
(p.x<Rect.Right);
end;
function IntersectRect(var Rect : TRect;const R1,R2 : TRect) : Boolean;
begin
Rect:=R1;
with R2 do
begin
if Left>R1.Left then
Rect.Left:=Left;
if Top>R1.Top then
Rect.Top:=Top;
if Right<R1.Right then
Rect.Right:=Right;
if Bottom<R1.Bottom then
Rect.Bottom:=Bottom;
end;
if IsRectEmpty(Rect) then
begin
FillChar(Rect,SizeOf(Rect),0);
IntersectRect:=false;
end
else
IntersectRect:=true;
end;
function UnionRect(var Rect : TRect;const R1,R2 : TRect) : Boolean;
begin
Rect:=R1;
with R2 do
begin
if Left<R1.Left then
Rect.Left:=Left;
if Top<R1.Top then
Rect.Top:=Top;
if Right>R1.Right then
Rect.Right:=Right;
if Bottom>R1.Bottom then
Rect.Bottom:=Bottom;
end;
if IsRectEmpty(Rect) then
begin
FillChar(Rect,SizeOf(Rect),0);
UnionRect:=false;
end
else
UnionRect:=true;
end;
function IsRectEmpty(const Rect : TRect) : Boolean;
begin
IsRectEmpty:=(Rect.Right<=Rect.Left) or (Rect.Bottom<=Rect.Top);
end;
function OffsetRect(var Rect : TRect;DX : Integer;DY : Integer) : Boolean;
begin
if assigned(@Rect) then
begin
with Rect do
begin
inc(Left,dx);
inc(Top,dy);
inc(Right,dx);
inc(Bottom,dy);
end;
OffsetRect:=true;
end
else
OffsetRect:=false;
end;
function CenterPoint(const Rect: TRect): TPoint;
begin
With Rect do
begin
Result.X:=(Left+Right) div 2;
Result.Y:=(Top+Bottom) div 2;
end;
end;
function InflateRect(var Rect: TRect; dx: Integer; dy: Integer): Boolean;
begin
if Assigned(@Rect) then
begin
with Rect do
begin
dec(Left, dx);
dec(Top, dy);
inc(Right, dx);
inc(Bottom, dy);
end;
Result := True;
end
else
Result := False;
end;
function Size(AWidth, AHeight: Integer): TSize;
begin
Result.cx := AWidth;
Result.cy := AHeight;
end;
function Size(ARect: TRect): TSize;
begin
Result.cx := ARect.Right - ARect.Left;
Result.cy := ARect.Bottom - ARect.Top;
end;
end.

7
programs/develop/fp/rtl/windows.pp Normal file
View File

@ -0,0 +1,7 @@
unit Windows;
interface
implementation
end.