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

Text File | 1993-01-04 | 15.9 KB | 854 lines

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

(********************************************************************)
(*
 * control statement processors
 *    for, while, repeat, with, idents
 *
 * all expect tok to be keyword
 * all exit at end of statement with ltok as ; or end
 *
 *)

procedure pfor;
var
   up:       boolean;
   id:       string80;
   low,high: string80;

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

   id := plvalue;
   gettok;   {consume the :=}

   low := pexpr;

   if tok = 'TO' then
      up := true
   else

   if tok = 'DOWNTO' then
      up := false
   else

   begin
      syntax('TO or DOWNTO expected (pfor)');
      exit;
   end;

   gettok;
   high := pexpr;

   if up then
      write(ofd[level],id,' = ',low,'; ',id,' <= ',high,'; ',id,'++) ')
   else
      write(ofd[level],id,' = ',low,'; ',id,' >= ',high,'; ',id,'--) ');

   gettok;   {consume the DO}
   pstatement;
end;


(********************************************************************)
procedure pwhile;
var
   cond: string255;

begin
   gettok;   {consume the WHILE}

   cond := pexpr;
   write(ofd[level],'while (',cond,') ');

   gettok;   {consume the DO}
   pstatement;
end;


(********************************************************************)
procedure pwith;
var
   prefix: string80;

begin
   write(ofd[level],'/* with ');

   gettok;   {consume the DO}
   prefix := plvalue;

   write(ofd[level],prefix,' DO */ ');
   gettok;   {consume the DO}
   pstatement;

   write(ofd[level],' /* end with */');
   newline;
end;


(********************************************************************)
procedure prepeat;
var
   cond: string255;

begin
   write(ofd[level],'do { ');
   gettok;

   while tok <> 'UNTIL' do
   begin
      pstatement;

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

   gettok;
   cond := pexpr;

   write(ofd[level],'}  while (!(', cond, ')) ');
end;


(********************************************************************)
procedure pcase;
var
   ex: string255;
   i:  integer;
   c:  char;

begin
   gettok;
   ex := pexpr;
   write(ofd[level],'switch (',ex,') {');

   gettok;   {consume the OF}

   while (tok <> '}') and (tok <> 'ELSE') do
   begin

      repeat
         if tok = ',' then
            gettok;

         if tok = '..' then
         begin
            i := atoi(ex);
            if i = 0 then
               c := ex[2];

            gettok;
            ex := pexpr;
            if i=0 then
               for c := succ(c) to ex[2] do
               begin
                  newline;
                  write(ofd[level],'case ''',c,''':   ');
               end
            else
               for i := succ(i) to atoi(ex) do
               begin
                  newline;
                  write(ofd[level],'case ',i,':    ');
               end;

         end
         else
         begin
            ex := pexpr;
            newline;
            write(ofd[level],'case ',ex,':   ');
         end;

      until tok = ':';
      gettok;

      pstatement;
      write(ofd[level],'break; ');
      newline;

      if tok = ';' then
         gettok;
   end;

   if tok = 'ELSE' then
   begin
      newline;
      write(ofd[level],'default: ');
      gettok;   {consume the else}

      while tok <> '}' do
      begin
         pstatement;
         if tok = ';' then
            gettok;
      end;
   end;

   puttok;
   gettok;

   if tok = ';' then
      gettok;
end;


(********************************************************************)
procedure pif;
var
   cond: string255;
begin
   gettok;   {consume the IF}

   cond := pexpr;
   write(ofd[level],'if (', cond, ') ');

   gettok;   {consume the THEN}
   pstatement;

   if tok = 'ELSE' then
   begin
      write(ofd[level],'else ');
      gettok;
      if tok <> '}' then
         pstatement;
   end;

end;


(********************************************************************)
procedure pexit;
begin
   write(ofd[level],'return;');

   gettok;
   if tok = ';' then
      gettok;
end;


(********************************************************************)
procedure pgoto;
var
   ex:  anystring;

begin
   gettok;                      {consume the goto}

   if toktype = number then
      ltok := 'label_' + ltok;  {modify numeric labels}

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

   gettok;                      {consume the label}

   if tok = ';' then
      gettok;
end;


(********************************************************************)
procedure phalt;
var
   ex: anystring;

begin
   gettok;

   if tok = '(' then
   begin
      gettok;
      ex := pexpr;
      gettok;
   end
   else
      ex := '0';     {default exit expression}


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

   if tok = ';' then
      gettok;
end;


(********************************************************************)
procedure pread;
var
   ctl:  anystring;
   func: anystring;
   ex:   paramlist;
   ty:   paramlist;
   w:    anystring;
   n:    anystring;
   ln:   boolean;
   i:    integer;
   sym:  symptr;

begin
   nospace := true;   {don't copy source whitespace to output during
                       this processing.  this prevents spaces from
                       getting moved around}

   ln := tok = 'READLN';
   nospace := true;
   func := 'scanv(';

   gettok;   {consume the write}

   if tok = '(' then
   begin
      gettok;

      if ltok = '[' then   {check for MT+ [addr(name)], form}
      begin
         gettok;   {consume the '[' }

         if tok = ']' then
            func := 'scanf('
         else

         begin
            gettok;   {consume the ADDR}
            gettok;   {consume the '(' }

            func := 'fiscanf(' + usetok + ',';

            gettok;   {consume the ')'}
         end;

         gettok;   {consume the ']'}
         if tok = ',' then
            gettok;
      end
      else

      begin
         sym := locatesym(ltok);   {check for file variables}
         if sym <> nil then
         begin
            if sym^.symtype = s_file then
            begin
               func := 'fscanv(' + usetok + ',';
               if tok = ',' then
                  gettok;
            end;
         end;
      end;

      ctl := '';
      ex.n := 0;

      while tok <> ')' do
      begin
         inc(ex.n);
         ex.id[ex.n] := pexpr;
         ty.id[ex.n] := exprtype(ex.id[ex.n]);

         ctl := ctl + '%'+ty.id[ex.n];
         if tok = ',' then
            gettok;
      end;

      gettok;   {consume the )}

      if ctl = '%s' then
         ctl := '#';
      if ln then
         ctl := ctl + '\n';

      if func[1] <> 'f' then
         func := 'f' + func + 'stdin,';

      write(ofd[level],func,'"',ctl,'"');
      for i := 1 to ex.n do
         if ty.id[i] <> 's' then
            write(ofd[level],',&',ex.id[i])
         else
            write(ofd[level],',',ex.id[i]);

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

   else   {otherwise there is no param list}
      if ln then
         write(ofd[level],'scanf("\n")');

   nospace := false;

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

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

end;


(********************************************************************)
procedure pwrite;
var
   ctl:  anystring;
   func: anystring;
   ex:   paramlist;
   w:    anystring;
   n:    anystring;
   p:    string255;
   ln:   boolean;
   ty:   string[2];
   i:    integer;

begin
   nospace := true;   {don't copy source whitespace to output during
                       this processing.  this prevents spaces from
                       getting moved around}

   ln := tok = 'WRITELN';
   nospace := true;
   func := 'printf(';

   gettok;   {consume the write}

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

      ctl := '';
      ex.n := 0;

      while tok <> ')' do
      begin
         p := pexpr;

         if (ex.n = 0) and (curtype = s_file) then
         begin
            func := 'fprintf(' + p + ',';
         end
         else

         begin
            inc(ex.n);
            ex.id[ex.n] := p;
            ty := exprtype(p);
            if ty = 'D' then
               ty := 'ld';

            w := '';
            n := '';
            if tok = ':' then
            begin
               gettok;
               w := pexpr;

               if tok = ':' then
               begin
                  gettok;
                  n := pexpr;
                  ctl := ctl + '%'+w+'.'+n+'f';
               end
               else
                  ctl := ctl + '%'+w+ty;
            end
            else

            begin
               {pass literals into the control string}
               if (p[1] = '"') or (p[1] = '''') then
               begin
                  ctl := ctl + copy(p,2,length(p)-2);
                  dec(ex.n);
               end

               {otherwise put in the control string for this param}
               else
                  ctl := ctl + '%'+ty;
            end;
         end;

         if tok = ',' then
            gettok;
      end;

      gettok;   {consume the )}

      if ln then
         ctl := ctl + '\n';

      write(ofd[level],func,'"',ctl,'"');
      for i := 1 to ex.n do
         write(ofd[level],',',ex.id[i]);

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

   else   {otherwise there is no param list}
      if ln then
         write(ofd[level],'printf("\n")');

   nospace := false;

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

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

end;


(********************************************************************)
procedure pnew;
var
   lv: string255;
begin

   gettok;   {consume the new}
   gettok;   {consume the (}
   lv := plvalue;
   gettok;   {consume the )}

   write(ofd[level],lv,' = malloc(sizeof(*',lv,'));');

   if tok = ';' then
      gettok;
end;


(********************************************************************)
procedure pport(kw: string255);
   {translate port/portw/mem/memw}
var
   lv: string255;

begin
   lv := kw + '(';

   gettok;     {consume the keyword}
   gettok;     {consume the [ }

   repeat
      lv := lv + pexpr;
      if tok = ':' then
      begin
         gettok;
         lv := lv + ',';
      end;
   until tok = ']';

   gettok;     {consume the ] }

   if tok = ':=' then
   begin
      gettok;       {consume :=, assignment statement}
      lv := lv + ',' + pexpr;
   end;

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

   if tok = ';' then
      gettok;
end;


(********************************************************************)
procedure pinline;
   {translate inline statements}
var
   lv: string255;

begin
   gettok;     {consume the keyword}

   lv := '';
   while tok <> ')' do
   begin
      gettok;
      if (tok = '/') or (tok = ')') then
      begin
         writeln(ofd[level],'     asm db ',lv,';');
         lv := '';
      end
      else
         lv := lv + ltok + ' ';
   end;

   gettok;     {consume the ) }

   if tok = ';' then
      gettok;
end;


(********************************************************************)
procedure pident;
   {parse statements starting with an identifier;  these are either
    assignment statements, function calls, return-value assignments,
    or label identifiers}
var
   ex: string255;
   lv: string255;
   lvt,ext: char;

begin
   nospace := true;   {don't copy source whitespace to output during
                       this processing.  this prevents spaces from
                       getting moved around}
   lv := plvalue;

   if tok = ':=' then
   begin
      gettok;       {consume :=, assignment statement}
      ex := pexpr;

      if iscall(lv) then
         write(ofd[level],'return ',ex)
      else

      begin
         lvt := exprtype(lv);
         ext := exprtype(ex);

         if copy(ex,1,5) = 'scat(' then
            write(ofd[level],'sbld(', lv,',' , copy(ex,6,255))
         else

         if copy(ex,1,5) = 'scat(' then
            write(ofd[level],'sbld(', lv,',' , copy(ex,6,255))
         else

         if lvt = 's' then
            if ext = 's' then
               write(ofd[level],'strcpy(',lv,', ',ex,')')
            else
               write(ofd[level],'sbld(',lv,',"%',ext,'",',ex,')')
         else

         if lvt = 'c' then
            if ext = 's' then
               write(ofd[level],lv,' = first(',ex,')')
            else
               write(ofd[level],lv,' = ',ex)
         else
            write(ofd[level],lv,' = ',ex);
      end;
   end
   else

   if tok = ':' then
   begin
      writeln(ofd[level]);
      write(ofd[level],lv,': ');

      gettok;       {label identifier}

      if tok = ';' then
         gettok;

      exit;
   end
   else

   if iscall(lv) then
      write(ofd[level],lv)
   else
      write(ofd[level],lv,'()');

   nospace := false;

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

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

end;


(********************************************************************)
procedure pnumlabel;
   {parse statements starting with an number;  these must be
    numeric labels}
begin
   writeln(ofd[level]);
   write(ofd[level],'label_',tok,': ');

   gettok;      {consume the number}

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

   gettok;      {consume the :}
end;


(********************************************************************)
(*
 * process single statement
 *
 * expects tok to be first token of statement
 * processes nested blocks
 * exits with tok as end of statement
 *
 *)

procedure pstatement;
begin

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

   if tok = '{' then
      pblock
   else

   if tok = 'FOR' then
      pfor
   else

   if tok = 'WHILE' then
      pwhile
   else

   if tok = 'WITH' then
      pwith
   else

   if tok = 'REPEAT' then
      prepeat
   else

   if tok = 'CASE' then
      pcase
   else

   if tok = 'IF' then
      pif
   else

   if tok = 'EXIT' then
      pexit
   else

   if tok = 'GOTO' then
      pgoto
   else

   if tok = 'HALT' then
      phalt
   else

   if tok = 'WRITE' then
      pwrite
   else

   if tok = 'WRITELN' then
      pwrite
   else

   if tok = 'READ' then
      pread
   else

   if tok = 'READLN' then
      pread
   else

   if tok = 'NEW' then
      pnew
   else

   if tok = 'PORT' then
      pport('outportb')
   else
   if tok = 'PORTW' then
      pport('outport')
   else
   if tok = 'MEM' then
      pport('pokeb')
   else
   if tok = 'MEMW' then
      pport('poke')
   else

   if tok = 'INLINE' then
      pinline
   else

   if toktype = number then
      pnumlabel
   else

      pident;
end;


(********************************************************************)
(*
 * process begin...end blocks
 *
 * expects tok to be begin
 * exits with tok = end
 *
 *)

procedure pblock;
begin

   write(ofd[level],'{ ');
   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;
   gettok;
   if tok = ';' then
      gettok;

end;