Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TPTC16.ZIP/TPCUNIT.INC

Text File | 1993-01-04 | 10.6 KB | 556 lines

(*
 * TPTC - Turbo Pascal to C translator
 *
 * (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
 *
 *)


(********************************************************************)
(*
 * process generic declaration section
 *   dispatches to const, type, var, proc, func
 *   enter with tok=section type
 *   exit with tok=next section type
 *
 *)

procedure psection;
begin

   if tok = 'EXTERNAL' then
      punit
   else

   if tok = 'OVERLAY' then
      punit
   else

   if tok = 'PROCEDURE' then
      punit
   else

   if tok = 'FUNCTION' then
      punit
   else

   if tok = 'CONST' then
      pconst
   else

   if tok = 'TYPE' then
      ptype
   else

   if tok = 'VAR' then
      pvar
   else

   if tok = 'LABEL' then
      plabel
   else

   if tok = '{' then
      pblock
   else

   if tok = '.' then
      exit

   else
      syntax('Section header expected (psection)');
end;


(********************************************************************)
(*
 * process argument declarations to
 *    program, procedure, function
 *
 * enter with header as tok
 * exits with tok as ; or :
 *
 *)

function punitheader(ext: boolean): anystring;
var
   proc:  string80;
   vars:  paramlist;
   types: paramlist;
   i:     integer;
   ii:    integer;
   rtype: string80;
   varval:integer;
   varon: boolean;
   locvar:integer;
   iptr:  integer;

begin
   nospace := true;
   gettok;                 {skip unit type}

   proc := ltok;
   punitheader := proc;
   if unitlevel > 1 then
      error('Enter nested function');

   gettok;                 {skip unit identifier}

   vars.n := 0;
   varval := 0;       { 0 bit means value, 1 = var }
   varon  := false;

   (* process param list, if any *)
   if tok = '(' then
   begin

      gettok;

      while tok <> ')' do
      begin

         ii := vars.n + 1;
         repeat
            if tok = ',' then
               gettok;

            if tok = 'VAR' then
            begin
               gettok;
               varon := true;
            end;

            inc(vars.n);
            vars.id[vars.n] := ltok;
            gettok;

         until tok <> ',';

         if tok <> ':' then
         begin
            syntax('":" expected (punitheader)');
            exit;
         end;

         gettok;   {consume the :}

         {parse the param type}
         rtype := psimpletype;
         iptr := 0;

         if rtype[1] = '^' then
            rtype[1] := '*';

         if (not varon) then
         begin
            if (curtype = s_string) then
               rtype := 'char *'
            else
            if cursuptype = ss_array then
               iptr := 1 shl (ii - 1);
         end;

{        for i := ii to vars.n-1 do
            if varon then
               varval := varval or (1 shl ii);   }

         for i := ii to vars.n do   {assign data types}
         begin
            types.id[i] := rtype;
            types.stype[i] := curtype;
            types.sstype[i] := cursuptype;
            varval := varval or iptr;
            iptr := iptr shl 1;
         end;

         if (tok = ';') then
         begin
            gettok;
            varon := false;
         end;

      end;   {) seen}

      gettok;   {consume the )}
   end;

   (* process function return type, if any *)
   if tok = ':' then
   begin
      gettok;            {consume the :}
      rtype := psimpletype;

      if curtype = s_string then
         rtype := 'char *'
      else
      if cursuptype = ss_array then
         rtype := typename[curtype] + ' *';
   end
   else

   begin
      rtype := 'void ';
      curtype := s_void;
   end;

   writeln(ofd[level]);

   (* prefix procedure decl's when external *)
   if ext then
   begin
      writeln(ofd[level],'extern ',LJUST(rtype,identlen),' ',proc,'();');
      addsym(globals,proc,curtype,ss_func,0,0,varval);
      exit;
   end;

   (* output the return type, proc name, formal param list *)
   write(ofd[level],LJUST(rtype,identlen),' ',proc,'(');

   if vars.n = 0 then
      write(ofd[level],'void');

   (* output the formal param declarations *)
   locvar := varval;
   for i := 1 to vars.n do
   begin
      iptr := -1;

      if (locvar and 1) = 1 then
      begin
         iptr := -2;
         types.id[i] := types.id[i] + ' *';
      end;

      write(ofd[level],LJUST(types.id[i],identlen),vars.id[i]);
      newsym(vars.id[i],types.stype[i],ss_scalar,iptr,0,0);
      locvar := locvar shr 1;

      if i < vars.n then
      begin
         writeln(ofd[level],',');
         write(ofd[level],'':identlen+length(proc)+2);
      end;
   end;

   write(ofd[level],') ');

   addsym(globals,proc,curtype,ss_func,vars.n,0,varval);
   nospace := false;
end;


(********************************************************************)
(*
 * process body of program unit
 *   handles all declaration sections
 *   and a single begin...end
 *   recursively handles procedure declarations
 *   ends with tok=}
 *)

procedure punitbody;
begin
   gettok;

   if tok <> 'FORWARD' then
   begin
      write(ofd[level],'{ ');

      repeat
         if tok = ';' then
         begin
            puttok;
            gettok;
         end;

         if tok <> '{' then
            psection;
      until tok = '{';

      gettok;                 {get first token of first statement}

      while tok <> '}' do
      begin
         pstatement;                {process the statement}

         if tok = ';' then
         begin
            puttok;
            gettok;              {get first token of next statement}
         end;
      end;

      puttok;
      writeln(ofd[level]);

   end    {if not FORWARD}

   else
   begin
      write(ofd[level],'/* forward */ ;');
      gettok;
   end;

end;


(********************************************************************)
function makename(n: integer): anystring;
var
   nam:  anystring;
begin
   str(n,nam);
   makename := nestfile + nam;
end;

(********************************************************************)
procedure enter_nested;
begin
   inc(level);
   assign(ofd[level],makename(level));
   rewrite(ofd[level]);
end;


(********************************************************************)
procedure exit_nested;
var
   nfd:   text;
   line:  anystring;

begin
   writeln(ofd[level]);
   close(ofd[level]);
   reset(ofd[level]);

   assign(nfd,nestfile);
   {$i-} append(nfd); {$i+}
   if ioresult <>0 then
      rewrite(nfd);

   while not eof(ofd[level]) do
   begin
      readln(ofd[level],line);
      writeln(nfd,line);
   end;

   close(ofd[level]);
   erase(ofd[level]);
   close(nfd);

   dec(level);

end;


(********************************************************************)
procedure discard_nested;
var
   nfd:   text;

begin
   {$i-}
   close(ofd[level]);
   erase(ofd[level]);
   assign(nfd,nestfile);
   rewrite(nfd);
   writeln(nfd);
   close(nfd);
   {$i+}

   dec(level);
end;


(********************************************************************)
procedure append_nested;
var
   nfd:   text;
   line:  anystring;

begin
   assign(nfd,nestfile);
   {$i-} reset(nfd); {$i+}
   if ioresult <> 0 then
      exit;

   while not eof(nfd) do
   begin
      readln(nfd,line);
      writeln(ofd[level],line);
   end;

   close(nfd);
   erase(nfd);
end;


(********************************************************************)
(*
 * process program, procedure and function declaration
 *
 * enter with tok=function
 * exit with tok=;
 *
 *)

procedure punit;
var
   proc:  anystring;
   xxx:   char;

begin
   inc(unitlevel);

   if (tok = 'OVERLAY') then
      gettok;

   if (tok = 'EXTERNAL') then  {mt+}
   begin
      gettok;      {consume the EXTERNAL}

      if tok = '[' then
      begin
         gettok;   {consume the '['}

         write(ofd[level],'/* overlay ',ltok,' */ ');
         gettok;   {consume the overlay number}

         gettok;   {consume the ']'}
      end;

      proc := punitheader(true);

      if tok = ';' then
         gettok;
   end
   else

   begin
      if unitlevel > 1 then
      begin
         writeln;
         enter_nested;
         srclines[level] := srclines[level-1];
         if locals^.id <> localseprt then
            newsym(localseprt, s_int, ss_scalar, -1,0,0);
      end;

      proc := punitheader(false);
      punitbody;

      if unitlevel > 1 then
      begin
         tok := proc;
         error('Exit nested function');

         exit_nested;
         srclines[level] := srclines[level+1];
         purgefrom(localseprt);
      end
      else

      begin
         append_nested;

         inc(nestn[2]);
         if nestn[2] > '9' then
         begin
            inc(nestn[1]);
            nestn[2] := '0';
         end;
      end;

     gettok;
     if tok = ';' then
        gettok;

   end;

   dec(unitlevel);

   if unitlevel = 0 then
      purgetable(locals);

end;



(********************************************************************)
(*
 * process main program
 *
 *  expects program head
 *  optional declarations
 *  block of main code
 *  .
 *
 *)

procedure pprogram;
begin
   writeln(ofd[level]);
   writeln(ofd[level],'/*');
   writeln(ofd[level],' * Generated by ',version1);
   writeln(ofd[level],' *    ',version2);
   writeln(ofd[level],' */');
   writeln(ofd[level]);
   writeln(ofd[level],'#include "tptcmac.h"');

   getchar;  {get first char}
   gettok;   {get first token}

   if (tok = 'PROGRAM') or (tok = 'UNIT') then
   begin
      repeat
         gettok;
      until tok = ';';
      gettok;
   end;

   if tok = 'MODULE' then
   begin
      mt_plus := true;   {shift into pascal/mt+ mode}
      repeat
         gettok;
      until tok = ';';
      gettok;
   end;

   repeat
      if tok = ';' then
      begin
         puttok;
         gettok;
      end;

      if tok = 'MODEND' then
         exit;

      if (tok <> '{') then
         psection;
   until (tok = '{');

   writeln(ofd[level]);
   writeln(ofd[level],'main(int    argc,');
   writeln(ofd[level],'     char   *argv[])');

   puttok;
   gettok;                 {get first token of main block}

   while tok <> '}' do
   begin
      pstatement;                {process the statement}

      if tok = ';' then
      begin
         puttok;
         gettok;              {get first token of next statement}
      end;
   end;

   puttok;
   writeln(ofd[level]);
end;