home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power Programming
/
powerprogramming1994.iso
/
progtool
/
turbopas
/
tptc17sc.arc
/
TPTC.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-03-26
|
18KB
|
531 lines
(*
* TPTC - Turbo Pascal to C translator
*
* S.H.Smith, 9/9/85 (rev. 2/13/88)
*
* Copyright 1986, 1988 by Samuel H. Smith; All rights reserved.
*
* See HISTORY.DOC for complete revision history.
* See TODO.DOC for pending changes.
*
*)
{$T+} {Produce mapfile}
{$R-} {Range checking}
{$B-} {Boolean complete evaluation}
{$S-} {Stack checking}
{$I+} {I/O checking}
{$N-} {Numeric coprocessor}
{$V-} {Relax string rules}
{$M 65500,16384,655360} {stack, minheap, maxhep}
program translate_tp_to_c;
uses Dos;
const
version1 = 'TPTC - Translate Pascal to C';
version2 = 'Version 1.7 03/26/88 (C) 1988 S.H.Smith';
minstack = 4000; {minimum free stack space needed}
outbufsiz = 10000; {size of top level output file buffer}
inbufsiz = 2000; {size of input file buffers}
maxparam = 16; {max number of parameters to process}
maxnest = 10; {maximum procedure nesting-1}
maxincl = 2; {maximum source file nesting-1}
statrate = 5; {clock ticks between status displays}
ticks_per_second = 18.2;
const
nestfile = 'p$'; {scratchfile for nested procedures}
type
anystring = string [127];
string255 = string [255];
string80 = string [80];
string64 = string [64];
string40 = string [40];
string20 = string [20];
string10 = string [10];
(* command options *)
const
debug: boolean = false; {-B trace scan}
debug_parse: boolean = false; {-BP trace parse}
mt_plus: boolean = false; {-M true if translating Pascal/MT+}
map_lower: boolean = false; {-L true to map idents to lower case}
dumpsymbols: boolean = false; {-D dump tables to object file}
dumppredef: boolean = false; {-DP dump predefined system symbols}
includeinclude:boolean = false; {-I include include files in output}
quietmode: boolean = false; {-Q disable warnings?}
identlen: integer = 13; {-Tnn nominal length of identifiers}
workdir: string64 = ''; {-Wd: work/scratch file directory}
tshell: boolean = false; {-# pass lines starting with '#'}
pass_comments: boolean = true; {-NC no comments in output}
type
toktypes = (number, identifier,
strng, keyword,
chars, comment,
unknown);
symtypes = (s_int, s_long,
s_double, s_string,
s_char, s_struct,
s_file, s_bool,
s_void );
supertypes = (ss_scalar, ss_const,
ss_func, ss_struct,
ss_array, ss_pointer,
ss_builtin, ss_none );
symptr = ^symrec;
symrec = record
symtype: symtypes; { simple type }
suptype: supertypes; { scalar,array etc. }
id: string40; { name of entry }
repid: string40; { replacement ident }
parcount: integer; { parameter count,
>=0 -- procedure/func pars
>=1 -- array level
-1 -- simple variable
-2 -- implicit deref var }
pvar: word; { var/val reference bitmap, or
structure member nest level }
base: integer; { base value for subscripts }
limit: word; { limiting value for scalars }
next: symptr; { link to next symbol in table }
end;
paramlist = record
n: integer;
id: array [1..maxparam] of string80;
stype: array [1..maxparam] of symtypes;
sstype: array [1..maxparam] of supertypes;
end;
const
(* names of symbol types *)
typename: array[symtypes] of string40 =
('int', 'long',
'double', 'strptr',
'char', 'struct',
'file', 'boolean',
'void' );
supertypename: array[supertypes] of string40 =
('scalar', 'constant',
'function', 'structure',
'array', 'pointer',
'builtin', 'none' );
(* these words start new statements or program sections *)
nkeywords = 14;
keywords: array[1..nkeywords] of string40 = (
'PROGRAM', 'PROCEDURE', 'FUNCTION',
'VAR', 'CONST', 'TYPE',
'LABEL', 'OVERLAY', 'FORWARD',
'MODULE', 'EXTERNAL', 'CASE',
'INTERFACE', 'IMPLEMENTATION');
type
byteptr = ^byte;
var
inbuf: array [0..maxincl] of byteptr;
srcfd: array [0..maxincl] of text;
srclines: array [0..maxincl] of integer;
srcfiles: array [0..maxincl] of string64;
outbuf: array [0..maxnest] of byteptr;
ofd: array [0..maxnest] of text;
inname: string64; {source filename}
outname: string64; {output filename}
unitname: string64; {output filename without extention}
symdir: string64; {.UNS symbol search directory}
ltok: string80; {lower/upper current token}
tok: string80; {all upper case current token}
ptok: string80; {previous token}
spaces: anystring; {leading spaces on current line}
decl_prefix: anystring; {declaration identifier prefix, if any}
const
starttime: longint = 0; {time translation was started}
curtime: longint = 0; {current time}
statustime: longint = 0; {time of last status display}
nextc: char = ' ';
toktype: toktypes = unknown;
ptoktype: toktypes = unknown;
linestart: boolean = true;
extradot: boolean = false;
nospace: boolean = false;
cursym: symptr = nil;
curtype: symtypes = s_void;
cexprtype: symtypes = s_void;
cursuptype: supertypes = ss_scalar;
curlimit: integer = 0;
curbase: integer = 0;
curpars: integer = 0;
withlevel: integer = 0;
unitlevel: integer = 0;
srclevel: integer = 0;
srctotal: integer = 1;
objtotal: integer = 0;
procnum: string[2] = 'AA';
recovery: boolean = false;
in_interface: boolean = false;
top_interface: symptr = nil;
globals: symptr = nil;
locals: symptr = nil;
(* nonspecific library includes *)
{$I ljust.inc} {left justify writeln strings}
{$I atoi.inc} {ascii to integer conversion}
{$I itoa.inc} {integer to ascii conversion}
{$I ftoa.inc} {float to ascii conversion}
{$I stoupper.inc} {map string to upper case}
{$I keypress.inc} {msdos versions of keypressed and readkey}
{$I getenv.inc} {get environment variables}
procedure fatal (message: string); forward;
procedure warning (message: string); forward;
procedure scan_tok; forward;
procedure gettok; forward;
procedure puttok; forward;
procedure putline; forward;
procedure puts(s: string); forward;
procedure putln(s: string); forward;
function plvalue: string; forward;
function pexpr: string; forward;
procedure exit_procdef; forward;
procedure pblock; forward;
procedure pstatement; forward;
procedure pimplementation; forward;
procedure punit; forward;
procedure pvar; forward;
procedure pident; forward;
(********************************************************************)
{$I tpcsym.inc} {symbol table handler}
{$I tpcmisc.inc} {misc functions}
{$I tpcscan.inc} {scanner; lexical analysis}
{$I tpcexpr.inc} {expression parser and translator}
{$I tpcstmt.inc} {statement parser and translator}
{$I tpcdecl.inc} {declaration parser and translator}
{$I tpcunit.inc} {program unit parser and translator}
(********************************************************************)
procedure initialize;
{initializations before translation can begin}
procedure enter(name: anystring; etype: symtypes; elimit: integer);
begin
newsym(name, etype, ss_scalar, -1, 0, elimit, 0);
end;
begin
srclines[srclevel] := 1;
srcfiles[srclevel] := inname;
assign(srcfd[srclevel],inname);
{$I-} reset(srcfd[srclevel]); {$I+}
if ioresult <> 0 then
begin
writeln('Can''t open input file: ',inname);
halt(88);
end;
getmem(inbuf[srclevel],inbufsiz);
SetTextBuf(srcfd[srclevel],inbuf[srclevel]^,inbufsiz);
assign(ofd[unitlevel],outname);
{$I-}
rewrite(ofd[unitlevel]);
{$I+}
if ioresult <> 0 then
begin
writeln('Can''t open output file: ',outname);
halt(88);
end;
getmem(outbuf[unitlevel],outbufsiz);
SetTextBuf(ofd[unitlevel],outbuf[unitlevel]^,outbufsiz);
mark_time(starttime);
{enter predefined types into symbol table}
enter('boolean', s_bool,1);
enter('integer', s_int,maxint);
enter('word', s_int,0);
enter('longint', s_long,0);
enter('real', s_double,0);
enter('char', s_char,255);
enter('byte', s_int,255);
enter('file', s_file,0);
enter('text', s_file,0);
enter('true', s_bool,1);
enter('false', s_bool,1);
newsym('string', s_string, ss_scalar, -1, 0, 0, 1);
newsym('not', s_int, ss_builtin, 0, 0, 0, 0);
{enter predefined functions into symbol table}
newsym('chr', s_char, ss_builtin, 1, 0, 0, 0);
newsym('pos', s_int, ss_builtin, 2, 0, 0, 0);
newsym('str', s_void, ss_builtin, 2, 0, 0, 0);
newsym('port', s_int, ss_builtin, 1, 0, 0, 0);
newsym('portw', s_int, ss_builtin, 1, 0, 0, 0);
newsym('mem', s_int, ss_builtin, 2, 0, 0, 0);
newsym('memw', s_int, ss_builtin, 2, 0, 0, 0);
newsym('exit', s_void, ss_builtin, 1, 0, 0, 0);
{load the standard 'system' unit unit symbol table}
load_unitfile('TPTCSYS.UNS',globals);
{mark the end of predefined entries in the symbol table}
newsym('<predef>', s_void, ss_builtin,-1, 0, 0, 0);
end;
(********************************************************************)
procedure usage(why: anystring);
{print usage instructions and copyright}
procedure pause;
var
answer: string20;
begin
writeln;
write('More: (Enter)=yes? ');
answer := 'Y';
readln(answer);
writeln;
if upcase(answer[1]) = 'N' then
halt;
end;
begin
writeln('Copyright 1986, 1988 by Samuel H. Smith; All rights reserved.');
writeln;
writeln('Please refer all inquiries to:');
writeln(' Samuel H. Smith The Tool Shop BBS');
writeln(' 5119 N 11 Ave 332 (602) 279-2673');
writeln(' Phoenix, AZ 85013');
writeln;
writeln('You may copy and distribute this program freely, provided that:');
writeln(' 1) No fee is charged for such copying and distribution, and');
writeln(' 2) It is distributed ONLY in its original, unmodified state.');
writeln;
writeln('If you like this program, and find it of use, then your contribution');
writeln('will be appreciated. If you are using this product in a commercial');
writeln('environment then the contribution is not voluntary.');
writeln;
writeln('Error: ',why);
pause;
writeln;
writeln('Usage: TPTC input_file [output_file] [options]');
writeln;
writeln('Where: input_file specifies the main source file, .PAS default');
writeln(' output_file specifies the output file, .C default');
writeln(' -B deBug trace during scan');
writeln(' -BP deBug trace during Parse');
writeln(' -D Dump user symbols');
writeln(' -DP Dump Predefined system symbols');
writeln(' -I output Include files'' contents');
writeln(' -L map all identifiers to Lower case');
writeln(' -M use Pascal/MT+ specific translations');
writeln(' -NC No Comments passed to output file');
writeln(' -Q Quiet mode; suppress warnings');
writeln(' -Sdir\ search dir\ for .UNS symbol files');
writeln(' -Tnn Tab nn columns in declarations');
writeln(' -Wdrive: use drive: for Work/scratch files (ramdrive)');
writeln(' -# don''t translate lines starting with "#"');
pause;
writeln('Default command parameters are loaded from TPTC environment variable.');
writeln;
writeln('Example: tptc fmap');
writeln(' tptc fmap -L -d -wj:\tmp\');
writeln(' tptc -l -d -wj: -i -q -t15 fmap.pas fmap.out');
writeln;
writeln(' set tptc=-wj: -i -l -sc:\libs');
writeln(' tptc test ;uses options specified earlier');
halt(88);
end;
(********************************************************************)
procedure process_option(par: anystring);
begin
stoupper(par);
if (par[1] = '-') or (par[1] = '/') then
begin
delete(par,1,1);
par[length(par)+1] := ' ';
case(par[1]) of
'B': begin
if par[2] = 'P' then
debug_parse := true;
debug := true;
end;
'D': begin
if par[2] = 'P' then
dumppredef := true;
dumpsymbols := true;
end;
'I': includeinclude := true;
'L': map_lower := true;
'M': mt_plus := true;
'N': if par[2] = 'C' then
pass_comments := false;
'Q': quietmode := true;
'S': begin
symdir := copy(par,2,65);
if symdir[length(symdir)] <> '\' then
symdir := symdir + '\';
end;
'T': identlen := atoi(copy(par,2,10));
'W': begin
workdir := copy(par,2,65);
if workdir[length(workdir)] <> '\' then
workdir := workdir + '\';
end;
'#': tshell := true;
else usage('invalid option: -'+par);
end;
end
else
if inname = '' then
inname := par
else
if outname = '' then
outname := par
else
usage('extra output name: '+par);
end;
(********************************************************************)
procedure decode_options;
var
i: integer;
options: string;
opt: string;
begin
inname := '';
outname := '';
unitname := '';
symdir := '';
ltok := '';
tok := '';
ptok := '';
spaces := '';
decl_prefix := '';
(* build option list from TPTC environment variable and from
all command line parameters *)
options := get_environment_var('TPTC=');
for i := 1 to paramcount do
options := options + ' ' + paramstr(i);
options := options + ' ';
(* parse the options into spaces and process each one *)
repeat
i := pos(' ',options);
opt := copy(options,1,i-1);
options := copy(options,i+1,255);
if length(opt) > 0 then
process_option(opt);
until length(options) = 0;
(* verify all required options have been specified *)
if inname = '' then
usage('missing input name');
if outname = '' then
begin
outname := inname;
i := pos('.',outname);
if i > 0 then
outname := copy(outname,1,i-1);
end;
if pos('.',outname) = 0 then
outname := outname + '.C';
i := pos('.',outname);
unitname := copy(outname,1,i-1);
if pos('.',inname) = 0 then
inname := inname + '.PAS';
if inname = outname then
usage('duplicate input/output name');
end;
(********************************************************************)
(* main program *)
begin
assign(output,'');
rewrite(output);
writeln;
writeln(version1,' ',version2);
(* do initializations *)
decode_options;
initialize;
(* process the source file(s) *)
pprogram;
(* clean up and leave *)
closing_statistics;
end.