diff --git a/programs/develop/fp/exe2kos/exe2kos.pp b/programs/develop/fp/exe2kos/exe2kos.pp new file mode 100644 index 0000000000..7d3c75f830 --- /dev/null +++ b/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 [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. diff --git a/programs/develop/fp/exe2kos/exeimage.pp b/programs/develop/fp/exe2kos/exeimage.pp new file mode 100644 index 0000000000..5137fb0c11 --- /dev/null +++ b/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. diff --git a/programs/develop/fp/exe2kos/exetypes.pp b/programs/develop/fp/exe2kos/exetypes.pp new file mode 100644 index 0000000000..f8059f5ec8 --- /dev/null +++ b/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. diff --git a/programs/develop/fp/exe2kos/kostypes.pp b/programs/develop/fp/exe2kos/kostypes.pp new file mode 100644 index 0000000000..1d0082c740 --- /dev/null +++ b/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. diff --git a/programs/develop/fp/readme-ru.txt b/programs/develop/fp/readme-ru.txt new file mode 100644 index 0000000000..39c0b48b54 --- /dev/null +++ b/programs/develop/fp/readme-ru.txt @@ -0,0 +1,3 @@ +Codepage: koi8-r + +ы╧══┼╬╘┴╥╔╔ ┬╒─╒╘ ╨╧┌╓┼. diff --git a/programs/develop/fp/rtl/_defines.inc b/programs/develop/fp/rtl/_defines.inc new file mode 100644 index 0000000000..8fe7b9a3da --- /dev/null +++ b/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} diff --git a/programs/develop/fp/rtl/build.bat b/programs/develop/fp/rtl/build.bat new file mode 100644 index 0000000000..4e24db7df5 --- /dev/null +++ b/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 diff --git a/programs/develop/fp/rtl/buildrtl.pp b/programs/develop/fp/rtl/buildrtl.pp new file mode 100644 index 0000000000..d064562877 --- /dev/null +++ b/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. diff --git a/programs/develop/fp/rtl/classes.pp b/programs/develop/fp/rtl/classes.pp new file mode 100644 index 0000000000..e9178dbecb --- /dev/null +++ b/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. diff --git a/programs/develop/fp/rtl/crt.pp b/programs/develop/fp/rtl/crt.pp new file mode 100644 index 0000000000..68730a82f1 --- /dev/null +++ b/programs/develop/fp/rtl/crt.pp @@ -0,0 +1,7 @@ +unit Crt; + +interface + +implementation + +end. diff --git a/programs/develop/fp/rtl/dos.pp b/programs/develop/fp/rtl/dos.pp new file mode 100644 index 0000000000..c7c0857b64 --- /dev/null +++ b/programs/develop/fp/rtl/dos.pp @@ -0,0 +1,9 @@ +unit Dos; + +interface + +{$i filerec.inc} + +implementation + +end. diff --git a/programs/develop/fp/rtl/kos.inc b/programs/develop/fp/rtl/kos.inc new file mode 100644 index 0000000000..944aa0a9f0 --- /dev/null +++ b/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; diff --git a/programs/develop/fp/rtl/kos_def.inc b/programs/develop/fp/rtl/kos_def.inc new file mode 100644 index 0000000000..c6395306f5 --- /dev/null +++ b/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; diff --git a/programs/develop/fp/rtl/kos_stdio.inc b/programs/develop/fp/rtl/kos_stdio.inc new file mode 100644 index 0000000000..bc6e137f7e --- /dev/null +++ b/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; diff --git a/programs/develop/fp/rtl/kosh.inc b/programs/develop/fp/rtl/kosh.inc new file mode 100644 index 0000000000..3f4c32212e --- /dev/null +++ b/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; diff --git a/programs/develop/fp/rtl/sysdir.inc b/programs/develop/fp/rtl/sysdir.inc new file mode 100644 index 0000000000..3748211ac2 --- /dev/null +++ b/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; diff --git a/programs/develop/fp/rtl/sysfile.inc b/programs/develop/fp/rtl/sysfile.inc new file mode 100644 index 0000000000..fdec72cb27 --- /dev/null +++ b/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; diff --git a/programs/develop/fp/rtl/sysheap.inc b/programs/develop/fp/rtl/sysheap.inc new file mode 100644 index 0000000000..c97634b174 --- /dev/null +++ b/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;*) diff --git a/programs/develop/fp/rtl/sysinitpas.pp b/programs/develop/fp/rtl/sysinitpas.pp new file mode 100644 index 0000000000..6224005c95 --- /dev/null +++ b/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. diff --git a/programs/develop/fp/rtl/sysos.inc b/programs/develop/fp/rtl/sysos.inc new file mode 100644 index 0000000000..277b80e796 --- /dev/null +++ b/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; diff --git a/programs/develop/fp/rtl/sysosh.inc b/programs/develop/fp/rtl/sysosh.inc new file mode 100644 index 0000000000..97940fd621 --- /dev/null +++ b/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; diff --git a/programs/develop/fp/rtl/system.pp b/programs/develop/fp/rtl/system.pp new file mode 100644 index 0000000000..90330b117c --- /dev/null +++ b/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. diff --git a/programs/develop/fp/rtl/systhrd.inc b/programs/develop/fp/rtl/systhrd.inc new file mode 100644 index 0000000000..47daf9f2e7 --- /dev/null +++ b/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; diff --git a/programs/develop/fp/rtl/sysutils.pp b/programs/develop/fp/rtl/sysutils.pp new file mode 100644 index 0000000000..4eea758eae --- /dev/null +++ b/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. diff --git a/programs/develop/fp/rtl/tthread.inc b/programs/develop/fp/rtl/tthread.inc new file mode 100644 index 0000000000..bc9e4b2400 --- /dev/null +++ b/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; diff --git a/programs/develop/fp/rtl/types.pp b/programs/develop/fp/rtl/types.pp new file mode 100644 index 0000000000..08303e43ab --- /dev/null +++ b/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.Left) and + (p.xR1.Left then + Rect.Left:=Left; + if Top>R1.Top then + Rect.Top:=Top; + if RightR1.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. diff --git a/programs/develop/fp/rtl/windows.pp b/programs/develop/fp/rtl/windows.pp new file mode 100644 index 0000000000..d26aa6ac8f --- /dev/null +++ b/programs/develop/fp/rtl/windows.pp @@ -0,0 +1,7 @@ +unit Windows; + +interface + +implementation + +end.