development/compilers/freepascal/compiler/t_os2.pas

   1 {
   2     $Id$
   3     Copyright (c) 1998-2000 by Daniel Mantione
   4     Portions Copyright (c) 1998-2000 Eberhard Mattes
   5
   6     Unit to write out import libraries and def files for OS/2
   7
   8     This program is free software; you can redistribute it and/or modify
   9     it under the terms of the GNU General Public License as published by
  10     the Free Software Foundation; either version 2 of the License, or
  11     (at your option) any later version.
  12
  13     This program is distributed in the hope that it will be useful,
  14     but WITHOUT ANY WARRANTY; without even the implied warranty of
  15     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16     GNU General Public License for more details.
  17
  18     You should have received a copy of the GNU General Public License
  19     along with this program; if not, write to the Free Software
  20     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21
  22  ****************************************************************************
  23 }
  24 {
  25    A lot of code in this unit has been ported from C to Pascal from the
  26    emximp utility, part of the EMX development system. Emximp is copyrighted
  27    by Eberhard Mattes. Note: Eberhard doesn't know much about the Pascal
  28    port, please send questions to Daniel Mantione
  29    <d.s.p.mantione@twi.tudelft.nl>.
  30 }
  31 unit t_os2;
  32
  33 interface
  34 uses
  35   import,link,comprsrc;
  36
  37 type
  38   pimportlibos2=^timportlibos2;
  39   timportlibos2=object(timportlib)
  40     procedure preparelib(const s:string);virtual;
  41     procedure importprocedure(const func,module:string;index:longint;const name:string);virtual;
  42     procedure generatelib;virtual;
  43   end;
  44
  45     plinkeros2=^tlinkeros2;
  46     tlinkeros2=object(tlinker)
  47     private
  48        Function  WriteResponseFile(isdll:boolean) : Boolean;
  49     public
  50        constructor Init;
  51        procedure SetDefaultInfo;virtual;
  52        function  MakeExecutable:boolean;virtual;
  53     end;
  54
  55
  56 {***************************************************************************}
  57
  58 {***************************************************************************}
  59
  60 implementation
  61
  62   uses
  63 {$ifdef Delphi}
  64      dmisc,
  65 {$else Delphi}
  66      dos,
  67 {$endif Delphi}
  68      globtype,strings,cobjects,comphook,systems,
  69      globals,verbose,files,script;
  70
  71 const   profile_flag:boolean=false;
  72
  73 const   n_ext   = 1;
  74         n_abs   = 2;
  75         n_text  = 4;
  76         n_data  = 6;
  77         n_bss   = 8;
  78         n_imp1  = $68;
  79         n_imp2  = $6a;
  80
  81 type    reloc=packed record     {This is the layout of a relocation table
  82                                  entry.}
  83             address:longint;    {Fixup location}
  84             remaining:longint;
  85             {Meaning of bits for remaining:
  86              0..23:              Symbol number or segment
  87              24:                 Self-relative fixup if non-zero
  88              25..26:             Fixup size (0: 1 byte, 1: 2, 2: 4 bytes)
  89              27:                 Reference to symbol or segment
  90              28..31              Not used}
  91         end;
  92
  93         nlist=packed record     {This is the layout of a symbol table entry.}
  94             strofs:longint;     {Offset in string table}
  95             typ:byte;           {Type of the symbol}
  96             other:byte;         {Other information}
  97             desc:word;          {More information}
  98             value:longint;      {Value (address)}
  99         end;
 100
 101         a_out_header=packed record
 102             magic:word;         {Magic word, must be $0107}
 103             machtype:byte;      {Machine type}
 104             flags:byte;         {Flags}
 105             text_size:longint;  {Length of text, in bytes}
 106             data_size:longint;  {Length of initialized data, in bytes}
 107             bss_size:longint;   {Length of uninitialized data, in bytes}
 108             sym_size:longint;   {Length of symbol table, in bytes}
 109             entry:longint;      {Start address (entry point)}
 110             trsize:longint;     {Length of relocation info for text, bytes}
 111             drsize:longint;     {Length of relocation info for data, bytes}
 112         end;
 113
 114         ar_hdr=packed record
 115             ar_name:array[0..15] of char;
 116             ar_date:array[0..11] of char;
 117             ar_uid:array[0..5] of char;
 118             ar_gid:array[0..5] of char;
 119             ar_mode:array[0..7] of char;
 120             ar_size:array[0..9] of char;
 121             ar_fmag:array[0..1] of char;
 122         end;
 123
 124 var aout_str_size:longint;
 125     aout_str_tab:array[0..2047] of byte;
 126     aout_sym_count:longint;
 127     aout_sym_tab:array[0..5] of nlist;
 128
 129     aout_text:array[0..63] of byte;
 130     aout_text_size:longint;
 131
 132     aout_treloc_tab:array[0..1] of reloc;
 133     aout_treloc_count:longint;
 134
 135     aout_size:longint;
 136     seq_no:longint;
 137
 138     ar_member_size:longint;
 139
 140     out_file:file;
 141
 142 procedure write_ar(const name:string;size:longint);
 143
 144 var ar:ar_hdr;
 145     time:datetime;
 146     dummy:word;
 147     numtime:longint;
 148     tmp:string[19];
 149
 150
 151 begin
 152     ar_member_size:=size;
 153     fillchar(ar.ar_name,sizeof(ar.ar_name),' ');
 154     move(name[1],ar.ar_name,length(name));
 155     getdate(time.year,time.month,time.day,dummy);
 156     gettime(time.hour,time.min,time.sec,dummy);
 157     packtime(time,numtime);
 158     str(numtime,tmp);
 159     fillchar(ar.ar_date,sizeof(ar.ar_date),' ');
 160     move(tmp[1],ar.ar_date,length(tmp));
 161     ar.ar_uid:='0     ';
 162     ar.ar_gid:='0     ';
 163     ar.ar_mode:='100666'#0#0;
 164     str(size,tmp);
 165     fillchar(ar.ar_size,sizeof(ar.ar_size),' ');
 166     move(tmp[1],ar.ar_size,length(tmp));
 167     ar.ar_fmag:='`'#10;
 168     blockwrite(out_file,ar,sizeof(ar));
 169 end;
 170
 171 procedure finish_ar;
 172
 173 var a:byte;
 174
 175 begin
 176     a:=0;
 177     if odd(ar_member_size) then
 178         blockwrite(out_file,a,1);
 179 end;
 180
 181 procedure aout_init;
 182
 183 begin
 184   aout_str_size:=sizeof(longint);
 185   aout_sym_count:=0;
 186   aout_text_size:=0;
 187   aout_treloc_count:=0;
 188 end;
 189
 190 function aout_sym(const name:string;typ,other:byte;desc:word;
 191                   value:longint):longint;
 192
 193 begin
 194     if aout_str_size+length(name)+1>sizeof(aout_str_tab) then
 195         Do_halt($da);
 196     if aout_sym_count>=sizeof(aout_sym_tab) div sizeof(aout_sym_tab[0]) then
 197         Do_halt($da);
 198     aout_sym_tab[aout_sym_count].strofs:=aout_str_size;
 199     aout_sym_tab[aout_sym_count].typ:=typ;
 200     aout_sym_tab[aout_sym_count].other:=other;
 201     aout_sym_tab[aout_sym_count].desc:=desc;
 202     aout_sym_tab[aout_sym_count].value:=value;
 203     strPcopy(@aout_str_tab[aout_str_size],name);
 204     aout_str_size:=aout_str_size+length(name)+1;
 205     aout_sym:=aout_sym_count;
 206     inc(aout_sym_count);
 207 end;
 208
 209 procedure aout_text_byte(b:byte);
 210
 211 begin
 212     if aout_text_size>=sizeof(aout_text) then
 213         Do_halt($da);
 214     aout_text[aout_text_size]:=b;
 215     inc(aout_text_size);
 216 end;
 217
 218 procedure aout_text_dword(d:longint);
 219
 220 type li_ar=array[0..3] of byte;
 221
 222 begin
 223     aout_text_byte(li_ar(d)[0]);
 224     aout_text_byte(li_ar(d)[1]);
 225     aout_text_byte(li_ar(d)[2]);
 226     aout_text_byte(li_ar(d)[3]);
 227 end;
 228
 229 procedure aout_treloc(address,symbolnum,pcrel,len,ext:longint);
 230
 231 begin
 232     if aout_treloc_count>=sizeof(aout_treloc_tab) div sizeof(reloc) then
 233         Do_halt($da);
 234     aout_treloc_tab[aout_treloc_count].address:=address;
 235     aout_treloc_tab[aout_treloc_count].remaining:=symbolnum+pcrel shl 24+
 236      len shl 25+ext shl 27;
 237     inc(aout_treloc_count);
 238 end;
 239
 240 procedure aout_finish;
 241
 242 begin
 243     while (aout_text_size and 3)<>0 do
 244         aout_text_byte ($90);
 245     aout_size:=sizeof(a_out_header)+aout_text_size+aout_treloc_count*
 246      sizeof(reloc)+aout_sym_count*sizeof(aout_sym_tab[0])+aout_str_size;
 247 end;
 248
 249 procedure aout_write;
 250
 251 var ao:a_out_header;
 252
 253 begin
 254     ao.magic:=$0107;
 255     ao.machtype:=0;
 256     ao.flags:=0;
 257     ao.text_size:=aout_text_size;
 258     ao.data_size:=0;
 259     ao.bss_size:=0;
 260     ao.sym_size:=aout_sym_count*sizeof(aout_sym_tab[0]);
 261     ao.entry:=0;
 262     ao.trsize:=aout_treloc_count*sizeof(reloc);
 263     ao.drsize:=0;
 264     blockwrite(out_file,ao,sizeof(ao));
 265     blockwrite(out_file,aout_text,aout_text_size);
 266     blockwrite(out_file,aout_treloc_tab,sizeof(reloc)*aout_treloc_count);
 267     blockwrite(out_file,aout_sym_tab,sizeof(aout_sym_tab[0])*aout_sym_count);
 268     longint((@aout_str_tab)^):=aout_str_size;
 269     blockwrite(out_file,aout_str_tab,aout_str_size);
 270 end;
 271
 272 procedure timportlibos2.preparelib(const s:string);
 273
 274 {This code triggers a lot of bugs in the compiler.
 275 const   armag='!<arch>'#10;
 276         ar_magic:array[1..length(armag)] of char=armag;}
 277 const   ar_magic:array[1..8] of char='!<arch>'#10;
 278 var
 279   libname : string;
 280 begin
 281     libname:=FixFileName(s+'.ao2');
 282     seq_no:=1;
 283     current_module^.linkunitstaticlibs.insert(libname,link_allways);
 284     assign(out_file,current_module^.outputpath^+libname);
 285     rewrite(out_file,1);
 286     blockwrite(out_file,ar_magic,sizeof(ar_magic));
 287 end;
 288
 289 procedure timportlibos2.importprocedure(const func,module:string;index:longint;const name:string);
 290 {func       = Name of function to import.
 291  module     = Name of DLL to import from.
 292  index      = Index of function in DLL. Use 0 to import by name.
 293  name       = Name of function in DLL. Ignored when index=0;}
 294 var tmp1,tmp2,tmp3:string;
 295     sym_mcount,sym_import:longint;
 296     fixup_mcount,fixup_import:longint;
 297 begin
 298     aout_init;
 299     tmp2:=func;
 300     if profile_flag and not (copy(func,1,4)='_16_') then
 301         begin
 302             {sym_entry:=aout_sym(func,n_text+n_ext,0,0,aout_text_size);}
 303             sym_mcount:=aout_sym('__mcount',n_ext,0,0,0);
 304             {Use, say, "_$U_DosRead" for "DosRead" to import the
 305              non-profiled function.}
 306             tmp2:='__$U_'+func;
 307             sym_import:=aout_sym(tmp2,n_ext,0,0,0);
 308             aout_text_byte($55);    {push ebp}
 309             aout_text_byte($89);    {mov ebp, esp}
 310             aout_text_byte($e5);
 311             aout_text_byte($e8);    {call _mcount}
 312             fixup_mcount:=aout_text_size;
 313             aout_text_dword(0-(aout_text_size+4));
 314             aout_text_byte($5d);    {pop ebp}
 315             aout_text_byte($e9);    {jmp _$U_DosRead}
 316             fixup_import:=aout_text_size;
 317             aout_text_dword(0-(aout_text_size+4));
 318
 319             aout_treloc(fixup_mcount,sym_mcount,1,2,1);
 320             aout_treloc (fixup_import, sym_import,1,2,1);
 321         end;
 322     str(seq_no,tmp1);
 323     tmp1:='IMPORT#'+tmp1;
 324     if name='' then
 325         begin
 326             str(index,tmp3);
 327             tmp3:=func+'='+module+'.'+tmp3;
 328         end
 329     else
 330         tmp3:=func+'='+module+'.'+name;
 331     aout_sym(tmp2,n_imp1+n_ext,0,0,0);
 332     aout_sym(tmp3,n_imp2+n_ext,0,0,0);
 333     aout_finish;
 334     write_ar(tmp1,aout_size);
 335     aout_write;
 336     finish_ar;
 337     inc(seq_no);
 338 end;
 339
 340 procedure timportlibos2.generatelib;
 341
 342 begin
 343     close(out_file);
 344 end;
 345
 346
 347 {****************************************************************************
 348                                TLinkeros2
 349 ****************************************************************************}
 350
 351 Constructor TLinkeros2.Init;
 352 begin
 353   Inherited Init;
 354   { allow duplicated libs (PM) }
 355   SharedLibFiles.doubles:=true;
 356   StaticLibFiles.doubles:=true;
 357 end;
 358
 359
 360 procedure TLinkeros2.SetDefaultInfo;
 361 begin
 362   with Info do
 363    begin
 364      ExeCmd[1]:='ld $OPT -o $EXE @$RES';
 365      ExeCmd[2]:='emxbind -b $STRIP $PM $RSRC -k$STACKKB -h$HEAPMB -o $EXE.exe $EXE -aim -s$DOSHEAPKB';
 366    end;
 367 end;
 368
 369
 370 Function TLinkeros2.WriteResponseFile(isdll:boolean) : Boolean;
 371 Var
 372   linkres  : TLinkRes;
 373   i        : longint;
 374 {$IFDEF NEWST}
 375   HPath    : PStringItem;
 376 {$ELSE}
 377   HPath    : PStringQueueItem;
 378 {$ENDIF NEWST}
 379   s        : string;
 380 begin
 381   WriteResponseFile:=False;
 382
 383   { Open link.res file }
 384   LinkRes.Init(outputexedir+Info.ResName);
 385
 386   { Write path to search libraries }
 387   HPath:=current_module^.locallibrarysearchpath.First;
 388   while assigned(HPath) do
 389    begin
 390      LinkRes.Add('-L'+HPath^.Data^);
 391      HPath:=HPath^.Next;
 392    end;
 393   HPath:=LibrarySearchPath.First;
 394   while assigned(HPath) do
 395    begin
 396      LinkRes.Add('-L'+HPath^.Data^);
 397      HPath:=HPath^.Next;
 398    end;
 399
 400   { add objectfiles, start with prt0 always }
 401   LinkRes.AddFileName(FindObjectFile('prt0',''));
 402   while not ObjectFiles.Empty do
 403    begin
 404      s:=ObjectFiles.Get;
 405      if s<>'' then
 406       LinkRes.AddFileName(s);
 407    end;
 408
 409   { Write staticlibraries }
 410   { No group !! This will not work correctly PM }
 411   While not StaticLibFiles.Empty do
 412    begin
 413      S:=StaticLibFiles.Get;
 414      LinkRes.AddFileName(s)
 415    end;
 416
 417   { Write sharedlibraries like -l<lib>, also add the needed dynamic linker
 418     here to be sure that it gets linked this is needed for glibc2 systems (PFV) }
 419   While not SharedLibFiles.Empty do
 420    begin
 421      S:=SharedLibFiles.Get;
 422      i:=Pos(target_os.sharedlibext,S);
 423      if i>0 then
 424       Delete(S,i,255);
 425      LinkRes.Add('-l'+s);
 426    end;
 427
 428 { Write and Close response }
 429   linkres.writetodisk;
 430   linkres.done;
 431
 432   WriteResponseFile:=True;
 433 end;
 434
 435
 436 function TLinkeros2.MakeExecutable:boolean;
 437 var
 438   binstr,
 439   cmdstr  : string;
 440   success : boolean;
 441   i       : longint;
 442   PMStr,
 443   StripStr: string[40];
 444   RsrcStr : string;
 445 begin
 446   if not(cs_link_extern in aktglobalswitches) then
 447    Message1(exec_i_linking,current_module^.exefilename^);
 448
 449 { Create some replacements }
 450   if (cs_link_strip in aktglobalswitches) then
 451    StripStr := '-s'
 452   else
 453    StripStr := '';
 454   if usewindowapi then
 455    PMStr := '-p'
 456   else
 457    PMStr := '';
 458   if not (Current_Module^.ResourceFiles.Empty) then
 459    RsrcStr := '-r ' + Current_Module^.ResourceFiles.Get
 460   else
 461    RsrcStr := '';
 462 (* Only one resource file supported, discard everything else
 463    (should be already empty anyway, however. *)
 464   Current_Module^.ResourceFiles.Clear;
 465 { Write used files and libraries }
 466   WriteResponseFile(false);
 467
 468 { Call linker }
 469   success:=false;
 470   for i:=1 to 2 do
 471    begin
 472      SplitBinCmd(Info.ExeCmd[i],binstr,cmdstr);
 473      if binstr<>'' then
 474       begin
 475         Replace(cmdstr,'$HEAPMB',tostr((maxheapsize+1048575) shr 20));
 476         {Size of the stack when an EMX program runs in OS/2.}
 477         Replace(cmdstr,'$STACKKB',tostr((stacksize+1023) shr 10));
 478         {When an EMX program runs in DOS, the heap and stack share the
 479          same memory pool. The heap grows upwards, the stack grows downwards.}
 480         Replace(cmdstr,'$DOSHEAPKB',tostr((stacksize+maxheapsize+1023) shr 10));
 481         Replace(cmdstr,'$STRIP',StripStr);
 482         Replace(cmdstr,'$PM',PMStr);
 483         Replace(cmdstr,'$RES',outputexedir+Info.ResName);
 484         Replace(cmdstr,'$OPT',Info.ExtraOptions);
 485         Replace(cmdstr,'$RSRC',RsrcStr);
 486         Replace(cmdstr,'$EXE',current_module^.exefilename^);
 487         success:=DoExec(FindUtil(binstr),cmdstr,(i=1),false);
 488 (* We still want to have the PPAS script complete, right?
 489         if not success then
 490          break;
 491 *)
 492       end;
 493    end;
 494
 495 { Remove ReponseFile }
 496   if (success) and not(cs_link_extern in aktglobalswitches) then
 497    RemoveFile(outputexedir+Info.ResName);
 498
 499   MakeExecutable:=success;   { otherwise a recursive call to link method }
 500 end;
 501
 502
 503 end.
 504 {
 505   $Log$
 506   Revision 1.1  2002/02/19 08:24:12  sasu
 507   Initial revision
 508
 509   Revision 1.1.2.1  2000/09/20 19:39:40  peter
 510     * fixed staticlib filename and unitlink instead of otherlink
 511
 512   Revision 1.1  2000/07/13 06:29:57  michael
 513   + Initial import
 514
 515   Revision 1.14  2000/07/08 20:43:38  peter
 516     * findobjectfile gets extra arg with directory where the unit is found
 517       and the .o should be looked first
 518
 519   Revision 1.13  2000/06/28 03:34:06  hajny
 520     * little corrections for EMX resources
 521
 522   Revision 1.12  2000/06/25 19:08:28  hajny
 523     + $R support for OS/2 (EMX) added
 524
 525   Revision 1.11  2000/04/01 10:45:14  hajny
 526     * .ao2 bug fixed
 527
 528   Revision 1.10  2000/02/28 17:23:57  daniel
 529   * Current work of symtable integration committed. The symtable can be
 530     activated by defining 'newst', but doesn't compile yet. Changes in type
 531     checking and oop are completed. What is left is to write a new
 532     symtablestack and adapt the parser to use it.
 533
 534   Revision 1.9  2000/02/09 13:23:06  peter
 535     * log truncated
 536
 537   Revision 1.8  2000/01/09 00:55:51  pierre
 538     * GROUP of smartlink units put before the C libraries
 539       to allow for smartlinking code that uses C code.
 540
 541   Revision 1.7  2000/01/07 01:14:43  peter
 542     * updated copyright to 2000
 543
 544   Revision 1.6  1999/11/30 10:40:56  peter
 545     + ttype, tsymlist
 546
 547   Revision 1.5  1999/11/29 20:15:29  hajny
 548     * missing space in EMXBIND params
 549
 550   Revision 1.4  1999/11/16 23:39:04  peter
 551     * use outputexedir for link.res location
 552
 553   Revision 1.3  1999/11/12 11:03:50  peter
 554     * searchpaths changed to stringqueue object
 555
 556   Revision 1.2  1999/11/04 10:55:31  peter
 557     * TSearchPathString for the string type of the searchpaths, which is
 558       ansistring under FPC/Delphi
 559
 560   Revision 1.1  1999/10/21 14:29:38  peter
 561     * redesigned linker object
 562     + library support for linux (only procedures can be exported)
 563
 564 }