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

--- Merging r30991 into '.':

Browse Source 
U    rtl/morphos/system.pp
U    rtl/amicommon/sysosh.inc
U    rtl/amicommon/sysos.inc
U    rtl/amiga/system.pp
--- Recording mergeinfo for merge of r30991 into '.':
 U   .
--- Merging r30992 into '.':
U    rtl/amicommon/athreads.pp
--- Recording mergeinfo for merge of r30992 into '.':
 G   .
--- Merging r30993 into '.':
U    packages/rtl-extra/src/amiga/sockets.pp
D    packages/rtl-extra/src/morphos
U    packages/rtl-extra/fpmake.pp
--- Recording mergeinfo for merge of r30993 into '.':
 G   .
--- Merging r30994 into '.':
G    packages/rtl-extra/src/amiga/sockets.pp
--- Recording mergeinfo for merge of r30994 into '.':
 G   .
--- Merging r30995 into '.':
U    packages/morphunits/src/utility.pas
--- Recording mergeinfo for merge of r30995 into '.':
 G   .
--- Merging r30996 into '.':
U    packages/morphunits/src/exec.pas
--- Recording mergeinfo for merge of r30996 into '.':
 G   .
--- Merging r30997 into '.':
U    packages/morphunits/src/amigalib.pas
--- Recording mergeinfo for merge of r30997 into '.':
 G   .
--- Merging r30998 into '.':
U    packages/amunits/src/coreunits/exec.pas
--- Recording mergeinfo for merge of r30998 into '.':
 G   .
--- Merging r30999 into '.':
G    packages/morphunits/src/amigalib.pas
--- Recording mergeinfo for merge of r30999 into '.':
 G   .
--- Merging r31000 into '.':
G    packages/morphunits/src/exec.pas
--- Recording mergeinfo for merge of r31000 into '.':
 G   .
--- Merging r31001 into '.':
U    packages/amunits/src/coreunits/amigalib.pas
--- Recording mergeinfo for merge of r31001 into '.':
 G   .
--- Merging r31005 into '.':
U    utils/fpcres/fpmake.pp
--- Recording mergeinfo for merge of r31005 into '.':
 G   .

# revisions: 30991,30992,30993,30994,30995,30996,30997,30998,30999,31000,31001,31005

git-svn-id: branches/fixes_3_0@31097 -
This commit is contained in:
marco 2015-06-17 18:42:30 +00:00
parent ac02f7e440
commit d6bd0750b8
15 changed files with 289 additions and 325 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -6714,7 +6714,6 @@ packages/rtl-extra/src/linux/unixsock.inc svneol=native#text/plain
packages/rtl-extra/src/linux/unixsockets.inc svneol=native#text/plain
packages/rtl-extra/src/linux/unixsocketsh.inc svneol=native#text/plain
packages/rtl-extra/src/linux/unxsockh.inc svneol=native#text/plain
packages/rtl-extra/src/morphos/sockets.pp svneol=native#text/plain
packages/rtl-extra/src/msdos/printer.pp svneol=native#text/plain
packages/rtl-extra/src/netbsd/unixsock.inc svneol=native#text/plain
packages/rtl-extra/src/netbsd/unxsockh.inc svneol=native#text/plain

15
packages/amunits/src/coreunits/amigalib.pas
View File

@ -100,6 +100,8 @@ function DoSuperMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong;
function CoerceMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong;
function SetSuperAttrsA(cl : pIClass; obj: pObject_; msg : APTR): ulong;
procedure HookEntry;
{
NAME
@ -391,6 +393,19 @@ begin
SetSuperAttrsA := DoSuperMethodA(cl, obj, @arr);
end;
{ Do *NOT* change this to nostackframe! }
{ The compiler will build a stackframe with link/unlk. So that will actually correct
the stackpointer for both Pascal/StdCall and cdecl functions, so the stackpointer will
be correct on exit. It also needs no manual RTS. The argument push order is also
correct for both. (KB) }
procedure HookEntry; assembler;
asm
move.l a1,-(a7) // Msg
move.l a2,-(a7) // Obj
move.l a0,-(a7) // PHook
move.l 12(a0),a0 // h_SubEntry = Offset 12
jsr (a0) // Call the SubEntry
end;
procedure printf(Fmtstr : pchar; const Args : array of const);
var

1
packages/amunits/src/coreunits/exec.pas
View File

@ -110,7 +110,6 @@ TYPE
PULONG = ^longword;
PAPTR = ^APTR;
PLONG = ^LONG;
psmallint = ^smallint;
const
{There is a problem with boolean

15
packages/morphunits/src/amigalib.pas
View File

@ -33,9 +33,11 @@ function DoSuperNew(class_: pointer; obj: pointer; tags: array of LongWord): lon
// This procedure is used to pop dispatcher args from emulstruc
procedure DISPATCHERARG(var cl; var obj; var msg); assembler;
function HookEntry: longword;
implementation
uses intuition;
uses exec, intuition, utility;
function DoMethodA(obj : longword; msg1 : Pointer): longword; assembler;
asm
@ -111,4 +113,15 @@ asm
stw r6,(r5) // msg
end;
type
THookSubEntryFunc = function(a, b, c: Pointer): longword;
function HookEntry: longword;
var
hook: PHook;
begin
hook:=REG_A0;
HookEntry:=THookSubEntryFunc(hook^.h_SubEntry)(hook, REG_A2, REG_A1);
end;
end.

138
packages/morphunits/src/exec.pas
View File

@ -23,8 +23,30 @@ interface
var
ExecBase: Pointer;
{.$include execd.inc}
{.$include execf.inc}
{ Some types for classic Amiga and AROS compatibility }
type
STRPTR = PChar;
ULONG = Longword;
LONG = Longint;
APTR = Pointer;
BPTR = Longint;
BSTR = Longint;
BOOL = Smallint; { I think this could be changed to WordBool (KB) }
UWORD = Word;
WORDBITS = Word;
LONGBITS = Longword;
PLONGBITS = ^LONGBITS;
UBYTE = Byte;
PULONG = ^Longword;
PAPTR = ^APTR;
PLONG = ^LONG;
{ Some constants for classic Amiga and AROS compatibility }
const
LTrue : Longint = 1;
LFalse : Longint = 0;
{ * emulinterface consts from MorphOS SDK * }
@ -66,6 +88,26 @@ type
Func : Pointer;
end;
function REG_D0: DWord;
function REG_D1: DWord;
function REG_D2: DWord;
function REG_D3: DWord;
function REG_D4: DWord;
function REG_D5: DWord;
function REG_D6: DWord;
function REG_D7: DWord;
function REG_A0: Pointer;
function REG_A1: Pointer;
function REG_A2: Pointer;
function REG_A3: Pointer;
function REG_A4: Pointer;
function REG_A5: Pointer;
function REG_A6: Pointer;
function REG_A7: Pointer;
function REG_PC: Pointer;
function REG_SR: DWord;
{ * "dummy" definitions from utility, which we can't include here because it
* would create a circular dependency (KB) }
@ -2372,6 +2414,98 @@ begin
end;
function REG_D0: DWord; assembler; nostackframe;
asm
lwz r3,0(r2)
end;
function REG_D1: DWord; assembler; nostackframe;
asm
lwz r3,4(r2)
end;
function REG_D2: DWord; assembler; nostackframe;
asm
lwz r3,8(r2)
end;
function REG_D3: DWord; assembler; nostackframe;
asm
lwz r3,12(r2)
end;
function REG_D4: DWord; assembler; nostackframe;
asm
lwz r3,16(r2)
end;
function REG_D5: DWord; assembler; nostackframe;
asm
lwz r3,20(r2)
end;
function REG_D6: DWord; assembler; nostackframe;
asm
lwz r3,24(r2)
end;
function REG_D7: DWord; assembler; nostackframe;
asm
lwz r3,28(r2)
end;
function REG_A0: Pointer; assembler; nostackframe;
asm
lwz r3,32(r2)
end;
function REG_A1: Pointer; assembler; nostackframe;
asm
lwz r3,36(r2)
end;
function REG_A2: Pointer; assembler; nostackframe;
asm
lwz r3,40(r2)
end;
function REG_A3: Pointer; assembler; nostackframe;
asm
lwz r3,44(r2)
end;
function REG_A4: Pointer; assembler; nostackframe;
asm
lwz r3,48(r2)
end;
function REG_A5: Pointer; assembler; nostackframe;
asm
lwz r3,52(r2)
end;
function REG_A6: Pointer; assembler; nostackframe;
asm
lwz r3,56(r2)
end;
function REG_A7: Pointer; assembler; nostackframe;
asm
lwz r3,60(r2)
end;
function REG_PC: Pointer; assembler; nostackframe;
asm
lwz r3,64(r2)
end;
function REG_SR: DWord; assembler; nostackframe;
asm
lwz r3,68(r2)
end;
begin
ExecBase:=MOS_ExecBase;
end.

4
packages/morphunits/src/utility.pas
View File

@ -188,8 +188,8 @@ type
PHook = ^THook;
THook = packed record
h_MinNode : TMinNode;
h_Entry : Cardinal;
h_SubEntry: Cardinal;
h_Entry : Pointer;
h_SubEntry: Pointer;
h_Data : Pointer;
end;

1
packages/rtl-extra/fpmake.pp
View File

@ -67,6 +67,7 @@ begin
// unit from that directory. Maybe we should try to merge the WinSock(2)
// units to remove the wince directory completely...
P.SourcePath.Add('src/win',[win32,win64,wince]);
P.SourcePath.Add('src/amiga',[morphos]);
P.IncludePath.Add('src/bsd',AllBSDOSes);
P.IncludePath.Add('src/inc');

49
packages/rtl-extra/src/amiga/sockets.pp
View File

@ -1,6 +1,6 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2007 by the Free Pascal development team
Copyright (c) 1999-2015 by the Free Pascal development team
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -11,6 +11,7 @@
**********************************************************************}
{$PACKRECORDS 2}
{.$DEFINE SOCKETS_DEBUG}
unit Sockets;
Interface
@ -109,7 +110,7 @@ Function Accept(Sock:longint;var addr:string;var SockIn,SockOut:File):Boolean;
//function fpbind (s:cint; addrx : psockaddr; addrlen : tsocklen):cint; maybelibc
//function fpconnect (s:cint; name : psockaddr; namelen : tsocklen):cint; maybelibc
var
threadvar
SocketBase: PLibrary;
function bsd_socket(Domain: LongInt location 'd0'; Type_: LongInt location 'd1'; Protocol: LongInt location 'd2'): LongInt; syscall SocketBase 30;
@ -133,6 +134,15 @@ function bsd_inet_addr(const cp: PChar location 'a0'): LongWord; syscall SocketB
function bsd_gethostbyname(const Name: PChar location 'a0'): PHostEnt; syscall SocketBase 210;
function bsd_gethostbyaddr(const Addr: PByte location 'a0'; Len: LongInt location 'd0'; Type_: LongInt location 'd1'): PHostEnt; syscall SocketBase 216;
{ Definition for Release(CopyOf)Socket unique id }
const
UNIQUE_ID = -1;
{ Amiga-specific functions for passing socket descriptors between threads (processes) }
function ObtainSocket(id: LongInt location 'd0'; domain: LongInt location 'd1'; _type: LongInt location 'd2'; protocol: LongInt location 'd3'): LongInt; syscall SocketBase 144;
function ReleaseSocket(s: LongInt location 'd0'; id: LongInt location 'd1'): LongInt; syscall SocketBase 150;
function ReleaseCopyOfSocket(s: LongInt location 'd0'; id: LongInt location 'd1'): LongInt; syscall SocketBase 156;
Implementation
threadvar internal_socketerror: cint;
@ -258,14 +268,37 @@ end;
{$i sockovl.inc}
{$i sockets.inc}
// FIXME: this doesn't make any sense here, because SocketBase should be task-specific
// but FPC doesn't support that yet (TODO)
{$WARNING FIX ME, TODO}
const
BSDSOCKET_LIBRARY_VER = 4;
procedure BSDSocketOpen;
begin
{$IFDEF SOCKETS_DEBUG}
SysDebugLn('FPC Sockets: Opening bsdsocket.library...');
{$ENDIF}
SocketBase:=OpenLibrary('bsdsocket.library', BSDSOCKET_LIBRARY_VER);
{$IFDEF SOCKETS_DEBUG}
if SocketBase = nil then
SysDebugLn('FPC Sockets: FAILED to open bsdsocket.library.')
else
SysDebugLn('FPC Sockets: bsdsocket.library opened successfully.');
{$ENDIF}
end;
procedure BSDSocketClose;
begin
if (SocketBase<>NIL) then CloseLibrary(SocketBase);
SocketBase:=NIL;
{$IFDEF SOCKETS_DEBUG}
SysDebugLn('FPC Sockets: bsdsocket.library closed.');
{$ENDIF}
end;
initialization
SocketBase := OpenLibrary('bsdsocket.library',0);
AddThreadInitProc(@BSDSocketOpen);
AddThreadExitProc(@BSDSocketClose);
BSDSocketOpen;
finalization
if SocketBase <> nil then
CloseLibrary(SocketBase);
BSDSocketClose;
end.

309
packages/rtl-extra/src/morphos/sockets.pp
View File

@ -1,309 +0,0 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2007 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.
**********************************************************************}
{$PACKRECORDS 2}
unit Sockets;
Interface
Uses ctypes,exec;
type
size_t = cuint32; { as definied in the C standard}
ssize_t = cint32; { used by function for returning number of bytes}
socklen_t= cuint32;
TSocklen = socklen_t;
pSocklen = ^socklen_t;
//{ $i unxsockh.inc}
{$define BSD}
{$define SOCK_HAS_SINLEN}
{$i socketsh.inc}
type
TUnixSockAddr = packed Record
sa_len : cuchar;
family : sa_family_t;
path:array[0..107] of char; //104 total for freebsd.
end;
type
hostent = record
h_name : PChar;
h_aliases : PPChar;
h_addrtype : LongInt;
h_Length : LongInt;
h_addr_list: ^PDWord;
end;
THostEnt = hostent;
PHostEnt = ^THostEnt;
const
AF_UNSPEC = 0; {* unspecified *}
AF_LOCAL = 1; {* local to host (pipes, portals) *}
AF_UNIX = AF_LOCAL; {* backward compatibility *}
AF_INET = 2; {* internetwork: UDP, TCP, etc. *}
AF_IMPLINK = 3; {* arpanet imp addresses *}
AF_PUP = 4; {* pup protocols: e.g. BSP *}
AF_CHAOS = 5; {* mit CHAOS protocols *}
AF_NS = 6; {* XEROX NS protocols *}
AF_ISO = 7; {* ISO protocols *}
AF_OSI = AF_ISO;
AF_ECMA = 8; {* european computer manufacturers *}
AF_DATAKIT = 9; {* datakit protocols *}
AF_CCITT = 10; {* CCITT protocols, X.25 etc *}
AF_SNA = 11; {* IBM SNA *}
AF_DECnet = 12; {* DECnet *}
AF_DLI = 13; {* DEC Direct data link interface *}
AF_LAT = 14; {* LAT *}
AF_HYLINK = 15; {* NSC Hyperchannel *}
AF_APPLETALK = 16; {* Apple Talk *}
AF_ROUTE = 17; {* Internal Routing Protocol *}
AF_LINK = 18; {* Link layer interface *}
pseudo_AF_XTP = 19; {* eXpress Transfer Protocol (no AF) *}
AF_COIP = 20; {* connection-oriented IP, aka ST II *}
AF_CNT = 21; {* Computer Network Technology *}
pseudo_AF_RTIP = 22; {* Help Identify RTIP packets *}
AF_IPX = 23; {* Novell Internet Protocol *}
AF_SIP = 24; {* Simple Internet Protocol *}
pseudo_AF_PIP = 25; {* Help Identify PIP packets *}
AF_MAX = 26;
SO_LINGER = $0080;
SOL_SOCKET = $FFFF;
const
EsockEINTR = 4; // EsysEINTR;
EsockEBADF = 9; // EsysEBADF;
EsockEFAULT = 14; // EsysEFAULT;
EsockEINVAL = 22; //EsysEINVAL;
EsockEACCESS = 13; //ESysEAcces;
EsockEMFILE = 24; //ESysEmfile;
EsockENOBUFS = 55; //ESysENoBufs;
EsockENOTCONN = 57; //ESysENotConn;
EsockEPROTONOSUPPORT = 43; //ESysEProtoNoSupport;
EsockEWOULDBLOCK = 35; //ESysEWouldBlock; // same as eagain on morphos
{ unix socket specific functions }
{*
Procedure Str2UnixSockAddr(const addr:string;var t:TUnixSockAddr;var len:longint); deprecated;
Function Bind(Sock:longint;const addr:string):boolean; deprecated;
Function Connect(Sock:longint;const addr:string;var SockIn,SockOut:text):Boolean; deprecated;
Function Connect(Sock:longint;const addr:string;var SockIn,SockOut:file):Boolean; deprecated;
Function Accept(Sock:longint;var addr:string;var SockIn,SockOut:text):Boolean; deprecated;
Function Accept(Sock:longint;var addr:string;var SockIn,SockOut:File):Boolean; deprecated;
*}
//function fpaccept (s:cint; addrx : psockaddr; addrlen : psocklen):cint; maybelibc
//function fpbind (s:cint; addrx : psockaddr; addrlen : tsocklen):cint; maybelibc
//function fpconnect (s:cint; name : psockaddr; namelen : tsocklen):cint; maybelibc
var SocketBase : pLibrary;
function bsd_socket(domain : LongInt location 'd0'; type_ : LongInt location 'd1'; protocol : LongInt location 'd2') : LongInt; syscall legacy SocketBase 030;
function bsd_bind(s : LongInt location 'd0'; const name : psockaddr location 'a0'; namelen : LongInt location 'd1') : LongInt; syscall legacy SocketBase 036;
function bsd_listen(s : LongInt location 'd0'; backlog : LongInt location 'd1') : LongInt; syscall legacy SocketBase 042;
function bsd_accept(s : LongInt location 'd0'; addr : psockaddr location 'a0'; var addrlen : LongInt location 'a1') : LongInt; syscall legacy SocketBase 048;
function bsd_connect(s : LongInt location 'd0'; const name : psockaddr location 'a0'; namelen : LongInt location 'd1') : LongInt; syscall legacy SocketBase 054;
function bsd_sendto(s : LongInt location 'd0'; const msg : pChar location 'a0'; len : LongInt location 'd1'; flags : LongInt location 'd2'; const to_ : psockaddr location 'a1'; tolen : LongInt location 'd3') : LongInt; syscall legacy SocketBase 060;
function bsd_send(s : LongInt location 'd0'; const msg : pChar location 'a0'; len : LongInt location 'd1'; flags : LongInt location 'd2') : LongInt; syscall legacy SocketBase 066;
function bsd_recvfrom(s : LongInt location 'd0'; buf : pChar location 'a0'; len : LongInt location 'd1'; flags : LongInt location 'd2'; from : psockaddr location 'a1'; var fromlen : LongInt location 'a2') : LongInt; syscall legacy SocketBase 072;
function bsd_recv(s : LongInt location 'd0'; buf : pChar location 'a0'; len : LongInt location 'd1'; flags : LongInt location 'd2') : LongInt; syscall legacy SocketBase 078;
function bsd_shutdown(s : LongInt location 'd0'; how : LongInt location 'd1') : LongInt; syscall legacy SocketBase 084;
function bsd_closesocket(d : LongInt location 'd0') : LongInt; syscall legacy SocketBase 120;
function bsd_Errno: LongInt; syscall SocketBase 162;
function bsd_inet_ntoa(in_ : DWord location 'd0') : pChar; syscall legacy SocketBase 174;
function bsd_inet_addr(const cp : pChar location 'a0') : DWord; syscall legacy SocketBase 180;
function bsd_gethostbyname(const name : pChar location 'a0') : phostent; syscall legacy SocketBase 210;
function bsd_gethostbyaddr(const addr : pChar location 'a0'; len : LongInt location 'd0'; type_ : LongInt location 'd1') : phostent; syscall legacy SocketBase 216;
Implementation
//Uses {$ifndef FPC_USE_LIBC}SysCall{$else}initc{$endif};
threadvar internal_socketerror : cint;
{******************************************************************************
Kernel Socket Callings
******************************************************************************}
function socketerror:cint;
begin
socketerror:=internal_socketerror;
end;
//{$define uselibc:=cdecl; external;}
//const libname='c';
{
function cfpaccept (s:cint; addrx : psockaddr; addrlen : psocklen):cint; cdecl; external libname name 'accept';
function cfpbind (s:cint; addrx : psockaddr; addrlen : tsocklen):cint; cdecl; external libname name 'bind';
function cfpconnect (s:cint; name : psockaddr; namelen : tsocklen):cint; cdecl; external libname name 'connect';
function cfpgetpeername (s:cint; name : psockaddr; namelen : psocklen):cint; cdecl; external libname name 'getpeername';
function cfpgetsockname (s:cint; name : psockaddr; namelen : psocklen):cint; cdecl; external libname name 'getsockname';
function cfpgetsockopt (s:cint; level:cint; optname:cint; optval:pointer; optlen : psocklen):cint; cdecl; external libname name 'getsockopt';
function cfplisten (s:cint; backlog : cint):cint; cdecl; external libname name 'listen';
function cfprecv (s:cint; buf: pointer; len: size_t; flags: cint):ssize_t; cdecl; external libname name 'recv';
function cfprecvfrom (s:cint; buf: pointer; len: size_t; flags: cint; from : psockaddr; fromlen : psocklen):ssize_t; cdecl; external libname name 'recvfrom';
//function cfprecvmsg (s:cint; msg: pmsghdr; flags:cint):ssize_t; cdecl; external libname name '';
function cfpsend (s:cint; msg:pointer; len:size_t; flags:cint):ssize_t; cdecl; external libname name 'send';
function cfpsendto (s:cint; msg:pointer; len:size_t; flags:cint; tox :psockaddr; tolen: tsocklen):ssize_t; cdecl; external libname name 'sendto';
//function cfpsendmsg (s:cint; hdr: pmsghdr; flags:cint):ssize; cdecl; external libname name '';
function cfpsetsockopt (s:cint; level:cint; optname:cint; optval:pointer; optlen :tsocklen):cint; cdecl; external libname name 'setsockopt';
function cfpshutdown (s:cint; how:cint):cint; cdecl; external libname name 'shutdown';
function cfpsocket (domain:cint; xtype:cint; protocol: cint):cint; cdecl; external libname name 'socket';
function cfpsocketpair (d:cint; xtype:cint; protocol:cint; sv:pcint):cint; cdecl; external libname name 'socketpair';
}
function cfpaccept(s : LongInt location 'd0'; addr : psockaddr location 'a0'; addrlen : pSocklen location 'a1') : LongInt; syscall legacy SocketBase 048;
function cfpbind(s : LongInt location 'd0'; const name : psockaddr location 'a0'; namelen : LongInt location 'd1') : LongInt; syscall legacy SocketBase 036;
function cfpconnect(s : LongInt location 'd0'; const name : psockaddr location 'a0'; namelen : LongInt location 'd1') : LongInt; syscall legacy SocketBase 054;
function cfpsendto(s : LongInt location 'd0'; const msg : pChar location 'a0'; len : LongInt location 'd1'; flags : LongInt location 'd2'; const to_ : psockaddr location 'a1'; tolen : LongInt location 'd3') : LongInt; syscall legacy SocketBase 060;
function cfpsend(s : LongInt location 'd0'; const msg : pChar location 'a0'; len : LongInt location 'd1'; flags : LongInt location 'd2') : LongInt; syscall legacy SocketBase 066;
function cfprecvfrom(s : LongInt location 'd0'; buf : pChar location 'a0'; len : LongInt location 'd1'; flags : LongInt location 'd2'; from : psockaddr location 'a1'; fromlen : pSockLen location 'a2') : LongInt; syscall legacy SocketBase 072;
function cfprecv(s : LongInt location 'd0'; buf : pChar location 'a0'; len : LongInt location 'd1'; flags : LongInt location 'd2') : LongInt; syscall legacy SocketBase 078;
function cfpgetsockopt(s : LongInt location 'd0'; level : LongInt location 'd1'; optname : LongInt location 'd2'; optval : Pointer location 'a0'; optlen : pSockLen location 'a1') : LongInt; syscall legacy SocketBase 096;
function cfpgetsockname(s : LongInt location 'd0'; hostname : psockaddr location 'a0'; namelen : pSockLen location 'a1') : LongInt; syscall legacy SocketBase 102;
function cfpgetpeername(s : LongInt location 'd0'; hostname : psockaddr location 'a0'; namelen : pSockLen location 'a1') : LongInt; syscall legacy SocketBase 108;
function cfpsetsockopt(s : LongInt location 'd0'; level : LongInt location 'd1'; optname : LongInt location 'd2'; const optval : Pointer location 'a0'; optlen : LongInt location 'd3') : LongInt; syscall legacy SocketBase 090;
function cfplisten(s : LongInt location 'd0'; backlog : LongInt location 'd1') : LongInt; syscall legacy SocketBase 042;
function cfpsocket(domain : LongInt location 'd0'; type_ : LongInt location 'd1'; protocol : LongInt location 'd2') : LongInt; syscall legacy SocketBase 030;
function cfpshutdown(s : LongInt location 'd0'; how : LongInt location 'd1') : LongInt; syscall legacy SocketBase 084;
function cfpCloseSocket(d : LongInt location 'd0') : LongInt; syscall legacy SocketBase 120;
function cfpErrno : LongInt; syscall legacy SocketBase 162;
function fpgeterrno: longint; inline;
begin
fpgeterrno:=cfpErrno;
end;
function fpClose(d: LongInt): LongInt; inline;
begin
fpClose:=cfpCloseSocket(d);
end;
function fpaccept (s:cint; addrx : psockaddr; addrlen : psocklen):cint;
begin
fpaccept:=cfpaccept(s,addrx,addrlen);
internal_socketerror:=fpgeterrno;
end;
function fpbind (s:cint; addrx : psockaddr; addrlen : tsocklen):cint;
begin
fpbind:=cfpbind (s,addrx,addrlen);
internal_socketerror:=fpgeterrno;
end;
function fpconnect (s:cint; name : psockaddr; namelen : tsocklen):cint;
begin
fpconnect:=cfpconnect (s,name,namelen);
internal_socketerror:=fpgeterrno;
end;
function fpgetpeername (s:cint; name : psockaddr; namelen : psocklen):cint;
begin
fpgetpeername:=cfpgetpeername (s,name,namelen);
internal_socketerror:=fpgeterrno;
end;
function fpgetsockname (s:cint; name : psockaddr; namelen : psocklen):cint;
begin
fpgetsockname:=cfpgetsockname(s,name,namelen);
internal_socketerror:=fpgeterrno;
end;
function fpgetsockopt (s:cint; level:cint; optname:cint; optval:pointer; optlen : psocklen):cint;
begin
fpgetsockopt:=cfpgetsockopt(s,level,optname,optval,optlen);
internal_socketerror:=fpgeterrno;
end;
function fplisten (s:cint; backlog : cint):cint;
begin
fplisten:=cfplisten(s,backlog);
internal_socketerror:=fpgeterrno;
end;
function fprecv (s:cint; buf: pointer; len: size_t; flags:cint):ssize_t;
begin
fprecv:= cfprecv (s,buf,len,flags);
internal_socketerror:=fpgeterrno;
end;
function fprecvfrom (s:cint; buf: pointer; len: size_t; flags: cint; from : psockaddr; fromlen : psocklen):ssize_t;
begin
fprecvfrom:= cfprecvfrom (s,buf,len,flags,from,fromlen);
internal_socketerror:=fpgeterrno;
end;
function fpsend (s:cint; msg:pointer; len:size_t; flags:cint):ssize_t;
begin
fpsend:=cfpsend (s,msg,len,flags);
internal_socketerror:=fpgeterrno;
end;
function fpsendto (s:cint; msg:pointer; len:size_t; flags:cint; tox :psockaddr; tolen: tsocklen):ssize_t;
begin
fpsendto:=cfpsendto (s,msg,len,flags,tox,tolen);
internal_socketerror:=fpgeterrno;
end;
function fpsetsockopt (s:cint; level:cint; optname:cint; optval:pointer; optlen :tsocklen):cint;
begin
fpsetsockopt:=cfpsetsockopt(s,level,optname,optval,optlen);
internal_socketerror:=fpgeterrno;
end;
function fpshutdown (s:cint; how:cint):cint;
begin
fpshutdown:=cfpshutdown(s,how);
internal_socketerror:=fpgeterrno;
end;
function fpsocket (domain:cint; xtype:cint; protocol: cint):cint;
begin
fpsocket:=cfpsocket(domain,xtype,protocol);
internal_socketerror:=fpgeterrno;
end;
function fpsocketpair (d:cint; xtype:cint; protocol:cint; sv:pcint):cint;
begin
{
fpsocketpair:=cfpsocketpair(d,xtype,protocol,sv);
internal_socketerror:=fpgeterrno;
}
fpsocketpair:=-1;
end;
{$i sockovl.inc}
{$i sockets.inc}
// FIXME: this doesn't make any sense here, because SocketBase should be task-specific
// but FPC doesn't support that yet (TODO)
{$WARNING FIX ME, TODO}
initialization
SocketBase:=NIL;
SocketBase:=OpenLibrary('bsdsocket.library',4);
finalization
if (SocketBase<>NIL) then CloseLibrary(SocketBase);
end.

2
rtl/amicommon/athreads.pp
View File

@ -460,7 +460,9 @@ begin
if not exitSuspend then
begin
InitThread(threadInfo^.stackLen);
DoThreadInitProcChain;
threadInfo^.exitCode:=Pointer(threadInfo^.f(threadInfo^.p));
DoThreadExitProcChain;
DoneThread;
end;

63
rtl/amicommon/sysos.inc
View File

@ -172,3 +172,66 @@ begin
end;
end;
end;
{ Thread Init/Exit Procedure support }
Type
PThreadProcInfo = ^TThreadProcInfo;
TThreadProcInfo = Record
Next : PThreadProcInfo;
Proc : TProcedure;
End;
const
threadInitProcList :PThreadProcInfo = nil;
threadExitProcList :PThreadProcInfo = nil;
Procedure DoThreadProcChain(p: PThreadProcInfo);
Begin
while p <> nil do
begin
p^.proc;
p:=p^.next;
end;
End;
Procedure AddThreadProc(var procList: PThreadProcInfo; Proc: TProcedure);
var
P : PThreadProcInfo;
Begin
New(P);
P^.Next:=procList;
P^.Proc:=Proc;
procList:=P;
End;
Procedure CleanupThreadProcChain(var procList: PThreadProcInfo);
var
P : PThreadProcInfo;
Begin
while procList <> nil do
begin
p:=procList;
procList:=procList^.next;
dispose(p);
end;
End;
Procedure AddThreadInitProc(Proc: TProcedure);
Begin
AddThreadProc(threadInitProcList,Proc);
End;
Procedure AddThreadExitProc(Proc: TProcedure);
Begin
AddThreadProc(threadExitProcList,Proc);
End;
Procedure DoThreadInitProcChain;
Begin
DoThreadProcChain(threadInitProcList);
End;
Procedure DoThreadExitProcChain;
Begin
DoThreadProcChain(threadExitProcList);
End;

6
rtl/amicommon/sysosh.inc
View File

@ -39,3 +39,9 @@ type
const
CREATE_SUSPENDED = 1;
STACK_SIZE_PARAM_IS_A_RESERVATION = 2;
{ Thread Init/Exit Procedure support }
Procedure AddThreadInitProc(Proc: TProcedure);
Procedure AddThreadExitProc(Proc: TProcedure);
Procedure DoThreadInitProcChain;
Procedure DoThreadExitProcChain;

4
rtl/amiga/system.pp
View File

@ -141,6 +141,10 @@ procedure System_exit;
var
oldDirLock: LongInt;
begin
{ Dispose the thread init/exit chains }
CleanupThreadProcChain(threadInitProcList);
CleanupThreadProcChain(threadExitProcList);
{ We must remove the CTRL-C FLAG here because halt }
{ may call I/O routines, which in turn might call }
{ halt, so a recursive stack crash }

4
rtl/morphos/system.pp
View File

@ -99,6 +99,10 @@ procedure System_exit;
var
oldDirLock: LongInt;
begin
{ Dispose the thread init/exit chains }
CleanupThreadProcChain(threadInitProcList);
CleanupThreadProcChain(threadExitProcList);
{ We must remove the CTRL-C FLAG here because halt }
{ may call I/O routines, which in turn might call }
{ halt, so a recursive stack crash }

2
utils/fpcres/fpmake.pp
View File

@ -27,7 +27,7 @@ begin
P.Directory:=ADirectory;
P.Version:='3.0.1';
P.OSes:=[win32,win64,wince,haiku,linux,freebsd,openbsd,netbsd,darwin,iphonesim,solaris,os2,emx,aix,aros];
P.OSes:=[win32,win64,wince,haiku,linux,freebsd,openbsd,netbsd,darwin,iphonesim,solaris,os2,emx,aix,aros,amiga,morphos];
P.Dependencies.Add('fcl-res');
P.Dependencies.Add('paszlib');