Path: utzoo!utgpu!water!watmath!clyde!att!osu-cis!tut.cis.ohio-state.edu!cwjcc!hal!ncoast!allbery
From: alan@leadsv.UUCP (Alan Strassberg)
Newsgroups: comp.sources.misc
Subject: v04i024: Turbo Pascal to C, part 3/4
Message-ID: <12229@ncoast.UUCP>
Date: 14 Aug 88 22:56:01 GMT
Sender: allbery@ncoast.UUCP
Reply-To: alan@leadsv.UUCP (Alan Strassberg)
Lines: 2468
Approved: allbery@ncoast.UUCP

Posting-number: Volume 4, Issue 24
Submitted-by: "Alan Strassberg" 
Archive-name: tptc/Part3

[WARNING!!!  This software is shareware and copyrighted.  Those who do not
accept such programs should give this a miss.  ++bsa]

#--------------------------------CUT HERE-------------------------------------
#! /bin/sh
#
# This is a shell archive.  Save this into a file, edit it
# and delete all lines above this comment.  Then give this
# file to sh by executing the command "sh file".  The files
# will be extracted into the current directory owned by
# you with default permissions.
#
# The files contained herein are:
#
# -rw-r--r--   1 allbery  System     22616 Aug 14 16:46 tpcstmt.inc
# -rw-r--r--   1 allbery  System      7059 Aug 14 16:46 tpcsym.inc
# -rw-r--r--   1 allbery  System     12098 Aug 14 16:46 tpcunit.inc
# -rw-r--r--   1 allbery  System     11061 Aug 14 16:46 tptc.doc
#
echo 'x - tpcstmt.inc'
if test -f tpcstmt.inc; then echo 'shar: not overwriting tpcstmt.inc'; else
sed 's/^X//' << '________This_Is_The_END________' > tpcstmt.inc
X
X(*
X * TPTC - Turbo Pascal to C translator
X *
X * (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
X *
X *)
X
X(********************************************************************)
X(*
X * control statement processors
X *    for, while, repeat, with, idents
X *
X * all expect tok to be keyword
X * all exit at end of statement with ltok as ; or end
X *
X *)
X
Xprocedure pfor;
Xvar
X   up:       boolean;
X   id:       string80;
X   low,high: string80;
X
Xbegin
X   if debug_parse then write(' ');
X
X   nospace := true;
X   puts('for (');
X   gettok;   {consume the FOR}
X
X   id := plvalue;
X   gettok;   {consume the :=}
X
X   low := pexpr;
X
X   if tok = 'TO' then
X      up := true
X   else
X
X   if tok = 'DOWNTO' then
X      up := false;
X
X   gettok;
X   high := pexpr;
X
X   if up then
X      puts(id+' = '+low+'; '+id+' <= '+high+'; '+id+'++) ')
X   else
X      puts(id+' = '+low+'; '+id+' >= '+high+'; '+id+'--) ');
X
X   nospace := false;
X   gettok;   {consume the DO}
X   pstatement;
Xend;
X
X
X(********************************************************************)
Xprocedure pwhile;
Xbegin
X   if debug_parse then write(' ');
X   gettok;   {consume the WHILE}
X
X   nospace := true;
X   puts('while ('+pexpr+') ');
X   nospace := false;
X
X   gettok;   {consume the DO}
X   pstatement;
Xend;
X
X
X(********************************************************************)
Xprocedure pwith;
Xvar
X   prefix: string;
X   levels: integer;
X   
Xbegin
X   if debug_parse then write(' ');
X   gettok;   {consume the WITH}
X
X   {warning('WITH not translated');}
X   levels := 0;
X   puts('{ ');
X   nospace := true;
X      
X   repeat
X      if tok[1] = ',' then 
X      begin
X         gettok;
X         newline;
X         puts('  ');
X      end;
X         
X      prefix := plvalue;
X      make_pointer(prefix);
X      
X      inc(levels);
X      inc(withlevel);
X      puts('void *with'+itoa(withlevel)+' = '+prefix+'; ');
X      
X   until tok[1] <> ',';
X   
X   nospace := false;
X   gettok;   {consume the DO}
X   
X   if tok[1] <> '{' then
X      pstatement
X   else
X
X   begin
X      gettok;                 {consume the open brace}
X   
X      while (tok[1] <> '}') and not recovery do
X      begin
X         pstatement;          {process the statement}
X   
X         if tok[1] = ';' then
X         begin
X            puttok;
X            gettok;           {get first token of next statement}
X         end;
X      end;
X      
X      gettok;                 {consume the close brace}
X   end;
X
X   puts('   } ');
X   newline;
X
X   if tok[1] = ';' then
X      gettok;
X
X   dec(withlevel,levels);
Xend;
X
X
X(********************************************************************)
Xprocedure prepeat;
Xbegin
X   if debug_parse then write(' ');
X   puts('do { ');
X   gettok;
X
X   while (tok <> 'UNTIL') and not recovery do
X   begin
X      pstatement;
X
X      if tok[1] = ';' then
X      begin
X         puttok;
X         gettok;
X      end;
X   end;
X
X   gettok;
X   nospace := true;
X   puts('}  while (!('+ pexpr+ '))');
X   nospace := false;
Xend;
X
X
X(********************************************************************)
Xprocedure pcase;
Xvar
X   ex:  string80;
X   ex2: string80;   
X   i:   integer;
X   c:   char;
X
Xbegin
X   if debug_parse then write(' ');
X   gettok;
X   ex := pexpr;
X   puts('switch ('+ex+') {');
X
X   gettok;   {consume the OF}
X
X   while (tok[1] <> '}') and (tok <> 'ELSE') and not recovery do
X   begin
X
X      repeat
X         if tok[1] = ',' then
X            gettok;
X
X         if tok = '..' then
X         begin
X            gettok;
X            ex2 := pexpr;
X            
X            if (ex2[1] = '''') or (ex2[1] = '"') then
X               for c := succ(ex[2]) to ex2[2] do
X               begin
X                  newline;
X                  puts('case '''+c+''':   ');
X               end
X            else
X            
X            if atoi(ex2) - atoi(ex) > 128 then
X            begin
X               ltok := ex+'..'+ex2;
X               warning('Gigantic case range');
X            end 
X            else
X            
X            for i := succ(atoi(ex)) to atoi(ex2) do
X            begin
X               newline;
X               write(ofd[unitlevel],'case ',i,':   ');
X            end;
X         end
X         else
X         
X         begin
X            ex := pexpr;
X            newline;
X            puts('case '+ex+':   ');
X         end;
X
X      until (tok[1] = ':') or recovery;
X      gettok;
X
X      if (tok[1] <> '}') and (tok <> 'ELSE') then
X         pstatement;
X      puts('break; ');
X      newline;
X
X      if tok[1] = ';' then
X         gettok;
X   end;
X
X   if tok = 'ELSE' then
X   begin
X      newline;
X      puts('default: ');
X      gettok;   {consume the else}
X
X      while (tok[1] <> '}') and not recovery do
X      begin
X         if (tok[1] <> '}') and (tok <> 'ELSE') then
X            pstatement;
X         if tok[1] = ';' then
X            gettok;
X      end;
X   end;
X
X   puttok;
X   gettok;
X
X   if tok[1] = ';' then
X      gettok;
Xend;
X
X
X(********************************************************************)
Xprocedure pif;
Xvar
X   pspace: integer;
Xbegin
X   if debug_parse then write(' ');
X   gettok;   {consume the IF}
X
X   pspace := length(spaces);
X   nospace := true;
X   puts('if ('+ pexpr+ ') ');
X   nospace := false;
X   
X   gettok;   {consume the THEN}
X
X   if (tok[1] <> '}') and (tok <> 'ELSE') then
X      pstatement;
X
X   if tok = 'ELSE' then
X   begin
X      spaces := copy(spaces,1,pspace);
X      if not linestart then
X         newline;
X      puts('else ');
X
X      gettok;
X      if tok[1] <> '}' then
X         pstatement;
X   end;
X
Xend;
X
X
X(********************************************************************)
Xprocedure pexit;
Xbegin
X   if debug_parse then write(' ');
X   puts('return;');
X
X   gettok;
X   if tok[1] = ';' then
X      gettok;
Xend;
X
X
X(********************************************************************)
Xprocedure pgoto;
Xvar
X   ex:  anystring;
X
Xbegin
X   gettok;                      {consume the goto}
X
X   if toktype = number then
X      ltok := 'label_' + ltok;  {modify numeric labels}
X
X   puts('goto '+ltok+';');
X
X   gettok;                      {consume the label}
X
X   if tok[1] = ';' then
X      gettok;
Xend;
X
X
X(********************************************************************)
Xprocedure phalt;
Xvar
X   ex: anystring;
X
Xbegin
X   if debug_parse then write(' ');
X   gettok;
X
X   if tok[1] = '(' then
X   begin
X      gettok;
X      ex := pexpr;
X      gettok;
X   end
X   else
X      ex := '0';     {default exit expression}
X
X   puts('exit('+ex+');');
X
X   if tok[1] = ';' then
X      gettok;
Xend;
X
X
X(********************************************************************)
Xprocedure pread;
Xvar
X   ctl:  string;
X   func: anystring;
X   ex:   paramlist;
X   p:    string;
X   ln:   boolean;
X   ty:   string[2];
X   i:    integer;
X
Xbegin
X   if debug_parse then write(' ');
X   
X   nospace := true;   {don't copy source whitespace to output during
X                       this processing.  this prevents spaces from
X                       getting moved around}
X
X   ln := tok = 'READLN';
X   nospace := true;
X   func := 'scanv(';
X
X   gettok;   {consume the read}
X
X   if tok[1] = '(' then
X   begin
X      gettok;
X
X      if ltok[1] = '[' then   {check for MT+ [addr(name)], form}
X      begin
X         gettok;   {consume the '[' }
X
X         if tok[1] = ']' then
X            func := 'scanf('
X         else
X
X         begin
X            gettok;   {consume the ADDR}
X            gettok;   {consume the '(' }
X            func := 'fiscanf(' + usetok + ',';
X            gettok;   {consume the ')'}
X         end;
X
X         gettok;   {consume the ']'}
X         if tok[1] = ',' then
X            gettok;
X      end;
X
X      ctl := '';
X      ex.n := 0;
X
X      while (tok[1] <> ')') and not recovery do
X      begin
X         p := pexpr;
X         ty := exprtype;
X
X         {convert to fprintf if first param is a file variable}
X         if (ex.n = 0) and (ty = '@') then
X            func := 'fscanv(' + p + ','
X         else
X
X         {process a new expression; add expressions to ex.id table
X          and append proper control codes to the control string}
X         begin
X            if ty <> 's' then
X               if p[1] = '*' then
X                  delete(p,1,1)
X               else
X                  p := '&' + p;
X            inc(ex.n);
X            if ex.n > maxparam then
X               fatal('Too many params (pread)');
X            ex.id[ex.n] := p;
X            ctl := ctl + '%'+ty;
X         end;
X
X         if tok[1] = ',' then
X            gettok;
X      end;
X
X      gettok;   {consume the )}
X
X      if ctl = '%s' then
X         ctl := '#';
X      if ln then
X         ctl := ctl + '\n';
X
X      if func[1] <> 'f' then
X         func := 'f' + func + 'stdin,';
X
X      puts(func+'"'+ctl+'"');
X      for i := 1 to ex.n do
X         puts(','+ex.id[i]);
X
X      puts(')');
X   end
X
X   else   {otherwise there is no param list}
X      if ln then
X         puts('scanf("\n")');
X
X   nospace := false;
X
X   if tok[1] = ';' then
X   begin
X      puttok;
X      gettok;
X   end
X   else
X
X   begin
X      puts('; ');
X      newline;
X   end;
X
Xend;
X
X
X(********************************************************************)
Xtype
X   write_modes = (m_write, m_writeln, m_str);
X
Xprocedure pwrite(mode: write_modes);
Xvar
X   ctl:  string;
X   func: anystring;
X   ex:   paramlist;
X   p:    string;
X   ty:   string[2];
X   i:    integer;
X
X   procedure addform(f: anystring);
X      {add a form parameter, special handling for form expressions}
X   begin
X      if isnumber(f) then
X         ctl := ctl + f      {pass literal form}
X      else
X      begin                      {insert form expression in parlist}
X         ctl := ctl + '*';
X         inc(ex.n);
X         if ex.n > maxparam then
X            fatal('Too many params (pwrite.form)');
X         ex.id[ex.n] := ex.id[ex.n-1];
X         ex.id[ex.n-1] := f;
X      end;
X   end;
X   
Xbegin
X   if debug_parse then write(' ');
X   
X   nospace := true;   {don't copy source whitespace to output during
X                       this processing.  this prevents spaces from
X                       getting moved around}
X
X   nospace := true;
X
X   if mode = m_str then
X      func := 'sbld('
X   else
X      func := 'printf(';
X      
X   gettok;   {consume the write}
X   
X   if tok[1] = '(' then
X   begin
X      gettok;   {consume the (}
X
X      if ltok[1] = '[' then   {check for MT+ [addr(name)], form}
X      begin
X         gettok;   {consume the '[' }
X
X         if tok[1] <> ']' then
X         begin
X            gettok;   {consume the ADDR}
X            gettok;   {consume the '(' }
X            func := 'iprintf(' + usetok + ',';
X            gettok;   {consume the ')'}
X         end;
X
X         gettok;   {consume the ']'}
X         if tok[1] = ',' then
X            gettok;
X      end;
X
X      ctl := '';
X      ex.n := 0;
X
X      while (tok[1] <> ')') and not recovery do
X      begin
X         p := pexpr;
X         ty := exprtype;
X
X         {convert to fprintf if first param is a file variable}
X         if (ex.n = 0) and (ty = '@') then
X            func := 'fprintf(' + p + ','
X         else
X
X         {process a new expression; add expressions to ex.id table
X          and append proper control codes to the control string}
X         begin
X            inc(ex.n);
X            if ex.n > maxparam then
X               fatal('Too many params (pwrite)');
X            ex.id[ex.n] := p;
X
X            if ty = 'D' then
X               ty := 'ld';
X            if ty = 'b' then
X               ty := 'd';
X
X            {decode optional form parameters}
X            if tok[1] = ':' then
X            begin
X               ctl := ctl + '%';
X               gettok;
X               addform(pexpr);               
X               
X               if tok[1] = ':' then
X               begin
X                  ctl := ctl + '.';
X                  gettok;
X                  addform(pexpr);
X                  ty := 'f';
X               end;
X               
X               ctl := ctl + ty;
X            end
X            else
X
X            begin
X               {pass literals into the control string}
X               if (p[1] = '"') or (p[1] = '''') then
X               begin
X                  ctl := ctl + copy(p,2,length(p)-2);
X                  dec(ex.n);
X               end
X
X               {otherwise put in the control string for this param}
X               else
X                  ctl := ctl + '%'+ty;
X            end;
X         end;
X
X         if tok[1] = ',' then
X            gettok;
X      end;
X
X      gettok;   {consume the )}
X
X      {add newline in 'writeln' translation}
X      if mode = m_writeln then
X         ctl := ctl + '\n';
X
X      {convert last parameter into destination in 'str' translation}
X      if mode = m_str then
X      begin
X         func := func + ex.id[ex.n] + ',';
X         dec(ex.n);
X         delete(ctl,length(ctl)-1,2);
X      end;
X
X      {produce the translated statement}
X      puts(func+'"'+ctl+'"');
X      for i := 1 to ex.n do
X         puts(','+ex.id[i]);
X
X      puts(')');
X   end
X
X   else   {otherwise there is no param list}
X      if mode = m_writeln then
X         puts('printf("\n")');
X
X   nospace := false;
X
X   if tok[1] = ';' then
X   begin
X      puttok;
X      gettok;
X   end
X   else
X
X   begin
X      puts('; ');
X      newline;
X   end;
X
Xend;
X
X
X(********************************************************************)
Xprocedure pnew;
Xvar
X   lv: string;
Xbegin
X   if debug_parse then write(' ');
X
X   gettok;   {consume the new}
X   gettok;   {consume the (}
X
X   lv := plvalue;
X   puts(lv+' = malloc(sizeof(*'+lv+'));');
X
X   gettok;   {consume the )}
X   if tok[1] = ';' then
X      gettok;
Xend;
X
X
X(********************************************************************)
Xprocedure pport(kw: string);
X   {translate port/portw/mem/memw}
Xvar
X   lv: string;
X
Xbegin
X   if debug_parse then write(' ');
X   lv := kw + '(';
X
X   gettok;     {consume the keyword}
X   gettok;     {consume the [ }
X
X   repeat
X      lv := lv + pexpr;
X      if tok[1] = ':' then
X      begin
X         gettok;
X         lv := lv + ',';
X      end;
X   until (tok[1] = ']') or recovery;
X
X   gettok;     {consume the ] }
X
X   if tok = ':=' then
X   begin
X      gettok;       {consume :=, assignment statement}
X      lv := lv + ',' + pexpr;
X   end;
X
X   puts(lv+');');
X
X   if tok[1] = ';' then
X      gettok;
Xend;
X
X
X(********************************************************************)
Xprocedure pinline;
X   {translate inline statements}
X
Xvar
X   sixteen: boolean;
X
Xbegin
X   if debug_parse then write(' ');
X
X   gettok;     {consume the keyword}
X   nospace := true;
X   gettok;
X
X   while (tok[1] <> ')') and not recovery do
X   begin
X      if tok[1] = '/' then
X         gettok;
X
X      if tok[1] = '>' then
X      begin
X         gettok;
X         sixteen := true;
X      end
X      else
X         sixteen := htoi(ltok) > $00ff;
X
X      putline;
X      if sixteen then
X         puts('      asm DW '+ltok+'; ')
X      else
X         puts('      asm DB '+ltok+'; ');
X      gettok;
X   end;
X
X   nospace := false;
X   gettok;     {consume the ) }
X
X   if tok[1] = ';' then
X      gettok;
Xend;
X
X
X(********************************************************************)
Xprocedure pident;
X   {parse statements starting with an identifier;  these are either
X    assignment statements, function calls, return-value assignments,
X    or label identifiers}
Xvar
X   ex: string;
X   lv: string;
X   lvt,ext: char;
X
Xbegin
X   if debug_parse then write(' ');
X
X   nospace := true;   {don't copy source whitespace to output during
X                       this processing.  this prevents spaces from
X                       getting moved around}
X
X   lv := plvalue;     {destination variable or function name}
X   lvt := exprtype;   {destination data type}
X
X   if tok = ':=' then
X   begin
X      if debug_parse then write(' ');
X      
X      gettok;       {consume :=, assignment statement}
X      ex := pexpr;
X      ext := exprtype;
X
X      if iscall(lv) then      {assignment to function name}
X         puts('return '+ex)
X      else
X
X      begin
X         if copy(ex,1,5) = 'scat(' then
X            puts('sbld('+lv+',' + copy(ex,6,255))
X         else
X
X         if lvt = 's' then
X            if ext = 's' then
X               puts('strcpy('+lv+','+ex+')')
X            else
X               puts('sbld('+lv+',"%'+ext+'",'+ex+')')
X         else
X
X         if lvt = 'c' then
X            if ext = 's' then
X               puts(lv+' = first('+ex+')')
X            else
X               puts(lv+' = '+ex)
X         else
X            puts(lv+' = '+ex);
X      end;
X   end
X   else
X
X   if tok[1] = ':' then
X   begin
X      if debug_parse then write('