paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-23 06:09:39 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ threads and winsock2 implemented

Browse Source
This commit is contained in:
armin 2002-03-17 17:57:33 +00:00
parent c43735cc42
commit 8d292eb468
7 changed files with 3021 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
rtl/netware/Makefile
View File

@ -1,15 +1,19 @@
# Makefile for freepascal rtl for netware
# Needs working nlmconv + i386-netware-ld
UNITDIR = /usr/lib/fpc/1.1/units/netware/rtl
PPC386OPT = -n -di386 -dSYSTEMDEBUG -O3 -Sg -Tnetware -Aelf -a -al -FE.
UNITDIR = $(INSTALL_PREFIX)/usr/lib/fpc/1.1/units/netware/rtl
#PPC386OPT = -n -dMT -dDEBUG_MT -di386 -dSYSTEMDEBUG -O3 -Sg -Tnetware -Aelf -a -al -gg -FE.
#PPC386OPT = -n -di386 -dSYSTEMDEBUG -O3 -Sg -Tnetware -Aelf -a -al -gg -FE.
PPC386OPT = -n -di386 -O3 -Sg -Tnetware -Aelf -a -al -FE.
PPC386OPTDBG = -n -di386 -O3 -Sg -Tnetware -Aelf -a -al -gg -FE.
INCLUDES = -I../inc -I../i386 -I../objpas
SYSUNIT=system
NWPRE=nwpre
OBJEXT=on
PPUEXT=ppn
ASMEXT=s
OBJS = $(SYSUNIT).$(OBJEXT) ../inc/strings.$(OBJEXT) dos.$(OBJEXT) nwpre.$(OBJEXT) ../objpas/objpas.$(OBJEXT) sysutils.$(OBJEXT) crt.$(OBJEXT) sockets.$(OBJEXT) mouse.$(OBJEXT) netware.$(OBJEXT) video.$(OBJEXT) keyboard.$(OBJEXT) ../objpas/math.$(OBJEXT) ../objpas/typinfo.$(OBJEXT) ../inc/objects.$(OBJEXT) ../inc/getopts.$(OBJEXT) ../inc/heaptrc.$(OBJEXT) varutils.$(OBJEXT) ../i386/cpu.$(OBJEXT) ../i386/mmx.$(OBJEXT)
OBJS = $(SYSUNIT).$(OBJEXT) $(NWPRE).$(OBJEXT) ../inc/os_types.$(OBJEXT) ../inc/strings.$(OBJEXT) dos.$(OBJEXT) ../objpas/objpas.$(OBJEXT) sysutils.$(OBJEXT) crt.$(OBJEXT) sockets.$(OBJEXT) mouse.$(OBJEXT) netware.$(OBJEXT) video.$(OBJEXT) keyboard.$(OBJEXT) ../objpas/math.$(OBJEXT) ../objpas/typinfo.$(OBJEXT) ../inc/objects.$(OBJEXT) ../inc/getopts.$(OBJEXT) ../inc/heaptrc.$(OBJEXT) varutils.$(OBJEXT) ../i386/cpu.$(OBJEXT) ../i386/mmx.$(OBJEXT) winsock2.$(OBJEXT)
all: $(OBJS)
@ -17,6 +21,9 @@ all: $(OBJS)
$(SYSUNIT).$(OBJEXT): $(SYSUNIT).pp nwsys.inc
ppc386 -Us $(PPC386OPT) $(INCLUDES) $(SYSUNIT).pp
$(NWPRE).$(OBJEXT): $(NWPRE).pp
ppc386 $(PPC386OPTDBG) $(INCLUDES) $(NWPRE).pp
%.$(OBJEXT): %.pp nwsys.inc
ppc386 $(PPC386OPT) $(INCLUDES) $*.pp
@ -62,6 +69,9 @@ install: $(OBJS)
cp -f cpu.$(PPUEXT) $(UNITDIR)
cp -f mmx.$(OBJEXT) $(UNITDIR)
cp -f mmx.$(PPUEXT) $(UNITDIR)
cp -f os_types.$(PPUEXT) $(UNITDIR)
cp -f winsock2.$(OBJEXT) $(UNITDIR)
cp -f winsock2.$(PPUEXT) $(UNITDIR)
cp -f nwimp/*.imp $(UNITDIR)
clean:

32
rtl/netware/README
View File

@ -1,6 +1,8 @@
News
====
2002/02/27 armin:
- changes for current fpc 1.1
2001/04/16 armin:
- implemented CRT and SYSUTILS
- nwimp/convertimp to convert .imp files to unix
@ -14,9 +16,9 @@
General
=======
Currently generating NetWare-NLM's only work under Linux. (may be under bsd also)
This is because nlmconv from binutils does not work with i.e. win32 coff object files.
It works fine with ELF-Objects.
Currently generating NetWare-NLM's only work under Linux and win32. (may be under bsd also)
For Win32 you need a win32 compiled binutils with netware target enabled. Because nlmconv
only works with elf objects, elf support in binutils is also needed.
Binutils with netware-support needed
@ -45,7 +47,7 @@
linux on:
http://home.sch.bme.hu/~keresztg/novell/howto/NLM-Linux-HOWTO.html.
Binutils-2.11 for win32 with netware support and a patched nlmconv
Binutils-2.11 for win32 and RedHat 7.2 with netware support and a patched nlmconv
that supports "copyright" are available from:
http://home.t-online.de/home/armin-diehl/fpcnw
or
@ -145,20 +147,25 @@
FUNCTION rmdir (path : PCHAR) : LONGINT; CDECL; EXTERNAL;
If nlmlib.nlm is not loaded while loading yout nlm, you will get an error abount
If nlmlib.nlm is not loaded while loading your nlm, you will get an error about
unknown symbols.
- Debugging
---------
Thats currently a problem. There is no source level debugger available. The only way
to debug is using the netware internal debugger or nwdbg. nwdbg is a debugger on
assembler level written by Jan Beulich. Symbols are supported. You can get nwdbg for
netware 4.11,5.0 or 5.1 at developer.novell.com.
Thats currently a problem. As for as i know, there is no source level debugger
available that works with freepascal. (But i have a modified version of
Novells Rdebug that works with nlms generated by freepascal. Currently
i'm waiting for novell to answer my questions about redistributing Rdebug.
The only way to debug i know is using the netware internal debugger or nwdbg.
Nwdbg is a debugger on assembler level written by Jan Beulich. Symbols are
supported. You can get nwdbg for netware 4.11,5.0 or 5.1 at developer.novell.com.
I have no Information about netware 6 yet.
I read about plans to adapt gdb to current netware versions. As soon as i have news
about gdb i will change this document.
I also have a compiled version of gdbserve.nlm for gdb on my homepage
but this does not seem to be stable and will only run on netwar 4.x.
- Netware SDK
-----------
@ -196,4 +203,7 @@
- VARUTILS
- CPU
- MMX
- WinSock2
armin@freepascal.org

7
rtl/netware/nwpre.pp
View File

@ -85,7 +85,7 @@ TYPE
wchar_tSize : LONGINT;
END;
CONST NLM_INFO_SIGNATURE = 'NLMI'; // $494d3c3e;
CONST NLM_INFO_SIGNATURE = 'NLMI'; // 0x494d3c3e;
kNLMInfo : kNLMInfoT =
(Signature : NLM_INFO_SIGNATURE;
@ -152,7 +152,10 @@ END;
end.
{
$Log$
Revision 1.3 2001-04-16 18:39:50 florian
Revision 1.4 2002-03-17 17:57:33 armin
+ threads and winsock2 implemented
Revision 1.3 2001/04/16 18:39:50 florian
* updates from Armin commited
Revision 1.2 2001/04/11 14:17:00 florian

293
rtl/netware/qos.inc Normal file
View File

@ -0,0 +1,293 @@
{
$Id$
This file is part of the Free Pascal run time library.
This unit contains the declarations for the WinSock2
Socket Library for Netware and Win32
Copyright (c) 1999-2002 by the Free Pascal development team
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{ This module defines the Quality of Service structures and types used
by Winsock applications. }
{
Definitions for valued-based Service Type for each direction of data flow.
}
type
SERVICETYPE = u_long;
{ No data in this direction }
const
SERVICETYPE_NOTRAFFIC = $00000000;
{ Best Effort }
SERVICETYPE_BESTEFFORT = $00000001;
{ Controlled Load }
SERVICETYPE_CONTROLLEDLOAD = $00000002;
{ Guaranteed }
SERVICETYPE_GUARANTEED = $00000003;
{ Used to notify
change to user }
SERVICETYPE_NETWORK_UNAVAILABLE = $00000004;
{ corresponds to
"General Parameters"
defined by IntServ }
SERVICETYPE_GENERAL_INFORMATION = $00000005;
{ used to indicate
that the flow spec
contains no change
from any previous
one }
SERVICETYPE_NOCHANGE = $00000006;
{ Non-Conforming Traffic }
SERVICETYPE_NONCONFORMING = $00000009;
{ Custom ServiceType 1 }
SERVICETYPE_CUSTOM1 = $0000000A;
{ Custom ServiceType 2 }
SERVICETYPE_CUSTOM2 = $0000000B;
{ Custom ServiceType 3 }
SERVICETYPE_CUSTOM3 = $0000000C;
{ Custom ServiceType 4 }
SERVICETYPE_CUSTOM4 = $0000000D;
{
Definitions for bitmap-based Service Type for each direction of data flow.
}
SERVICE_BESTEFFORT = $80020000;
SERVICE_CONTROLLEDLOAD = $80040000;
SERVICE_GUARANTEED = $80080000;
SERVICE_CUSTOM1 = $80100000;
SERVICE_CUSTOM2 = $80200000;
SERVICE_CUSTOM3 = $80400000;
SERVICE_CUSTOM4 = $80800000;
{
Number of available Service Types.
}
NUM_SERVICETYPES = 8;
{
to turn on immediate traffic control, OR ( | ) this flag with the
ServiceType field in the FLOWSPEC
}
{ #define SERVICE_IMMEDIATE_TRAFFIC_CONTROL 0x80000000 // obsolete }
SERVICE_NO_TRAFFIC_CONTROL = $81000000;
{
this flag can be used with the immediate traffic control flag above to
prevent any rsvp signaling messages from being sent. Local traffic
control will be invoked, but no RSVP Path messages will be sent.This flag
can also be used in conjunction with a receiving flowspec to suppress
the automatic generation of a Reserve message. The application would
receive notification that a Path message had arrived and would then need
to alter the QOS by issuing WSAIoctl( SIO_SET_QOS ), to unset this flag
and thereby cause Reserve messages to go out.
}
SERVICE_NO_QOS_SIGNALING = $40000000;
{ rsvp status code }
STATUS_QOS_RELEASED = $10101010;
{
Flow Specifications for each direction of data flow.
}
{ In Bytes/sec }
{ In Bytes }
{ In Bytes/sec }
{ In microseconds }
{ In microseconds }
{ In Bytes }
{ In Bytes }
type
Tflowspec = record
TokenRate : u_long;
TokenBucketSize : u_long;
PeakBandwidth : u_long;
Latency : u_long;
DelayVariation : u_long;
ServiceType : SERVICETYPE;
MaxSduSize : u_long;
MinimumPolicedSize : u_long;
end;
PFLOWSPEC = ^Tflowspec;
LPFLOWSPEC = ^Tflowspec;
{
this value can be used in the FLOWSPEC structure to instruct the Rsvp Service
provider to derive the appropriate default value for the parameter. Note
that not all values in the FLOWSPEC structure can be defaults. In the
ReceivingFlowspec, all parameters can be defaulted except the ServiceType.
In the SendingFlowspec, the MaxSduSize and MinimumPolicedSize can be
defaulted. Other defaults may be possible. Refer to the appropriate
documentation.
}
const
QOS_NOT_SPECIFIED = $FFFFFFFF;
NULL_QOS_TYPE = $FFFFFFFD;
{
define a value that can be used for the PeakBandwidth, which will map into
positive infinity when the FLOWSPEC is converted into IntServ floating point
format. We can't use (-1) because that value was previously defined to mean
"select the default".
}
POSITIVE_INFINITY_RATE = $FFFFFFFE;
{
the provider specific structure can have a number of objects in it.
Each next structure in the
ProviderSpecific will be the QOS_OBJECT_HDR struct that prefaces the actual
data with a type and length for that object. This QOS_OBJECT struct can
repeat several times if there are several objects. This list of objects
terminates either when the buffer length has been reached ( WSABUF ) or
an object of type QOS_END_OF_LIST is encountered.
}
{ the length of object buffer INCLUDING
this header }
type
TQOS_OBJECT_HDR = record
ObjectType : u_long;
ObjectLength : u_long;
end;
LPQOS_OBJECT_HDR = ^TQOS_OBJECT_HDR;
PQOS_OBJECT_HDR = ^TQOS_OBJECT_HDR;
{
general QOS objects start at this offset from the base and have a range
of 1000
}
const
QOS_GENERAL_ID_BASE = 2000;
QOS_OBJECT_PRIORITY = $00000000 + QOS_GENERAL_ID_BASE;
{ QOS_PRIORITY structure passed }
QOS_OBJECT_END_OF_LIST = $00000001 + QOS_GENERAL_ID_BASE;
{ QOS_End_of_list structure passed }
QOS_OBJECT_SD_MODE = $00000002 + QOS_GENERAL_ID_BASE;
{ QOS_ShapeDiscard structure passed }
QOS_OBJECT_TRAFFIC_CLASS = $00000003 + QOS_GENERAL_ID_BASE;
{ QOS_Traffic class structure passed }
QOS_OBJECT_DESTADDR = $00000004 + QOS_GENERAL_ID_BASE;
{ QOS_DestAddr structure }
QOS_OBJECT_SHAPER_QUEUE_DROP_MODE = $00000005 + QOS_GENERAL_ID_BASE;
{ QOS_ShaperQueueDropMode structure }
QOS_OBJECT_SHAPER_QUEUE_LIMIT = $00000006 + QOS_GENERAL_ID_BASE;
{ QOS_ShaperQueueLimit structure }
{
This structure defines the absolute priorty of the flow. Priorities in the
range of 0-7 are currently defined. Receive Priority is not currently used,
but may at some point in the future.
}
{ this gets mapped to layer 2 priority. }
{ there are none currently defined. }
{ this could be used to decide who
gets forwarded up the stack first
- not used now }
type
TQOS_PRIORITY = record
ObjectHdr : TQOS_OBJECT_HDR;
SendPriority : u_char;
SendFlags : u_char;
ReceivePriority : u_char;
Unused : u_char;
end;
LPQOS_PRIORITY = ^TQOS_PRIORITY;
PQOS_PRIORITY = ^TQOS_PRIORITY;
{
This structure is used to define the behaviour that the traffic
control packet shaper will apply to the flow.
PS_NONCONF_BORROW - the flow will receive resources remaining
after all higher priority flows have been serviced. If a
TokenRate is specified, packets may be non-conforming and
will be demoted to less than best-effort priority.
PS_NONCONF_SHAPE - TokenRate must be specified. Non-conforming
packets will be retianed in the packet shaper until they become
conforming.
PS_NONCONF_DISCARD - TokenRate must be specified. Non-conforming
packets will be discarded.
}
TQOS_SD_MODE = record
ObjectHdr : TQOS_OBJECT_HDR;
ShapeDiscardMode : u_long;
end;
LPQOS_SD_MODE = ^TQOS_SD_MODE;
PQOS_SD_MODE = ^TQOS_SD_MODE;
const
TC_NONCONF_BORROW = 0;
TC_NONCONF_SHAPE = 1;
TC_NONCONF_DISCARD = 2;
TC_NONCONF_BORROW_PLUS = 3;
{
This structure may carry an 802.1 TrafficClass parameter which
has been provided to the host by a layer 2 network, for example,
in an 802.1 extended RSVP RESV message. If this object is obtained
from the network, hosts will stamp the MAC headers of corresponding
transmitted packets, with the value in the object. Otherwise, hosts
may select a value based on the standard Intserv mapping of
ServiceType to 802.1 TrafficClass.
}
type
TQOS_TRAFFIC_CLASS = record
ObjectHdr : TQOS_OBJECT_HDR;
TrafficClass : u_long;
end;
LPQOS_TRAFFIC_CLASS = ^TQOS_TRAFFIC_CLASS;
PQOS_TRAFFIC_CLASS = ^TQOS_TRAFFIC_CLASS;
{
This structure allows overriding of the default schema used to drop
packets when a flow's shaper queue limit is reached.
DropMethod -
QOS_SHAPER_DROP_FROM_HEAD - Drop packets from
the head of the queue until the new packet can be
accepted into the shaper under the current limit. This
behavior is the default.
QOS_SHAPER_DROP_INCOMING - Drop the incoming,
limit-offending packet.
}
TQOS_SHAPER_QUEUE_LIMIT_DROP_MODE = record
ObjectHdr : TQOS_OBJECT_HDR;
DropMode : u_long;
end;
LPQOS_SHAPER_QUEUE_LIMIT_DROP_MODE = ^TQOS_SHAPER_QUEUE_LIMIT_DROP_MODE;
PQOS_SHAPER_QUEUE_LIMIT_DROP_MODE = ^TQOS_SHAPER_QUEUE_LIMIT_DROP_MODE;
const
QOS_SHAPER_DROP_INCOMING = 0;
QOS_SHAPER_DROP_FROM_HEAD = 1;
{ This structure allows the default per-flow limit on the shaper queue
size to be overridden.
QueueSizeLimit - Limit, in bytes, of the size of the shaper queue }
type
TQOS_SHAPER_QUEUE_LIMIT = record
ObjectHdr : TQOS_OBJECT_HDR;
QueueSizeLimit : u_long;
end;
LPQOS_SHAPER_QUEUE_LIMIT = ^TQOS_SHAPER_QUEUE_LIMIT;
PQOS_SHAPER_QUEUE_LIMIT = ^TQOS_SHAPER_QUEUE_LIMIT;
{
$Log:
}

5
rtl/netware/system.pp
View File

@ -585,7 +585,6 @@ procedure InitFPU;assembler;
*****************************************************************************}
Begin
_EnterDebugger;
{$ifdef MT}
{ the exceptions use threadvars so do this _before_ initexceptions }
AllocateThreadVars;
@ -615,8 +614,8 @@ _EnterDebugger;
End.
{
$Log$
Revision 1.6 2002-03-08 19:13:49 armin
* changes for current rtl, basic MT support
Revision 1.7 2002-03-17 17:57:33 armin
+ threads and winsock2 implemented
Revision 1.5 2001/06/18 14:26:16 jonas
* move platform independent constant declarations after inclusion of

316
rtl/netware/thread.inc Normal file
View File

@ -0,0 +1,316 @@
{
$Id:
This file is part of the Free Pascal run time library.
Copyright (c) 2001-2002 by the Free Pascal development team.
Multithreading implementation for NetWare
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.
**********************************************************************}
{$ifdef MT}
{ Multithreading for netware, armin 16 Mar 2002
- threads are basicly tested and working
- threadvars should work but currently there is a bug in the
compiler preventing using multithreading
- TRTLCriticalSections are working but NEVER call Enter or
LeaveCriticalSection with uninitialized CriticalSections.
Critial Sections are based on local semaphores and the
Server will abend if the semaphore handles are invalid. There
are basic tests in the rtl but this will not work in every case.
Not closed semaphores will be closed by the rtl on program
termination because some versions of netware will abend if there
are open semaphores on nlm unload.
}
const
threadvarblocksize : dword = 0; // total size of allocated threadvars
type
tthreadinfo = record
f : tthreadfunc;
p : pointer;
end;
pthreadinfo = ^tthreadinfo;
{ all needed import stuff is in nwsys.inc and already included by
system.pp }
procedure init_threadvar(var offset : dword;size : dword);[public,alias: 'FPC_INIT_THREADVAR'];
begin
offset:=threadvarblocksize;
inc(threadvarblocksize,size);
{$ifdef DEBUG_MT}
ConsolePrintf3(#13'init_threadvar, new offset: (%d), Size:%d'#13#10,offset,size,0);
{$endif DEBUG_MT}
end;
{$ifdef DEBUG_MT}
var dummy_buff : array [0..255] of char; // to avoid abends (for current compiler error that not all threadvars are initialized)
{$endif}
function relocate_threadvar(offset : dword) : pointer;[public,alias: 'FPC_RELOCATE_THREADVAR'];
begin
{$ifdef DEBUG_MT}
ConsolePrintf(#13'relocate_threadvar, offset: (%d)'#13#10,offset);
if offset > threadvarblocksize then
begin
ConsolePrintf(#13'relocate_threadvar, invalid offset'#13#10,0);
relocate_threadvar := @dummy_buff;
exit;
end;
{$endif DEBUG_MT}
relocate_threadvar:=_GetThreadDataAreaPtr + offset;
end;
procedure AllocateThreadVars;
var
threadvars : pointer;
begin
{ we've to allocate the memory from netware }
{ 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 }
threadvars := _malloc (threadvarblocksize);
fillchar (threadvars^, threadvarblocksize, 0);
_SaveThreadDataAreaPtr (threadvars);
{$ifdef DEBUG_MT}
ConsolePrintf(#13'threadvars allocated at (%x)'#13#10,longint(threadvars));
ConsolePrintf(#13'size of threadvars: %d'#13#10,threadvarblocksize);
{$endif DEBUG_MT}
end;
procedure ReleaseThreadVars;
var
threadvars : pointer;
begin
{ release thread vars }
threadvars:=_GetThreadDataAreaPtr;
_Free (threadvars);
end;
procedure InitThread;
begin
InitFPU;
{ we don't need to set the data to 0 because we did this with }
{ the fillchar above, but it looks nicer }
{ ExceptAddrStack and ExceptObjectStack are threadvars }
{ so every thread has its on exception handling capabilities }
InitExceptions;
InOutRes:=0;
// ErrNo:=0;
end;
procedure DoneThread;
begin
{ release thread vars }
ReleaseThreadVars;
end;
function ThreadMain(param : pointer) : dword;stdcall;
var
ti : tthreadinfo;
begin
{$ifdef DEBUG_MT}
writeln('New thread started, initialising ...');
{$endif DEBUG_MT}
AllocateThreadVars;
InitThread;
ti:=pthreadinfo(param)^;
dispose(pthreadinfo(param));
{$ifdef DEBUG_MT}
writeln('Jumping to thread function');
{$endif DEBUG_MT}
ThreadMain:=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}
IsMultithread:=true;
{ 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;
{$ifdef DEBUG_MT}
writeln('Starting new thread');
{$endif DEBUG_MT}
BeginThread :=
_BeginThread (@ThreadMain,NIL,Stacksize,ti);
end;
function BeginThread(ThreadFunction : tthreadfunc) : DWord;
var dummy : dword;
begin
BeginThread:=BeginThread(nil,0,ThreadFunction,nil,0,dummy);
end;
function BeginThread(ThreadFunction : tthreadfunc;p : pointer) : DWord;
var dummy : dword;
begin
BeginThread:=BeginThread(nil,0,ThreadFunction,p,0,dummy);
end;
function BeginThread(ThreadFunction : tthreadfunc;p : pointer;var ThreadId : DWord) : DWord;
begin
BeginThread:=BeginThread(nil,0,ThreadFunction,p,0,ThreadId);
end;
procedure EndThread(ExitCode : DWord);
begin
DoneThread;
ExitThread(ExitCode, TSR_THREAD);
end;
procedure EndThread;
begin
EndThread(0);
end;
{ netware requires all allocated semaphores }
{ to be closed before terminating the nlm, otherwise }
{ the server will abend (except for netware 6 i think) }
TYPE TSemaList = ARRAY [1..1000] OF LONGINT;
PSemaList = ^TSemaList;
CONST NumSemaOpen : LONGINT = 0;
NumEntriesMax : LONGINT = 0;
SemaList : PSemaList = NIL;
PROCEDURE SaveSema (Handle : LONGINT);
BEGIN
{$ifdef DEBUG_MT}
ConsolePrintf(#13'new Semaphore allocated (%x)'#13#10,Handle);
{$endif DEBUG_MT}
_EnterCritSec;
IF NumSemaOpen = NumEntriesMax THEN
BEGIN
IF SemaList = NIL THEN
BEGIN
SemaList := _malloc (32 * SIZEOF (TSemaList[0]));
NumEntriesMax := 32;
END ELSE
BEGIN
INC (NumEntriesMax, 16);
SemaList := _realloc (SemaList, NumEntriesMax * SIZEOF (TSemaList[0]));
END;
END;
INC (NumSemaOpen);
SemaList^[NumSemaOpen] := Handle;
_ExitCritSec;
END;
PROCEDURE ReleaseSema (Handle : LONGINT);
VAR I : LONGINT;
BEGIN
{$ifdef DEBUG_MT}
ConsolePrintf(#13'Semaphore released (%x)'#13#10,Handle);
{$endif DEBUG_MT}
_EnterCritSec;
IF SemaList <> NIL then
if NumSemaOpen > 0 then
begin
for i := 1 to NumSemaOpen do
if SemaList^[i] = Handle then
begin
if i < NumSemaOpen then
SemaList^[i] := SemaList^[NumSemaOpen];
dec (NumSemaOpen);
_ExitCritSec;
exit;
end;
end;
_ExitCritSec;
ConsolePrintf (#13'fpc-rtl: ReleaseSema, Handle not found'#13#10,0);
END;
PROCEDURE CloseAllRemainingSemaphores;
var i : LONGINT;
begin
IF SemaList <> NIL then
begin
if NumSemaOpen > 0 then
for i := 1 to NumSemaOpen do
_CloseLocalSemaphore (SemaList^[i]);
_free (SemaList);
SemaList := NIL;
NumSemaOpen := 0;
NumEntriesMax := 0;
end;
end;
{ this allows to do a lot of things in MT safe way }
{ it is also used to make the heap management }
{ thread safe }
procedure InitCriticalSection(var cs : TRTLCriticalSection);
begin
cs.SemaHandle := _OpenLocalSemaphore (1);
cs.SemaIsOpen := true;
SaveSema (cs.SemaHandle);
end;
procedure DoneCriticalsection(var cs : TRTLCriticalSection);
begin
if cs.SemaIsOpen then
begin
_CloseLocalSemaphore (cs.SemaHandle);
ReleaseSema (cs.SemaHandle);
cs.SemaIsOpen := FALSE;
end;
end;
procedure EnterCriticalsection(var cs : TRTLCriticalSection);
begin
if cs.SemaIsOpen then
_WaitOnLocalSemaphore (cs.SemaHandle)
else
ConsolePrintf (#13'fpc-rtl: EnterCriticalsection, TRTLCriticalSection not open'#13#10,0);
end;
procedure LeaveCriticalsection(var cs : TRTLCriticalSection);
begin
if cs.SemaIsOpen then
_SignalLocalSemaphore (cs.SemaHandle)
else
ConsolePrintf (#13'fpc-rtl: LeaveCriticalsection, TRTLCriticalSection not open'#13#10,0);
end;
{$endif MT}
{
$Log$
Revision 1.1 2002-03-17 17:57:33 armin
+ threads and winsock2 implemented
}

2371
rtl/netware/winsock2.pp Normal file
View File

File diff suppressed because it is too large Load Diff