/programs/develop/fp/exe2kos/exe2kos.pp |
---|
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. |
/programs/develop/fp/exe2kos/exeimage.pp |
---|
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. |
/programs/develop/fp/exe2kos/exetypes.pp |
---|
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. |
/programs/develop/fp/exe2kos/kostypes.pp |
---|
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. |
/programs/develop/fp/exe2kos |
---|
Property changes: |
Added: svn:ignore |
+*.exe |
+*.o |
+*.ppu |
+*.log |
/programs/develop/fp/readme-ru.txt |
---|
0,0 → 1,3 |
Codepage: koi8-r |
ëÏÍÍÅÎÔÁÒÉÉ ÂÕÄÕÔ ÐÏÚÖÅ. |
/programs/develop/fp/rtl/_defines.inc |
---|
0,0 → 1,9 |
{$undef mswindows} |
{$undef windows} |
{$undef Windows} |
{$undef win32} |
{$undef os2} |
{$undef linux} |
{$define EMULATOR} |
{$undef debug_mt} |
/programs/develop/fp/rtl/build.bat |
---|
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 |
/programs/develop/fp/rtl/buildrtl.pp |
---|
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. |
/programs/develop/fp/rtl/classes.pp |
---|
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. |
/programs/develop/fp/rtl/crt.pp |
---|
0,0 → 1,7 |
unit Crt; |
interface |
implementation |
end. |
/programs/develop/fp/rtl/dos.pp |
---|
0,0 → 1,9 |
unit Dos; |
interface |
{$i filerec.inc} |
implementation |
end. |
/programs/develop/fp/rtl/kos.inc |
---|
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; |
/programs/develop/fp/rtl/kos_def.inc |
---|
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; |
/programs/develop/fp/rtl/kos_stdio.inc |
---|
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); |
{ ¡®ç¨© 横« ª®á®«¨} |
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; |
/programs/develop/fp/rtl/kosh.inc |
---|
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; |
{ãä¥à 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; |
/programs/develop/fp/rtl/sysdir.inc |
---|
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; |
/programs/develop/fp/rtl/sysfile.inc |
---|
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; |
/programs/develop/fp/rtl/sysheap.inc |
---|
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;*) |
/programs/develop/fp/rtl/sysinitpas.pp |
---|
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. |
/programs/develop/fp/rtl/sysos.inc |
---|
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; |
/programs/develop/fp/rtl/sysosh.inc |
---|
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; |
/programs/develop/fp/rtl/system.pp |
---|
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 |
{யãáâ¨âì «¨¤¨àãî騥 ¯à®¡¥«ë} |
while Args^ in [#1..#32] do Inc(Args); |
if Args^ = #0 then Break; |
{ ¯®¬¨âì 㪠§ â¥«ì ¯ à ¬¥âà} |
SetLength(Ptrs, Argc); |
Ptrs[Argc - 1] := Args; |
Inc(Argc); |
{யãáâ¨âì ⥪ã騩 ¯ à ¬¥âà} |
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. |
/programs/develop/fp/rtl/systhrd.inc |
---|
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; |
/programs/develop/fp/rtl/sysutils.pp |
---|
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. |
/programs/develop/fp/rtl/tthread.inc |
---|
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; |
/programs/develop/fp/rtl/types.pp |
---|
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. |
/programs/develop/fp/rtl/windows.pp |
---|
0,0 → 1,7 |
unit Windows; |
interface |
implementation |
end. |
/programs/develop/fp/rtl |
---|
Property changes: |
Added: svn:ignore |
+*.exe |
+*.o |
+*.ppu |
+*.log |
/programs/develop/fp |
---|
Property changes: |
Added: svn:ignore |
+*.exe |
+*.o |
+*.ppu |
+*.log |