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" <alan@leadsv.UUCP>
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(' <for>');
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(' <while>');
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(' <with>');
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(' <repeat>');
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(' <case>');
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(' <if>');
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(' <exit>');
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(' <halt>');
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(' <read>');
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(' <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(' <new>');
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(' <port>');
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(' <inline>');
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(' <ident>');
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(' <assign>');
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(' <label>');
X      
X      putline;
X      puts(lv+': ');
X
X      gettok;       {label identifier}
X
X      if tok[1] = ';' then
X         gettok;
X
X      exit;
X   end
X   else
X
X   begin   
X      if debug_parse then write(' <call>');
X
X      if iscall(lv) then
X         puts(lv)
X      else
X         puts(lv+'()');
X   end;
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
X
X(********************************************************************)
Xprocedure pnumlabel;
X   {parse statements starting with an number;  these must be
X    numeric labels}
Xbegin
X   if debug_parse then write(' <numlabel>');
X   putline;
X   puts('label_'+tok+': ');
X
X   gettok;      {consume the number}
X   gettok;      {consume the :}
Xend;
X
X
X(********************************************************************)
Xprocedure plabel;
X   {parse (and throw away) a label section}
Xbegin
X   if debug_parse then write(' <label>');
X
X   while tok[1] <> ';' do
X      gettok;
X
X   gettok;
Xend;
X
X
X
X
X(********************************************************************)
X(*
X * process single statement
X *
X * expects tok to be first token of statement
X * processes nested blocks
X * exits with tok as end of statement
X *
X *)
X
Xprocedure pstatement;
Xvar
X   builtin: boolean;
X   
Xbegin
X
X   if recovery then
X   begin
X      while tok[1] <> ';' do
X         gettok;
X      gettok;
X      {warning('Error recovery (pstatement)');}
X      recovery := false;
X      exit;
X   end;
X   
X   if (toktype = identifier) and (cursym <> nil) then
X      builtin := cursym^.suptype = ss_builtin
X   else
X      builtin := false;
X
X   if debug_parse then write(' <stmt>');
X
X   if toktype = number then
X      pnumlabel
X   else
X   
X   case tok[1] of
X   '.':
X      exit;
X
X   ';':
X      begin
X         puts('; ');
X         gettok;
X      end;
X      
X   '{':
X      pblock;
X
X   'C':
X      if tok = 'CASE' then
X         pcase
X      else
X         pident;
X
X   'E':
X      if builtin and (tok = 'EXIT') then
X         pexit
X      else
X         pident;
X
X   'F':
X      if tok = 'FOR' then
X         pfor
X      else
X         pident;
X      
X   'G':
X      if tok = 'GOTO' then
X         pgoto
X      else
X         pident;
X         
X   'H':
X      if tok = 'HALT' then
X         phalt
X      else
X         pident;
X         
X   'I':
X      if tok = 'IF' then
X         pif
X      else
X      if tok = 'INLINE' then
X         pinline
X      else
X         pident;
X         
X   'M':
X      if builtin and (tok = 'MEM') then
X         pport('pokeb')
X      else
X      if builtin and (tok = 'MEMW') then
X         pport('poke')
X      else
X         pident;
X         
X   'N':
X      if tok = 'NEW' then
X         pnew
X      else
X         pident;
X         
X   'P':
X      if builtin and (tok = 'PORT') then
X         pport('outportb')
X      else
X      if builtin and (tok = 'PORTW') then
X         pport('outport')
X      else
X         pident;
X         
X   'R':
X      if tok = 'REPEAT' then
X         prepeat
X      else
X      if tok = 'READ' then
X         pread
X      else
X      if tok = 'READLN' then
X         pread
X      else
X         pident;
X
X   'S':
X      if builtin and (tok = 'STR') then
X         pwrite(m_str)
X      else
X         pident;
X                  
X   'W':
X      if tok = 'WHILE' then
X         pwhile
X      else
X      if tok = 'WITH' then
X         pwith
X      else
X      if tok = 'WRITE' then
X         pwrite(m_write)
X      else
X      if tok = 'WRITELN' then
X         pwrite(m_writeln)
X      else
X         pident;
X   else
X      pident;
X   end;
Xend;
X
X
X(********************************************************************)
X(*
X * process begin...end blocks
X *
X * expects tok to be begin
X * exits with tok = end
X *
X *)
X
Xprocedure pblock;
Xbegin
X   if debug_parse then write(' <block>');
X
X   puts('{ ');
X   gettok;                 {get first token of first statement}
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   if not linestart then
X      newline;
X      
X   puttok;                 {put the closing brace}
X
X   gettok;
X   if tok[1] = ';' then
X      gettok;
Xend;
X
X
X(********************************************************************)
X(*
X * process interface, implementation and uses statements
X *
X *)
X
X(********************************************************************)
Xprocedure puses;
X   {parse a uses clause}
Xbegin
X   if debug_parse then write(' <uses>');
X
X   gettok;     {consume the USES}
X   
X   repeat
X
X      {generate an include for the unit header file}
X      puts('#include "'+ltok+'.UNH"');
X      newline;                      
X      
X      {load the saved unit header symbol table}
X      load_unitfile(ltok+'.UNS',globals);
X
X      {move interface section to skip new entries}
X      top_interface := globals;     
X      
X      gettok;                       {consume the unit name}
X      if tok[1] = ',' then
X         gettok;
X   until (tok[1] = ';') or recovery;
X   
Xend;
X
X
X(********************************************************************)
Xprocedure pinterface;
Xbegin
X   if debug_parse then write(' <interface>');
X   gettok;
X   if tok = 'USES' then
X      puses;
X      
X   in_interface := true;
X   top_interface := globals;
X
X   putline;
X   putln('#define extern /* globals defined here */');
X   putln('#include "'+unitname+'.UNH"');
X   putln('#undef extern');
X   
X   inc(unitlevel);
X   assign(ofd[unitlevel],unitname+'.UNH');
X   rewrite(ofd[unitlevel]);
X   getmem(outbuf[unitlevel],inbufsiz);
X   SetTextBuf(ofd[unitlevel],outbuf[unitlevel]^,inbufsiz);
X
X   putline;
X   putln('/* Unit header for: '+outname+' -- Made by '+version1+' */');
X
X   if tok[1] = ';' then
X      gettok;
Xend;
X
X
X(********************************************************************)
Xprocedure pimplementation;
Xbegin
X   if debug_parse then write(' <implementation>');
X   if not in_interface then
X      exit;
X   in_interface := false;
X
X   {terminate the .unh file being generated}
X   close(ofd[unitlevel]);
X   freemem(outbuf[unitlevel],inbufsiz);
X   dec(unitlevel);
X   
X   {create the requested unit symbol file}
X   create_unitfile(unitname+'.UNS',globals,top_interface);
X
X   gettok;
Xend;
X
X
________This_Is_The_END________
if test `wc -c < tpcstmt.inc` -ne 22616; then
	echo 'shar: tpcstmt.inc was damaged during transit (should have been 22616 bytes)'
fi
fi		; : end of overwriting check
echo 'x - tpcsym.inc'
if test -f tpcsym.inc; then echo 'shar: not overwriting tpcsym.inc'; else
sed 's/^X//' << '________This_Is_The_END________' > tpcsym.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(********************************************************************)
Xfunction findsym( table: symptr;
X                  id:    string40): symptr;
X   {locate a symbol in a specified symbol table.  returns pointer to
X    the entry if found, otherwise nil is returned}
Xvar
X   sym: symptr;
X   
Xbegin
X   stoupper(id);
X   
X   sym := table;
X   while sym <> nil do
X   begin
X
X      if sym^.id[1] = id[1] then             {for speed, try first char}
X      if length(sym^.id) = length(id) then   {... then verify length}
X      if sym^.id = id then                   {... finally compare strings}
X      begin
X         findsym := sym;    {symbol found}
X         exit;
X      end;
X
X      sym := sym^.next;
X   end;
X
X   findsym := nil;   {symbol not found}
Xend;
X
X
X(********************************************************************)
Xfunction locatesym(id:    string40): symptr;
X   {locate a symbol in either the local or the global symbol table.
X    returns the symbol table entry pointer, if found.  returns
X    nil when not in either table}
Xvar
X   sym: symptr;
X
Xbegin
X   if id[1] = '^' then
X      delete(id,1,1);
X      
X   sym := findsym(locals,id);
X   if sym = nil then
X      sym := findsym(globals,id);
X
X   locatesym := sym;
Xend;
X
X
X(********************************************************************)
Xprocedure addsym( var table: symptr;
X                  id:        string40;
X                  symtype:   symtypes;
X                  suptype:   supertypes;
X                  parcount:  integer;
X                  varmap:    integer;
X                  lim:       integer;
X                  base:      integer;
X                  dup_ok:    boolean);
X   {add a symbol to a specific symbol table.  duplicates hide prior entries.
X    new symbol pointed to by cursym}
Xbegin
X   if maxavail-300 < sizeof(cursym^) then
X   begin
X      ltok := id;
X      fatal('Out of memory');
X   end;
X
X   if (not dup_ok) and (not in_interface) then
X   begin
X      cursym := findsym(table,id);
X      if cursym <> nil then
X      begin
X         ltok := id;
X         if (cursym^.parcount <> parcount) or 
X            (cursym^.symtype <> symtype) or (cursym^.limit <> lim) then
X            warning('Redeclaration not identical');
X         ltok := tok;
X      end;
X   end;
X   
X   new(cursym);
X   cursym^.next := table;
X   table := cursym;
X
X   cursym^.repid := decl_prefix + id;
X   stoupper(id);
X   cursym^.id := id;
X   cursym^.symtype := symtype;
X   cursym^.suptype := suptype;
X   cursym^.parcount := parcount;
X   cursym^.limit := lim;
X   cursym^.base := base;
X   cursym^.pvar := varmap;
Xend;
X
X
X(********************************************************************)
Xprocedure newsym( id:       string40;
X                  symtype:  symtypes;
X                  suptype:  supertypes;
X                  parcount: integer;
X                  varmap:   integer;
X                  lim:      integer;
X                  base:     integer);
X   {enter a new symbol into the current symbol table (local or global)}
Xbegin
X   if (unitlevel = 0) or (in_interface) then
X      addsym(globals,id,symtype,suptype,parcount,varmap,lim,base,false)
X   else
X      addsym(locals,id,symtype,suptype,parcount,varmap,lim,base,true);
Xend;
X
X
X
X(********************************************************************)
Xprocedure dumptable(sym: symptr; top: symptr);
X   {dump entries from the specified symbol table, stopping where indicated}
Xvar
X   info: string40;
X   
Xbegin
X      
X   if (not dumpsymbols) or (sym = nil) or (sym = top) then
X      exit;
X
X   {putline;}
X   putln('/* User symbols:');
X   putln(' *    Class        Type        Base   Limit Pars  Pvar   Identifier');
X   putln(' *   ------------ ------------ ----- ------ ---- ------ --------------');
X   
X   while (sym <> nil) and (sym <> top) do
X   begin
X   
X      if sym^.repid = '<predef>' then
X      begin
X         if dumppredef then
X         begin
X            putln(' *');
X            putln(' * Predefined symbols:');
X            putln(' *    Class        Type        Base   Limit Pars  Pvar   Identifier');
X            putln(' *   ------------ ------------ ----- ------ ---- ------ --------------');
X         end
X         else
X            sym := nil;
X      end
X      else
X      
X      begin         
X         write(ofd[unitlevel],' *    ',
X           ljust(supertypename[sym^.suptype],13),
X           ljust(typename[sym^.symtype],12),
X           sym^.base:5,' ',
X           sym^.limit:6,' ',
X           sym^.parcount:4,' ',
X           sym^.pvar:6,'   ',
X           sym^.repid);
X         putline;
X      end;
X
X      if sym <> nil then
X         sym := sym^.next;
X   end;
X
X   putln(' */');
X   putline;
Xend;
X
X
X(********************************************************************)
Xprocedure purgetable( var table: symptr; top: symptr);
X   {purge all entries from the specified symbol table}
Xvar
X   sym: symptr;
X
Xbegin
X   dumptable(table, top);
X   
X   while (table <> nil) and (table <> top) do
X   begin
X      sym := table;
X      table := table^.next;
X
X      {if sym^.suptype = ss_const then
X         putln('#undef '+sym^.repid);}
X         
X      dispose(sym);
X   end;
Xend;
X
X
X(********************************************************************)
Xprocedure create_unitfile(name: string64; sym, top: symptr);
X   {dump symbol table to the specified unit symbol file}
Xvar
X   fd:      text;
X   outbuf:  array[1..inbufsiz] of byte;
X   
Xbegin
X   assign(fd,name);
X{$I-}
X   rewrite(fd);
X{$I+}
X   if ioresult <> 0 then
X   begin
X      ltok := name;
X      fatal('Can''t create unit symbol file');
X   end;
X   
X   setTextBuf(fd,outbuf);
X
X   while (sym <> nil) and (sym <> top) do
X   begin
X      writeln(fd,sym^.id);
X      writeln(fd,sym^.repid);
X      writeln(fd,ord(sym^.suptype),' ',
X                 ord(sym^.symtype),' ',
X                 sym^.base,' ',
X                 sym^.limit,' ',
X                 sym^.parcount,' ',
X                 sym^.pvar);
X      
X      inc(objtotal,3);
X      sym := sym^.next;
X   end;
X
X   close(fd);
Xend;
X
X
X(********************************************************************)
Xprocedure load_unitfile(name: string64; var table: symptr);
X   {load symbol table fromthe specified unit symbol file}
Xvar
X   fd:      text;
X   sym:     symptr;
X   sstype:  byte;
X   stype:   byte;
X   inbuf:   array[1..inbufsiz] of byte;
X      
Xbegin
X   assign(fd,name);
X   {$I-} reset(fd); {$I+}
X   if ioresult <> 0 then
X   begin
X      name := symdir + name;
X      assign(fd,name);
X      {$I-} reset(fd); {$I+}
X   end;
X   
X   if ioresult <> 0 then
X   begin
X      ltok := name;
X      fatal('Can''t open unit symbol file');
X   end;
X   
X   setTextBuf(fd,inbuf);
X   
X   while not eof(fd) do
X   begin
X      new(sym);
X      sym^.next := table;
X      table := sym;
X      
X      readln(fd,sym^.id);
X      readln(fd,sym^.repid);
X      readln(fd,sstype,stype,
X                sym^.base,
X                sym^.limit,
X                sym^.parcount,
X                sym^.pvar);
X
X      sym^.suptype := supertypes(sstype);
X      sym^.symtype := symtypes(stype);
X   end;
X
X   close(fd);
Xend;
X
X
________This_Is_The_END________
if test `wc -c < tpcsym.inc` -ne 7059; then
	echo 'shar: tpcsym.inc was damaged during transit (should have been 7059 bytes)'
fi
fi		; : end of overwriting check
echo 'x - tpcunit.inc'
if test -f tpcunit.inc; then echo 'shar: not overwriting tpcunit.inc'; else
sed 's/^X//' << '________This_Is_The_END________' > tpcunit.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(*
X * process generic declaration section
X *   dispatches to const, type, var, proc, func
X *   enter with tok=section type
X *   exit with tok=next section type
X *
X *)
X
Xprocedure psection;
Xbegin
X   if recovery then
X   begin
X      while toktype <> keyword do
X         gettok;
X      {warning('Error recovery (psection)');}
X      recovery := false;
X   end;
X
X   if debug_parse then write(' <section>');
X
X   if (tok = 'EXTERNAL')  or (tok = 'OVERLAY') or
X      (tok = 'PROCEDURE') or (tok = 'FUNCTION') then
X      punit
X   else
X
X   if tok = 'INTERFACE' then
X      pinterface
X   else
X   
X   if tok = 'IMPLEMENTATION' then
X      pimplementation
X   else
X   
X   if tok = 'USES' then
X   begin
X      puses;
X      if tok[1] = ';' then 
X         gettok;
X   end
X   else
X   
X   if tok = 'UNIT' then
X      comment_statement
X   else
X   
X   if tok = 'CONST' then
X      pconst
X   else
X
X   if tok = 'TYPE' then
X      ptype
X   else
X
X   if tok = 'VAR' then
X      pvar
X   else
X
X   if tok = 'LABEL' then
X      plabel
X   else
X
X   if tok[1] = '{' then
X      pblock
X   else
X
X   if (tok[1] = '.') or (tok[1] = '}') then
X   begin
X      tok := '.';
X      exit;
X   end
X   else
X      syntax('Section header expected (psection)');
Xend;
X
X
X(********************************************************************)
X(*
X * process argument declarations to
X *    program, procedure, function
X *
X * enter with header as tok
X * exits with tok as ; or :
X *
X *)
X
Xconst
X   extern = true;
X   
Xprocedure punitheader(is_external: boolean);
Xvar
X   proc:    string40;
X   proclit: string40;
X   vars:    paramlist;
X   types:   paramlist;
X   bases:   array [1..maxparam] of integer;
X   i:       integer;
X   ii:      integer;
X   rtype:   string40;
X   varval:  integer;
X   varon:   boolean;
X   locvar:  integer;
X   iptr:    integer;
X
Xbegin
X   gettok;                 {skip unit type}
X   proclit := ltok;
X
X   if (unitlevel > 1) and (not in_interface) then
X   begin
X      {make name unique if it clashes with an existing global}
X      if cursym = nil then
X         proc := proclit
X      else
X         proc := procnum + '_' + proclit;
X         
X      warning('Nested function');
X      
X      writeln(ofd[unitlevel-1],^M^J'   /* Nested function: ',proc,' */ ');
X      inc(objtotal,2);
X   end
X   else
X      proc := proclit;
X
X   gettok;                 {skip unit identifier}
X
X   vars.n := 0;
X   varval := 0;       { 0 bit means value, 1 = var }
X   varon  := false;
X
X   (* process param list, if any *)
X   if tok[1] = '(' then
X   begin
X      gettok;
X
X      while (tok[1] <> ')') and not recovery do
X      begin
X
X         ii := vars.n + 1;
X         repeat
X            if tok[1] = ',' then
X               gettok;
X
X            if tok = 'VAR' then
X            begin
X               gettok;
X               varon := true;
X            end;
X
X            inc(vars.n);
X            if vars.n > maxparam then
X               fatal('Too many params (punitheader)');
X            vars.id[vars.n] := ltok;
X            gettok;
X
X         until tok[1] <> ',';
X
X         if tok[1] = ':' then       
X         begin
X            gettok;   {consume the :}
X   
X            {parse the param type}
X            rtype := psimpletype;
X         end
X         else
X
X         begin    {untyped variable if ':' is missing}
X            rtype := 'void';
X            curtype := s_void;
X            curbase := 0;
X            cursuptype := ss_scalar; {ss_array?}
X         end;
X
X         {assign and param types, converting 'var' and 'array' params}
X         iptr := 0;
X         if rtype[1] = '^' then
X            rtype[1] := '*';
X
X         {flag var parameters; strings and arrays are implicitly var in C}
X         if varon and (curtype <> s_string) and (cursuptype <> ss_array) then
X            iptr := 1 shl (ii - 1);
X
X         if curtype = s_string then
X            rtype := 'char *'
X         else
X         if cursuptype = ss_array then
X            rtype := typename[curtype] + ' *';
X
X         {assign data types for each ident}
X         for i := ii to vars.n do   
X         begin
X            types.id[i] := rtype;
X            types.stype[i] := curtype;
X            types.sstype[i] := cursuptype;
X            bases[i] := curbase;
X            varval := varval or iptr;
X            iptr := iptr shl 1;
X         end;
X
X         if tok[1] = ';' then
X         begin
X            gettok;
X            varon := false;
X         end;
X
X      end;   {) seen}
X
X      gettok;   {consume the )}
X   end;
X
X   (* process function return type, if any *)
X   if tok[1] = ':' then
X   begin
X      gettok;            {consume the :}
X      rtype := psimpletype;
X
X      if curtype = s_string then
X         rtype := 'char *'
X      else
X      if cursuptype = ss_array then
X         rtype := typename[curtype] + ' *';
X   end
X   else
X
X   begin
X      rtype := 'void';
X      curtype := s_void;
X   end;
X
X   putline;
X   
X   (* prefix procedure decl's when external *)
X   if is_external then
X   begin
X      putln(ljust('extern '+rtype,identlen)+proc+'();');
X      addsym(globals,proc,curtype,ss_func,0,varval,0,9,false);
X      exit;
X   end;
X
X
X   (* process 'as NEWNAME' clause, if present (tptc extention to specify
X      the replacement name in the symbol table *)
X   if tok = 'AS' then
X   begin
X      gettok;
X      proc := usetok;
X   end;
X    
X
X   (* output the return type, proc name, formal param list *)
X   if in_interface then
X      rtype := 'extern '+rtype;
X   puts(ljust(rtype,identlen)+proc+'(');
X
X   if vars.n = 0 then
X      puts('void');
X
X
X   (* output the formal param declarations *)
X   locvar := varval;
X   for i := 1 to vars.n do
X   begin
X      iptr := -1;
X
X      if (locvar and 1) = 1 then
X      begin
X         iptr := -2;
X         types.id[i] := types.id[i] + ' *';
X      end;
X
X      puts(ljust(types.id[i],identlen)+vars.id[i]);
X      addsym(locals,vars.id[i],types.stype[i],ss_scalar,iptr,0,0,bases[i],true);
X      locvar := locvar shr 1;
X
X      if i < vars.n then
X      begin
X         putln(','); 
X         puts(ljust('',identlen+length(proc)+1));
X      end;
X   end;
X
X   puts(')');
X   nospace := false;
X
X   {enter the procedure in the global symbol table}
X   addsym(globals,proclit,curtype,ss_func,vars.n,varval,0,0,false);
X   cursym^.repid := proc;
Xend;
X
X
X(********************************************************************)
X(*
X * process body of program unit
X *   handles all declaration sections
X *   and a single begin...end
X *   recursively handles procedure declarations
X *   ends with tok=}
X *)
X
Xprocedure punitbody;
Xbegin
X   gettok;
X
X   if tok = 'INTERRUPT' then
X   begin
X      warning('Interrupt handler');
X      gettok;
X   end;
X   
X   if tok = 'FORWARD' then
X   begin
X      puts(';');
X      gettok;
X   end
X   else
X
X   if tok = 'EXTERNAL' then
X   begin
X      puts('/* ');
X      repeat
X         puttok;
X         gettok;
X      until tok[1] = ';';
X      puts(' */ ;');
X   end
X   else
X
X   if tok = 'INLINE' then
X   begin
X      newline;
X      putln('{');
X      puts('   ');
X      pinline;
X      putln('}');
X   end
X   else
X
X   begin
X      puts('{ ');
X
X      repeat
X         if tok[1] = ';' then
X         begin
X            puttok;
X            gettok;
X         end;
X
X         if tok[1] <> '{' then
X            psection;
X      until tok[1] = '{';
X
X      gettok;                 {get first token of first statement}
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      puttok;
X   end;
Xend;
X
X
X(********************************************************************)
Xprocedure enter_procdef;
X   {increase output file level and direct output to the new file}
Xvar
X   nam:  anystring;
Xbegin
X   {increment this procedure number}
X   inc(procnum[2]);
X   if procnum[2] > 'Z' then
X   begin
X      inc(procnum[1]);
X      procnum[2] := 'A';
X   end;
X
X   inc(unitlevel);
X   if unitlevel > maxnest then
X      fatal('Functions nested too deeply');
X
X   str(unitlevel,nam);
X   nam := workdir + nestfile + nam;
X
X   assign(ofd[unitlevel],nam);
X   {$i-} rewrite(ofd[unitlevel]); {$i+}
X
X   if ioresult <> 0 then
X   begin
X      dec(unitlevel);
X      ltok := nam;
X      fatal('Can''t create tempfile');
X   end;
X
X   if maxavail-300 <= inbufsiz then
X   begin
X      ltok := nam;
X      fatal('Out of memory');
X   end;
X
X   getmem(outbuf[unitlevel],inbufsiz);
X   SetTextBuf(ofd[unitlevel],outbuf[unitlevel]^,inbufsiz);
Xend;
X
X
X(********************************************************************)
Xprocedure exit_procdef;
X   {copy the outer output file to the next lower level output
X    and reduce output level by 1}
Xvar
X   line:  string;
X
Xbegin
X   if unitlevel < 1 then 
X      exit;
X   
X   close(ofd[unitlevel]);
X   reset(ofd[unitlevel]);
X   SetTextBuf(ofd[unitlevel],outbuf[unitlevel]^,inbufsiz);
X
X   while not eof(ofd[unitlevel]) do
X   begin
X      readln(ofd[unitlevel],line);
X      writeln(ofd[0],line);
X   end;
X
X   close(ofd[unitlevel]);
X   erase(ofd[unitlevel]);
X   freemem(outbuf[unitlevel],inbufsiz);
X   dec(unitlevel);
Xend;
X
X
X(********************************************************************)
X(*
X * process program, procedure and function declaration
X *
X * enter with tok=function
X * exit with tok=;
X *
X *)
X
Xprocedure punit;
Xvar
X   top: symptr;
Xbegin
X   if debug_parse then write(' <unit>');
X
X   nospace := true;
X   top := locals;
X
X   if (tok = 'OVERLAY') then
X      gettok;
X
X   if (tok = 'EXTERNAL') then  {mt+}
X   begin
X      gettok;      {consume the EXTERNAL}
X
X      if tok[1] = '[' then
X      begin
X         gettok;   {consume the '['}
Xi         puts('/* overlay '+ltok+' */ ');
X         gettok;   {consume the overlay number}
X
X         gettok;   {consume the ']'}
X      end;
X
X      punitheader(extern);
X      if tok[1] = ';' then
X         gettok;
X      purgetable(locals,top);
X   end
X   else
X
X   if in_interface then
X   begin
X      nospace := false;
X      punitheader(not extern);
X
X      puts(';');
X      if tok[1] = ';' then
X         gettok;
X      
X      if tok = 'INLINE' then
X      begin
X         pinline;
X         warning('Inline procedure');
X      end;
X
X      purgetable(locals,top);
X   end
X   else
X   
X   begin
X      {enter a (possibly nested) procedure}
X      enter_procdef;
X
X      punitheader(not extern);
X      punitbody;
X      gettok;
X      if tok[1] = ';' then
X         gettok;
X      purgetable(locals,top);
X
X      {exit the (possibly nested) procedure, append text to toplevel outfile}
X      exit_procdef;
X   end;
X
Xend;
X
X
X
X(********************************************************************)
X(*
X * process main program
X *
X *  expects program head
X *  optional declarations
X *  block of main code
X *  .
X *
X *)
X
Xprocedure pprogram;
Xbegin
X   putline;
X   putln('/*');
X   putln(' * Generated by '+version1);
X   putln(' *     '+version2);
X   putln(' */');
X   putln('#include "tptcmac.h"');
X   
X   getchar;  {get first char}
X   gettok;   {get first token}
X
X   if (tok = 'PROGRAM') or (tok = 'UNIT') then
X   begin
X      comment_statement;
X      gettok;
X   end;
X
X   if tok = 'MODULE' then
X   begin
X      mt_plus := true;   {shift into pascal/mt+ mode}
X      comment_statement;
X      gettok;
X   end;
X
X   repeat
X      if tok[1] = ';' then
X      begin
X         puttok;
X         gettok;
X      end;
X
X      if tok = 'MODEND' then
X         exit;
X
X      if (tok[1] <> '{') then
X         psection;
X   until (tok[1] = '{') or (tok[1] = '.') or recovery;
X
X   {process the main block, if any}
X   if tok[1] = '{' then
X   begin
X      putline;
X      putln('main(int   argc,');
X      putln('     char  *argv[])');
X      
X      puttok;
X      gettok;                 {get first token of main block}
X   
X      while (tok[1] <> '}') and (tok[1] <> '.') 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      putln('}');
X   end;
X   
X   putline;
Xend;
X
________This_Is_The_END________
if test `wc -c < tpcunit.inc` -ne 12098; then
	echo 'shar: tpcunit.inc was damaged during transit (should have been 12098 bytes)'
fi
fi		; : end of overwriting check
echo 'x - tptc.doc'
if test -f tptc.doc; then echo 'shar: not overwriting tptc.doc'; else
sed 's/^X//' << '________This_Is_The_END________' > tptc.doc
X
X
X                       TPTC16 - Translate Pascal to C
X                           Version 1.6, 13-Feb-88
X
X                 (C) Copyright 1986, 1988 by Samuel H. Smith
X                            All rights reserved.
X
X
XThis program will read a turbo pascal source file and convert it into
Xthe  corresponding C source code.   It does much of the work required in
Xa full translation.
X
XUsage:   TPTC input_file [output_file] [options]
X
XWhere:   input_file      specifies the main source file, .PAS default
X         output_file     specifies the output file, .C default
X         -B              deBug trace during scan
X         -BP             deBug trace during Parse
X         -D              Dump user symbols
X         -DP             Dump Predefined system symbols
X         -I              output Include files' contents
X         -L              map all identifiers to Lower case
X         -M              use Pascal/MT+ specific translations
X         -NC             No Comments passed to output file
X         -Q              Quiet mode; suppress warnings
X         -Sdir\          search dir\ for .UNS symbol files
X         -Tnn            Tab nn columns in declarations
X         -Wdrive:        use drive: for Work/scratch files (ramdrive)
X         -#              don't translate lines starting with "#"
X
XDefault command parameters are loaded from TPTC environment variable.
X
XExample: tptc fmap
X         tptc fmap -L -d -wj:\tmp\
X         tptc -l -d -wj: -i -q -t15 fmap.pas fmap.out
X
X         set tptc=-wj: -i -l -sc:\libs
X         tptc test       ;uses options specified earlier
X
X
XLICENSE
X=======
X
X   SourceWare: What is it?
X   -----------------------
X   SourceWare is my name for a unique concept in user supported software. 
X   
X   Programs distributed under the SourceWare concept always offer complete 
X   source code. 
X
X   This package can be freely distributed so long as it is not modified 
X   or sold for profit.  If you find that this program is valuable,  you 
X   can send me a donation for what you think it is worth.  I suggest
X   about $20.
X
X   Send your contributions to:
X      Samuel. H. Smith
X      5119 N. 11 ave 332
X      Phoenix, Az 85013
X
X
X   Why SourceWare?
X   ---------------
X   Why do I include source code?  Why isn't the donation manditory?  The
X   value of good software should be self-evident.  The source code is
X   the key to complete understanding of a program.  You can read it to
X   find out how things are done.  You can also change it to suit your
X   needs, so long as you do not distribute the modified version without
X   my consent.
X
X
X   Copyright
X   ---------
X   If you modify this program, I would appreciate a copy of the new
X   source code.   I am holding the copyright on the source code, so
X   please don't delete my name from the program files or from the
X   documentation.
X
X
XSUPPORT
X=======
X
X   I work very hard to produce a software package of the highest
X   quality and functionality.  I try to look into all reported bugs, and
X   will generally fix reported problems within a few days.
X
X   Since this is user supported software under the SourceWare  concept,
X   I don't expect you to contribute if you don't like it or if it
X   doesn't meet your needs.
X
X   If you have any questions, bugs, or suggestions, please contact  me
X   at:  The Tool Shop BBS (602) 279-2673
X
X   The latest version is always available for downloading. 
X
X   Enjoy!     Samuel H. Smith
X              Author and Sysop of The Tool Shop.
X
X
X
X
XThe following language constructs are translated:
X------------------------------------------------
X
X   Comments are translated from either {...} or (*...*) into /*...*/.
X
X   Begin and End are translated into { and }.
X
X   Const declarations are translated from
X      ID = VALUE
X   into
X      static ID = VALUE.
X
X   Simple Var declarations are translated from
X      ID TYPE
X   into
X      TYPE ID.
X
X   Integer subrange types are translated into integers.
X
X   Record types are translated from
X      ID = record MEMBER-LIST end
X   into
X      typedef struct { MEMBER-LIST } ID.
X
X   Enumeration types are translated from
X      ID = (...)
X   into
X      typedef enum {...} ID.
X
X   Array types are translated from
X      ID = array [RANGE] of TYPE
X   into
X      typedef TYPE ID[RANGE].
X
X   Pointer types are translated from
X      ID = ^DEFINED-TYPE
X   into
X      DEFINED-TYPE *ID.
X
X   String types are translated from
X      ID = string[N]
X   into
X      typedef char ID[N+1].
X
X   File types are translated from
X      ID = text[N]
X      ID = file
X   into
X      FILE *ID
X      int ID.
X
X   For statements are translated from
X      for VAR := FIRST to LAST do STATEMENT
X      for VAR := FIRST downto LAST do statement
X   into
X      for (VAR = FIRST; VAR <= LAST; VAR++) STATEMENT
X      for (VAR = FIRST; VAR >= LAST; VAR--) STATEMENT
X
X   While statements are translated from
X      while COND do STATEMENT
X   into
X      while (COND) statement.
X
X   Repeat statements are translated from
X      repeat STATEMENTS until COND
X   into
X      do { STATEMENTS } while(!COND).
X
X   If statements are translated from
X      if COND then STATEMENT else STATEMENT
X   into
X      if (COND) STATEMENT; else STATEMENT.
X
X   Case statements are translated from
X      case VALUE of
X         V:    STATEMENT;
X         V,U:  STATEMENT;
X         else  STATEMENT
X      end
X   into
X      switch (VALUE) {
X         case V:  STATEMENT; break;
X         case V:
X         case U:  STATEMENT; break;
X         default: STATEMENT;
X      }.
X      
X   Ranges in the form VAL..VAL automatically include cases for 
X   intermediate values.
X
X   The IN operator is translated from
X      VAL in [A,B,C]
X    into
X      inset(VAL, setof(A,B,C,-1)).
X
X   The ParamCount and ParamStr functions are translated from
X      paramcount
X      paramstr(n)
X   into
X      argc
X      argv[n].
X
X   Dummy parameter lists are added to function and procedure calls,
X   where they are required in C but not in Pascal.
X
X   The following expression operators are translated
X      from  DIV  to  / ,     MOD  to  % ,
X            AND  to  &&,     OR   to  ||,
X            XOR  to  ~ ,     <>   to  !=,
X            NOT  to  ! ,     SHR  to  >>,
X            SHL  to  <<,     =    to  ==,               {+others}
X            :=   to  = .
X   Bitwise AND and OR operators are translated into & and |.
X
X   The '^' symbol is translated
X      from  VAR^          to  *VAR,
X            VAR^.MEMBER   to  VAR->MEMBER.
X
X   Exit statements are translated
X      from  exit    to  return.
X
X   The New operator is translated from
X      new(VAR)
X   into
X      VAR = malloc(sizeof(*VAR)).
X
X
X   Procedure/function formal parameter lists are translated into the
X      new form defined in ANSI C (and as used by Turbo C):
X   from
X      function NAME(V1: TYPE1; V2: TYPE2): TYPE3
X   into
X      TYPE3 NAME(TYPE1 V1,TYPE2 V2)
X
X   Procedures are translated into functions with 'void' return types.
X
X   The special character literal syntax, ^C or #nn, is translated into
X   '\ooo', where ooo is the octal notation for the ascii code.
X
X   Hex constants $hhhh are translated into 0xhhhh.
X
X   Write and WriteLn are translated from:
X      write(VAR,VAR:n,VAR:n:m)
X      writeln(FILE,VAR,VAR,VAR)
X   into
X      printf("%d%nd%n.md",VAR,VAR,VAR)
X      fprintf(FILE,"%d%d%d\n",VAR,VAR,VAR).
X
X   Read and ReadLn are translated from:
X      read(VAR,VAR,VAR)
X      readln(FILE,VAR,VAR,VAR)
X   into
X      scanf("%d%nd%d",&VAR,&VAR,&VAR)
X      fscanf(FILE,"%d%d%d\n",&VAR,&VAR,&VAR).
X
X   String assignments are translated from:
X      VAR := "string"
X      VAR := "string1(" + VAR1 + ")string2"
X   into
X      strcpy(VAR, "string")
X      sbld(VAR,"string1(%s)string2",VAR1).      {+other compound forms}
X
X   String comparisons are translated from:
X      VAR == "string"
X      VAR < "string"
X      "string" >= VAR
X   into
X      (strcmp(VAR,"string") == 0)
X      (strcmp(VAR,"string") < 0)
X      (strcmp("string",VAR) >= 0).
X
X   Function value assignments are translated from:
X      FUN_NAME := expr
X   into
X      return expr.
X
X   Numeric statement labels are translated to label_nn.  
X   Label identifiers are not changed.  
X   Local GOTO statements are handled properly. 
X
X   Nested procedures are "flattened" out, but local variable sharing and 
X   local scoping are not translated. 
X
X   Direct I/O port and memory references are translated:
X      portw[expr] := expr + port[n]
X      mem[seg:ofs] := memw[seg:ofs] + expr
X   into
X      outport(expr, expr+inportb(n))
X      pokeb(seg,ofs, peek(seg,ofs)+expr)
X
X   VAR parameters are translated into pointer variables; 
X   references to formal parameters are implicitly dereferenced (i.e. * added);
X   references to actual parameters are implicitly referenced (i.e. & added).
X
X   Forward pointer type declarations are translated, but will not compile 
X   in C.  They must be manually recoded. 
X
X   Variant record type declarations are translated into unions.
X
X   Absolute variables are translated into initialized pointer variables.
X   
X
X
XSupport Pascal/MT+:
X-------------------
X
X   Var declarations are translated from
X      ID external TYPE
X   into
X      extern TYPE ID.
X
X   The following expression operators are translated
X      from   !   to  | ,    |    to   |,
X             &   to  & ,    ~    to   !,
X             ?   to  ! ,    \    to   !.
X
X   External function declarations are translated
X   from
X      external function NAME(V1: TYPE1; V2: TYPE2): TYPE3
X      external [n] function NAME(V1: TYPE1; V2: TYPE2): TYPE3
X   into
X      extern TYPE3 NAME()
X
X   External procedure declarations are translated
X   from
X      external procedure NAME(V1: TYPE1; V2: TYPE2)
X      external [n] procedure NAME(V1: TYPE1; V2: TYPE2)
X   into
X      extern void NAME()
X
X   Write and WriteLn are translated from:
X      write([ADDR(FUN)],VAR:n,VAR:n:m)
X      write([],VAR:n,VAR:n:m)
X   into
X      iprintf(FUN,"%nd%n.md",VAR,VAR)
X      printf("%nd%n.md",VAR,VAR)
X
X   Read and ReadLn are translated from:
X      read([ADDR(FUN)],VAR,VAR)
X      read([],VAR,VAR)
X   into
X      iscanf(FUN,"%d%nd%d",&VAR,&VAR,&VAR)
X      scanf("%d%nd%d",&VAR,&VAR,&VAR)
X
X   Long integer constants #nnn are translated into nnnL.
X
X
X
XSome language features that are not yet translated:
X---------------------------------------------------
X
X   File access procedures are only partially supported (assign, close, 
X   etc.). 
X
X   Variant record type decl's are translated into unions, but expressions
X   using the variant part are not translated.
X
X   C operator precedence differs from that of Pascal, and the differences 
X   are not translated. 
X
X   The WITH statement is not translated.
X
X   Local variable sharing among nested procedures is not translated. 
X
X
X
XRevision history
X----------------
X
X  See HISTORY.DOC for the complete revision history.
X  
X  I continue to update and improve TPTC.  If you have a program that
X  TPTC will not translate, please send me a copy of it.  This will help
X  me in future versions.  I will not redistribute the file without your
X  permission.
X
X  Send sample sources to:
X      Samuel. H. Smith
X      (602) 279-2673 (data)
X      5119 N. 11 ave 332
X      Phoenix, Az 85013
X
________This_Is_The_END________
if test `wc -c < tptc.doc` -ne 11061; then
	echo 'shar: tptc.doc was damaged during transit (should have been 11061 bytes)'
fi
fi		; : end of overwriting check
exit 0