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

Text File | 1993-01-04 | 12.7 KB | 583 lines

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

(********************************************************************)
(*
 * process pascal data type specifications
 *
 *)

function psimpletype: string80;
   {parse a simple (single keyword and predefined) type; returns the
    translated type specification; sets the current data type}
var
   ts: string80;
   sym: symptr;

begin
   ts := '';

   repeat
      if (tok = 'CHAR') or (tok = 'BYTE') then
      begin
         curtype := s_char;
         cursuptype := ss_scalar;
         curlimit := 255;
      end
      else

      if tok = 'STRING' then
      begin
         curtype := s_string;
         cursuptype := ss_scalar;
         curlimit := 255;
      end
      else

      if tok = 'TEXT' then
      begin
         curtype := s_file;
         cursuptype := ss_scalar;
         curlimit := 0;
      end
      else

      if tok = 'LONGINT' then
      begin
         curtype := s_long;
         cursuptype := ss_scalar;
         curlimit := maxint;
      end
      else

      if tok = 'BOOLEAN' then
      begin
         curtype := s_int;
         cursuptype := ss_scalar;
         curlimit := maxint;
      end
      else

      if tok = 'INTEGER' then
      begin
         curtype := s_int;
         cursuptype := ss_scalar;
         curlimit := maxint;
      end
      else

      if tok = 'REAL' then
      begin
         curtype := s_double;
         cursuptype := ss_scalar;
         curlimit := maxint;
      end;

      sym := locatesym(ltok);
      if sym <> nil then
      begin
         curtype := sym^.symtype;
         cursuptype := sym^.suptype;
         curlimit := sym^.limit;
      end;

      if ts <> '' then
         ts := ts + ' ' + ltok
      else
         ts := ltok;
      gettok;

   until (tok = ';') or (tok = ')') or (tok = '=') or (tok = '}');

   psimpletype := ts;
end;


(********************************************************************)
procedure pdatatype(stoclass: anystring;
                    var vars: paramlist;
                    prefix:   anystring;
                    suffix:   anystring;
                    addsemi:  boolean);
   {parse any full data type specification;  input is a list of variables
    to be declared with this data type; stoclass is a storage class prefix
    (usually 'static ', '', 'typedef ', or 'extern '.  prefix and suffix
    are variable name modifiers used in pointer and subscript translations;
    recursive for complex data types}

const
   forward_typedef: anystring = '';
   forward_undef:   anystring = '';

var
   i:      integer;
   ts:     anystring;
   sym:    symptr;


   procedure pvarlist;
   var
      i: integer;
   begin
      for i := 1 to vars.n do
      begin
         newsym(vars.id[i],curtype,cursuptype,-1,0,curlimit);

         write(ofd[level],' ',prefix,vars.id[i],suffix);
         if i < vars.n then
            write(ofd[level],',');
      end;
   end;


   procedure parray;
   begin
      gettok;     {consume the ARRAY}
      gettok;     {consume the [}

      ts := pexpr;   {consume the lower subscript expression}
      if tok = '..' then
      begin
         gettok;   {consume the ..}
         ts := pexpr;
      end;

      sym := locatesym(ts);
      if sym <> nil then
         if (sym^.limit > 0) and (sym^.suptype <> ss_const) then
            ts := ' /* ' + ts + ' */ ' + ftoa(sym^.limit,0,0);

      suffix := '[' + ts + '+1]'; {increment array size by one}

      gettok;     {consume the ]}
      gettok;     {consume the OF}

      cursuptype := ss_array;
   end;


   procedure pstring;
   begin
      gettok;     {consume the STRING}

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

         ts := pexpr;
         suffix := suffix + '[' + ts + '+1]'; {increment string size by one}

         gettok;     {consume the ]}
      end
      else
         suffix := suffix + '[STRSIZ]';

      write(ofd[level],stoclass,LJUST('char',identlen) );
      curtype := s_string;
      pvarlist;
   end;


   procedure ptext;
   begin
      gettok;     {consume the TEXT}

      if tok = '[' then
      begin
         gettok;     {consume the [}
         ts := pexpr;
         gettok;     {consume the ]}
      end;

      write(ofd[level],stoclass,LJUST('text',identlen));
      curtype := s_file;
      pvarlist;
   end;


   procedure pfile;
   begin
      gettok;     {consume the FILE}

      if tok = 'OF' then
      begin
         gettok;     {consume the OF}
         ts := tok;
         gettok;     {consume the recordtype}
      end;

      write(ofd[level],stoclass,LJUST('int',identlen),' /* file of ',ts,' */ ');
      curtype := s_file;
      pvarlist;
   end;


   procedure pset;
   begin
      gettok;     {consume the SET}
      gettok;     {consume the OF}

      pdatatype(stoclass,vars,'/* set of */ ','',false);
   end;


   procedure pvariant;
   begin
      gettok;     {consume the CASE}

      ts := ltok;
      gettok;     {consume the selector identifier}

      if tok = ':' then
      begin
         gettok;     {consume the :}
         write(ofd[level], ltok,' ',ts, ';  /* Variant Selector */');
         gettok;     {consume the selector type}
      end
      else
         write(ofd[level],'/* Variant Selector is ',ts,' */');

      if tok <> 'OF' then
         syntax('OF expected (pvariant)');
      gettok;

      write(ofd[level],' union { ');
      newline;

      while tok <> '}' do
      begin
         ts := pexpr;      {parse the selector constant}
         while tok = ',' do
         begin
            gettok;
            ts := pexpr;
         end;

         gettok;    {consume the :}

         write(ofd[level],' struct { ');
         pvar;
         gettok;    {consume the ')'}

         write(ofd[level],' } s',ts,';');

         if tok = ';' then
            gettok;
      end;

      write(ofd[level],' } v;');
      newline;
   end;

   procedure precord;
   begin
      write(ofd[level],stoclass,'struct ',vars.id[1],' { ');

      pvar;     {process each record member}

      if tok = 'CASE' then    {process the variant part, if any}
         pvariant;

      puttok;   {output the closing brace}
      gettok;   {and consume it}

      curtype := s_struct;
      cursuptype := ss_struct;
      pvarlist; {output any variables of this record type}

      {convert a #define into a typedef in case of a forward pointer decl}
      if forward_typedef <> '' then
      begin
         writeln(ofd[level],';');
         writeln(ofd[level],forward_undef);
         write(ofd[level],forward_typedef);
         forward_typedef := '';
      end;
   end;


   procedure penum;
   begin
      write(ofd[level],stoclass,'enum {  ');

      gettok;
      i := 0;
      repeat
         write(ofd[level],ltok);
         inc(i);
         gettok;
      until tok = ')';

      write(ofd[level],' }');
      gettok;   {consume the )}

      curtype := s_int;
      curlimit := i;
      pvarlist;
   end;


   procedure pnumber;
   begin
      ts := pexpr;   {consume the lower limit expression}
      if tok <> '..' then
         error('".." expected (pdatatype)');

      gettok;        {consume the ..}
      ts := pexpr;   {consume the number}

      sym := locatesym(ts);
      if sym <> nil then
         if sym^.limit > 0 then
            ts := ftoa(sym^.limit,0,0);

      curtype := s_int;
      curlimit := atoi(ts);
      write(ofd[level],stoclass,LJUST('int',identlen),' /* limit=',ts,' */');
      pvarlist;
   end;


   procedure psimple;
   begin
      ts := psimpletype;

      i := pos('^',ts);
      if i <> 0 then
      begin
         delete(ts,i,1);
         prefix := '*';
      end;

      if (stoclass = 'typedef ') and (vars.n = 1) and (prefix = '*') then
      begin
         newsym(vars.id[1],curtype,cursuptype,-1,0,curlimit);
         write(ofd[level],'#define ',LJUST(vars.id[1],identlen),' struct ',ts,' *');
         forward_undef := '#undef '+vars.id[1];
         forward_typedef := 'typedef struct '+ts+' *'+vars.id[1];
         addsemi := false;
      end
      else

      begin
         write(ofd[level],stoclass,LJUST(ts,identlen));
         pvarlist;
      end;
   end;


begin
   curlimit := 0;

   if tok = 'EXTERNAL' then
   begin
      gettok;     {consume the EXTERNAL}
      stoclass := 'extern '+stoclass;
   end;

   if tok = 'ARRAY' then
      parray;

   if tok = 'STRING'        then pstring
   else if tok = 'TEXT'     then ptext
   else if tok = 'FILE'     then pfile
   else if tok = 'SET'      then pset
   else if tok = '('        then penum
   else if tok = 'RECORD'   then precord
   else if toktype = number then pnumber
   else psimple;

   if addsemi then
      write(ofd[level],';');

   if tok = ';' then
      gettok;
end;


(********************************************************************)
(*
 * declaration keyword processors
 *   const, type, var, label
 *
 * all enter with tok=section type
 * exit with tok=new section or begin or proc or func
 *
 *)

procedure pconst;
   {parse and translate a constant section}
var
   vars:   paramlist;
   parlev: integer;
   exp:    string80;

begin
   gettok;

   while (toktype <> keyword) do
   begin
      nospace := false;
      vars.n := 1;
      vars.id[1] := ltok;

      gettok;    {consume the id}

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

         exp := pexpr;
         case exprtype(exp) of
            'c': curtype := s_char;
            'f': curtype := s_double;
            's': curtype := s_string;
            else curtype := s_int;
         end;

         write(ofd[level],'#define ',LJUST(vars.id[1],identlen),
                          ' ',LJUST(exp,identlen));

         newsym(vars.id[1],curtype,ss_const,-1,0,{0}atoi(exp));

         gettok;   {consume the ;}
      end
      else

      begin               {typed constants}

         gettok;   {consume the :}

         pdatatype('static ',vars,'','',false);

         gettok;   {consume the =}

         write(ofd[level],' = ');
         parlev := 0;

         repeat
            if tok = '(' then
            begin
               inc(parlev);
               write(ofd[level],'{');
               gettok;
            end
            else

            if tok = ')' then
            begin
               dec(parlev);
               write(ofd[level],'}');
               gettok;
            end
            else

            if tok = ',' then
            begin
               puttok;
               gettok;
            end
            else

            if (parlev > 0) and (tok = ';') then
            begin
               write(ofd[level],',');
               gettok;
            end
            else

            if tok <> ';' then
            begin
               exp := pexpr;
               if tok = ':' then
                  gettok   {discard 'member-identifier :'}
               else
                  write(ofd[level],exp);
            end;

         until (tok = ';') and (parlev = 0);

         puttok;      {output the final ;}
         gettok;
      end;
   end;
end;


(********************************************************************)
procedure ptype;
   {parse and translate a type section}
var
   vars: paramlist;

begin
   gettok;

   while (toktype <> keyword) do
   begin
      vars.n := 1;
      vars.id[1] := usetok;

      if tok = '=' then
         gettok
      else
         syntax('"=" expected (ptype)');

      nospace := false;
      pdatatype('typedef ',vars,'','',true);
   end;

end;


(********************************************************************)
procedure pvar;
   {parse and translate a variable section}
var
   vars:  paramlist;
begin

   vars.n := 0;
   gettok;

   while (toktype <> keyword) and (tok <> '}') and (tok <> ')') do
   begin
      nospace := true;

      repeat
         if tok = ',' then
            gettok;

         inc(vars.n);
         vars.id[vars.n] := ltok;
         gettok;
      until tok <> ',';

      if tok <> ':' then
         syntax('":" expected (pvar)')
      else
         gettok;   {consume the :}

      nospace := false;
      pdatatype('',vars,'','',true);
      vars.n := 0;
   end;
end;


(********************************************************************)
procedure plabel;
   {parse (and throw away) a label section}
begin

   while tok <> ';' do
      gettok;

   gettok;
end;