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('