alan@leadsv.UUCP (Alan Strassberg) (08/15/88)
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