paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-13 20:29:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

Merged revisions 2282,2290,2292-2295,2297,2299,2302,2304 via svnmerge from

Browse Source 
http://peter@svn.freepascal.org/svn/fpc/trunk

........
r2282 | florian | 2006-01-14 13:55:26 +0100 (Sat, 14 Jan 2006) | 2 lines

* cleanup

........
r2290 | marco | 2006-01-15 01:08:15 +0100 (Sun, 15 Jan 2006) | 2 lines

 * .size stuff for GOT

........
r2292 | marco | 2006-01-15 13:00:49 +0100 (Sun, 15 Jan 2006) | 2 lines

 * picified syscall code

........
r2293 | vincents | 2006-01-15 15:12:42 +0100 (Sun, 15 Jan 2006) | 1 line

write pointer values using 16 hexadecimal digits on 64 bits platforms
........
r2294 | marco | 2006-01-15 15:33:30 +0100 (Sun, 15 Jan 2006) | 2 lines

 * some patches related to shared linking + some AMD64 checks.

........
r2295 | marco | 2006-01-15 15:56:20 +0100 (Sun, 15 Jan 2006) | 2 lines

 * more "shared" fixes

........
r2297 | marco | 2006-01-15 16:22:29 +0100 (Sun, 15 Jan 2006) | 2 lines

 * shared lib i_ and t_ changes. Some small comments cleanup to t_

........
r2299 | peter | 2006-01-15 20:36:56 +0100 (Sun, 15 Jan 2006) | 2 lines

  * remove $ifdef WINDOWS which was broken for fpc

........
r2302 | olle | 2006-01-15 22:55:07 +0100 (Sun, 15 Jan 2006) | 1 line

added test cases for comming macpas features
........
r2304 | peter | 2006-01-16 11:48:21 +0100 (Mon, 16 Jan 2006) | 2 lines

  * support section names with length > 8

........

git-svn-id: branches/fixes_2_0@2456 -
This commit is contained in:
peter 2006-02-06 08:51:13 +00:00
parent 52d043f7a6
commit 495ffec968
13 changed files with 248 additions and 218 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -5346,6 +5346,9 @@ tests/test/tintuint.pp svneol=native#text/plain
tests/test/tlibrary1.pp svneol=native#text/plain tests/test/tlibrary1.pp svneol=native#text/plain
tests/test/tlibrary2.pp svneol=native#text/plain tests/test/tlibrary2.pp svneol=native#text/plain
tests/test/tmacfunret.pp svneol=native#text/plain tests/test/tmacfunret.pp svneol=native#text/plain
tests/test/tmaclocalprocparam.pp svneol=native#text/plain
tests/test/tmacnonlocalexit.pp svneol=native#text/plain
tests/test/tmacnonlocalgoto.pp svneol=native#text/plain
tests/test/tmacpas1.pp svneol=native#text/plain tests/test/tmacpas1.pp svneol=native#text/plain
tests/test/tmacpas2.pp svneol=native#text/plain tests/test/tmacpas2.pp svneol=native#text/plain
tests/test/tmacpas3.pp svneol=native#text/plain tests/test/tmacpas3.pp svneol=native#text/plain

27
compiler/ogcoff.pas
View File

@ -168,7 +168,7 @@ implementation
uses uses
strings, strings,
cutils,verbose, cutils,verbose,
globals,fmodule; globals,fmodule,aasmtai;
const const
COFF_FLAG_NORELOCS = $0001; COFF_FLAG_NORELOCS = $0001;
@ -563,9 +563,15 @@ const go32v2stub : array[0..2047] of byte=(
'.debug_frame', '.debug_frame',
'.fpc' '.fpc'
); );
var
secname : string;
begin begin
{ No support for named sections, because section names are limited to 8 chars } secname:=secnames[atype];
result:=secnames[atype]; if use_smartlink_section and
(aname<>'') then
result:=secname+'$'+aname
else
result:=secname;
end; end;
@ -936,9 +942,9 @@ const go32v2stub : array[0..2047] of byte=(
procedure tcoffobjectoutput.write_symbols(data:TAsmObjectData); procedure tcoffobjectoutput.write_symbols(data:TAsmObjectData);
var var
filename : string[18]; filename : string[18];
value : longint;
sectionval, sectionval,
globalval : byte; globalval,
value : longint;
p : tasmsymbol; p : tasmsymbol;
begin begin
with tcoffobjectdata(data) do with tcoffobjectdata(data) do
@ -1004,12 +1010,17 @@ const go32v2stub : array[0..2047] of byte=(
var var
sechdr : coffsechdr; sechdr : coffsechdr;
s : string; s : string;
strpos : longint;
begin begin
fillchar(sechdr,sizeof(sechdr),0); fillchar(sechdr,sizeof(sechdr),0);
s:=tasmsection(p).name; s:=tasmsection(p).name;
{ section names are limited to 8 chars }
if length(s)>8 then if length(s)>8 then
internalerror(200403312); begin
strpos:=FCoffStrs.size+4;
FCoffStrs.writestr(s);
FCoffStrs.writestr(#0);
s:='/'+ToStr(strpos);
end;
move(s[1],sechdr.name,length(s)); move(s[1],sechdr.name,length(s));
if not win32 then if not win32 then
begin begin
@ -1764,7 +1775,7 @@ const go32v2stub : array[0..2047] of byte=(
asmbin : ''; asmbin : '';
asmcmd : ''; asmcmd : '';
supported_target : system_i386_win32; supported_target : system_i386_win32;
flags : [af_outputbinary]; flags : [af_outputbinary,af_smartlink_sections];
labelprefix : '.L'; labelprefix : '.L';
comment : ''; comment : '';
); );

151
packages/extra/unzip/unzip.pp
View File

@ -65,21 +65,9 @@ INTERFACE
{$R-} {No range checking} {$R-} {No range checking}
USES USES
{$ifdef windows} strings,
wintypes, dos,
winprocs, ziptypes;
{$ifdef Delphi}
Messages,
Sysutils,
{$else Delphi}
strings,
windos,
{$endif Delphi}
{$else Windows}
strings,
dos,
{$endif Windows}
ziptypes;
{**********************************************************************} {**********************************************************************}
{**********************************************************************} {**********************************************************************}
@ -89,8 +77,6 @@ ziptypes;
FUNCTION FileUnzip FUNCTION FileUnzip
( SourceZipFile, TargetDirectory, FileSpecs : pChar; ( SourceZipFile, TargetDirectory, FileSpecs : pChar;
Report : UnzipReportProc;Question : UnzipQuestionProc ) : integer; Report : UnzipReportProc;Question : UnzipQuestionProc ) : integer;
{$ifdef Windows}{$ifdef Win32}STDCALL;{$else}EXPORT;{$endif Win32}{$endif Windows}
{$ifdef DPMI} EXPORT; {$endif DPMI}
{ {
high level unzip high level unzip
@ -110,8 +96,6 @@ e.g.,
} }
FUNCTION FileUnzipEx ( SourceZipFile, TargetDirectory, FileSpecs : pChar ) : integer; FUNCTION FileUnzipEx ( SourceZipFile, TargetDirectory, FileSpecs : pChar ) : integer;
{$ifdef Windows}{$ifdef Win32}STDCALL;{$else}EXPORT;{$endif Win32}{$endif Windows}
{$ifdef DPMI} EXPORT; {$endif DPMI}
{ {
high level unzip with no callback parameters; high level unzip with no callback parameters;
passes ZipReport & ZipQuestion internally, so you passes ZipReport & ZipQuestion internally, so you
@ -122,8 +106,6 @@ e.g.,
} }
FUNCTION ViewZip ( SourceZipFile, FileSpecs : pChar; Report : UnzipReportProc ) : integer; FUNCTION ViewZip ( SourceZipFile, FileSpecs : pChar; Report : UnzipReportProc ) : integer;
{$ifdef Windows}{$ifdef Win32}STDCALL;{$else}EXPORT;{$endif Win32}{$endif Windows}
{$ifdef DPMI} EXPORT; {$endif DPMI}
{ {
view contents of zip file view contents of zip file
usage: usage:
@ -138,8 +120,6 @@ e.g.,
} }
FUNCTION SetUnZipReportProc ( aProc : UnzipReportProc ) : Pointer; FUNCTION SetUnZipReportProc ( aProc : UnzipReportProc ) : Pointer;
{$ifdef Windows}{$ifdef Win32}STDCALL;{$else}EXPORT;{$endif Win32}{$endif Windows}
{$ifdef DPMI} EXPORT; {$endif DPMI}
{ {
sets the internal unzip report procedure to aproc sets the internal unzip report procedure to aproc
Returns: pointer to the original report procedure Returns: pointer to the original report procedure
@ -150,8 +130,6 @@ e.g.,
} }
FUNCTION SetUnZipQuestionProc ( aProc : UnzipQuestionProc ) : Pointer; FUNCTION SetUnZipQuestionProc ( aProc : UnzipQuestionProc ) : Pointer;
{$ifdef Windows}{$ifdef Win32}STDCALL;{$else}EXPORT;{$endif Win32}{$endif Windows}
{$ifdef DPMI} EXPORT; {$endif DPMI}
{ {
sets the internal unzip question procedure to aproc sets the internal unzip question procedure to aproc
Returns: pointer to the original "question" procedure Returns: pointer to the original "question" procedure
@ -162,8 +140,6 @@ SetUnZipQuestionProc(QueryFileExistProc);
} }
FUNCTION UnzipSize ( SourceZipFile : pChar;VAR Compressed : Longint ) : longint; FUNCTION UnzipSize ( SourceZipFile : pChar;VAR Compressed : Longint ) : longint;
{$ifdef Windows}{$ifdef Win32}STDCALL;{$else}EXPORT;{$endif Win32}{$endif Windows}
{$ifdef DPMI} EXPORT; {$endif DPMI}
{ uncompressed and compressed zip size { uncompressed and compressed zip size
usage: usage:
SourceZipFile = the zip file SourceZipFile = the zip file
@ -179,15 +155,11 @@ e.g.,
} }
PROCEDURE ChfUnzip_Init; PROCEDURE ChfUnzip_Init;
{$ifdef Windows}{$ifdef Win32}STDCALL;{$else}EXPORT;{$endif Win32}{$endif Windows}
{$ifdef DPMI} EXPORT; {$endif DPMI}
{ {
initialise or reinitialise the shared data: !!! use with care !!! initialise or reinitialise the shared data: !!! use with care !!!
} }
FUNCTION SetNoRecurseDirs ( DontRecurse : Boolean ) : Boolean; FUNCTION SetNoRecurseDirs ( DontRecurse : Boolean ) : Boolean;
{$ifdef Windows}{$ifdef Win32}STDCALL;{$else}EXPORT;{$endif Win32}{$endif Windows}
{$ifdef DPMI} EXPORT; {$endif DPMI}
{ {
determine whether the UNZIP function should recreate determine whether the UNZIP function should recreate
the subdirectory structure; the subdirectory structure;
@ -201,14 +173,10 @@ the subdirectory structure;
{**********************************************************************} {**********************************************************************}
{**********************************************************************} {**********************************************************************}
FUNCTION GetSupportedMethods : longint; FUNCTION GetSupportedMethods : longint;
{$ifdef Windows}{$ifdef Win32}STDCALL;{$else}EXPORT;{$endif Win32}{$endif Windows}
{$ifdef DPMI} EXPORT; {$endif DPMI}
{Checks which pack methods are supported by the dll} {Checks which pack methods are supported by the dll}
{bit 8=1 -> Format 8 supported, etc.} {bit 8=1 -> Format 8 supported, etc.}
FUNCTION UnzipFile ( in_name : pchar;out_name : pchar;offset : longint;hFileAction : word;cm_index : integer ) : integer; FUNCTION UnzipFile ( in_name : pchar;out_name : pchar;offset : longint;hFileAction : word;cm_index : integer ) : integer;
{$ifdef Windows}{$ifdef Win32}STDCALL;{$else}EXPORT;{$endif Win32}{$endif Windows}
{$ifdef DPMI} EXPORT; {$endif DPMI}
{usage: {usage:
in_name: name of zip file with full path in_name: name of zip file with full path
out_name: desired name for out file out_name: desired name for out file
@ -244,8 +212,6 @@ FUNCTION UnzipFile ( in_name : pchar;out_name : pchar;offset : longint;hFileActi
} }
FUNCTION GetFirstInZip ( zipfilename : pchar;VAR zprec : tZipRec ) : integer; FUNCTION GetFirstInZip ( zipfilename : pchar;VAR zprec : tZipRec ) : integer;
{$ifdef Windows}{$ifdef Win32}STDCALL;{$else}EXPORT;{$endif Win32}{$endif Windows}
{$ifdef DPMI} EXPORT; {$endif DPMI}
{ {
Get first entry from ZIP file Get first entry from ZIP file
e.g., e.g.,
@ -253,8 +219,6 @@ FUNCTION GetFirstInZip ( zipfilename : pchar;VAR zprec : tZipRec ) : integer;
} }
FUNCTION GetNextInZip ( VAR Zprec : tZiprec ) : integer; FUNCTION GetNextInZip ( VAR Zprec : tZiprec ) : integer;
{$ifdef Windows}{$ifdef Win32}STDCALL;{$else}EXPORT;{$endif Win32}{$endif Windows}
{$ifdef DPMI} EXPORT; {$endif DPMI}
{ {
Get next entry from ZIP file Get next entry from ZIP file
@ -263,8 +227,6 @@ FUNCTION GetNextInZip ( VAR Zprec : tZiprec ) : integer;
} }
FUNCTION IsZip ( filename : pchar ) : boolean; FUNCTION IsZip ( filename : pchar ) : boolean;
{$ifdef Windows}{$ifdef Win32}STDCALL;{$else}EXPORT;{$endif Win32}{$endif Windows}
{$ifdef DPMI} EXPORT; {$endif DPMI}
{ {
VERY simple test for zip file VERY simple test for zip file
@ -273,8 +235,6 @@ FUNCTION IsZip ( filename : pchar ) : boolean;
} }
PROCEDURE CloseZipFile ( VAR Zprec : tZiprec ); {Only free buffer, file only open in Getfirstinzip} PROCEDURE CloseZipFile ( VAR Zprec : tZiprec ); {Only free buffer, file only open in Getfirstinzip}
{$ifdef Windows}{$ifdef Win32}STDCALL;{$else}EXPORT;{$endif Win32}{$endif Windows}
{$ifdef DPMI} EXPORT; {$endif DPMI}
{ {
free ZIP buffers free ZIP buffers
@ -384,10 +344,6 @@ TYPE
VAR slide : pchar; {Sliding dictionary for unzipping} VAR slide : pchar; {Sliding dictionary for unzipping}
inbuf : iobuf; {input buffer} inbuf : iobuf; {input buffer}
inpos, readpos : integer; {position in input buffer, position read from file} inpos, readpos : integer; {position in input buffer, position read from file}
{$ifdef windows}
dlghandle : word; {optional: handle of a cancel and "%-done"-dialog}
dlgnotify : integer; {notification code to tell dialog how far the decompression is}
{$endif}
VAR w : longint; {Current Position in slide} VAR w : longint; {Current Position in slide}
b : longint; {Bit Buffer} b : longint; {Bit Buffer}
@ -402,10 +358,6 @@ VAR w : longint; {Current Position in slide}
totalabort, {User pressed abort button, set in showpercent!} totalabort, {User pressed abort button, set in showpercent!}
zipeof : boolean; {read over end of zip section for this file} zipeof : boolean; {read over end of zip section for this file}
inuse : boolean; {is unit already in use -> don't call it again!!!} inuse : boolean; {is unit already in use -> don't call it again!!!}
{$ifdef windows}
oldpercent : integer; {last percent value shown}
lastusedtime : longint; {Time of last usage in timer ticks for timeout!}
{$endif}
(***************************************************************************) (***************************************************************************)
{.$I z_tables.pas} {Tables for bit masking, huffman codes and CRC checking} {.$I z_tables.pas} {Tables for bit masking, huffman codes and CRC checking}
@ -574,38 +526,6 @@ BEGIN
{$endif} {$endif}
END; END;
{************************* tell dialog to show % ******************************}
{$ifdef windows}
PROCEDURE messageloop;
VAR msg : tmsg;
BEGIN
lastusedtime := gettickcount;
WHILE PeekMessage ( Msg, 0, 0, 0, PM_Remove ) DO
IF ( dlghandle = 0 ) OR NOT IsDialogMessage ( dlghandle, msg ) THEN BEGIN
TranslateMessage ( Msg );
DispatchMessage ( Msg );
END;
END;
PROCEDURE showpercent; {use this with the low level functions only !!!}
VAR percent : word;
BEGIN
IF compsize <> 0 THEN BEGIN
percent := reachedsize * 100 DIV compsize;
IF percent > 100 THEN percent := 100;
IF ( percent <> oldpercent ) THEN BEGIN
oldpercent := percent;
IF dlghandle <> 0 THEN BEGIN {Use dialog box for aborting}
{Sendmessage returns directly -> ppercent contains result}
sendmessage ( dlghandle, wm_command, dlgnotify, longint ( @percent ) );
totalabort := ( percent = $FFFF ); {Abort pressed!}
END ELSE
IF dlgnotify <> 0 THEN
totalabort := getasynckeystate ( dlgnotify ) < 0; {break Key pressed!}
END;
END;
END;
{$endif}
{************************** fill inbuf from infile *********************} {************************** fill inbuf from infile *********************}
PROCEDURE readbuf; PROCEDURE readbuf;
@ -614,10 +534,6 @@ BEGIN
readpos := sizeof ( inbuf ); {Simulates reading -> no blocking} readpos := sizeof ( inbuf ); {Simulates reading -> no blocking}
zipeof := TRUE zipeof := TRUE
END ELSE BEGIN END ELSE BEGIN
{$ifdef windows}
messageloop; {Other programs, or in DOS: keypressed?}
showpercent; {Before, because it shows the data processed, not read!}
{$endif}
{$I-} {$I-}
blockread ( infile, inbuf, sizeof ( inbuf ), readpos ); blockread ( infile, inbuf, sizeof ( inbuf ), readpos );
{$I+} {$I+}
@ -1422,10 +1338,6 @@ BEGIN
exit exit
END; END;
inc ( reachedsize, outcnt ); inc ( reachedsize, outcnt );
{$ifdef windows}
messageloop; {Other programs, or in DOS: keypressed?}
showpercent;
{$endif}
END; END;
IF NOT totalabort THEN IF NOT totalabort THEN
copystored := unzip_Ok copystored := unzip_Ok
@ -2326,22 +2238,6 @@ VAR err : integer;
oldcurdir : string [ 80 ]; oldcurdir : string [ 80 ];
BEGIN BEGIN
{$ifdef windows}
IF inuse THEN BEGIN
{take care of crashed applications!}
IF ( lastusedtime <> 0 ) AND
( abs ( gettickcount -lastusedtime ) > 30000 ) THEN BEGIN {1/2 minute timeout!!!}
{do not close files or free slide, they were already freed when application crashed!}
inuse := FALSE;
{memory for huffman trees is lost}
END ELSE BEGIN
unzipfile := unzip_inuse;
exit
END;
END;{inuse}
inuse := TRUE;
{$endif}
getmem ( slide, wsize ); getmem ( slide, wsize );
fillchar ( slide [ 0 ], wsize, #0 ); fillchar ( slide [ 0 ], wsize, #0 );
assign ( infile, in_name ); assign ( infile, in_name );
@ -2439,44 +2335,23 @@ BEGIN
IF ( p <> NIL ) AND ( p [ 1 ] = ':' ) THEN BEGIN IF ( p <> NIL ) AND ( p [ 1 ] = ':' ) THEN BEGIN
strcopy ( buf0, 'c:\' ); {set drive} strcopy ( buf0, 'c:\' ); {set drive}
buf0 [ 0 ] := p [ 0 ]; buf0 [ 0 ] := p [ 0 ];
{$ifdef windows}
setcurdir ( buf0 );
{$else}
{$I-} {$I-}
chdir ( buf0 ); chdir ( buf0 );
{$I+} {$I+}
err := ioresult; err := ioresult;
{$endif}
p := strtok ( NIL, '\' ); p := strtok ( NIL, '\' );
END; END;
{$endif} {$endif}
WHILE ( p <> NIL ) AND ( p <> p1 ) DO BEGIN WHILE ( p <> NIL ) AND ( p <> p1 ) DO BEGIN
{$ifdef windows}
{$ifdef Delphi}
{$I-}
chdir ( strpas ( p ) );
{$I+}
err := ioresult;
{$else Delphi}
setcurdir ( p );
err := doserror;
{$endif Delphi}
{$else Windows}
{$I-} {$I-}
chdir ( strpas ( p ) ); chdir ( strpas ( p ) );
{$I+} {$I+}
err := ioresult; err := ioresult;
{$endif}
IF err <> 0 THEN BEGIN IF err <> 0 THEN BEGIN
{$ifdef windows}
createdir ( p );
err := doserror;
{$else}
{$I-} {$I-}
mkdir ( strpas ( p ) ); mkdir ( strpas ( p ) );
{$I+} {$I+}
err := ioresult; err := ioresult;
{$endif}
IF err = 0 THEN IF err = 0 THEN
{$I-} {$I-}
chdir ( strpas ( p ) ); chdir ( strpas ( p ) );
@ -2516,13 +2391,6 @@ BEGIN
totalabort := FALSE; totalabort := FALSE;
zipeof := FALSE; zipeof := FALSE;
{$ifdef windows}
dlghandle := hFileAction;
dlgnotify := cm_index;
messageloop;
oldpercent := 0;
{$endif}
crc32val := $FFFFFFFF; crc32val := $FFFFFFFF;
{Unzip correct type} {Unzip correct type}
@ -2555,11 +2423,6 @@ BEGIN
unzipfile := unzip_CRCErr; unzipfile := unzip_CRCErr;
erase ( outfile ); erase ( outfile );
END ELSE BEGIN END ELSE BEGIN
{$ifdef windows}
oldpercent := 100; {100 percent}
IF dlghandle <> 0 THEN
sendmessage ( dlghandle, wm_command, dlgnotify, longint ( @oldpercent ) );
{$endif}
filemode := 2; filemode := 2;
reset ( outfile ); reset ( outfile );
filemode := storefilemode; filemode := storefilemode;
@ -2953,13 +2816,11 @@ END;
{$endif Delphi} {$endif Delphi}
PROCEDURE DummyReport ( Retcode : longint;Rec : pReportRec ); PROCEDURE DummyReport ( Retcode : longint;Rec : pReportRec );
{$ifdef Windows}{$ifdef win32}STDCALL;{$else}EXPORT;{$endif}{$endif}
{dummy report procedure} {dummy report procedure}
BEGIN BEGIN
END; END;
FUNCTION DummyQuestion( Rec : pReportRec ) : Boolean; FUNCTION DummyQuestion( Rec : pReportRec ) : Boolean;
{$ifdef Windows}{$ifdef win32}STDCALL;{$else}EXPORT;{$endif}{$endif}
{dummy question procedure} {dummy question procedure}
begin begin
DummyQuestion:=true; DummyQuestion:=true;
@ -3106,7 +2967,7 @@ BEGIN
END; END;
END ELSE BEGIN END ELSE BEGIN
rc := unzipfile ( thename, buf, r.headeroffset, 0, rc := unzipfile ( thename, buf, r.headeroffset, 0,
{$ifdef windows}vk_escape{$else}27{$endif} ); {Escape interrupts} 27 ); {Escape interrupts}
END; END;
IF rc = unzip_ok IF rc = unzip_ok
@ -3303,10 +3164,6 @@ END; { SetNoRecurseDirs }
PROCEDURE ChfUnzip_Init; PROCEDURE ChfUnzip_Init;
BEGIN BEGIN
slide := NIL; {unused} slide := NIL; {unused}
{$ifdef windows}
inuse := FALSE; {Not yet in use!}
lastusedtime := 0; {Not yet used}
{$endif}
if inuse then; { to remove warning } if inuse then; { to remove warning }
SetUnZipReportProc ( NIL ); SetUnZipReportProc ( NIL );
SetUnZipQuestionProc ( NIL ); SetUnZipQuestionProc ( NIL );

47
rtl/bsd/i386/syscall.inc
View File

@ -31,44 +31,43 @@ These functions are the same over all three BSDs, except that some have a
{$DEFINE ErrnoWord} {$DEFINE ErrnoWord}
{$endif} {$endif}
Procedure fpc_geteipasebx;[external name 'fpc_geteipasebx'];
procedure actualsyscall; assembler; {inline requires a dummy push IIRC} procedure actualsyscall; assembler; {inline requires a dummy push IIRC}
asm asm
int $0x80 int $0x80
jb .LErrorcode jb .LErrorcode
ret ret
.LErrorcode: .LErrorcode:
{$ifdef REGCALL} {$ifdef FPC_PIC}
call fpc_geteipasebx
addl $_GLOBAL_OFFSET_TABLE_,%ebx
movl fpc_threadvar_relocate_proc@GOT(%ebx),%ecx
movl (%ecx),%ecx
movl Errno@GOT(%ebx),%edi
{$else FPC_PIC}
leal Errno,%edi
movl fpc_threadvar_relocate_proc,%ecx movl fpc_threadvar_relocate_proc,%ecx
{$endif FPC_PIC}
testl %ecx,%ecx testl %ecx,%ecx
jne .LThread jne .LThread
movl %eax,Errno+4 {$ifdef ErrnoWord}
movw %ax,4(%edi)
{$else}
movl %eax,4(%edi)
{$endif}
jmp .LNoThread jmp .LNoThread
.LThread: .LThread:
movl %eax,%ebx movl %eax,%ebx
movl Errno,%eax movl (%edi),%eax
call *%ecx call *%ecx
movl %ebx,(%eax) {$ifdef ErrnoWord}
movw %bx,4(%eax)
{$else}
movl %ebx,4(%eax)
{$endif}
.LNoThread: .LNoThread:
{$else} movl $-1,%eax
movl %eax,%edx
movl fpc_threadvar_relocate_proc,%eax
testl %eax,%eax
jne .LThread
movl %edx,Errno+4
jmp .LNoThread
.LThread:
pushl %edx
pushl Errno
call *%eax
popl %edx
{$ifdef ErrnoWord}
movw %dx,(%eax)
{$else}
movl %edx,(%eax)
{$endif}
.LNoThread:
{$endif REGCALL}
mov $-1,%eax
end; end;
function FpSysCall(sysnr:TSysParam):TSysResult; oldfpccall; assembler; [public,alias:'FPC_DOSYS0']; function FpSysCall(sysnr:TSysParam):TSysResult; oldfpccall; assembler; [public,alias:'FPC_DOSYS0'];

30
rtl/freebsd/i386/cprt0.as
View File

@ -32,15 +32,18 @@ abitag:
.section .rodata.str1.1,"aMS",@progbits,1 .section .rodata.str1.1,"aMS",@progbits,1
.LC0: .LC0:
.string "" .string ""
.globl __progname
.data .data
.p2align 2 .p2align 2
.globl __progname
.type __progname,@object .type __progname,@object
.size __progname,4 .size __progname,4
__progname: __progname:
.long .LC0 .long .LC0
.text .text
.p2align 2,,3 .p2align 2,,3
.type __fpucw,@object
.size __fpucw,4
.global __fpucw
___fpucw: ___fpucw:
.long 0x1332 .long 0x1332
.globl ___fpc_brk_addr /* heap management */ .globl ___fpc_brk_addr /* heap management */
@ -165,8 +168,25 @@ get_rtld_cleanup:
.weak _DYNAMIC .weak _DYNAMIC
.ident "GCC: (GNU) 3.4.2 - FPC: 2.0.2" .ident "GCC: (GNU) 3.4.2 - FPC: 2.0.2"
.bss .bss
.comm operatingsystem_parameter_envp,4 .type __stkptr,@object
.comm operatingsystem_parameter_argc,4 .size __stkptr,4
.comm operatingsystem_parameter_argv,4 .global __stkptr
__stkptr:
.skip 4
.type operatingsystem_parameters,@object
.size operatingsystem_parameters,12
operatingsystem_parameters:
.skip 3*4
.global operatingsystem_parameter_envp
.global operatingsystem_parameter_argc
.global operatingsystem_parameter_argv
.set operatingsystem_parameter_envp,operatingsystem_parameters+0
.set operatingsystem_parameter_argc,operatingsystem_parameters+4
.set operatingsystem_parameter_argv,operatingsystem_parameters+8
//.section .threadvar,"aw",@nobits
.comm ___fpc_threadvar_offset,4

31
rtl/freebsd/i386/prt0.as
View File

@ -20,17 +20,20 @@
.file "prt1.as" .file "prt1.as"
.version "01.01" .version "01.01"
gcc2_compiled.: gcc2_compiled.:
.globl __progname
.section .rodata .section .rodata
.LC0: .LC0:
.ascii "\0" .ascii "\0"
.data .data
.p2align 2 .p2align 2
.globl __progname
.type __progname,@object .type __progname,@object
.size __progname,4 .size __progname,4
__progname: __progname:
.long .LC0 .long .LC0
.align 4 .align 4
.type __fpucw,@object
.size __fpucw,4
.global __fpucw
___fpucw: ___fpucw:
.long 0x1332 .long 0x1332
@ -40,7 +43,6 @@ ___fpucw:
___fpc_brk_addr: ___fpc_brk_addr:
.long 0 .long 0
.text .text
.p2align 2 .p2align 2
.globl _start .globl _start
@ -123,8 +125,25 @@ _actualsyscall:
.weak _DYNAMIC .weak _DYNAMIC
.ident "GCC: (GNU) 2.7.2.1" .ident "GCC: (GNU) 2.7.2.1"
.bss .bss
.comm operatingsystem_parameter_envp,4 .type __stkptr,@object
.comm operatingsystem_parameter_argc,4 .size __stkptr,4
.comm operatingsystem_parameter_argv,4 .global __stkptr
__stkptr:
.skip 4
.type operatingsystem_parameters,@object
.size operatingsystem_parameters,12
operatingsystem_parameters:
.skip 3*4
.global operatingsystem_parameter_envp
.global operatingsystem_parameter_argc
.global operatingsystem_parameter_argv
.set operatingsystem_parameter_envp,operatingsystem_parameters+0
.set operatingsystem_parameter_argc,operatingsystem_parameters+4
.set operatingsystem_parameter_argv,operatingsystem_parameters+8
//.section .threadvar,"aw",@nobits
.comm ___fpc_threadvar_offset,4

28
rtl/freebsd/ptypes.inc
View File

@ -32,7 +32,11 @@ type
TGid = gid_t; TGid = gid_t;
pGid = ^gid_t; pGid = ^gid_t;
ino_t = clong; { used for file serial numbers } {$ifdef CPU64}
ino_t = cuint32; { used for file serial numbers }
{$else}
ino_t = clong; { used for file serial numbers }
{$endif}
TIno = ino_t; TIno = ino_t;
pIno = ^ino_t; pIno = ^ino_t;
@ -148,9 +152,12 @@ type
Const Const
MNAMLEN = 80; // slightly machine specific. MNAMLEN = 80; // slightly machine specific.
MFSNamLen = 16;
type type
fsid_t = array[0..1] of cint;
// Kernel statfs
TStatfs = packed record TStatfs = packed record
spare2, { place holder} spare2, { place holder}
@ -161,13 +168,13 @@ type
bavail, { block available for mortal users} bavail, { block available for mortal users}
files, { Total file nodes} files, { Total file nodes}
ffree : clong ; { file nodes free} ffree : clong ; { file nodes free}
fsid : array[0..1] of longint; // fsid_t fsid : fsid_t;
fowner : tuid; {mounter uid} fowner : tuid; {mounter uid}
ftype : cint; ftype : cint;
fflags : cint; {copy of mount flags} fflags : cint; {copy of mount flags}
fsyncwrites, fsyncwrites,
fasyncwrites : cint; fasyncwrites : clong;
fstypename : array[0..15] of char; fstypename : array[0..MFSNamLen-1] of char;
mountpoint : array[0..MNAMLEN-1] of char; mountpoint : array[0..MNAMLEN-1] of char;
fsyncreads, { count of sync reads since mount } fsyncreads, { count of sync reads since mount }
fasyncreads : clong; fasyncreads : clong;
@ -183,7 +190,6 @@ type
It_Value : TimeVal; It_Value : TimeVal;
end; end;
const const
_PTHREAD_MUTEX_DEFAULT = _PTHREAD_MUTEX_ERRORCHECK; _PTHREAD_MUTEX_DEFAULT = _PTHREAD_MUTEX_ERRORCHECK;
_MUTEX_TYPE_FAST = _PTHREAD_MUTEX_NORMAL; _MUTEX_TYPE_FAST = _PTHREAD_MUTEX_NORMAL;
@ -193,14 +199,18 @@ const
_PTHREAD_STACK_MIN = 1024; _PTHREAD_STACK_MIN = 1024;
{ System limits, POSIX value in parentheses, used for buffer and stack allocation } { System limits, POSIX value in parentheses, used for buffer and stack allocation }
{$ifdef CPU64}
ARG_MAX = 262144; {4096} { Maximum number of argument size }
{$else}
ARG_MAX = 65536; {4096} { Maximum number of argument size } ARG_MAX = 65536; {4096} { Maximum number of argument size }
{$endif}
NAME_MAX = 255; {14} { Maximum number of bytes in filename } NAME_MAX = 255; {14} { Maximum number of bytes in filename }
PATH_MAX = 1024; {255} { Maximum number of bytes in pathname } PATH_MAX = 1024; {255} { Maximum number of bytes in pathname }
SYS_NMLN = 32; {BSD utsname struct limit, kernel mode} SYS_NMLN = 32; {BSD utsname struct limit, kernel mode}
SIG_MAXSIG = 128; // highest signal version SIG_MAXSIG = 128; // highest signal version
// wordsinsigset = 4; // words in sigset_t // wordsinsigset = 4; // words in sigset_t
{ For getting/setting priority } { For getting/setting priority }

18
rtl/inc/heaptrc.pp
View File

@ -227,7 +227,7 @@ procedure call_stack(pp : pheap_mem_info;var ptext : text);
var var
i : ptrint; i : ptrint;
begin begin
writeln(ptext,'Call trace for block $',hexstr(ptrint(pointer(pp)+sizeof(theap_mem_info)),8),' size ',pp^.size); writeln(ptext,'Call trace for block $',hexstr(ptrint(pointer(pp)+sizeof(theap_mem_info)),2*sizeof(pointer)),' size ',pp^.size);
for i:=1 to tracesize do for i:=1 to tracesize do
if pp^.calls[i]<>nil then if pp^.calls[i]<>nil then
writeln(ptext,BackTraceStrFunc(pp^.calls[i])); writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
@ -243,7 +243,7 @@ procedure call_free_stack(pp : pheap_mem_info;var ptext : text);
var var
i : ptrint; i : ptrint;
begin begin
writeln(ptext,'Call trace for block at $',hexstr(ptrint(pointer(pp)+sizeof(theap_mem_info)),8),' size ',pp^.size); writeln(ptext,'Call trace for block at $',hexstr(ptrint(pointer(pp)+sizeof(theap_mem_info)),2*sizeof(pointer)),' size ',pp^.size);
for i:=1 to tracesize div 2 do for i:=1 to tracesize div 2 do
if pp^.calls[i]<>nil then if pp^.calls[i]<>nil then
writeln(ptext,BackTraceStrFunc(pp^.calls[i])); writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
@ -261,7 +261,7 @@ end;
procedure dump_already_free(p : pheap_mem_info;var ptext : text); procedure dump_already_free(p : pheap_mem_info;var ptext : text);
begin begin
Writeln(ptext,'Marked memory at $',HexStr(ptrint(pointer(p)+sizeof(theap_mem_info)),8),' released'); Writeln(ptext,'Marked memory at $',HexStr(ptrint(pointer(p)+sizeof(theap_mem_info)),2*sizeof(pointer)),' released');
call_free_stack(p,ptext); call_free_stack(p,ptext);
Writeln(ptext,'freed again at'); Writeln(ptext,'freed again at');
dump_stack(ptext,get_caller_frame(get_frame)); dump_stack(ptext,get_caller_frame(get_frame));
@ -269,7 +269,7 @@ end;
procedure dump_error(p : pheap_mem_info;var ptext : text); procedure dump_error(p : pheap_mem_info;var ptext : text);
begin begin
Writeln(ptext,'Marked memory at $',HexStr(ptrint(pointer(p)+sizeof(theap_mem_info)),8),' invalid'); Writeln(ptext,'Marked memory at $',HexStr(ptrint(pointer(p)+sizeof(theap_mem_info)),2*sizeof(pointer)),' invalid');
Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8),' instead of ',hexstr(calculate_sig(p),8)); Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8),' instead of ',hexstr(calculate_sig(p),8));
dump_stack(ptext,get_caller_frame(get_frame)); dump_stack(ptext,get_caller_frame(get_frame));
end; end;
@ -279,20 +279,20 @@ procedure dump_change_after(p : pheap_mem_info;var ptext : text);
var pp : pchar; var pp : pchar;
i : ptrint; i : ptrint;
begin begin
Writeln(ptext,'Marked memory at $',HexStr(ptrint(pointer(p)+sizeof(theap_mem_info)),8),' invalid'); Writeln(ptext,'Marked memory at $',HexStr(ptrint(pointer(p)+sizeof(theap_mem_info)),2*sizeof(pointer)),' invalid');
Writeln(ptext,'Wrong release CRC $',hexstr(p^.release_sig,8),' instead of ',hexstr(calculate_release_sig(p),8)); Writeln(ptext,'Wrong release CRC $',hexstr(p^.release_sig,8),' instead of ',hexstr(calculate_release_sig(p),8));
Writeln(ptext,'This memory was changed after call to freemem !'); Writeln(ptext,'This memory was changed after call to freemem !');
call_free_stack(p,ptext); call_free_stack(p,ptext);
pp:=pointer(p)+sizeof(theap_mem_info); pp:=pointer(p)+sizeof(theap_mem_info);
for i:=0 to p^.size-1 do for i:=0 to p^.size-1 do
if byte(pp[i])<>$F0 then if byte(pp[i])<>$F0 then
Writeln(ptext,'offset',i,':$',hexstr(i,8),'"',pp[i],'"'); Writeln(ptext,'offset',i,':$',hexstr(i,2*sizeof(pointer)),'"',pp[i],'"');
end; end;
{$endif EXTRA} {$endif EXTRA}
procedure dump_wrong_size(p : pheap_mem_info;size : ptrint;var ptext : text); procedure dump_wrong_size(p : pheap_mem_info;size : ptrint;var ptext : text);
begin begin
Writeln(ptext,'Marked memory at $',HexStr(ptrint(pointer(p)+sizeof(theap_mem_info)),8),' invalid'); Writeln(ptext,'Marked memory at $',HexStr(ptrint(pointer(p)+sizeof(theap_mem_info)),2*sizeof(pointer)),' invalid');
Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed'); Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed');
dump_stack(ptext,get_caller_frame(get_frame)); dump_stack(ptext,get_caller_frame(get_frame));
{ the check is done to be sure that the procvar is not overwritten } { the check is done to be sure that the procvar is not overwritten }
@ -869,7 +869,7 @@ begin
goto _exit goto _exit
else else
begin begin
writeln(ptext^,'pointer $',hexstr(ptrint(p),8),' points into invalid memory block'); writeln(ptext^,'pointer $',hexstr(ptrint(p),2*sizeof(pointer)),' points into invalid memory block');
dump_error(pp,ptext^); dump_error(pp,ptext^);
runerror(204); runerror(204);
end; end;
@ -881,7 +881,7 @@ begin
halt(1); halt(1);
end; end;
end; end;
writeln(ptext^,'pointer $',hexstr(ptrint(p),8),' does not point to valid memory block'); writeln(ptext^,'pointer $',hexstr(ptrint(p),2*sizeof(pointer)),' does not point to valid memory block');
runerror(204); runerror(204);
_exit: _exit:
end; end;

8
rtl/inc/objpas.inc
View File

@ -713,11 +713,3 @@
****************************************************************************} ****************************************************************************}
{$i except.inc} {$i except.inc}
{****************************************************************************
Initialize
****************************************************************************}

7
rtl/unix/cwstring.pp
View File

@ -26,7 +26,10 @@ implementation
{$linklib c} {$linklib c}
{$ifndef linux} // Linux (and maybe glibc platforms in general), have iconv in glibc. {$ifndef linux} // Linux (and maybe glibc platforms in general), have iconv in glibc.
{$linklib iconv} {$ifndef FreeBSD5}
{$linklib iconv}
{$define useiconv}
{$endif}
{$endif linux} {$endif linux}
Uses Uses
@ -38,7 +41,7 @@ Uses
initc; initc;
Const Const
{$ifdef Linux} {$ifndef useiconv}
libiconvname='c'; // is in libc under Linux. libiconvname='c'; // is in libc under Linux.
{$else} {$else}
libiconvname='iconv'; libiconvname='iconv';

43
tests/test/tmaclocalprocparam.pp Normal file
View File

@ -0,0 +1,43 @@
program tmaclocalprocparam;
{$MODE MACPAS}
var
failed: Boolean;
procedure Outside (procedure P);
begin
P;
end;
procedure Global;
var
nonlocalvar: integer;
procedure Local;
begin
nonlocalvar := 42;
end;
begin
nonlocalvar := 24;
Outside(Local);
failed := (nonlocalvar <> 42);
end;
begin
Global;
if failed then
writeln('Failed')
else
writeln('Succeded');
{$IFC UNDEFINED THINK_Pascal}
if failed then
Halt(1);
{$ENDC}
end.

35
tests/test/tmacnonlocalexit.pp Normal file
View File

@ -0,0 +1,35 @@
program tmacnonlocalexit;
{$MODE MACPAS}
var
failed: Boolean;
procedure Global;
procedure Local;
begin
Exit(Global);
failed := true;
end;
begin
Local;
failed := true;
end;
begin
failed := false;
Global;
if failed then
writeln('Failed')
else
writeln('Succeded');
{$IFC NOT UNDEFINED FPC}
if failed then
Halt(1);
{$ENDC}
end.

38
tests/test/tmacnonlocalgoto.pp Normal file
View File

@ -0,0 +1,38 @@
program tmacnonlocalgoto;
{$MODE MACPAS}
label
1;
var
failed: Boolean;
procedure Global;
procedure Local;
begin
goto 1;
failed := true;
end;
begin
Local;
failed := true;
end;
begin
failed := false;
Global;
1:
if failed then
writeln('Failed')
else
writeln('Succeded');
{$IFC NOT UNDEFINED FPC}
if failed then
Halt(1);
{$ENDC}
end.