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

Text File | 1993-01-04 | 13.8 KB | 625 lines

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


(*
 * expression parser
 *
 *)

function iscall(var lv: string255): boolean;
   {see if the given lvalue is a function call or not}
begin
   iscall := lv[length(lv)] = ')';
end;


function exprtype(var ex: string255): char;
   {determine expression type and return the printf code for the type}
var
   sym: symptr;
   xt:  char;
   p:   integer;
   id:  string40;

begin
   if ex[1] = '''' then
      xt := 'c'
   else

   if ex[1] = '"' then
      xt := 's'
   else

   begin
      ex[length(ex)+1] := #0;
      p := 1;
      while (ex[p] in ['a'..'z','A'..'Z','0'..'9']) do
         inc(p);

      id := copy(ex,1,p-1);
      sym := locatesym(id);

      if sym <> nil then
         case sym^.symtype of
            s_char:    xt := 'c';
            s_int:     xt := 'd';
            s_long:    xt := 'D'; { calling routine should convert to "ld" }
            s_double:  xt := 'f';

            s_string:
               begin
                  p := length(id) + 1;
                  while (p < length(ex)) and (ex[p] in [' ',^I]) do
                     inc(p);

                  if (ex[p] = '[') and (sym^.suptype = ss_scalar) then
                     xt := 'c'
                  else
                     xt := 's';
               end;

            else     xt := 'd';
         end
      else

      if copy(ex,1,5) = 'scat(' then
         xt := 's'
      else

      if copy(ex,1,5) = 'copy(' then
         xt := 's'
      else

      if copy(ex,1,5) = 'ctos(' then
         xt := 's'
      else

      if copy(ex,1,4) = 'chr(' then
         xt := 'c'
      else

      if copy(ex,1,4) = 'ord(' then
         xt := 'd'

      else
         xt := 'd'     {all other kinds are defaulted to integer}
   end;

   exprtype := xt;
end;


function strtype(var ex: string255): boolean;
   {see if the expression is a string data type or not}
begin
   case exprtype(ex) of
      's':  strtype := true;
      'c':  strtype := true;
      else  strtype := false;
   end;
end;



function psetof:  string255;
   {parse a literal set; returns the set literal translated into
    the form: setof(.....)}
var
   ex: string255;

begin
   gettok;   {consume the [}
   ex := 'setof(';

   repeat
      if tok = '..' then       {set ranges are passed as FROM,-2,TO}
      begin                    {and are interpreted by inset()}
         gettok;
         ex := ex + ',THRU,';
      end
      else

      if tok = ',' then
      begin
         gettok;
         ex := ex + ',';
      end
      else

      if tok <> ']' then
         ex := ex + pexpr;

   until tok = ']';

   gettok;   {consume the ]}
   ex := ex + ',ENDSET)';
   psetof := ex;
end;


function pterm:   string255;
   {parse an expression term;  returns the translated expression term;
    detects subexpressions, set literals and lvalues(variable names)}
var
   ex: string255;

begin

   (* translate NOT term into !term *)
   if tok = 'NOT' then
   begin
      gettok;
      pterm := '!' + pterm;
   end
   else

   (* process pos(c,str) and pos(str,str) *)
   if (tok = 'POS') then
   begin
      gettok;   {consume the keyword}
      gettok;   {consume the (}
      ex := pexpr;
      if exprtype(ex) = 'c' then
         ex := 'cpos(' + ex
      else
         ex := 'spos(' + ex;

      gettok;   {consume the ,}
      ex := ex + ',' + pexpr;
      gettok;   {consume the )}
      pterm := ex + ')';
   end
   else

   (* process port/memory array references *)
   if (tok = 'PORT') or (tok = 'PORTW') or
      (tok = 'MEM')  or (tok = 'MEMW') then
   begin
      if tok = 'PORT'  then ex := 'inportb('    else
      if tok = 'PORTW' then ex := 'inport('     else
      if tok = 'MEM'   then ex := 'peekb('      else
                            ex := 'peek(';

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

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

      gettok;     {consume the ] }
      pterm := ex + ')';
   end
   else

   (* translate bitwise not (mt+) *)
   if (tok = '?') or (tok = '~') or (tok = '\') then
   begin
      gettok;
      pterm := '!' + pterm;         {what is a bitwise NOT in c?}
   end
   else

   (* process unary minus *)
   if tok = '-' then
   begin
      gettok;
      pterm := '-' + pterm;
   end
   else

   (* pass numbers *)
   if toktype = number then
   begin
      pterm := tok;
      gettok;
   end
   else

   (* pass strings *)
   if toktype = strng then
   begin
      pterm := tok;
      gettok;
   end
   else

   (* pass sub expressions *)
   if tok = '(' then
   begin
      gettok;
      pterm := '(' + pexpr + ')';
      gettok;
   end
   else

   (* translate literal sets *)
   if tok = '[' then
   begin
      pterm := psetof;
   end

   (* otherwise the term will be treated as an lvalue *)
   else
      pterm := plvalue;
end;


function pexpr {: string255};
   {top level expression parser; parse and translate an expression and
    return the translated expr}
var
   ex:   string255;
   ty:   char;
   ex2:  string255;
   ty2:  char;

   procedure relop(newop: string40);
   begin
      gettok;        {consume the operator token}
      ex2 := pterm;  {get the second term}

      {use strcmp if either param is a string}
      ty := exprtype(ex);
      ty2 := exprtype(ex2);

      if ty = 's' then
      begin
         if ty2 = 's' then
            ex := 'strcmp(' + ex + ',' + ex2 + ') ' + newop + ' 0'
         else
         if ex2[1] = '''' then
            ex := 'strcmp(' + ex + ',"' +
                     copy(ex2,2,length(ex2)-2) + '") ' + newop + ' 0'
         else
            ex := 'strcmp(' + ex + ',ctos(' + ex2 + ')) ' + newop + ' 0'
      end
      else

      if ty = 'c' then
      begin
         if ty2 = 's' then
            ex := 'strcmp(ctos(' + ex + '),' + ex2 + ') ' + newop + ' 0'
         else
            ex := ex + ' ' + newop + ' ' + ex2
      end

      else
         ex := ex + ' ' + newop + ' ' + ex2;
   end;


   procedure addop;

      procedure add_scat;
      var
         p: integer;

      begin
         ty := exprtype(ex);
         ty2 := exprtype(ex2);

         p := 7;
         while ex[p] <> '"' do
            p := succ(p);
         p := succ(p);

         {add literals to the control string if possible}

         if (ex2[1] = '''') or (ex2[1] = '"') then
            ex := copy(ex,1,p-2) + copy(ex2,2,length(ex2)-2) +
                  copy(ex,p-1,length(ex)-p+2)

         else {add a parameter to the control string}

            ex := copy(ex,1,p-2) + '%' + ty2 +
                  copy(ex,p-1,length(ex)-p+1) + ',' + ex2 + ')';
      end;

   begin
      gettok;        {consume the operator token}
      ex2 := pterm;  {get the second term}

      if copy(ex,1,5) = 'scat(' then
         add_scat
      else

      if strtype(ex) or strtype(ex2) then
      begin
         if (ex[1] = '''') or (ex[1] = '"') then
            ex := 'scat("' + copy(ex,2,length(ex)-2) + '")'
         else
            ex := 'scat("%' + exprtype(ex) + '",' + ex + ')';
         add_scat;
      end
      else
         ex := ex + ' + ' + ex2;
   end;

   procedure mulop(newop: string40);
   begin
      gettok;        {consume the operator token}
      ex2 := pterm;  {get the second term}
      ex := ex + ' ' + newop + ' ' + ex2;
   end;


begin
   ex := pterm;

   while true do
   begin
      (* process operators *)
      if      tok = '>'   then relop(tok)
      else if tok = '<'   then relop(tok)
      else if tok = '>='  then relop(tok)
      else if tok = '<='  then relop(tok)
      else if tok = '<>'  then relop('!=')
      else if tok = '='   then relop('==')
      else if tok = '+'   then addop
      else if tok = '-'   then mulop(tok)
      else if tok = '*'   then mulop(tok)
      else if tok = '/'   then mulop(tok)
      else if tok = 'DIV' then mulop('/')
      else if tok = 'MOD' then mulop('%')
      else if tok = 'AND' then mulop('&&')
      else if tok = 'OR'  then mulop('||')
      else if tok = 'SHR' then mulop('>>')
      else if tok = 'SHL' then mulop('<<')
      else if tok = 'XOR' then mulop('^')
      else if tok = '&'   then mulop(tok)  {mt+}
      else if tok = '!'   then mulop('|')  {mt+}
      else if tok = '|'   then mulop('|')  {mt+}
      else

      (* translate the expr IN set operator *)
      if tok = 'IN'  then
      begin
         gettok;
         ex := 'inset('+ex+', ' + pterm + ')';
      end
      else

      (* ran out of legal expression operators; return what we found *)
      begin
         pexpr := ex;
         exit;
      end;
   end;

end;


function plvalue{: string255};
   {parse and translate an lvalue specification and return the translated
    lvalue as a string}

var
   lv:   string255;
   v:    string255;
   tv:   string255;
   pref: anystring;
   idok: boolean;
   sym:  symptr;
   func: symptr;
   pvars:integer;
   ind:  string40;

begin

(* lvalues must begin with an identifier in pascal *)
   if toktype <> identifier then
      error('Identifier expected (plvalue)');

(* assign initial part of the lvalue *)
   lv := ltok;
   v := tok;
   idok := false;
   pref := '';

   gettok;
   sym := locatesym(lv);
   if sym <> nil then
   begin
{      if in_locals and past_marker then
         pref := 'nest_' + nestn + '_';  }

      if sym^.parcount = -2 then
         pref := '*' + pref;
   end;

(* process a list of qualifiers and modifiers *)
   repeat

      (* additional identifiers (field names) *)
      if idok and (toktype = identifier) then
      begin
         lv := lv + ltok;
         gettok;
         idok := false;
      end
      else

      (* pointers *)
      if tok = '^' then
      begin
         pref := '*' + pref;
         gettok;
      end
      else

      (* pointer subscripts *)
      if tok = '^[' then
      begin
         pref := '*{?}' + pref;         {should this be here?}
         lv := lv + '[';
         gettok;

         while tok <> ']' do
         begin
            lv := lv + pexpr;
            if tok = ',' then
            begin
               lv := lv + '][';
               gettok;
            end;
         end;

         lv := lv + ']';
         gettok;
      end
      else

      (* pointer members *)
      if tok = '^.' then
      begin
         lv := lv + '->';
         gettok;
         idok := true;
      end
      else

      (* record members *)
      if tok = '.' then
      begin
         if pref = '*' then     {translate *id. into id->}
         begin
            pref := '';
            lv := lv + '->';
         end
         else
            lv := lv + '.';
         idok := true;
         gettok;
      end
      else

      (* subscripts *)
      if tok = '[' then
      begin
         sym := locatesym(lv);

         if copy(pref,1,1) = '*' then
            pref := '';       {replace '*id[' with 'id['}

         lv := lv + '[';
         gettok;

         while tok <> ']' do
         begin
            lv := lv + pexpr;

            if sym <> nil then
               if sym^.symtype = s_string then
                  lv := lv + '-1';

            if tok = ',' then
            begin
               lv := lv + '][';
               gettok;
            end;
         end;

         lv := lv + ']';
         gettok;
      end
      else

      (* function calls *)
      if tok = '(' then
      begin
         func := findsym(globals, v);
         pvars := 0;
         if func <> nil then
            pvars := func^.pvar;
         lv := lv + '(';
         gettok;

         while tok <> ')' do
         begin
            ind := '';
            if (pvars and 1) = 1 then
               ind := '&';
            tv := pexpr;

            if ind = '&' then   {var parameter?  pass pointer}
            begin
               if tv[1] = '*' then      {address of pointer deref is ptr}
               begin
                  delete(tv,1,1);
                  ind := '';
               end
               else

               if tv[1] in ['a'..'z','A'..'Z'] then
               begin                    {pass pointer to strings/arrays}
                  sym := locatesym(tv);
                  if sym <> nil then
                     if (sym^.symtype = s_string) or
                        (sym^.suptype = ss_array) then
                       ind := '';
               end;
{               else
                  ind := ''; }
            end;

            lv := lv + ind + tv;
            pvars := pvars shr 1;

            if (tok = ',') or (tok = ':') then
            begin
               lv := lv + ', ';
               gettok;
            end;
         end;

         lv := lv + ')';
         gettok;
      end
      else

(* otherwise just return what was found so far *)
      begin

         (* add dummy param list to function calls where the proc
            expects no parameters *)
         sym := locatesym(lv);

         if sym <> nil then
         begin
            if sym^.parcount = 0 then
               lv := lv + '()'
            else

            if sym^.parcount > 0 then
               if not iscall(lv) then
                  lv := lv + '()';
         end;

         if v = 'PARAMCOUNT' then
            lv := '(argc-1)'
         else

         if v = 'PARAMSTR' then
            lv := 'argv[' + copy(lv,10,length(lv)-10) + ']';

         plvalue := pref + lv;
         exit;
      end;

   until true=false;

end;