home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / msdos / turbopas / tptc17sc.arc / TPTC.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-03-26  |  17.4 KB  |  531 lines
  1.  
  2. (*
  3.  * TPTC - Turbo Pascal to C translator
  4.  *
  5.  * S.H.Smith, 9/9/85  (rev. 2/13/88)
  6.  *
  7.  * Copyright 1986, 1988 by Samuel H. Smith;  All rights reserved.
  8.  *
  9.  * See HISTORY.DOC for complete revision history.
  10.  * See TODO.DOC for pending changes.
  11.  *
  12.  *)
  13.  
  14. {$T+}    {Produce mapfile}
  15. {$R-}    {Range checking}
  16. {$B-}    {Boolean complete evaluation}
  17. {$S-}    {Stack checking}
  18. {$I+}    {I/O checking}
  19. {$N-}    {Numeric coprocessor}
  20. {$V-}    {Relax string rules}
  21. {$M 65500,16384,655360} {stack, minheap, maxhep}
  22.  
  23.  
  24. program translate_tp_to_c;
  25.  
  26. uses Dos;
  27.  
  28. const
  29.    version1 =     'TPTC - Translate Pascal to C';
  30.    version2 =     'Version 1.7 03/26/88   (C) 1988 S.H.Smith';
  31.    
  32.    minstack =     4000;       {minimum free stack space needed}
  33.    outbufsiz =    10000;      {size of top level output file buffer}
  34.    inbufsiz =     2000;       {size of input file buffers}
  35.    maxparam =     16;         {max number of parameters to process}
  36.    maxnest =      10;         {maximum procedure nesting-1}
  37.    maxincl =      2;          {maximum source file nesting-1}
  38.    statrate =     5;          {clock ticks between status displays}
  39.    ticks_per_second = 18.2;
  40.    
  41.  
  42. const
  43.    nestfile =     'p$';       {scratchfile for nested procedures}
  44.  
  45. type
  46.    anystring =    string [127];
  47.    string255 =    string [255];
  48.    string80  =    string [80];
  49.    string64  =    string [64];
  50.    string40  =    string [40];
  51.    string20  =    string [20];
  52.    string10  =    string [10];
  53.  
  54.  
  55. (* command options *)
  56.  
  57. const
  58.    debug:         boolean = false;   {-B   trace scan}
  59.    debug_parse:   boolean = false;   {-BP  trace parse}
  60.    mt_plus:       boolean = false;   {-M   true if translating Pascal/MT+}
  61.    map_lower:     boolean = false;   {-L   true to map idents to lower case}
  62.    dumpsymbols:   boolean = false;   {-D   dump tables to object file}
  63.    dumppredef:    boolean = false;   {-DP  dump predefined system symbols}
  64.    includeinclude:boolean = false;   {-I   include include files in output}
  65.    quietmode:     boolean = false;   {-Q   disable warnings?}
  66.    identlen:      integer = 13;      {-Tnn nominal length of identifiers}
  67.    workdir:       string64 = '';     {-Wd: work/scratch file directory}
  68.    tshell:        boolean = false;   {-#   pass lines starting with '#'}
  69.    pass_comments: boolean = true;    {-NC  no comments in output}
  70.  
  71.  
  72. type
  73.    toktypes =     (number,      identifier,
  74.                    strng,       keyword,
  75.                    chars,       comment,
  76.                    unknown);
  77.  
  78.    symtypes =     (s_int,       s_long,
  79.                    s_double,    s_string,
  80.                    s_char,      s_struct,
  81.                    s_file,      s_bool,
  82.                    s_void                );
  83.  
  84.    supertypes =   (ss_scalar,   ss_const,
  85.                    ss_func,     ss_struct,
  86.                    ss_array,    ss_pointer,
  87.                    ss_builtin,  ss_none  );
  88.  
  89.    symptr =      ^symrec;
  90.    symrec =       record
  91.                      symtype:  symtypes;        { simple type }
  92.                      suptype:  supertypes;      { scalar,array etc. }
  93.                      id:       string40;        { name of entry }
  94.                      repid:    string40;        { replacement ident }
  95.  
  96.                      parcount: integer;         { parameter count,
  97.                                                   >=0 -- procedure/func pars
  98.                                                   >=1 -- array level
  99.                                                    -1 -- simple variable
  100.                                                    -2 -- implicit deref var }
  101.  
  102.                      pvar:     word;            { var/val reference bitmap, or
  103.                                                   structure member nest level }
  104.  
  105.                      base:     integer;         { base value for subscripts }
  106.                      limit:    word;            { limiting value for scalars }
  107.  
  108.                      next:     symptr;          { link to next symbol in table }
  109.                   end;
  110.  
  111.    paramlist =    record
  112.                      n:      integer;
  113.                      id:     array [1..maxparam] of string80;
  114.                      stype:  array [1..maxparam] of symtypes;
  115.                      sstype: array [1..maxparam] of supertypes;
  116.                   end;
  117.  
  118. const
  119.  
  120.    (* names of symbol types *)
  121.    typename:  array[symtypes] of string40 =
  122.                   ('int',       'long',
  123.                    'double',    'strptr',
  124.                    'char',      'struct',
  125.                    'file',      'boolean',
  126.                    'void' );
  127.  
  128.    supertypename:  array[supertypes] of string40 =
  129.                   ('scalar',    'constant',
  130.                    'function',  'structure',
  131.                    'array',     'pointer',
  132.                    'builtin',   'none' );
  133.  
  134.  
  135.    (* these words start new statements or program sections *)
  136.    nkeywords = 14;
  137.    keywords:  array[1..nkeywords] of string40 = (
  138.       'PROGRAM',   'PROCEDURE', 'FUNCTION',
  139.       'VAR',       'CONST',     'TYPE',
  140.       'LABEL',     'OVERLAY',   'FORWARD',
  141.       'MODULE',    'EXTERNAL',  'CASE',
  142.       'INTERFACE', 'IMPLEMENTATION');
  143.  
  144. type
  145.    byteptr =      ^byte;
  146.    
  147. var
  148.    inbuf:         array [0..maxincl] of byteptr;
  149.    srcfd:         array [0..maxincl] of text;
  150.    srclines:      array [0..maxincl] of integer;
  151.    srcfiles:      array [0..maxincl] of string64;
  152.    
  153.    outbuf:        array [0..maxnest] of byteptr;
  154.    ofd:           array [0..maxnest] of text;
  155.    
  156.    inname:        string64;         {source filename}
  157.    outname:       string64;         {output filename}
  158.    unitname:      string64;         {output filename without extention}
  159.    symdir:        string64;         {.UNS symbol search directory}
  160.    ltok:          string80;         {lower/upper current token}
  161.    tok:           string80;         {all upper case current token}
  162.    ptok:          string80;         {previous token}
  163.    spaces:        anystring;        {leading spaces on current line}
  164.    decl_prefix:   anystring;        {declaration identifier prefix, if any}
  165.  
  166. const
  167.    starttime:     longint     = 0;      {time translation was started}
  168.    curtime:       longint     = 0;      {current time}
  169.    statustime:    longint     = 0;      {time of last status display}
  170.    
  171.    nextc:         char        = ' ';
  172.    toktype:       toktypes    = unknown;
  173.    ptoktype:      toktypes    = unknown;
  174.    linestart:     boolean     = true;
  175.    extradot:      boolean     = false;
  176.    nospace:       boolean     = false;
  177.  
  178.    cursym:        symptr      = nil;
  179.    curtype:       symtypes    = s_void;
  180.    cexprtype:     symtypes    = s_void;
  181.    cursuptype:    supertypes  = ss_scalar;
  182.    curlimit:      integer     = 0;
  183.    curbase:       integer     = 0;
  184.    curpars:       integer     = 0;
  185.  
  186.    withlevel:     integer     = 0;
  187.    unitlevel:     integer     = 0;
  188.    srclevel:      integer     = 0;
  189.    srctotal:      integer     = 1;
  190.    objtotal:      integer     = 0;
  191.    
  192.    procnum:       string[2]   = 'AA';
  193.    recovery:      boolean     = false;
  194.  
  195.    in_interface:  boolean     = false;
  196.    top_interface: symptr      = nil;
  197.  
  198.    globals:       symptr      = nil;
  199.    locals:        symptr      = nil;
  200.  
  201.  
  202.  
  203. (* nonspecific library includes *)
  204.  
  205. {$I ljust.inc}     {left justify writeln strings}
  206. {$I atoi.inc}      {ascii to integer conversion}
  207. {$I itoa.inc}      {integer to ascii conversion}
  208. {$I ftoa.inc}      {float to ascii conversion}
  209. {$I stoupper.inc}  {map string to upper case}
  210. {$I keypress.inc}  {msdos versions of keypressed and readkey}
  211. {$I getenv.inc}    {get environment variables}
  212.  
  213.  
  214.  
  215. procedure fatal  (message:  string);      forward;
  216. procedure warning  (message:  string);    forward;
  217. procedure scan_tok;                       forward;
  218. procedure gettok;                         forward;
  219. procedure puttok;                         forward;
  220. procedure putline;                        forward;
  221. procedure puts(s: string);                forward;
  222. procedure putln(s: string);               forward;
  223. function  plvalue: string;                forward;
  224. function  pexpr:   string;                forward;
  225. procedure exit_procdef;                   forward;
  226. procedure pblock;                         forward;
  227. procedure pstatement;                     forward;
  228. procedure pimplementation;                forward;
  229. procedure punit;                          forward;
  230. procedure pvar;                           forward;
  231. procedure pident;                         forward;
  232.  
  233.  
  234. (********************************************************************)
  235.  
  236. {$I tpcsym.inc}          {symbol table handler}
  237. {$I tpcmisc.inc}         {misc functions}
  238. {$I tpcscan.inc}         {scanner; lexical analysis}
  239. {$I tpcexpr.inc}         {expression parser and translator}
  240. {$I tpcstmt.inc}         {statement parser and translator}
  241. {$I tpcdecl.inc}         {declaration parser and translator}
  242. {$I tpcunit.inc}         {program unit parser and translator}
  243.  
  244.  
  245.  
  246. (********************************************************************)
  247. procedure initialize;
  248.    {initializations before translation can begin}
  249.  
  250.    procedure enter(name: anystring; etype: symtypes; elimit: integer);
  251.    begin
  252.       newsym(name, etype, ss_scalar, -1, 0, elimit, 0);
  253.    end;
  254.  
  255. begin
  256.    srclines[srclevel] := 1;
  257.    srcfiles[srclevel] := inname;
  258.    assign(srcfd[srclevel],inname);
  259.    {$I-} reset(srcfd[srclevel]); {$I+}
  260.    if ioresult <> 0 then
  261.    begin
  262.       writeln('Can''t open input file: ',inname);
  263.       halt(88);
  264.    end;
  265.  
  266.    getmem(inbuf[srclevel],inbufsiz);
  267.    SetTextBuf(srcfd[srclevel],inbuf[srclevel]^,inbufsiz);
  268.  
  269.    assign(ofd[unitlevel],outname);
  270. {$I-}
  271.    rewrite(ofd[unitlevel]);
  272. {$I+}
  273.    if ioresult <> 0 then
  274.    begin
  275.       writeln('Can''t open output file: ',outname);
  276.       halt(88);
  277.    end;
  278.  
  279.    getmem(outbuf[unitlevel],outbufsiz);
  280.    SetTextBuf(ofd[unitlevel],outbuf[unitlevel]^,outbufsiz);
  281.    mark_time(starttime);
  282.          
  283.    {enter predefined types into symbol table}
  284.    enter('boolean',    s_bool,1);
  285.    enter('integer',    s_int,maxint);
  286.    enter('word',       s_int,0);    
  287.    enter('longint',    s_long,0);
  288.    enter('real',       s_double,0);
  289.    enter('char',       s_char,255);
  290.    enter('byte',       s_int,255);
  291.    enter('file',       s_file,0);
  292.    enter('text',       s_file,0);
  293.    enter('true',       s_bool,1);
  294.    enter('false',      s_bool,1);
  295.    newsym('string',    s_string, ss_scalar,    -1, 0, 0, 1);
  296.    newsym('not',       s_int,    ss_builtin,    0, 0, 0, 0);
  297.  
  298.    {enter predefined functions into symbol table}
  299.    newsym('chr',       s_char,   ss_builtin,    1, 0, 0, 0);
  300.    newsym('pos',       s_int,    ss_builtin,    2, 0, 0, 0);
  301.    newsym('str',       s_void,   ss_builtin,    2, 0, 0, 0);
  302.    newsym('port',      s_int,    ss_builtin,    1, 0, 0, 0);
  303.    newsym('portw',     s_int,    ss_builtin,    1, 0, 0, 0);
  304.    newsym('mem',       s_int,    ss_builtin,    2, 0, 0, 0);
  305.    newsym('memw',      s_int,    ss_builtin,    2, 0, 0, 0);
  306.    newsym('exit',      s_void,   ss_builtin,    1, 0, 0, 0);
  307.    
  308.    {load the standard 'system' unit unit symbol table}
  309.    load_unitfile('TPTCSYS.UNS',globals);
  310.  
  311.    {mark the end of predefined entries in the symbol table}
  312.    newsym('<predef>',  s_void,   ss_builtin,-1, 0, 0, 0);
  313. end;
  314.  
  315.  
  316. (********************************************************************)
  317. procedure usage(why: anystring);
  318.    {print usage instructions and copyright}
  319.  
  320.    procedure pause;
  321.    var
  322.       answer: string20;
  323.    begin
  324.       writeln;
  325.       write('More: (Enter)=yes? ');
  326.       answer := 'Y';
  327.       readln(answer);
  328.       writeln;
  329.       if upcase(answer[1]) = 'N' then
  330.          halt;
  331.    end;
  332.    
  333. begin
  334.    writeln('Copyright 1986, 1988 by Samuel H. Smith;  All rights reserved.');
  335.    writeln;
  336.    writeln('Please refer all inquiries to:');
  337.    writeln('    Samuel H. Smith          The Tool Shop BBS');
  338.    writeln('    5119 N 11 Ave 332         (602) 279-2673');
  339.    writeln('    Phoenix, AZ 85013');
  340.    writeln;
  341.    writeln('You may copy and distribute this program freely, provided that:');
  342.    writeln('    1)   No fee is charged for such copying and distribution, and');
  343.    writeln('    2)   It is distributed ONLY in its original, unmodified state.');
  344.    writeln;
  345.    writeln('If you like this program, and find it of use, then your contribution');
  346.    writeln('will be appreciated.  If you are using this product in a commercial');
  347.    writeln('environment then the contribution is not voluntary.');
  348.    writeln;
  349.    writeln('Error:   ',why);
  350.    pause;
  351.    
  352.    writeln;
  353.    writeln('Usage:   TPTC input_file [output_file] [options]');
  354.    writeln;
  355.    writeln('Where:   input_file      specifies the main source file, .PAS default');
  356.    writeln('         output_file     specifies the output file, .C default');
  357.    writeln('         -B              deBug trace during scan');
  358.    writeln('         -BP             deBug trace during Parse');
  359.    writeln('         -D              Dump user symbols');
  360.    writeln('         -DP             Dump Predefined system symbols');
  361.    writeln('         -I              output Include files'' contents');
  362.    writeln('         -L              map all identifiers to Lower case');
  363.    writeln('         -M              use Pascal/MT+ specific translations');
  364.    writeln('         -NC             No Comments passed to output file');
  365.    writeln('         -Q              Quiet mode; suppress warnings');
  366.    writeln('         -Sdir\          search dir\ for .UNS symbol files');
  367.    writeln('         -Tnn            Tab nn columns in declarations');
  368.    writeln('         -Wdrive:        use drive: for Work/scratch files (ramdrive)');
  369.    writeln('         -#              don''t translate lines starting with "#"');
  370.    pause;
  371.  
  372.    writeln('Default command parameters are loaded from TPTC environment variable.');
  373.    writeln;
  374.    writeln('Example: tptc fmap');
  375.    writeln('         tptc fmap -L -d -wj:\tmp\');
  376.    writeln('         tptc -l -d -wj: -i -q -t15 fmap.pas fmap.out');
  377.    writeln;
  378.    writeln('         set tptc=-wj: -i -l -sc:\libs');
  379.    writeln('         tptc test       ;uses options specified earlier');
  380.    halt(88);
  381. end;
  382.  
  383.  
  384. (********************************************************************)
  385. procedure process_option(par: anystring);
  386. begin
  387.    stoupper(par);
  388.  
  389.    if (par[1] = '-') or (par[1] = '/') then
  390.    begin
  391.       delete(par,1,1);
  392.       par[length(par)+1] := ' ';
  393.       
  394.       case(par[1]) of
  395.          'B': begin
  396.                  if par[2] = 'P' then
  397.                     debug_parse := true;
  398.                  debug := true;
  399.               end;
  400.  
  401.          'D': begin
  402.                  if par[2] = 'P' then
  403.                     dumppredef := true;
  404.                  dumpsymbols := true;
  405.               end;
  406.  
  407.          'I': includeinclude := true;
  408.          'L': map_lower := true;
  409.          'M': mt_plus := true;
  410.  
  411.          'N': if par[2] = 'C' then
  412.                  pass_comments := false;
  413.  
  414.          'Q': quietmode := true;
  415.  
  416.          'S': begin
  417.                  symdir := copy(par,2,65);
  418.                  if symdir[length(symdir)] <> '\' then
  419.                     symdir := symdir + '\';
  420.               end;
  421.               
  422.          'T': identlen := atoi(copy(par,2,10));
  423.          
  424.          'W': begin
  425.                  workdir := copy(par,2,65);
  426.                  if workdir[length(workdir)] <> '\' then
  427.                     workdir := workdir + '\';
  428.               end;
  429.               
  430.          '#': tshell := true;
  431.          
  432.          else usage('invalid option: -'+par);
  433.       end;
  434.    end
  435.    else
  436.  
  437.    if inname = '' then
  438.       inname := par
  439.    else
  440.  
  441.    if outname = '' then
  442.       outname := par
  443.    else
  444.       usage('extra output name: '+par);
  445. end;
  446.  
  447.  
  448. (********************************************************************)
  449. procedure decode_options;
  450. var
  451.    i:        integer;
  452.    options:  string;
  453.    opt:      string;
  454.       
  455. begin
  456.    inname := '';
  457.    outname := '';
  458.    unitname := '';
  459.    symdir := '';
  460.    ltok := '';
  461.    tok := '';
  462.    ptok := '';
  463.    spaces := '';
  464.    decl_prefix := '';
  465.  
  466.    (* build option list from TPTC environment variable and from
  467.       all command line parameters *)
  468.    options := get_environment_var('TPTC=');
  469.    for i := 1 to paramcount do
  470.       options := options + ' ' + paramstr(i);         
  471.    options := options + ' ';
  472.  
  473.  
  474.    (* parse the options into spaces and process each one *)   
  475.    repeat
  476.       i := pos(' ',options);
  477.       opt := copy(options,1,i-1);
  478.       options := copy(options,i+1,255);
  479.       if length(opt) > 0 then
  480.          process_option(opt);
  481.    until length(options) = 0;
  482.  
  483.  
  484.    (* verify all required options have been specified *)   
  485.    if inname = '' then
  486.       usage('missing input name');
  487.  
  488.    if outname = '' then
  489.    begin
  490.       outname := inname;
  491.       i := pos('.',outname);
  492.       if i > 0 then
  493.         outname := copy(outname,1,i-1);
  494.    end;
  495.    
  496.    if pos('.',outname) = 0 then
  497.       outname := outname + '.C';
  498.  
  499.    i := pos('.',outname);
  500.    unitname := copy(outname,1,i-1);
  501.    
  502.    if pos('.',inname) = 0 then
  503.       inname := inname + '.PAS';
  504.  
  505.    if inname = outname then
  506.       usage('duplicate input/output name');
  507. end;
  508.  
  509.  
  510.  
  511. (********************************************************************)
  512. (* main program *)
  513.  
  514. begin
  515.    assign(output,'');
  516.    rewrite(output);
  517.    writeln;
  518.    writeln(version1,'      ',version2);
  519.  
  520. (* do initializations *)
  521.    decode_options;
  522.    initialize;
  523.  
  524. (* process the source file(s) *)
  525.    pprogram;
  526.  
  527. (* clean up and leave *)
  528.    closing_statistics;
  529. end.
  530.  
  531.