paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 12:05:57 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ RTL for emx target

Browse Source
This commit is contained in:
Tomas Hajny 2002-11-17 16:22:53 +00:00
parent 758a11f069
commit 99d12084db
10 changed files with 5368 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1247
rtl/emx/Makefile Normal file
View File

File diff suppressed because it is too large Load Diff

190
rtl/emx/Makefile.fpc Normal file
View File

@ -0,0 +1,190 @@
#
# Makefile.fpc for Free Pascal OS/2 RTL
#
[package]
main=rtl
[target]
loaders=prt0 prt1
units=$(SYSTEMUNIT) objpas strings \
ports os2def doscalls moncalls kbdcalls moucalls viocalls \
pmbitmap pmwin pmgpi pmstddlg pmhelp pmdev pmspl dive \
dos crt objects printer \
sysutils math typinfo varutils \
charset ucomplex cpu mmx getopts heaptrc lineinfo dynlibs \
video mouse keyboard variants types
rsts=math varutils typinfo
[require]
nortl=y
[install]
fpcpackage=y
[default]
fpcdir=../..
target=emx
cpu=i386
[compiler]
includedir=$(INC) $(PROCINC) ../os2
sourcedir=$(INC) $(PROCINC) ../os2
targetdir=.
[prerules]
RTL=..
INC=$(RTL)/inc
PROCINC=$(RTL)/$(CPU_TARGET)
UNITPREFIX=rtl
ifeq ($(findstring 1.0.,$(FPC_VERSION)),)
SYSTEMUNIT=system
else
SYSTEMUNIT=sysos2
endif
# Use new feature from 1.0.5 version
# that generates release PPU files
# which will not be recompiled
ifdef RELEASE
override FPCOPT+=-Ur
endif
# Paths
OBJPASDIR=$(RTL)/objpas
GRAPHDIR=$(INC)/graph
[rules]
# Get the system independent include file names.
# This will set the following variables :
# SYSINCNAMES
include $(INC)/makefile.inc
SYSINCDEPS=$(addprefix $(INC)/,$(SYSINCNAMES))
# Get the processor dependent include file names.
# This will set the following variables :
# CPUINCNAMES
include $(PROCINC)/makefile.cpu
SYSCPUDEPS=$(addprefix $(PROCINC)/,$(CPUINCNAMES))
# Put system unit dependencies together.
SYSDEPS=$(SYSINCDEPS) $(SYSCPUDEPS)
#
# Loaders
#
%$(OEXT) : %.as
$(AS) -o $*$(OEXT) $*.as
#
# Base Units (System, strings, os-dependent-base-unit)
#
$(SYSTEMUNIT)$(PPUEXT) : $(SYSTEMUNIT).pas $(SYSDEPS)
$(COMPILER) -Us -Sg $(SYSTEMUNIT).pas $(REDIR)
objpas$(PPUEXT): $(OBJPASDIR)/objpas.pp $(INC)/except.inc $(SYSTEMUNIT)$(PPUEXT)
$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/objpas.pp $(REDIR)
strings$(PPUEXT) : $(INC)/strings.pp $(INC)/stringsi.inc \
$(PROCINC)/strings.inc $(PROCINC)/stringss.inc \
$(SYSTEMUNIT)$(PPUEXT)
#
# System Dependent Units
#
ports$(PPUEXT) : ports.pas objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
doscalls$(PPUEXT) : doscalls.pas strings$(PPUEXT) objects$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
kbdcalls$(PPUEXT) : kbdcalls.pas $(SYSTEMUNIT)$(PPUEXT)
moucalls$(PPUEXT) : moucalls.pas $(SYSTEMUNIT)$(PPUEXT)
moncalls$(PPUEXT) : moncalls.pas strings$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
os2def$(PPUEXT) : os2def.pas $(SYSTEMUNIT)$(PPUEXT)
pmwin$(PPUEXT) : pmwin.pas os2def$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
pmbitmap$(PPUEXT) : pmbitmap.pas $(SYSTEMUNIT)$(PPUEXT)
pmgpi$(PPUEXT) : pmgpi.pas pmbitmap$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
pmstddlg$(PPUEXT) : pmstddlg.pas os2def$(PPUEXT) doscalls$(PPUEXT) pmwin$(PPUEXT) pmgpi$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
pmhelp$(PPUEXT) : pmhelp.pas os2def$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
pmdev$(PPUEXT) : pmdev.pas os2def$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
pmspl$(PPUEXT) : pmspl.pas os2def$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
dive$(PPUEXT) : dive.pas os2def$(PPUEXT) pmwin$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
dynlibs$(PPUEXT) : $(INC)/dynlibs.pp doscalls$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
#
# TP7 Compatible RTL Units
#
dos$(PPUEXT) : dos.pas $(INC)/filerec.inc $(INC)/textrec.inc strings$(PPUEXT) \
doscalls$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
crt$(PPUEXT) : crt.pas $(INC)/textrec.inc $(SYSTEMUNIT)$(PPUEXT)
objects$(PPUEXT) : $(INC)/objects.pp $(SYSTEMUNIT)$(PPUEXT)
printer$(PPUEXT) : printer.pas $(INC)/textrec.inc $(SYSTEMUNIT)$(PPUEXT)
#graph$(PPUEXT) : graph.pp
#
# Delphi Compatible Units
#
sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
objpas$(PPUEXT) dos$(PPUEXT) doscalls$(PPUEXT)
$(COMPILER) -I$(OBJPASDIR) sysutils.pp $(REDIR)
typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp $(REDIR)
math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT)
$(COMPILER) $(OBJPASDIR)/math.pp $(REDIR)
varutils$(PPUEXT) : $(OBJPASDIR)/cvarutil.inc $(OBJPASDIR)/varutils.inc \
$(OBJPASDIR)/varutilh.inc varutils.pp
$(COMPILER) -I$(OBJPASDIR) varutils.pp $(REDIR)
types$(PPUEXT) : $(OBJPASDIR/types.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
$(COMPILER) $(OBJPASDIR)/types.pp
#
# Other system-independent RTL Units
#
ucomplex$(PPUEXT): $(INC)/ucomplex.pp math$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
cpu$(PPUEXT) : $(PROCINC)/cpu.pp $(SYSTEMUNIT)$(PPUEXT)
mmx$(PPUEXT) : $(PROCINC)/mmx.pp cpu$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
getopts$(PPUEXT) : $(INC)/getopts.pp $(SYSTEMUNIT)$(PPUEXT)
heaptrc$(PPUEXT) : $(INC)/heaptrc.pp $(SYSTEMUNIT)$(PPUEXT)
$(COMPILER) -Sg $(INC)/heaptrc.pp $(REDIR)
lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMUNIT)$(PPUEXT)
charset$(PPUEXT) : $(INC)/charset.pp $(SYSTEMUNIT)$(PPUEXT)
#
# Other system-dependent RTL Units
#

1235
rtl/emx/dos.pas Normal file
View File

File diff suppressed because it is too large Load Diff

155
rtl/emx/ports.pas Normal file
View File

@ -0,0 +1,155 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by the Free Pascal development team.
These files adds support for TP styled port accesses (port[],
portw[] and portl[] constructs) using Delphi classes.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
(*
Warning:
1) You have to enable port access in your CONFIG.SYS (IOPL directive),
either globally (IOPL=YES), or just for particular application/-s with
a need for port access (IOPL=app_name1, appname2, ...).
2) Once you access some port, access to this port is enabled all the time
for all EMX applications until EMX.DLL is unloaded from memory (i.e.
all applications using this library finish).
*)
unit Ports;
{ This unit uses classes so ObjFpc mode is required. }
{$Mode ObjFpc}
interface
type
TPort = class
protected
procedure WritePort (P: word; Data: byte);
function ReadPort (P: word): byte;
public
property PP [W: word]: byte read readport write writeport; default;
end;
TPortW = class
protected
procedure WritePort (P: word; Data: word);
function ReadPort (P: word): word;
public
property PP [W: word]: word read readport write writeport; default;
end;
TPortL = class
protected
procedure WritePort (P: word; Data: longint);
function ReadPort (P: word): longint;
public
property PP [W: word]: longint read readport write writeport; default;
end;
{ Non-instantiated vars. As yet, they don't have to be instantiated,
because neither member variables nor virtual methods are accessed }
var
Port, PortB: TPort;
PortW: TPortW;
PortL: TPortL;
implementation
{Import syscall to call it nicely from assembler procedures.}
procedure syscall; external name '___SYSCALL';
{$AsmMode ATT}
procedure TPort.WritePort (P: word; Data: byte); assembler;
asm
xorl %ecx, %ecx
movw P, %cx
movl %ecx, %edx
movw $0x7F12, %ax
call syscall
movw P, %dx
movb Data, %al
outb %al, %dx
end;
function TPort.ReadPort (P: word): byte; assembler;
asm
xorl %ecx, %ecx
movw P, %cx
movl %ecx, %edx
movw $0x7F12, %ax
call syscall
movw P, %dx
inb %dx, %al
end;
procedure TPortW.WritePort (P: word; Data : word); assembler;
asm
xorl %ecx, %ecx
movw P, %cx
movl %ecx, %edx
movw $0x7F12, %ax
call syscall
movw P, %dx
movw Data, %ax
outw %ax, %dx
end;
function TPortW.ReadPort (P: word): word; assembler;
asm
xorl %ecx, %ecx
movw P, %cx
movl %ecx, %edx
movw $0x7F12, %ax
call syscall
movw P, %dx
inw %dx, %ax
end;
procedure TPortL.WritePort (P: word; Data: longint); assembler;
asm
xorl %ecx, %ecx
movw P, %cx
movl %ecx, %edx
movw $0x7F12, %ax
call syscall
movw P, %dx
movl Data, %eax
outl %eax, %dx
end;
function TPortL.ReadPort (P: word): longint; assembler;
asm
xorl %ecx, %ecx
movw P, %cx
movl %ecx, %edx
movw $0x7F12, %ax
call syscall
movw P, %dx
inl %dx, %eax
end;
end.
{
$Log$
Revision 1.1 2002-11-17 16:22:54 hajny
+ RTL for emx target
Revision 1.2 2002/09/07 16:01:25 peter
* old logs removed and tabs fixed
}

74
rtl/emx/prt0.as Normal file
View File

@ -0,0 +1,74 @@
/ prt0.s (emx+fpc) -- Made from crt0.s,
/ Copyright (c) 1990-1999-2001 by Eberhard Mattes.
/ Changed for Free Pascal in 1997 Daniel Mantione.
/ This code is _not_ under the Library GNU Public
/ License, because the original is not. See copying.emx
/ for details. You should have received it with this
/ product, write the author if you haven't.
.globl __text
.globl ___SYSCALL
.globl __data
.globl __heap_base
.globl __heap_brk
.globl __heap_end
.globl __init
.text
__text:
push $__data
call __dos_init
jmp __init
___SYSCALL:
call __dos_syscall
ret
.space 6, 0x90
__init: cld
call __entry1
call _main
movb $0x4c,%ah
call ___SYSCALL
2: jmp 2b
.data
/ The data segment starts with a table containing the start and end
/ addresses of the text, data and bss segments
__data:
.long __text
.long __etext
.long __data
.long __edata
.long __edata
.long __end
__heap_base:
.long 0
__heap_end:
.long 0
__heap_brk:
.long 0
.long 0
.long __os2dll
.long 0
.long 0
.long 0x02000000
.long 0
.long 0
.byte 0
.space 63, 0
/ Don't touch this. It's EMX vodoo. In short, this causes the __os2dll symbol
/ point to table of DLL data that the linker includes in the executable.
.stabs "__os2dll", 21, 0, 0, 0xffffffff
.stabs "___CTOR_LIST__", 21, 0, 0, 0xffffffff
.stabs "___DTOR_LIST__", 21, 0, 0, 0xffffffff
.stabs "___crtinit1__", 21, 0, 0, 0xffffffff
.stabs "___crtexit1__", 21, 0, 0, 0xffffffff
.stabs "___eh_frame__", 21, 0, 0, 0xffffffff

61
rtl/emx/prt1.as Normal file
View File

@ -0,0 +1,61 @@
/ prt1.s (emx+fpk) -- Made from crt2.s and dos.s,
/ Copyright (c) 1990-1999-2000 by Eberhard Mattes.
/ Changed for Free Pascal in 1997 Daniel Mantione.
/ This code is _not_ under the Library GNU Public
/ License, because the original is not. See copying.emx
/ for details. You should have received it with this
/ product, write the author if you haven't.
.globl __entry1
.globl _environ
.globl _envc
.globl _argv
.globl _argc
.text
__entry1:
popl %esi
cld
xorl %ebp, %ebp
leal (%esp), %edi /* argv[] */
movl %edi,_environ
call L_ptr_tbl
movl %ecx,_envc
movl %edi,_argv
call L_ptr_tbl
movl %ecx,_argc
jmp *%esi
L_ptr_tbl:
xorl %eax, %eax
movl $-1, %ecx
1: incl %ecx
scasl
jne 1b
ret
/ In executables created with emxbind, the call to _dos_init will
/ be fixed up at load time to _emx_init of emx.dll. Under DOS,
/ this dummy is called instead as there is no fixup. This module
/ must be linked statically to avoid having two fixups for the
/ same location.
.globl __dos_init
.globl __dos_syscall
__dos_init:
ret $4
.align 2, 0x90
__dos_syscall:
int $0x21
ret
.data
.comm _environ, 4
.comm _envc, 4
.comm _argv, 4
.comm _argc, 4

1
rtl/emx/sysos2.pas Normal file
View File

@ -0,0 +1 @@
{$i system.pas}

1075
rtl/emx/system.pas Normal file
View File

File diff suppressed because it is too large Load Diff

969
rtl/emx/sysutils.pp Normal file
View File

@ -0,0 +1,969 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by Florian Klaempfl
member of the Free Pascal development team
Sysutils unit for OS/2
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit sysutils;
interface
{$MODE objfpc}
{ force ansistrings }
{$H+}
uses
Dos;
{ Include platform independent interface part }
{$i sysutilh.inc}
implementation
{ Include platform independent implementation part }
{$i sysutils.inc}
{****************************************************************************
System (imported) calls
****************************************************************************}
(* "uses DosCalls" could not be used here due to type *)
(* conflicts, so needed parts had to be redefined here). *)
type
TFileStatus = object
end;
PFileStatus = ^TFileStatus;
TFileStatus0 = object (TFileStatus)
DateCreation, {Date of file creation.}
TimeCreation, {Time of file creation.}
DateLastAccess, {Date of last access to file.}
TimeLastAccess, {Time of last access to file.}
DateLastWrite, {Date of last modification of file.}
TimeLastWrite: word; {Time of last modification of file.}
FileSize, {Size of file.}
FileAlloc: longint; {Amount of space the file really
occupies on disk.}
end;
PFileStatus0 = ^TFileStatus0;
TFileStatus3 = object (TFileStatus)
NextEntryOffset: longint; {Offset of next entry}
DateCreation, {Date of file creation.}
TimeCreation, {Time of file creation.}
DateLastAccess, {Date of last access to file.}
TimeLastAccess, {Time of last access to file.}
DateLastWrite, {Date of last modification of file.}
TimeLastWrite: word; {Time of last modification of file.}
FileSize, {Size of file.}
FileAlloc: longint; {Amount of space the file really
occupies on disk.}
AttrFile: longint; {Attributes of file.}
end;
PFileStatus3 = ^TFileStatus3;
TFileFindBuf3 = object (TFileStatus3)
Name: ShortString; {Also possible to use as ASCIIZ.
The byte following the last string
character is always zero.}
end;
PFileFindBuf3 = ^TFileFindBuf3;
TFSInfo = record
case word of
1:
(File_Sys_ID,
Sectors_Per_Cluster,
Total_Clusters,
Free_Clusters: longint;
Bytes_Per_Sector: word);
2: {For date/time description,
see file searching realted
routines.}
(Label_Date, {Date when volume label was created.}
Label_Time: word; {Time when volume label was created.}
VolumeLabel: ShortString); {Volume label. Can also be used
as ASCIIZ, because the byte
following the last character of
the string is always zero.}
end;
PFSInfo = ^TFSInfo;
TCountryCode=record
Country, {Country to query info about (0=current).}
CodePage: longint; {Code page to query info about (0=current).}
end;
PCountryCode=^TCountryCode;
TTimeFmt = (Clock12, Clock24);
TCountryInfo=record
Country, CodePage: longint; {Country and codepage requested.}
case byte of
0:
(DateFormat: longint; {1=ddmmyy 2=yymmdd 3=mmddyy}
CurrencyUnit: array [0..4] of char;
ThousandSeparator: char; {Thousands separator.}
Zero1: byte; {Always zero.}
DecimalSeparator: char; {Decimals separator,}
Zero2: byte;
DateSeparator: char; {Date separator.}
Zero3: byte;
TimeSeparator: char; {Time separator.}
Zero4: byte;
CurrencyFormat, {Bit field:
Bit 0: 0=indicator before value
1=indicator after value
Bit 1: 1=insert space after
indicator.
Bit 2: 1=Ignore bit 0&1, replace
decimal separator with
indicator.}
DecimalPlace: byte; {Number of decimal places used in
currency indication.}
TimeFormat: TTimeFmt; {12/24 hour.}
Reserve1: array [0..1] of word;
DataSeparator: char; {Data list separator}
Zero5: byte;
Reserve2: array [0..4] of word);
1:
(fsDateFmt: longint; {1=ddmmyy 2=yymmdd 3=mmddyy}
szCurrency: array [0..4] of char;
{null terminated currency symbol}
szThousandsSeparator: array [0..1] of char;
{Thousands separator + #0}
szDecimal: array [0..1] of char;
{Decimals separator + #0}
szDateSeparator: array [0..1] of char;
{Date separator + #0}
szTimeSeparator: array [0..1] of char;
{Time separator + #0}
fsCurrencyFmt, {Bit field:
Bit 0: 0=indicator before value
1=indicator after value
Bit 1: 1=insert space after
indicator.
Bit 2: 1=Ignore bit 0&1, replace
decimal separator with
indicator}
cDecimalPlace: byte; {Number of decimal places used in
currency indication}
fsTimeFmt: byte; {0=12,1=24 hours}
abReserved1: array [0..1] of word;
szDataSeparator: array [0..1] of char;
{Data list separator + #0}
abReserved2: array [0..4] of word);
end;
PCountryInfo=^TCountryInfo;
const
ilStandard = 1;
ilQueryEAsize = 2;
ilQueryEAs = 3;
ilQueryFullName = 5;
{This is the correct way to call external assembler procedures.}
procedure syscall;external name '___SYSCALL';
function DosSetFileInfo (Handle, InfoLevel: longint; AFileStatus: PFileStatus;
FileStatusLen: longint): longint; cdecl; external 'DOSCALLS' index 218;
function DosQueryFSInfo (DiskNum, InfoLevel: longint; var Buffer: TFSInfo;
BufLen: longint): longint; cdecl; external 'DOSCALLS' index 278;
function DosQueryFileInfo (Handle, InfoLevel: longint;
AFileStatus: PFileStatus; FileStatusLen: longint): longint; cdecl;
external 'DOSCALLS' index 279;
function DosScanEnv (Name: PChar; var Value: PChar): longint; cdecl;
external 'DOSCALLS' index 227;
function DosFindFirst (FileMask: PChar; var Handle: longint; Attrib: longint;
AFileStatus: PFileStatus; FileStatusLen: longint;
var Count: longint; InfoLevel: longint): longint; cdecl;
external 'DOSCALLS' index 264;
function DosFindNext (Handle: longint; AFileStatus: PFileStatus;
FileStatusLen: longint; var Count: longint): longint; cdecl;
external 'DOSCALLS' index 265;
function DosFindClose (Handle: longint): longint; cdecl;
external 'DOSCALLS' index 263;
function DosQueryCtryInfo (Size: longint; var Country: TCountryCode;
var Res: TCountryInfo; var ActualSize: longint): longint; cdecl;
external 'NLS' index 5;
function DosMapCase (Size: longint; var Country: TCountryCode;
AString: PChar): longint; cdecl; external 'NLS' index 7;
{****************************************************************************
File Functions
****************************************************************************}
const
ofRead = $0000; {Open for reading}
ofWrite = $0001; {Open for writing}
ofReadWrite = $0002; {Open for reading/writing}
doDenyRW = $0010; {DenyAll (no sharing)}
faCreateNew = $00010000; {Create if file does not exist}
faOpenReplace = $00040000; {Truncate if file exists}
faCreate = $00050000; {Create if file does not exist, truncate otherwise}
FindResvdMask = $00003737; {Allowed bits in attribute
specification for DosFindFirst call.}
{$ASMMODE INTEL}
function FileOpen (const FileName: string; Mode: integer): longint;
{$IFOPT H+}
assembler;
{$ELSE}
var FN: string;
begin
FN := FileName + #0;
{$ENDIF}
asm
mov eax, Mode
(* DenyAll if sharing not specified. *)
test eax, 112
jnz @FOpen1
or eax, 16
@FOpen1:
mov ecx, eax
mov eax, 7F2Bh
{$IFOPT H+}
mov edx, FileName
{$ELSE}
lea edx, FN
inc edx
{$ENDIF}
call syscall
{$IFOPT H-}
mov [ebp - 4], eax
end;
{$ENDIF}
end;
function FileCreate (const FileName: string): longint;
{$IFOPT H+}
assembler;
{$ELSE}
var FN: string;
begin
FN := FileName + #0;
{$ENDIF}
asm
mov eax, 7F2Bh
mov ecx, ofReadWrite or faCreate or doDenyRW (* Sharing to DenyAll *)
{$IFOPT H+}
mov edx, FileName
{$ELSE}
lea edx, FN
inc edx
{$ENDIF}
call syscall
{$IFOPT H-}
mov [ebp - 4], eax
end;
{$ENDIF}
end;
function FileRead (Handle: longint; var Buffer; Count: longint): longint;
assembler;
asm
mov eax, 3F00h
mov ebx, Handle
mov ecx, Count
mov edx, Buffer
call syscall
jnc @FReadEnd
mov eax, -1
@FReadEnd:
end;
function FileWrite (Handle: longint; const Buffer; Count: longint): longint;
assembler;
asm
mov eax, 4000h
mov ebx, Handle
mov ecx, Count
mov edx, Buffer
call syscall
jnc @FWriteEnd
mov eax, -1
@FWriteEnd:
end;
function FileSeek (Handle, FOffset, Origin: longint): longint; assembler;
asm
mov eax, Origin
mov ah, 42h
mov ebx, Handle
mov edx, FOffset
call syscall
jnc @FSeekEnd
mov eax, -1
@FSeekEnd:
end;
Function FileSeek (Handle : Longint; FOffset,Origin : Int64) : Int64;
begin
{$warning need to add 64bit call }
Result:=FileSeek(Handle,Longint(Foffset),Longint(Origin));
end;
procedure FileClose (Handle: longint);
begin
if (Handle <= 4) or (os_mode = osOS2) and (Handle <= 2) then
asm
mov eax, 3E00h
mov ebx, Handle
call syscall
end;
end;
function FileTruncate (Handle, Size: longint): boolean; assembler;
asm
mov eax, 7F25h
mov ebx, Handle
mov edx, Size
call syscall
jc @FTruncEnd
mov eax, 4202h
mov ebx, Handle
mov edx, 0
call syscall
mov eax, 0
jnc @FTruncEnd
dec eax
@FTruncEnd:
end;
function FileAge (const FileName: string): longint;
var Handle: longint;
begin
Handle := FileOpen (FileName, 0);
if Handle <> -1 then
begin
Result := FileGetDate (Handle);
FileClose (Handle);
end
else
Result := -1;
end;
function FileExists (const FileName: string): boolean;
{$IFOPT H+}
assembler;
{$ELSE}
var FN: string;
begin
FN := FileName + #0;
{$ENDIF}
asm
mov ax, 4300h
{$IFOPT H+}
mov edx, FileName
{$ELSE}
lea edx, FN
inc edx
{$ENDIF}
call syscall
mov eax, 0
jc @FExistsEnd
test cx, 18h
jnz @FExistsEnd
inc eax
@FExistsEnd:
{$IFOPT H-}
end;
{$ENDIF}
end;
type TRec = record
T, D: word;
end;
PSearchRec = ^SearchRec;
function FindFirst (const Path: string; Attr: longint; var Rslt: TSearchRec): longint;
var SR: PSearchRec;
FStat: PFileFindBuf3;
Count: longint;
Err: longint;
begin
if os_mode = osOS2 then
begin
New (FStat);
Rslt.FindHandle := $FFFFFFFF;
Count := 1;
Err := DosFindFirst (PChar (Path), Rslt.FindHandle,
Attr and FindResvdMask, FStat, SizeOf (FStat^), Count,
ilStandard);
if (Err = 0) and (Count = 0) then Err := 18;
FindFirst := -Err;
if Err = 0 then
begin
Rslt.Name := FStat^.Name;
Rslt.Size := FStat^.FileSize;
Rslt.Attr := FStat^.AttrFile;
Rslt.ExcludeAttr := 0;
TRec (Rslt.Time).T := FStat^.TimeLastWrite;
TRec (Rslt.Time).D := FStat^.DateLastWrite;
end;
Dispose (FStat);
end
else
begin
Err := DOS.DosError;
GetMem (SR, SizeOf (SearchRec));
Rslt.FindHandle := longint(SR);
DOS.FindFirst (Path, Attr, SR^);
FindFirst := -DOS.DosError;
if DosError = 0 then
begin
Rslt.Time := SR^.Time;
Rslt.Size := SR^.Size;
Rslt.Attr := SR^.Attr;
Rslt.ExcludeAttr := 0;
Rslt.Name := SR^.Name;
end;
DOS.DosError := Err;
end;
end;
function FindNext (var Rslt: TSearchRec): longint;
var SR: PSearchRec;
FStat: PFileFindBuf3;
Count: longint;
Err: longint;
begin
if os_mode = osOS2 then
begin
New (FStat);
Count := 1;
Err := DosFindNext (Rslt.FindHandle, FStat, SizeOf (FStat^),
Count);
if (Err = 0) and (Count = 0) then Err := 18;
FindNext := -Err;
if Err = 0 then
begin
Rslt.Name := FStat^.Name;
Rslt.Size := FStat^.FileSize;
Rslt.Attr := FStat^.AttrFile;
Rslt.ExcludeAttr := 0;
TRec (Rslt.Time).T := FStat^.TimeLastWrite;
TRec (Rslt.Time).D := FStat^.DateLastWrite;
end;
Dispose (FStat);
end
else
begin
SR := PSearchRec (Rslt.FindHandle);
if SR <> nil then
begin
DOS.FindNext (SR^);
FindNext := -DosError;
if DosError = 0 then
begin
Rslt.Time := SR^.Time;
Rslt.Size := SR^.Size;
Rslt.Attr := SR^.Attr;
Rslt.ExcludeAttr := 0;
Rslt.Name := SR^.Name;
end;
end;
end;
end;
procedure FindClose (var F: TSearchrec);
var SR: PSearchRec;
begin
if os_mode = osOS2 then
begin
DosFindClose (F.FindHandle);
end
else
begin
SR := PSearchRec (F.FindHandle);
DOS.FindClose (SR^);
FreeMem (SR, SizeOf (SearchRec));
end;
F.FindHandle := 0;
end;
function FileGetDate (Handle: longint): longint; assembler;
asm
mov ax, 5700h
mov ebx, Handle
call syscall
mov eax, -1
jc @FGetDateEnd
mov ax, dx
shld eax, ecx, 16
@FGetDateEnd:
end;
function FileSetDate (Handle, Age: longint): longint;
var FStat: PFileStatus0;
RC: longint;
begin
if os_mode = osOS2 then
begin
New (FStat);
RC := DosQueryFileInfo (Handle, ilStandard, FStat,
SizeOf (FStat^));
if RC <> 0 then
FileSetDate := -1
else
begin
FStat^.DateLastAccess := Hi (Age);
FStat^.DateLastWrite := Hi (Age);
FStat^.TimeLastAccess := Lo (Age);
FStat^.TimeLastWrite := Lo (Age);
RC := DosSetFileInfo (Handle, ilStandard, FStat,
SizeOf (FStat^));
if RC <> 0 then
FileSetDate := -1
else
FileSetDate := 0;
end;
Dispose (FStat);
end
else
asm
mov ax, 5701h
mov ebx, Handle
mov cx, word ptr [Age]
mov dx, word ptr [Age + 2]
call syscall
jnc @FSetDateEnd
mov eax, -1
@FSetDateEnd:
mov [ebp - 4], eax
end;
end;
function FileGetAttr (const FileName: string): longint;
{$IFOPT H+}
assembler;
{$ELSE}
var FN: string;
begin
FN := FileName + #0;
{$ENDIF}
asm
mov ax, 4300h
{$IFOPT H+}
mov edx, FileName
{$ELSE}
lea edx, FN
inc edx
{$ENDIF}
call syscall
jnc @FGetAttrEnd
mov eax, -1
@FGetAttrEnd:
{$IFOPT H-}
mov [ebp - 4], eax
end;
{$ENDIF}
end;
function FileSetAttr (const Filename: string; Attr: longint): longint;
{$IFOPT H+}
assembler;
{$ELSE}
var FN: string;
begin
FN := FileName + #0;
{$ENDIF}
asm
mov ax, 4301h
mov ecx, Attr
{$IFOPT H+}
mov edx, FileName
{$ELSE}
lea edx, FN
inc edx
{$ENDIF}
call syscall
mov eax, 0
jnc @FSetAttrEnd
mov eax, -1
@FSetAttrEnd:
{$IFOPT H-}
mov [ebp - 4], eax
end;
{$ENDIF}
end;
function DeleteFile (const FileName: string): boolean;
{$IFOPT H+}
assembler;
{$ELSE}
var FN: string;
begin
FN := FileName + #0;
{$ENDIF}
asm
mov ax, 4100h
{$IFOPT H+}
mov edx, FileName
{$ELSE}
lea edx, FN
inc edx
{$ENDIF}
call syscall
mov eax, 0
jc @FDeleteEnd
inc eax
@FDeleteEnd:
{$IFOPT H-}
mov [ebp - 4], eax
end;
{$ENDIF}
end;
function RenameFile (const OldName, NewName: string): boolean;
{$IFOPT H+}
assembler;
{$ELSE}
var FN1, FN2: string;
begin
FN1 := OldName + #0;
FN2 := NewName + #0;
{$ENDIF}
asm
mov ax, 5600h
{$IFOPT H+}
mov edx, OldName
mov edi, NewName
{$ELSE}
lea edx, FN1
inc edx
lea edi, FN2
inc edi
{$ENDIF}
call syscall
mov eax, 0
jc @FRenameEnd
inc eax
@FRenameEnd:
{$IFOPT H-}
mov [ebp - 4], eax
end;
{$ENDIF}
end;
{****************************************************************************
Disk Functions
****************************************************************************}
{$ASMMODE ATT}
function DiskFree (Drive: byte): int64;
var FI: TFSinfo;
RC: longint;
begin
if (os_mode = osDOS) or (os_mode = osDPMI) then
{Function 36 is not supported in OS/2.}
asm
movb Drive,%dl
movb $0x36,%ah
call syscall
cmpw $-1,%ax
je .LDISKFREE1
mulw %cx
mulw %bx
shll $16,%edx
movw %ax,%dx
movl $0,%eax
xchgl %edx,%eax
leave
ret
.LDISKFREE1:
cltd
leave
ret
end
else
{In OS/2, we use the filesystem information.}
begin
RC := DosQueryFSInfo (Drive, 1, FI, SizeOf (FI));
if RC = 0 then
DiskFree := int64 (FI.Free_Clusters) *
int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
else
DiskFree := -1;
end;
end;
function DiskSize (Drive: byte): int64;
var FI: TFSinfo;
RC: longint;
begin
if (os_mode = osDOS) or (os_mode = osDPMI) then
{Function 36 is not supported in OS/2.}
asm
movb Drive,%dl
movb $0x36,%ah
call syscall
movw %dx,%bx
cmpw $-1,%ax
je .LDISKSIZE1
mulw %cx
mulw %bx
shll $16,%edx
movw %ax,%dx
movl $0,%eax
xchgl %edx,%eax
leave
ret
.LDISKSIZE1:
cltd
leave
ret
end
else
{In OS/2, we use the filesystem information.}
begin
RC := DosQueryFSinfo (Drive, 1, FI, SizeOf (FI));
if RC = 0 then
DiskSize := int64 (FI.Total_Clusters) *
int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
else
DiskSize := -1;
end;
end;
function GetCurrentDir: string;
begin
GetDir (0, Result);
end;
function SetCurrentDir (const NewDir: string): boolean;
begin
{$I-}
ChDir (NewDir);
Result := (IOResult = 0);
{$I+}
end;
function CreateDir (const NewDir: string): boolean;
begin
{$I-}
MkDir (NewDir);
Result := (IOResult = 0);
{$I+}
end;
function RemoveDir (const Dir: string): boolean;
begin
{$I-}
RmDir (Dir);
Result := (IOResult = 0);
{$I+}
end;
{****************************************************************************
Time Functions
****************************************************************************}
{$asmmode intel}
procedure GetLocalTime (var SystemTime: TSystemTime); assembler;
asm
(* Expects the default record alignment (word)!!! *)
mov ah, 2Ah
call syscall
mov edi, SystemTime
mov ax, cx
stosw
xor eax, eax
mov al, dl
shl eax, 16
mov al, dh
stosd
push edi
mov ah, 2Ch
call syscall
pop edi
xor eax, eax
mov al, cl
shl eax, 16
mov al, ch
stosd
mov al, dl
shl eax, 16
mov al, dh
stosd
end;
{$asmmode default}
{****************************************************************************
Misc Functions
****************************************************************************}
procedure Beep;
begin
end;
{****************************************************************************
Locale Functions
****************************************************************************}
procedure InitAnsi;
var I: byte;
Country: TCountryCode;
begin
for I := 0 to 255 do
UpperCaseTable [I] := Chr (I);
Move (UpperCaseTable, LowerCaseTable, SizeOf (UpperCaseTable));
if os_mode = osOS2 then
begin
FillChar (Country, SizeOf (Country), 0);
DosMapCase (SizeOf (UpperCaseTable), Country, @UpperCaseTable);
end
else
begin
(* !!! TODO: DOS/DPMI mode support!!! *)
end;
for I := 0 to 255 do
if UpperCaseTable [I] <> Chr (I) then
LowerCaseTable [Ord (UpperCaseTable [I])] := Chr (I);
end;
procedure InitInternational;
var Country: TCountryCode;
CtryInfo: TCountryInfo;
Size: longint;
RC: longint;
begin
Size := 0;
FillChar (Country, SizeOf (Country), 0);
FillChar (CtryInfo, SizeOf (CtryInfo), 0);
RC := DosQueryCtryInfo (SizeOf (CtryInfo), Country, CtryInfo, Size);
if RC = 0 then
begin
DateSeparator := CtryInfo.DateSeparator;
case CtryInfo.DateFormat of
1: begin
ShortDateFormat := 'd/m/y';
LongDateFormat := 'dd" "mmmm" "yyyy';
end;
2: begin
ShortDateFormat := 'y/m/d';
LongDateFormat := 'yyyy" "mmmm" "dd';
end;
3: begin
ShortDateFormat := 'm/d/y';
LongDateFormat := 'mmmm" "dd" "yyyy';
end;
end;
TimeSeparator := CtryInfo.TimeSeparator;
DecimalSeparator := CtryInfo.DecimalSeparator;
ThousandSeparator := CtryInfo.ThousandSeparator;
CurrencyFormat := CtryInfo.CurrencyFormat;
CurrencyString := PChar (CtryInfo.CurrencyUnit);
end;
InitAnsi;
end;
function SysErrorMessage(ErrorCode: Integer): String;
begin
Result:=Format(SUnknownErrorCode,[ErrorCode]);
end;
{****************************************************************************
OS Utils
****************************************************************************}
Function GetEnvironmentVariable(Const EnvVar : String) : String;
var P: PChar;
begin
if DosScanEnv (PChar (EnvVar), P) = 0
then GetEnvironmentVariable := StrPas (P)
else GetEnvironmentVariable := '';
end;
{****************************************************************************
Initialization code
****************************************************************************}
Initialization
InitExceptions; { Initialize exceptions. OS independent }
InitInternational; { Initialize internationalization settings }
Finalization
DoneExceptions;
end.
{
$Log$
Revision 1.1 2002-11-17 16:22:54 hajny
+ RTL for emx target
Revision 1.18 2002/09/23 17:42:37 hajny
* AnsiString to PChar typecast
Revision 1.17 2002/09/07 16:01:25 peter
* old logs removed and tabs fixed
Revision 1.16 2002/07/11 16:00:05 hajny
* FindFirst fix (invalid attribute bits masked out)
Revision 1.15 2002/01/25 16:23:03 peter
* merged filesearch() fix
}

361
rtl/emx/threads.pp Normal file
View File

@ -0,0 +1,361 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2002 by the Free Pascal development team.
OS/2 threading support implementation
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit threads;
interface
{$S-}
type
{ the fields of this record are os dependent }
{ and they shouldn't be used in a program }
{ only the type TCriticalSection is important }
PRTLCriticalSection = ^TRTLCriticalSection;
TRTLCriticalSection = packed record
DebugInfo : pointer;
LockCount : longint;
RecursionCount : longint;
OwningThread : DWord;
LockSemaphore : DWord;
Reserved : DWord;
end;
{ Include generic thread interface }
{$i threadh.inc}
implementation
{*****************************************************************************
Local Api imports
*****************************************************************************}
const
pag_Read = 1;
pag_Write = 2;
pag_Execute = 4;
pag_Guard = 8;
pag_Commit = $10;
obj_Tile = $40;
sem_Indefinite_Wait = -1;
dtSuspended = 1;
dtStack_Commited = 2;
type
TThreadInfo = record
F: TThreadFunc;
P: pointer;
end;
PThreadInfo = ^TThreadInfo;
{ import the necessary stuff from the OS }
function DosAllocThreadLocalMemory (Count: cardinal; var P: pointer): longint;
cdecl; external 'DOSCALLS' index 454;
function DosFreeThreadLocalMemory (P: pointer): longint; cdecl;
external 'DOSCALLS' index 455;
function DosCreateThread (var TID: longint; Address: pointer;
(* TThreadFunc *)
aParam: pointer; Flags: longint; StackSize: longint): longint; cdecl;
external 'DOSCALLS' index 311;
procedure DosExit (Action, Result: longint); cdecl;
external 'DOSCALLS' index 234;
function DosCreateMutExSem (Name: PChar; var Handle: longint; Attr: longint;
State: boolean): longint; cdecl; external 'DOSCALLS' index 331;
function DosCloseMutExSem (Handle: longint): longint; cdecl;
external 'DOSCALLS' index 333;
function DosQueryMutExSem (Handle: longint; var PID, TID, Count: longint):
longint; cdecl; external 'DOSCALLS' index 336;
function DosRequestMutExSem (Handle, Timeout: longint): longint; cdecl;
external 'DOSCALLS' index 334;
function DosReleaseMutExSem (Handle: longint): longint; cdecl;
external 'DOSCALLS' index 335;
function DosAllocMem (var P: pointer; Size, Flag: longint): longint; cdecl;
external 'DOSCALLS' index 299;
function DosFreeMem (P: pointer): longint; cdecl;
external 'DOSCALLS' index 304;
function DosEnterCritSec:longint; cdecl; external 'DOSCALLS' index 232;
function DosExitCritSec:longint; cdecl; external 'DOSCALLS' index 233;
{*****************************************************************************
Threadvar support
*****************************************************************************}
{$ifdef HASTHREADVAR}
const
ThreadVarBlockSize: dword = 0;
var
(* Pointer to an allocated dword space within the local thread *)
(* memory area. Pointer to the real memory block allocated for *)
(* thread vars in this block is then stored in this dword. *)
DataIndex: PPointer;
procedure SysInitThreadvar (var Offset: dword; Size: dword);
begin
Offset := ThreadVarBlockSize;
Inc (ThreadVarBlockSize, Size);
end;
function SysRelocateThreadVar (Offset: dword): pointer;
begin
SysRelocateThreadVar := DataIndex^ + Offset;
end;
procedure SysAllocateThreadVars;
begin
{ we've to allocate the memory from the OS }
{ because the FPC heap management uses }
{ exceptions which use threadvars but }
{ these aren't allocated yet ... }
{ allocate room on the heap for the thread vars }
if os_mode = osOS2 then
begin
if DosAllocMem (DataIndex^, ThreadVarBlockSize, pag_Read or pag_Write
or pag_Commit) <> 0 then HandleError (8);
end else
begin
(* Allocate the DOS memory here. *)
end;
end;
procedure SysReleaseThreadVars;
begin
{ release thread vars }
if os_mode = osOS2 then DosFreeMem (DataIndex^) else
begin
(* Deallocate the DOS memory here. *)
end;
end;
{ Include OS independent Threadvar initialization }
{$i threadvar.inc}
procedure InitThreadVars;
begin
{ We're still running in single thread mode, setup the TLS }
TLSKey:=TlsAlloc;
{ initialize threadvars }
init_all_unit_threadvars;
{ allocate mem for main thread threadvars }
SysAllocateThreadVars;
{ copy main thread threadvars }
copy_all_unit_threadvars;
{ install threadvar handler }
fpc_threadvar_relocate_proc:=@SysRelocateThreadvar;
end;
{$endif HASTHREADVAR}
{*****************************************************************************
Thread starting
*****************************************************************************}
const
DefaultStackSize = 32768; { including 16384 margin for stackchecking }
type
pthreadinfo = ^tthreadinfo;
tthreadinfo = record
f : tthreadfunc;
p : pointer;
stklen : cardinal;
end;
procedure InitThread(stklen:cardinal);
begin
SysResetFPU;
{ ExceptAddrStack and ExceptObjectStack are threadvars }
{ so every thread has its on exception handling capabilities }
SysInitExceptions;
{ Open all stdio fds again }
SysInitStdio;
InOutRes:=0;
// ErrNo:=0;
{ Stack checking }
StackLength:=stklen;
StackBottom:=Sptr - StackLength;
end;
procedure DoneThread;
begin
{ Release Threadvars }
{$ifdef HASTHREADVAR}
SysReleaseThreadVars;
{$endif HASTHREADVAR}
end;
function ThreadMain(param : pointer) : pointer;cdecl;
var
ti : tthreadinfo;
begin
{$ifdef HASTHREADVAR}
{ Allocate local thread vars, this must be the first thing,
because the exception management and io depends on threadvars }
SysAllocateThreadVars;
{$endif HASTHREADVAR}
{ Copy parameter to local data }
{$ifdef DEBUG_MT}
writeln('New thread started, initialising ...');
{$endif DEBUG_MT}
ti:=pthreadinfo(param)^;
dispose(pthreadinfo(param));
{ Initialize thread }
InitThread(ti.stklen);
{ Start thread function }
{$ifdef DEBUG_MT}
writeln('Jumping to thread function');
{$endif DEBUG_MT}
ThreadMain:=pointer(ti.f(ti.p));
end;
function BeginThread(sa : Pointer;stacksize : dword;
ThreadFunction : tthreadfunc;p : pointer;
creationFlags : dword; var ThreadId : DWord) : DWord;
var
ti : pthreadinfo;
begin
{$ifdef DEBUG_MT}
writeln('Creating new thread');
{$endif DEBUG_MT}
{ Initialize multithreading if not done }
if not IsMultiThread then
begin
{$ifdef HASTHREADVAR}
InitThreadVars;
{$endif HASTHREADVAR}
IsMultiThread:=true;
end;
{ the only way to pass data to the newly created thread
in a MT safe way, is to use the heap }
new(ti);
ti^.f:=ThreadFunction;
ti^.p:=p;
ti^.stklen:=stacksize;
{ call pthread_create }
{$ifdef DEBUG_MT}
writeln('Starting new thread');
{$endif DEBUG_MT}
BeginThread:=CreateThread(sa,stacksize,@ThreadMain,ti,creationflags,threadid);
BeginThread:=threadid;
end;
procedure EndThread(ExitCode : DWord);
begin
DoneThread;
ExitThread(ExitCode);
end;
{*****************************************************************************
Delphi/Win32 compatibility
*****************************************************************************}
{ we implement these procedures for win32 by importing them }
{ directly from windows }
procedure InitCriticalSection(var cs : TRTLCriticalSection);
external 'kernel32' name 'InitializeCriticalSection';
procedure DoneCriticalSection(var cs : TRTLCriticalSection);
external 'kernel32' name 'DeleteCriticalSection';
procedure EnterCriticalSection(var cs : TRTLCriticalSection);
external 'kernel32' name 'EnterCriticalSection';
procedure LeaveCriticalSection(var cs : TRTLCriticalSection);
external 'kernel32' name 'LeaveCriticalSection';
{*****************************************************************************
Heap Mutex Protection
*****************************************************************************}
var
HeapMutex : TRTLCriticalSection;
procedure Win32HeapMutexInit;
begin
InitCriticalSection(heapmutex);
end;
procedure Win32HeapMutexDone;
begin
DoneCriticalSection(heapmutex);
end;
procedure Win32HeapMutexLock;
begin
EnterCriticalSection(heapmutex);
end;
procedure Win32HeapMutexUnlock;
begin
LeaveCriticalSection(heapmutex);
end;
const
Win32MemoryMutexManager : TMemoryMutexManager = (
MutexInit : @Win32HeapMutexInit;
MutexDone : @Win32HeapMutexDone;
MutexLock : @Win32HeapMutexLock;
MutexUnlock : @Win32HeapMutexUnlock;
);
procedure InitHeapMutexes;
begin
SetMemoryMutexManager(Win32MemoryMutexManager);
end;
{*****************************************************************************
Generic overloaded
*****************************************************************************}
{ Include generic overloaded routines }
{$i thread.inc}
initialization
InitHeapMutexes;
end.
{
$Log$
Revision 1.1 2002-11-17 16:22:54 hajny
+ RTL for emx target
Revision 1.1 2002/10/14 19:39:18 peter
* threads unit added for thread support
}