mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-09-13 08:49:47 +02:00
Merged revisions 2282,2290,2292-2295,2297,2299,2302,2304 via svnmerge from
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
parent
52d043f7a6
commit
495ffec968
3
.gitattributes
vendored
3
.gitattributes
vendored
@ -5346,6 +5346,9 @@ tests/test/tintuint.pp svneol=native#text/plain
|
||||
tests/test/tlibrary1.pp svneol=native#text/plain
|
||||
tests/test/tlibrary2.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/tmacpas2.pp svneol=native#text/plain
|
||||
tests/test/tmacpas3.pp svneol=native#text/plain
|
||||
|
||||
@ -168,7 +168,7 @@ implementation
|
||||
uses
|
||||
strings,
|
||||
cutils,verbose,
|
||||
globals,fmodule;
|
||||
globals,fmodule,aasmtai;
|
||||
|
||||
const
|
||||
COFF_FLAG_NORELOCS = $0001;
|
||||
@ -563,9 +563,15 @@ const go32v2stub : array[0..2047] of byte=(
|
||||
'.debug_frame',
|
||||
'.fpc'
|
||||
);
|
||||
var
|
||||
secname : string;
|
||||
begin
|
||||
{ No support for named sections, because section names are limited to 8 chars }
|
||||
result:=secnames[atype];
|
||||
secname:=secnames[atype];
|
||||
if use_smartlink_section and
|
||||
(aname<>'') then
|
||||
result:=secname+'$'+aname
|
||||
else
|
||||
result:=secname;
|
||||
end;
|
||||
|
||||
|
||||
@ -936,9 +942,9 @@ const go32v2stub : array[0..2047] of byte=(
|
||||
procedure tcoffobjectoutput.write_symbols(data:TAsmObjectData);
|
||||
var
|
||||
filename : string[18];
|
||||
value : longint;
|
||||
sectionval,
|
||||
globalval : byte;
|
||||
globalval,
|
||||
value : longint;
|
||||
p : tasmsymbol;
|
||||
begin
|
||||
with tcoffobjectdata(data) do
|
||||
@ -1004,12 +1010,17 @@ const go32v2stub : array[0..2047] of byte=(
|
||||
var
|
||||
sechdr : coffsechdr;
|
||||
s : string;
|
||||
strpos : longint;
|
||||
begin
|
||||
fillchar(sechdr,sizeof(sechdr),0);
|
||||
s:=tasmsection(p).name;
|
||||
{ section names are limited to 8 chars }
|
||||
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));
|
||||
if not win32 then
|
||||
begin
|
||||
@ -1764,7 +1775,7 @@ const go32v2stub : array[0..2047] of byte=(
|
||||
asmbin : '';
|
||||
asmcmd : '';
|
||||
supported_target : system_i386_win32;
|
||||
flags : [af_outputbinary];
|
||||
flags : [af_outputbinary,af_smartlink_sections];
|
||||
labelprefix : '.L';
|
||||
comment : '';
|
||||
);
|
||||
|
||||
@ -65,21 +65,9 @@ INTERFACE
|
||||
{$R-} {No range checking}
|
||||
|
||||
USES
|
||||
{$ifdef windows}
|
||||
wintypes,
|
||||
winprocs,
|
||||
{$ifdef Delphi}
|
||||
Messages,
|
||||
Sysutils,
|
||||
{$else Delphi}
|
||||
strings,
|
||||
windos,
|
||||
{$endif Delphi}
|
||||
{$else Windows}
|
||||
strings,
|
||||
dos,
|
||||
{$endif Windows}
|
||||
ziptypes;
|
||||
strings,
|
||||
dos,
|
||||
ziptypes;
|
||||
|
||||
{**********************************************************************}
|
||||
{**********************************************************************}
|
||||
@ -89,8 +77,6 @@ ziptypes;
|
||||
FUNCTION FileUnzip
|
||||
( SourceZipFile, TargetDirectory, FileSpecs : pChar;
|
||||
Report : UnzipReportProc;Question : UnzipQuestionProc ) : integer;
|
||||
{$ifdef Windows}{$ifdef Win32}STDCALL;{$else}EXPORT;{$endif Win32}{$endif Windows}
|
||||
{$ifdef DPMI} EXPORT; {$endif DPMI}
|
||||
|
||||
{
|
||||
high level unzip
|
||||
@ -110,8 +96,6 @@ e.g.,
|
||||
}
|
||||
|
||||
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;
|
||||
passes ZipReport & ZipQuestion internally, so you
|
||||
@ -122,8 +106,6 @@ e.g.,
|
||||
}
|
||||
|
||||
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
|
||||
usage:
|
||||
@ -138,8 +120,6 @@ e.g.,
|
||||
}
|
||||
|
||||
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
|
||||
Returns: pointer to the original report procedure
|
||||
@ -150,8 +130,6 @@ e.g.,
|
||||
}
|
||||
|
||||
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
|
||||
Returns: pointer to the original "question" procedure
|
||||
@ -162,8 +140,6 @@ SetUnZipQuestionProc(QueryFileExistProc);
|
||||
}
|
||||
|
||||
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
|
||||
usage:
|
||||
SourceZipFile = the zip file
|
||||
@ -179,15 +155,11 @@ e.g.,
|
||||
}
|
||||
|
||||
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 !!!
|
||||
}
|
||||
|
||||
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
|
||||
the subdirectory structure;
|
||||
@ -201,14 +173,10 @@ the subdirectory structure;
|
||||
{**********************************************************************}
|
||||
{**********************************************************************}
|
||||
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}
|
||||
{bit 8=1 -> Format 8 supported, etc.}
|
||||
|
||||
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:
|
||||
in_name: name of zip file with full path
|
||||
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;
|
||||
{$ifdef Windows}{$ifdef Win32}STDCALL;{$else}EXPORT;{$endif Win32}{$endif Windows}
|
||||
{$ifdef DPMI} EXPORT; {$endif DPMI}
|
||||
{
|
||||
Get first entry from ZIP file
|
||||
e.g.,
|
||||
@ -253,8 +219,6 @@ FUNCTION GetFirstInZip ( zipfilename : pchar;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
|
||||
|
||||
@ -263,8 +227,6 @@ FUNCTION GetNextInZip ( VAR Zprec : tZiprec ) : integer;
|
||||
}
|
||||
|
||||
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
|
||||
|
||||
@ -273,8 +235,6 @@ FUNCTION IsZip ( filename : pchar ) : boolean;
|
||||
}
|
||||
|
||||
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
|
||||
|
||||
@ -384,10 +344,6 @@ TYPE
|
||||
VAR slide : pchar; {Sliding dictionary for unzipping}
|
||||
inbuf : iobuf; {input buffer}
|
||||
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}
|
||||
b : longint; {Bit Buffer}
|
||||
@ -402,10 +358,6 @@ VAR w : longint; {Current Position in slide}
|
||||
totalabort, {User pressed abort button, set in showpercent!}
|
||||
zipeof : boolean; {read over end of zip section for this file}
|
||||
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}
|
||||
@ -574,38 +526,6 @@ BEGIN
|
||||
{$endif}
|
||||
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 *********************}
|
||||
|
||||
PROCEDURE readbuf;
|
||||
@ -614,10 +534,6 @@ BEGIN
|
||||
readpos := sizeof ( inbuf ); {Simulates reading -> no blocking}
|
||||
zipeof := TRUE
|
||||
END ELSE BEGIN
|
||||
{$ifdef windows}
|
||||
messageloop; {Other programs, or in DOS: keypressed?}
|
||||
showpercent; {Before, because it shows the data processed, not read!}
|
||||
{$endif}
|
||||
{$I-}
|
||||
blockread ( infile, inbuf, sizeof ( inbuf ), readpos );
|
||||
{$I+}
|
||||
@ -1422,10 +1338,6 @@ BEGIN
|
||||
exit
|
||||
END;
|
||||
inc ( reachedsize, outcnt );
|
||||
{$ifdef windows}
|
||||
messageloop; {Other programs, or in DOS: keypressed?}
|
||||
showpercent;
|
||||
{$endif}
|
||||
END;
|
||||
IF NOT totalabort THEN
|
||||
copystored := unzip_Ok
|
||||
@ -2326,22 +2238,6 @@ VAR err : integer;
|
||||
oldcurdir : string [ 80 ];
|
||||
|
||||
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 );
|
||||
fillchar ( slide [ 0 ], wsize, #0 );
|
||||
assign ( infile, in_name );
|
||||
@ -2439,44 +2335,23 @@ BEGIN
|
||||
IF ( p <> NIL ) AND ( p [ 1 ] = ':' ) THEN BEGIN
|
||||
strcopy ( buf0, 'c:\' ); {set drive}
|
||||
buf0 [ 0 ] := p [ 0 ];
|
||||
{$ifdef windows}
|
||||
setcurdir ( buf0 );
|
||||
{$else}
|
||||
{$I-}
|
||||
chdir ( buf0 );
|
||||
{$I+}
|
||||
err := ioresult;
|
||||
{$endif}
|
||||
p := strtok ( NIL, '\' );
|
||||
END;
|
||||
{$endif}
|
||||
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-}
|
||||
chdir ( strpas ( p ) );
|
||||
{$I+}
|
||||
err := ioresult;
|
||||
{$endif}
|
||||
IF err <> 0 THEN BEGIN
|
||||
{$ifdef windows}
|
||||
createdir ( p );
|
||||
err := doserror;
|
||||
{$else}
|
||||
{$I-}
|
||||
mkdir ( strpas ( p ) );
|
||||
{$I+}
|
||||
err := ioresult;
|
||||
{$endif}
|
||||
IF err = 0 THEN
|
||||
{$I-}
|
||||
chdir ( strpas ( p ) );
|
||||
@ -2516,13 +2391,6 @@ BEGIN
|
||||
totalabort := FALSE;
|
||||
zipeof := FALSE;
|
||||
|
||||
{$ifdef windows}
|
||||
dlghandle := hFileAction;
|
||||
dlgnotify := cm_index;
|
||||
messageloop;
|
||||
oldpercent := 0;
|
||||
{$endif}
|
||||
|
||||
crc32val := $FFFFFFFF;
|
||||
|
||||
{Unzip correct type}
|
||||
@ -2555,11 +2423,6 @@ BEGIN
|
||||
unzipfile := unzip_CRCErr;
|
||||
erase ( outfile );
|
||||
END ELSE BEGIN
|
||||
{$ifdef windows}
|
||||
oldpercent := 100; {100 percent}
|
||||
IF dlghandle <> 0 THEN
|
||||
sendmessage ( dlghandle, wm_command, dlgnotify, longint ( @oldpercent ) );
|
||||
{$endif}
|
||||
filemode := 2;
|
||||
reset ( outfile );
|
||||
filemode := storefilemode;
|
||||
@ -2953,13 +2816,11 @@ END;
|
||||
{$endif Delphi}
|
||||
|
||||
PROCEDURE DummyReport ( Retcode : longint;Rec : pReportRec );
|
||||
{$ifdef Windows}{$ifdef win32}STDCALL;{$else}EXPORT;{$endif}{$endif}
|
||||
{dummy report procedure}
|
||||
BEGIN
|
||||
END;
|
||||
|
||||
FUNCTION DummyQuestion( Rec : pReportRec ) : Boolean;
|
||||
{$ifdef Windows}{$ifdef win32}STDCALL;{$else}EXPORT;{$endif}{$endif}
|
||||
{dummy question procedure}
|
||||
begin
|
||||
DummyQuestion:=true;
|
||||
@ -3106,7 +2967,7 @@ BEGIN
|
||||
END;
|
||||
END ELSE BEGIN
|
||||
rc := unzipfile ( thename, buf, r.headeroffset, 0,
|
||||
{$ifdef windows}vk_escape{$else}27{$endif} ); {Escape interrupts}
|
||||
27 ); {Escape interrupts}
|
||||
END;
|
||||
|
||||
IF rc = unzip_ok
|
||||
@ -3303,10 +3164,6 @@ END; { SetNoRecurseDirs }
|
||||
PROCEDURE ChfUnzip_Init;
|
||||
BEGIN
|
||||
slide := NIL; {unused}
|
||||
{$ifdef windows}
|
||||
inuse := FALSE; {Not yet in use!}
|
||||
lastusedtime := 0; {Not yet used}
|
||||
{$endif}
|
||||
if inuse then; { to remove warning }
|
||||
SetUnZipReportProc ( NIL );
|
||||
SetUnZipQuestionProc ( NIL );
|
||||
|
||||
@ -31,44 +31,43 @@ These functions are the same over all three BSDs, except that some have a
|
||||
{$DEFINE ErrnoWord}
|
||||
{$endif}
|
||||
|
||||
Procedure fpc_geteipasebx;[external name 'fpc_geteipasebx'];
|
||||
|
||||
procedure actualsyscall; assembler; {inline requires a dummy push IIRC}
|
||||
asm
|
||||
int $0x80
|
||||
jb .LErrorcode
|
||||
ret
|
||||
.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
|
||||
{$endif FPC_PIC}
|
||||
testl %ecx,%ecx
|
||||
jne .LThread
|
||||
movl %eax,Errno+4
|
||||
{$ifdef ErrnoWord}
|
||||
movw %ax,4(%edi)
|
||||
{$else}
|
||||
movl %eax,4(%edi)
|
||||
{$endif}
|
||||
jmp .LNoThread
|
||||
.LThread:
|
||||
movl %eax,%ebx
|
||||
movl Errno,%eax
|
||||
movl (%edi),%eax
|
||||
call *%ecx
|
||||
movl %ebx,(%eax)
|
||||
{$ifdef ErrnoWord}
|
||||
movw %bx,4(%eax)
|
||||
{$else}
|
||||
movl %ebx,4(%eax)
|
||||
{$endif}
|
||||
.LNoThread:
|
||||
{$else}
|
||||
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
|
||||
movl $-1,%eax
|
||||
end;
|
||||
|
||||
function FpSysCall(sysnr:TSysParam):TSysResult; oldfpccall; assembler; [public,alias:'FPC_DOSYS0'];
|
||||
|
||||
@ -32,15 +32,18 @@ abitag:
|
||||
.section .rodata.str1.1,"aMS",@progbits,1
|
||||
.LC0:
|
||||
.string ""
|
||||
.globl __progname
|
||||
.data
|
||||
.p2align 2
|
||||
.globl __progname
|
||||
.type __progname,@object
|
||||
.size __progname,4
|
||||
__progname:
|
||||
.long .LC0
|
||||
.text
|
||||
.p2align 2,,3
|
||||
.type __fpucw,@object
|
||||
.size __fpucw,4
|
||||
.global __fpucw
|
||||
___fpucw:
|
||||
.long 0x1332
|
||||
.globl ___fpc_brk_addr /* heap management */
|
||||
@ -165,8 +168,25 @@ get_rtld_cleanup:
|
||||
|
||||
.weak _DYNAMIC
|
||||
.ident "GCC: (GNU) 3.4.2 - FPC: 2.0.2"
|
||||
|
||||
.bss
|
||||
.comm operatingsystem_parameter_envp,4
|
||||
.comm operatingsystem_parameter_argc,4
|
||||
.comm operatingsystem_parameter_argv,4
|
||||
|
||||
.type __stkptr,@object
|
||||
.size __stkptr,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
|
||||
|
||||
@ -20,17 +20,20 @@
|
||||
.file "prt1.as"
|
||||
.version "01.01"
|
||||
gcc2_compiled.:
|
||||
.globl __progname
|
||||
.section .rodata
|
||||
.LC0:
|
||||
.ascii "\0"
|
||||
.data
|
||||
.p2align 2
|
||||
.globl __progname
|
||||
.type __progname,@object
|
||||
.size __progname,4
|
||||
__progname:
|
||||
.long .LC0
|
||||
.align 4
|
||||
.type __fpucw,@object
|
||||
.size __fpucw,4
|
||||
.global __fpucw
|
||||
___fpucw:
|
||||
.long 0x1332
|
||||
|
||||
@ -40,7 +43,6 @@ ___fpucw:
|
||||
___fpc_brk_addr:
|
||||
.long 0
|
||||
|
||||
|
||||
.text
|
||||
.p2align 2
|
||||
.globl _start
|
||||
@ -123,8 +125,25 @@ _actualsyscall:
|
||||
.weak _DYNAMIC
|
||||
.ident "GCC: (GNU) 2.7.2.1"
|
||||
|
||||
|
||||
.bss
|
||||
.comm operatingsystem_parameter_envp,4
|
||||
.comm operatingsystem_parameter_argc,4
|
||||
.comm operatingsystem_parameter_argv,4
|
||||
|
||||
.type __stkptr,@object
|
||||
.size __stkptr,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
|
||||
|
||||
@ -32,7 +32,11 @@ type
|
||||
TGid = 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;
|
||||
pIno = ^ino_t;
|
||||
|
||||
@ -148,9 +152,12 @@ type
|
||||
|
||||
|
||||
Const
|
||||
MNAMLEN = 80; // slightly machine specific.
|
||||
|
||||
MNAMLEN = 80; // slightly machine specific.
|
||||
MFSNamLen = 16;
|
||||
type
|
||||
fsid_t = array[0..1] of cint;
|
||||
|
||||
// Kernel statfs
|
||||
|
||||
TStatfs = packed record
|
||||
spare2, { place holder}
|
||||
@ -161,13 +168,13 @@ type
|
||||
bavail, { block available for mortal users}
|
||||
files, { Total file nodes}
|
||||
ffree : clong ; { file nodes free}
|
||||
fsid : array[0..1] of longint; // fsid_t
|
||||
fsid : fsid_t;
|
||||
fowner : tuid; {mounter uid}
|
||||
ftype : cint;
|
||||
fflags : cint; {copy of mount flags}
|
||||
fsyncwrites,
|
||||
fasyncwrites : cint;
|
||||
fstypename : array[0..15] of char;
|
||||
fasyncwrites : clong;
|
||||
fstypename : array[0..MFSNamLen-1] of char;
|
||||
mountpoint : array[0..MNAMLEN-1] of char;
|
||||
fsyncreads, { count of sync reads since mount }
|
||||
fasyncreads : clong;
|
||||
@ -183,7 +190,6 @@ type
|
||||
It_Value : TimeVal;
|
||||
end;
|
||||
|
||||
|
||||
const
|
||||
_PTHREAD_MUTEX_DEFAULT = _PTHREAD_MUTEX_ERRORCHECK;
|
||||
_MUTEX_TYPE_FAST = _PTHREAD_MUTEX_NORMAL;
|
||||
@ -193,14 +199,18 @@ const
|
||||
_PTHREAD_STACK_MIN = 1024;
|
||||
|
||||
{ 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 }
|
||||
{$endif}
|
||||
|
||||
NAME_MAX = 255; {14} { Maximum number of bytes in filename }
|
||||
PATH_MAX = 1024; {255} { Maximum number of bytes in pathname }
|
||||
|
||||
SYS_NMLN = 32; {BSD utsname struct limit, kernel mode}
|
||||
|
||||
SIG_MAXSIG = 128; // highest signal version
|
||||
// wordsinsigset = 4; // words in sigset_t
|
||||
// wordsinsigset = 4; // words in sigset_t
|
||||
|
||||
|
||||
{ For getting/setting priority }
|
||||
|
||||
@ -227,7 +227,7 @@ procedure call_stack(pp : pheap_mem_info;var ptext : text);
|
||||
var
|
||||
i : ptrint;
|
||||
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
|
||||
if pp^.calls[i]<>nil then
|
||||
writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
|
||||
@ -243,7 +243,7 @@ procedure call_free_stack(pp : pheap_mem_info;var ptext : text);
|
||||
var
|
||||
i : ptrint;
|
||||
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
|
||||
if pp^.calls[i]<>nil then
|
||||
writeln(ptext,BackTraceStrFunc(pp^.calls[i]));
|
||||
@ -261,7 +261,7 @@ end;
|
||||
|
||||
procedure dump_already_free(p : pheap_mem_info;var ptext : text);
|
||||
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);
|
||||
Writeln(ptext,'freed again at');
|
||||
dump_stack(ptext,get_caller_frame(get_frame));
|
||||
@ -269,7 +269,7 @@ end;
|
||||
|
||||
procedure dump_error(p : pheap_mem_info;var ptext : text);
|
||||
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));
|
||||
dump_stack(ptext,get_caller_frame(get_frame));
|
||||
end;
|
||||
@ -279,20 +279,20 @@ procedure dump_change_after(p : pheap_mem_info;var ptext : text);
|
||||
var pp : pchar;
|
||||
i : ptrint;
|
||||
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,'This memory was changed after call to freemem !');
|
||||
call_free_stack(p,ptext);
|
||||
pp:=pointer(p)+sizeof(theap_mem_info);
|
||||
for i:=0 to p^.size-1 do
|
||||
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;
|
||||
{$endif EXTRA}
|
||||
|
||||
procedure dump_wrong_size(p : pheap_mem_info;size : ptrint;var ptext : text);
|
||||
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');
|
||||
dump_stack(ptext,get_caller_frame(get_frame));
|
||||
{ the check is done to be sure that the procvar is not overwritten }
|
||||
@ -869,7 +869,7 @@ begin
|
||||
goto _exit
|
||||
else
|
||||
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^);
|
||||
runerror(204);
|
||||
end;
|
||||
@ -881,7 +881,7 @@ begin
|
||||
halt(1);
|
||||
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);
|
||||
_exit:
|
||||
end;
|
||||
|
||||
@ -713,11 +713,3 @@
|
||||
****************************************************************************}
|
||||
|
||||
{$i except.inc}
|
||||
|
||||
{****************************************************************************
|
||||
Initialize
|
||||
****************************************************************************}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -26,7 +26,10 @@ implementation
|
||||
{$linklib c}
|
||||
|
||||
{$ifndef linux} // Linux (and maybe glibc platforms in general), have iconv in glibc.
|
||||
{$linklib iconv}
|
||||
{$ifndef FreeBSD5}
|
||||
{$linklib iconv}
|
||||
{$define useiconv}
|
||||
{$endif}
|
||||
{$endif linux}
|
||||
|
||||
Uses
|
||||
@ -38,7 +41,7 @@ Uses
|
||||
initc;
|
||||
|
||||
Const
|
||||
{$ifdef Linux}
|
||||
{$ifndef useiconv}
|
||||
libiconvname='c'; // is in libc under Linux.
|
||||
{$else}
|
||||
libiconvname='iconv';
|
||||
|
||||
43
tests/test/tmaclocalprocparam.pp
Normal file
43
tests/test/tmaclocalprocparam.pp
Normal 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
35
tests/test/tmacnonlocalexit.pp
Normal 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
38
tests/test/tmacnonlocalgoto.pp
Normal 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.
|
||||
Loading…
Reference in New Issue
Block a user