paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-27 03:23:43 +02:00
Code Issues Packages Projects Releases Wiki Activity
ce3f177339
fpc/compiler/systems/t_emx.pas
Tomas Hajny efda160d12 * fix for compilation on 8.3 filesystems
2004-12-05 12:25:48 +00:00

548 lines
16 KiB
ObjectPascal
Raw Blame History

{
$Id$
Copyright (c) 1998-2002 by Daniel Mantione
Portions Copyright (c) 1998-2002 Eberhard Mattes
Unit to write out import libraries and def files for OS/2 via EMX
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
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. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
{
A lot of code in this unit has been ported from C to Pascal from the
emximp utility, part of the EMX development system. Emximp is copyrighted
by Eberhard Mattes. Note: Eberhard doesn't know much about the Pascal
port, please send questions to Daniel Mantione
<d.s.p.mantione@twi.tudelft.nl>.
}
unit t_emx;
{$i fpcdefs.inc}
interface
implementation
uses
strings,
dos,
cutils,cclasses,
globtype,comphook,systems,symconst,symsym,symdef,
globals,verbose,fmodule,script,
import,link,i_emx,ppu;
type
TImportLibEMX=class(timportlib)
procedure preparelib(const s:string);override;
procedure importprocedure(aprocdef:tprocdef;const module:string;index:longint;const name:string);override;
procedure generatelib;override;
end;
TLinkerEMX=class(texternallinker)
private
Function WriteResponseFile(isdll:boolean) : Boolean;
public
constructor Create;override;
procedure SetDefaultInfo;override;
function MakeExecutable:boolean;override;
end;
const profile_flag:boolean=false;
const n_ext = 1;
n_abs = 2;
n_text = 4;
n_data = 6;
n_bss = 8;
n_imp1 = $68;
n_imp2 = $6a;
type reloc=packed record {This is the layout of a relocation table
entry.}
address:longint; {Fixup location}
remaining:longint;
{Meaning of bits for remaining:
0..23: Symbol number or segment
24: Self-relative fixup if non-zero
25..26: Fixup size (0: 1 byte, 1: 2, 2: 4 bytes)
27: Reference to symbol or segment
28..31 Not used}
end;
nlist=packed record {This is the layout of a symbol table entry.}
strofs:longint; {Offset in string table}
typ:byte; {Type of the symbol}
other:byte; {Other information}
desc:word; {More information}
value:longint; {Value (address)}
end;
a_out_header=packed record
magic:word; {Magic word, must be $0107}
machtype:byte; {Machine type}
flags:byte; {Flags}
text_size:longint; {Length of text, in bytes}
data_size:longint; {Length of initialized data, in bytes}
bss_size:longint; {Length of uninitialized data, in bytes}
sym_size:longint; {Length of symbol table, in bytes}
entry:longint; {Start address (entry point)}
trsize:longint; {Length of relocation info for text, bytes}
drsize:longint; {Length of relocation info for data, bytes}
end;
ar_hdr=packed record
ar_name:array[0..15] of char;
ar_date:array[0..11] of char;
ar_uid:array[0..5] of char;
ar_gid:array[0..5] of char;
ar_mode:array[0..7] of char;
ar_size:array[0..9] of char;
ar_fmag:array[0..1] of char;
end;
var aout_str_size:longint;
aout_str_tab:array[0..2047] of byte;
aout_sym_count:longint;
aout_sym_tab:array[0..5] of nlist;
aout_text:array[0..63] of byte;
aout_text_size:longint;
aout_treloc_tab:array[0..1] of reloc;
aout_treloc_count:longint;
aout_size:longint;
seq_no:longint;
ar_member_size:longint;
out_file:file;
procedure write_ar(const name:string;size:longint);
var ar:ar_hdr;
time:datetime;
dummy:word;
numtime:longint;
tmp:string[19];
begin
ar_member_size:=size;
fillchar(ar.ar_name,sizeof(ar.ar_name),' ');
move(name[1],ar.ar_name,length(name));
getdate(time.year,time.month,time.day,dummy);
gettime(time.hour,time.min,time.sec,dummy);
packtime(time,numtime);
str(numtime,tmp);
fillchar(ar.ar_date,sizeof(ar.ar_date),' ');
move(tmp[1],ar.ar_date,length(tmp));
ar.ar_uid:='0 ';
ar.ar_gid:='0 ';
ar.ar_mode:='100666'#0#0;
str(size,tmp);
fillchar(ar.ar_size,sizeof(ar.ar_size),' ');
move(tmp[1],ar.ar_size,length(tmp));
ar.ar_fmag:='`'#10;
blockwrite(out_file,ar,sizeof(ar));
end;
procedure finish_ar;
var a:byte;
begin
a:=0;
if odd(ar_member_size) then
blockwrite(out_file,a,1);
end;
procedure aout_init;
begin
aout_str_size:=sizeof(longint);
aout_sym_count:=0;
aout_text_size:=0;
aout_treloc_count:=0;
end;
function aout_sym(const name:string;typ,other:byte;desc:word;
value:longint):longint;
begin
if aout_str_size+length(name)+1>sizeof(aout_str_tab) then
Do_Stop($da);
if aout_sym_count>=sizeof(aout_sym_tab) div sizeof(aout_sym_tab[0]) then
Do_Stop($da);
aout_sym_tab[aout_sym_count].strofs:=aout_str_size;
aout_sym_tab[aout_sym_count].typ:=typ;
aout_sym_tab[aout_sym_count].other:=other;
aout_sym_tab[aout_sym_count].desc:=desc;
aout_sym_tab[aout_sym_count].value:=value;
strPcopy(@aout_str_tab[aout_str_size],name);
aout_str_size:=aout_str_size+length(name)+1;
aout_sym:=aout_sym_count;
inc(aout_sym_count);
end;
procedure aout_text_byte(b:byte);
begin
if aout_text_size>=sizeof(aout_text) then
Do_Stop($da);
aout_text[aout_text_size]:=b;
inc(aout_text_size);
end;
procedure aout_text_dword(d:longint);
type li_ar=array[0..3] of byte;
begin
aout_text_byte(li_ar(d)[0]);
aout_text_byte(li_ar(d)[1]);
aout_text_byte(li_ar(d)[2]);
aout_text_byte(li_ar(d)[3]);
end;
procedure aout_treloc(address,symbolnum,pcrel,len,ext:longint);
begin
if aout_treloc_count>=sizeof(aout_treloc_tab) div sizeof(reloc) then
Do_Stop($da);
aout_treloc_tab[aout_treloc_count].address:=address;
aout_treloc_tab[aout_treloc_count].remaining:=symbolnum+pcrel shl 24+
len shl 25+ext shl 27;
inc(aout_treloc_count);
end;
procedure aout_finish;
begin
while (aout_text_size and 3)<>0 do
aout_text_byte ($90);
aout_size:=sizeof(a_out_header)+aout_text_size+aout_treloc_count*
sizeof(reloc)+aout_sym_count*sizeof(aout_sym_tab[0])+aout_str_size;
end;
procedure aout_write;
var ao:a_out_header;
begin
ao.magic:=$0107;
ao.machtype:=0;
ao.flags:=0;
ao.text_size:=aout_text_size;
ao.data_size:=0;
ao.bss_size:=0;
ao.sym_size:=aout_sym_count*sizeof(aout_sym_tab[0]);
ao.entry:=0;
ao.trsize:=aout_treloc_count*sizeof(reloc);
ao.drsize:=0;
blockwrite(out_file,ao,sizeof(ao));
blockwrite(out_file,aout_text,aout_text_size);
blockwrite(out_file,aout_treloc_tab,sizeof(reloc)*aout_treloc_count);
blockwrite(out_file,aout_sym_tab,sizeof(aout_sym_tab[0])*aout_sym_count);
longint((@aout_str_tab)^):=aout_str_size;
blockwrite(out_file,aout_str_tab,aout_str_size);
end;
procedure TImportLibEMX.preparelib(const s:string);
{This code triggers a lot of bugs in the compiler.
const armag='!<arch>'#10;
ar_magic:array[1..length(armag)] of char=armag;}
const ar_magic:array[1..8] of char='!<arch>'#10;
var
libname : string;
begin
LibName:=FixFileName(S + Target_Info.StaticCLibExt);
seq_no:=1;
current_module.linkotherstaticlibs.add(libname,link_allways);
assign(out_file,current_module.outputpath^+libname);
rewrite(out_file,1);
blockwrite(out_file,ar_magic,sizeof(ar_magic));
end;
procedure TImportLibEMX.importprocedure(aprocdef:tprocdef;const module:string;index:longint;const name:string);
{func = Name of function to import.
module = Name of DLL to import from.
index = Index of function in DLL. Use 0 to import by name.
name = Name of function in DLL. Ignored when index=0;}
var tmp1,tmp2,tmp3:string;
sym_mcount,sym_import:longint;
fixup_mcount,fixup_import:longint;
func : string;
begin
{ force the current mangledname }
include(aprocdef.procoptions,po_has_mangledname);
func:=aprocdef.mangledname;
aout_init;
tmp2:=func;
if profile_flag and not (copy(func,1,4)='_16_') then
begin
{sym_entry:=aout_sym(func,n_text+n_ext,0,0,aout_text_size);}
sym_mcount:=aout_sym('__mcount',n_ext,0,0,0);
{Use, say, "_$U_DosRead" for "DosRead" to import the
non-profiled function.}
tmp2:='__$U_'+func;
sym_import:=aout_sym(tmp2,n_ext,0,0,0);
aout_text_byte($55); {push ebp}
aout_text_byte($89); {mov ebp, esp}
aout_text_byte($e5);
aout_text_byte($e8); {call _mcount}
fixup_mcount:=aout_text_size;
aout_text_dword(0-(aout_text_size+4));
aout_text_byte($5d); {pop ebp}
aout_text_byte($e9); {jmp _$U_DosRead}
fixup_import:=aout_text_size;
aout_text_dword(0-(aout_text_size+4));
aout_treloc(fixup_mcount,sym_mcount,1,2,1);
aout_treloc (fixup_import, sym_import,1,2,1);
end;
str(seq_no,tmp1);
tmp1:='IMPORT#'+tmp1;
if name='' then
begin
str(index,tmp3);
tmp3:=func+'='+module+'.'+tmp3;
end
else
tmp3:=func+'='+module+'.'+name;
aout_sym(tmp2,n_imp1+n_ext,0,0,0);
aout_sym(tmp3,n_imp2+n_ext,0,0,0);
aout_finish;
write_ar(tmp1,aout_size);
aout_write;
finish_ar;
inc(seq_no);
end;
procedure TImportLibEMX.GenerateLib;
begin
close(out_file);
end;
{****************************************************************************
TLinkerEMX
****************************************************************************}
Constructor TLinkerEMX.Create;
begin
Inherited Create;
{ allow duplicated libs (PM) }
SharedLibFiles.doubles:=true;
StaticLibFiles.doubles:=true;
end;
procedure TLinkerEMX.SetDefaultInfo;
begin
with Info do
begin
ExeCmd[1]:='ld $OPT -o $OUT @$RES';
ExeCmd[2]:='emxbind -b $STRIP $APPTYPE $RSRC -k$STACKKB -h$HEAPMB -o $EXE $OUT -aim -s$DOSHEAPKB';
ExeCmd[3]:='del $OUT';
end;
end;
Function TLinkerEMX.WriteResponseFile(isdll:boolean) : Boolean;
Var
linkres : TLinkRes;
i : longint;
HPath : TStringListItem;
s : string;
begin
WriteResponseFile:=False;
{ Open link.res file }
LinkRes:=TLinkRes.Create(outputexedir+Info.ResName);
{ Write path to search libraries }
HPath:=TStringListItem(current_module.locallibrarysearchpath.First);
while assigned(HPath) do
begin
LinkRes.Add('-L'+HPath.Str);
HPath:=TStringListItem(HPath.Next);
end;
HPath:=TStringListItem(LibrarySearchPath.First);
while assigned(HPath) do
begin
LinkRes.Add('-L'+HPath.Str);
HPath:=TStringListItem(HPath.Next);
end;
{ add objectfiles, start with prt0 always }
LinkRes.AddFileName(FindObjectFile('prt0','',false));
while not ObjectFiles.Empty do
begin
s:=ObjectFiles.GetFirst;
if s<>'' then
LinkRes.AddFileName(s);
end;
{ Write staticlibraries }
{ No group !! This will not work correctly PM }
While not StaticLibFiles.Empty do
begin
S:=StaticLibFiles.GetFirst;
LinkRes.AddFileName(s)
end;
{ Write sharedlibraries like -l<lib>, also add the needed dynamic linker
here to be sure that it gets linked this is needed for glibc2 systems (PFV) }
While not SharedLibFiles.Empty do
begin
S:=SharedLibFiles.GetFirst;
i:=Pos(target_info.sharedlibext,S);
if i>0 then
Delete(S,i,255);
LinkRes.Add('-l'+s);
end;
{ Write and Close response }
linkres.writetodisk;
LinkRes.Free;
WriteResponseFile:=True;
end;
function TLinkerEMX.MakeExecutable:boolean;
var
binstr : String;
cmdstr : TCmdStr;
success : boolean;
i : longint;
AppTypeStr,
StripStr: string[40];
RsrcStr : string;
DS: DirStr;
NS: NameStr;
ES: ExtStr;
OutName: PathStr;
begin
if not(cs_link_extern in aktglobalswitches) then
Message1(exec_i_linking,current_module.exefilename^);
{ Create some replacements }
FSplit (current_module.exefilename^, DS, NS, ES);
OutName := DS + NS + '.out';
if (cs_link_strip in aktglobalswitches) then
StripStr := '-s'
else
StripStr := '';
if (usewindowapi) or (AppType = app_gui) then
AppTypeStr := '-p'
else if AppType = app_fs then
AppTypeStr := '-f'
else AppTypeStr := '-w';
if not (Current_module.ResourceFiles.Empty) then
RsrcStr := '-r ' + Current_module.ResourceFiles.GetFirst
else
RsrcStr := '';
(* Only one resource file supported, discard everything else
(should be already empty anyway, though). *)
Current_module.ResourceFiles.Clear;
{ Write used files and libraries }
WriteResponseFile(false);
{ Call linker }
success:=false;
for i:=1 to 3 do
begin
SplitBinCmd(Info.ExeCmd[i],binstr,cmdstr);
if binstr<>'' then
begin
{ Is this really required? Not anymore according to my EMX docs }
Replace(cmdstr,'$HEAPMB',tostr((1048575) shr 20));
{Size of the stack when an EMX program runs in OS/2.}
Replace(cmdstr,'$STACKKB',tostr((stacksize+1023) shr 10));
{When an EMX program runs in DOS, the heap and stack share the
same memory pool. The heap grows upwards, the stack grows downwards.}
Replace(cmdstr,'$DOSHEAPKB',tostr((stacksize+1023) shr 10));
Replace(cmdstr,'$STRIP',StripStr);
Replace(cmdstr,'$APPTYPE',AppTypeStr);
Replace(cmdstr,'$RES',outputexedir+Info.ResName);
Replace(cmdstr,'$OPT',Info.ExtraOptions);
Replace(cmdstr,'$RSRC',RsrcStr);
Replace(cmdstr,'$OUT',OutName);
Replace(cmdstr,'$EXE',current_module.exefilename^);
if i<>3 then
success:=DoExec(FindUtil(binstr),cmdstr,(i=1),false)
else
success:=DoExec(binstr,cmdstr,(i=1),true);
end;
end;
{ Remove ReponseFile }
if (success) and not(cs_link_extern in aktglobalswitches) then
RemoveFile(outputexedir+Info.ResName);
MakeExecutable:=success; { otherwise a recursive call to link method }
end;
{*****************************************************************************
Initialize
*****************************************************************************}
initialization
RegisterExternalLinker(system_i386_emx_info,TLinkerEMX);
RegisterImport(system_i386_emx,TImportLibEMX);
RegisterRes(res_emxbind_info);
RegisterTarget(system_i386_emx_info);
end.
{
$Log$
Revision 1.12 2004-12-05 12:25:48 hajny
* fix for compilation on 8.3 filesystems
Revision 1.11 2004/11/17 22:22:12 peter
mangledname setting moved to place after the complete proc declaration is read
import generation moved to place where body is also parsed (still gives problems with win32)
Revision 1.10 2004/10/25 15:38:41 peter
* heap and heapsize removed
* checkpointer fixes
Revision 1.9 2004/10/15 09:24:38 mazen
- remove $IFDEF DELPHI and related code
- remove $IFDEF FPCPROCVAR and related code
Revision 1.8 2004/10/14 18:16:17 mazen
* USE_SYSUTILS merged successfully : cycles with and without defines
* Need to be optimized in performance
Revision 1.7 2004/09/22 15:25:14 mazen
* Fix error committing : previous version must be in branch USE_SYSUTILS
Revision 1.5 2004/09/08 11:23:31 michael
+ Check if outputdir exists, Fix exitcode when displaying help pages
Revision 1.4 2004/06/20 08:55:32 florian
* logs truncated
}
Reference in New Issue View Git Blame Copy Permalink