home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 2 / AACD 2.iso / AACD / Programming / fpc / compiler / os2_targ.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-09-24  |  11.1 KB  |  376 lines
  1. {
  2.     $Id: os2_targ.pas,v 1.1.1.1 1998/03/25 11:18:15 root Exp $
  3.     Copyright (c) 1993-98 by Daniel Mantione
  4.     Portions Copyright (c) 1992-96 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 os2_targ;
  32.  
  33. interface
  34.  
  35. uses import;
  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. procedure write_def_file;
  46.  
  47. {***************************************************************************}
  48.  
  49. {***************************************************************************}
  50.  
  51. implementation
  52.  
  53. uses    dos,strings,globals,link,files;
  54.  
  55. const   profile_flag:boolean=false;
  56.  
  57. const   n_ext   = 1;
  58.         n_abs   = 2;
  59.         n_text  = 4;
  60.         n_data  = 6;
  61.         n_bss   = 8;
  62.         n_imp1  = $68;
  63.         n_imp2  = $6a;
  64.  
  65. type    reloc=packed record     {This is the layout of a relocation table
  66.                                  entry.}
  67.             address:longint;    {Fixup location}
  68.             remaining:longint;
  69.             {Meaning of bits for remaining:
  70.              0..23:              Symbol number or segment
  71.              24:                 Self-relative fixup if non-zero
  72.              25..26:             Fixup size (0: 1 byte, 1: 2, 2: 4 bytes)
  73.              27:                 Reference to symbol or segment
  74.              28..31              Not used}
  75.         end;
  76.  
  77.         nlist=packed record     {This is the layout of a symbol table entry.}
  78.             strofs:longint;     {Offset in string table}
  79.             typ:byte;           {Type of the symbol}
  80.             other:byte;         {Other information}
  81.             desc:word;          {More information}
  82.             value:longint;      {Value (address)}
  83.         end;
  84.  
  85.         a_out_header=packed record
  86.             magic:word;         {Magic word, must be $0107}
  87.             machtype:byte;      {Machine type}
  88.             flags:byte;         {Flags}
  89.             text_size:longint;  {Length of text, in bytes}
  90.             data_size:longint;  {Length of initialized data, in bytes}
  91.             bss_size:longint;   {Length of uninitialized data, in bytes}
  92.             sym_size:longint;   {Length of symbol table, in bytes}
  93.             entry:longint;      {Start address (entry point)}
  94.             trsize:longint;     {Length of relocation info for text, bytes}
  95.             drsize:longint;     {Length of relocation info for data, bytes}
  96.         end;
  97.  
  98.         ar_hdr=packed record
  99.             ar_name:array[0..15] of char;
  100.             ar_date:array[0..11] of char;
  101.             ar_uid:array[0..5] of char;
  102.             ar_gid:array[0..5] of char;
  103.             ar_mode:array[0..7] of char;
  104.             ar_size:array[0..9] of char;
  105.             ar_fmag:array[0..1] of char;
  106.         end;
  107.  
  108. var aout_str_size:longint;
  109.     aout_str_tab:array[0..2047] of byte;
  110.     aout_sym_count:longint;
  111.     aout_sym_tab:array[0..5] of nlist;
  112.  
  113.     aout_text:array[0..63] of byte;
  114.     aout_text_size:longint;
  115.  
  116.     aout_treloc_tab:array[0..1] of reloc;
  117.     aout_treloc_count:longint;
  118.  
  119.     aout_size:longint;
  120.     seq_no:longint;
  121.  
  122.     ar_member_size:longint;
  123.  
  124.     out_file:file;
  125.  
  126. procedure write_ar(const name:string;size:longint);
  127.  
  128. var ar:ar_hdr;
  129.     time:datetime;
  130.     dummy:word;
  131.     numtime:longint;
  132.     tmp:string[19];
  133.  
  134.  
  135. begin
  136.     ar_member_size:=size;
  137.     fillchar(ar.ar_name,sizeof(ar.ar_name),' ');
  138.     move(name[1],ar.ar_name,length(name));
  139.     getdate(time.year,time.month,time.day,dummy);
  140.     gettime(time.hour,time.min,time.sec,dummy);
  141.     packtime(time,numtime);
  142.     str(numtime,tmp);
  143.     fillchar(ar.ar_date,sizeof(ar.ar_date),' ');
  144.     move(tmp[1],ar.ar_date,length(tmp));
  145.     ar.ar_uid:='0     ';
  146.     ar.ar_gid:='0     ';
  147.     ar.ar_mode:='100666'#0#0;
  148.     str(size,tmp);
  149.     fillchar(ar.ar_size,sizeof(ar.ar_size),' ');
  150.     move(tmp[1],ar.ar_size,length(tmp));
  151.     ar.ar_fmag:='`'#10;
  152.     blockwrite(out_file,ar,sizeof(ar));
  153. end;
  154.  
  155. procedure finish_ar;
  156.  
  157. var a:byte;
  158.  
  159. begin
  160.     a:=0;
  161.     if odd(ar_member_size) then
  162.         blockwrite(out_file,a,1);
  163. end;
  164.  
  165. procedure aout_init;
  166.  
  167. begin
  168.   aout_str_size:=sizeof(longint);
  169.   aout_sym_count:=0;
  170.   aout_text_size:=0;
  171.   aout_treloc_count:=0;
  172. end;
  173.  
  174. function aout_sym(const name:string;typ,other:byte;desc:word;
  175.                   value:longint):longint;
  176.  
  177. begin
  178.     if aout_str_size+length(name)+1>sizeof(aout_str_tab) then
  179.         runerror($da);
  180.     if aout_sym_count>=sizeof(aout_sym_tab) div sizeof(aout_sym_tab[0]) then
  181.         runerror($da);
  182.     aout_sym_tab[aout_sym_count].strofs:=aout_str_size;
  183.     aout_sym_tab[aout_sym_count].typ:=typ;
  184.     aout_sym_tab[aout_sym_count].other:=other;
  185.     aout_sym_tab[aout_sym_count].desc:=desc;
  186.     aout_sym_tab[aout_sym_count].value:=value;
  187.     strPcopy(@aout_str_tab[aout_str_size],name);
  188.     aout_str_size:=aout_str_size+length(name)+1;
  189.     aout_sym:=aout_sym_count;
  190.     inc(aout_sym_count);
  191. end;
  192.  
  193. procedure aout_text_byte(b:byte);
  194.  
  195. begin
  196.     if aout_text_size>=sizeof(aout_text) then
  197.         runerror($da);
  198.     aout_text[aout_text_size]:=b;
  199.     inc(aout_text_size);
  200. end;
  201.  
  202. procedure aout_text_dword(d:longint);
  203.  
  204. type li_ar=array[0..3] of byte;
  205.  
  206. begin
  207.     aout_text_byte(li_ar(d)[0]);
  208.     aout_text_byte(li_ar(d)[1]);
  209.     aout_text_byte(li_ar(d)[2]);
  210.     aout_text_byte(li_ar(d)[3]);
  211. end;
  212.  
  213. procedure aout_treloc(address,symbolnum,pcrel,len,ext:longint);
  214.  
  215. begin
  216.     if aout_treloc_count>=sizeof(aout_treloc_tab) div sizeof(reloc) then
  217.         runerror($da);
  218.     aout_treloc_tab[aout_treloc_count].address:=address;
  219.     aout_treloc_tab[aout_treloc_count].remaining:=symbolnum+pcrel shl 24+
  220.      len shl 25+ext shl 27;
  221.     inc(aout_treloc_count);
  222. end;
  223.  
  224. procedure aout_finish;
  225.  
  226. begin
  227.     while (aout_text_size and 3)<>0 do
  228.         aout_text_byte ($90);
  229.     aout_size:=sizeof(a_out_header)+aout_text_size+aout_treloc_count*
  230.      sizeof(reloc)+aout_sym_count*sizeof(aout_sym_tab[0])+aout_str_size;
  231. end;
  232.  
  233. procedure aout_write;
  234.  
  235. var ao:a_out_header;
  236.  
  237. begin
  238.     ao.magic:=$0107;
  239.     ao.machtype:=0;
  240.     ao.flags:=0;
  241.     ao.text_size:=aout_text_size;
  242.     ao.data_size:=0;
  243.     ao.bss_size:=0;
  244.     ao.sym_size:=aout_sym_count*sizeof(aout_sym_tab[0]);
  245.     ao.entry:=0;
  246.     ao.trsize:=aout_treloc_count*sizeof(reloc);
  247.     ao.drsize:=0;
  248.     blockwrite(out_file,ao,sizeof(ao));
  249.     blockwrite(out_file,aout_text,aout_text_size);
  250.     blockwrite(out_file,aout_treloc_tab,sizeof(reloc)*aout_treloc_count);
  251.     blockwrite(out_file,aout_sym_tab,sizeof(aout_sym_tab[0])*aout_sym_count);
  252.     longint((@aout_str_tab)^):=aout_str_size;
  253.     blockwrite(out_file,aout_str_tab,aout_str_size);
  254. end;
  255.  
  256. procedure timportlibos2.preparelib(const s:string);
  257.  
  258. {This code triggers a lot of bugs in the compiler.
  259. const   armag='!<arch>'#10;
  260.         ar_magic:array[1..length(armag)] of char=armag;}
  261. const   ar_magic:array[1..8] of char='!<arch>'#10;
  262.  
  263. begin
  264.     seq_no:=1;
  265.     Linker.AddLibraryFile(s+'.dll');
  266.     current_module^.linkofiles.insert(s+'.dll');
  267.     assign(out_file,s+'.ao2');
  268.     rewrite(out_file,1);
  269.     blockwrite(out_file,ar_magic,sizeof(ar_magic));
  270. end;
  271.  
  272. procedure timportlibos2.importprocedure(const func,module:string;index:longint;const name:string);
  273. {func       = Name of function to import.
  274.  module     = Name of DLL to import from.
  275.  index      = Index of function in DLL. Use 0 to import by name.
  276.  name       = Name of function in DLL. Ignored when index=0;}
  277. var tmp1,tmp2,tmp3:string;
  278.     sym_mcount,sym_entry,sym_import:longint;
  279.     fixup_mcount,fixup_import:longint;
  280. begin
  281.     aout_init;
  282.     tmp2:=func;
  283.     if profile_flag and not (copy(func,1,4)='_16_') then
  284.         begin
  285.             sym_entry:=aout_sym(func,n_text+n_ext,0,0,aout_text_size);
  286.             sym_mcount:=aout_sym('__mcount',n_ext,0,0,0);
  287.             {Use, say, "_$U_DosRead" for "DosRead" to import the
  288.              non-profiled function.}
  289.             tmp2:='__$U_'+func;
  290.             sym_import:=aout_sym(tmp2,n_ext,0,0,0);
  291.             aout_text_byte($55);    {push ebp}
  292.             aout_text_byte($89);    {mov ebp, esp}
  293.             aout_text_byte($e5);
  294.             aout_text_byte($e8);    {call _mcount}
  295.             fixup_mcount:=aout_text_size;
  296.             aout_text_dword(0-(aout_text_size+4));
  297.             aout_text_byte($5d);    {pop ebp}
  298.             aout_text_byte($e9);    {jmp _$U_DosRead}
  299.             fixup_import:=aout_text_size;
  300.             aout_text_dword(0-(aout_text_size+4));
  301.  
  302.             aout_treloc(fixup_mcount,sym_mcount,1,2,1);
  303.             aout_treloc (fixup_import, sym_import,1,2,1);
  304.         end;
  305.     str(seq_no,tmp1);
  306.     tmp1:='IMPORT#'+tmp1;
  307.     if name='' then
  308.         begin
  309.             str(index,tmp3);
  310.             tmp3:=func+'='+module+'.'+tmp3;
  311.         end
  312.     else
  313.         tmp3:=func+'='+module+'.'+name;
  314.     aout_sym(tmp2,n_imp1+n_ext,0,0,0);
  315.     aout_sym(tmp3,n_imp2+n_ext,0,0,0);
  316.     aout_finish;
  317.     write_ar(tmp1,aout_size);
  318.     aout_write;
  319.     finish_ar;
  320.     inc(seq_no);
  321. end;
  322.  
  323. procedure timportlibos2.generatelib;
  324.  
  325. begin
  326.     close(out_file);
  327. end;
  328.  
  329.  
  330. procedure write_def_file;
  331. begin
  332.    assign(deffile,inputdir+inputfile+'.DEF');
  333.    {$I+}
  334.     rewrite(deffile);
  335.    {$I-}
  336.    if ioresult=0 then
  337.     begin
  338.       write(deffile,'NAME '+inputfile);
  339.       if genpm then
  340.         write(deffile,' WINDOWAPI');
  341.       writeln(deffile,#13#10#13#10'PROTMODE'#13#10);
  342.       writeln(deffile,'DESCRIPTION '+''''+description+''''#13#10);
  343.       writeln(deffile,'DATA'#9'MULTIPLE'#13#10);
  344.       writeln(deffile,'STACKSIZE'#9+tostr(stacksize));
  345.       writeln(deffile,'HEAPSIZE'#9+tostr(heapsize)+#13#10);
  346.       write(deffile,'EXPORTS');
  347.     end
  348.    else
  349.     gendeffile:=false;
  350. end;
  351.  
  352. end.
  353.  
  354. {
  355.   $Log: os2_targ.pas,v $
  356.   Revision 1.1.1.1  1998/03/25 11:18:15  root
  357.   * Restored version
  358.  
  359.   Revision 1.15  1998/03/10 01:17:21  peter
  360.     * all files have the same header
  361.     * messages are fully implemented, EXTDEBUG uses Comment()
  362.     + AG... files for the Assembler generation
  363.  
  364.   Revision 1.14  1998/03/02 23:08:41  florian
  365.     * the concatcopy bug removed (solves problems when compilg sysatari!)
  366.  
  367.   Revision 1.13  1998/03/02 13:38:40  peter
  368.     + importlib object
  369.     * doesn't crash on a systemunit anymore
  370.     * updated makefile and depend
  371.  
  372.   Revision 1.11  1998/02/28 00:20:27  florian
  373.     * more changes to get import libs for Win32 working
  374.  
  375. }
  376.