v04i022: Turbo Pascal to C, part 1/4
Alan Strassberg
alan at leadsv.UUCP
Mon Aug 15 08:53:57 AEST 1988
Posting-number: Volume 4, Issue 22
Submitted-by: "Alan Strassberg" <alan at leadsv.UUCP>
Archive-name: tptc/Part1
[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 1229 Aug 14 16:45 =cut
# -rw-r--r-- 1 allbery System 881 Aug 14 16:45 atoi.inc
# -rw-r--r-- 1 allbery System 48 Aug 14 16:45 compall.bat
# -rw-r--r-- 1 allbery System 32 Aug 14 16:45 compold.bat
# -rw-r--r-- 1 allbery System 277 Aug 14 16:45 doall.bat
# -rw-r--r-- 1 allbery System 322 Aug 14 16:45 dostd.bat
# -rw-r--r-- 1 allbery System 173 Aug 14 16:45 ftoa.inc
# -rw-r--r-- 1 allbery System 726 Aug 14 16:45 getenv.inc
# -rw-r--r-- 1 allbery System 20 Aug 14 16:45 go.bat
# -rw-r--r-- 1 allbery System 9576 Aug 14 16:45 history.doc
# -rw-r--r-- 1 allbery System 283 Aug 14 16:45 itoa.inc
# -rw-r--r-- 1 allbery System 480 Aug 14 16:45 keypress.inc
# -rw-r--r-- 1 allbery System 1921 Aug 14 16:45 license.doc
# -rw-r--r-- 1 allbery System 204 Aug 14 16:45 ljust.inc
# -rw-r--r-- 1 allbery System 32 Aug 14 16:45 look.bat
# -rw-r--r-- 1 allbery System 11 Aug 14 16:45 make.bat
# -rw-r--r-- 1 allbery System 3939 Aug 14 16:45 readme
# -rw-r--r-- 1 allbery System 1009 Aug 14 16:45 stoupper.inc
# -rw-r--r-- 1 allbery System 468 Aug 14 16:45 t2c.bat
# -rw-r--r-- 1 allbery System 16589 Aug 14 16:45 tpcdecl.inc
#
echo 'x - =cut'
if test -f =cut; then echo 'shar: not overwriting =cut'; else
sed 's/^X//' << '________This_Is_The_END________' > =cut
X
X <<< Part of the README file >>>
X
X
X TPTC - Turbo Pascal to C translator
X Version 1.7, 25-Mar-88
X
XTptc is delivered in three archives:
X
X <<< This shar contains the contents of TPTC17SC.ARC >>>
X <<< and TPTC.DOC from TPTC17.ARC >>>
X
XTPTC17.ARC 67244 03-26-88 Translate Pascal to C. Exe+DOC files. v1.7
X This is the main distribution archive. It contains the
X translator, documentation and a few supporting files. See
X HISTORY.DOC for the revision history, including changes since
X the manual was last updated. See TODO.DOC for a list of changes
X that are planned in the near future.
X
XTPTC17SC.ARC 63947 03-26-88 Full Source Code for TPTC. SourceWare. v1.7
X This is the complete source code for TPTC. This is distributed
X under the SourceWare concept. See the file LICENSE.DOC for
X details.
X
XTPTC17TC.ARC 34428 03-26-88 A number of Test Cases for TPTC. v1.7
X This archive contains a number of "test cases" used to verify
X the operation of TPTC. New test cases are added as the
X translator development proceeds.
X
________This_Is_The_END________
if test `wc -c < =cut` -ne 1229; then
echo 'shar: =cut was damaged during transit (should have been 1229 bytes)'
fi
fi ; : end of overwriting check
echo 'x - atoi.inc'
if test -f atoi.inc; then echo 'shar: not overwriting atoi.inc'; else
sed 's/^X//' << '________This_Is_The_END________' > atoi.inc
X
X(*
X * converts ascii string to an integer value
X * (tp3 dies on leading spaces but likes trailing.
X * tp4 likes leading spaces but dies on trailing!!)
X *
X *)
X
Xfunction atol (asc: anystring): longint;
Xvar
X i: integer;
X value: longint;
X num: anystring;
X
Xbegin
X num := '';
X for i := 1 to length(asc) do
X if ((asc[i] >= '0') and (asc[i] <= 'F')) or (asc[i] = '$') then
X num := num + asc[i];
X
X if length(num) = 0 then
X value := 0
X else
X val(num, value, i);
X
X atol := value;
Xend;
X
X
Xfunction atoi (asc: anystring): integer;
Xbegin
X atoi := integer(atol(asc));
Xend;
X
Xfunction atow (asc: anystring): word;
Xbegin
X atow := word(atol(asc) and $FFFF);
Xend;
X
Xfunction htoi (asc: anystring): word;
Xbegin
X if copy(asc,1,2) = '0x' then
X asc := '$' + copy(asc,3,99);
X htoi := word(atol(asc) and $FFFF);
Xend;
X
X
________This_Is_The_END________
if test `wc -c < atoi.inc` -ne 881; then
echo 'shar: atoi.inc was damaged during transit (should have been 881 bytes)'
fi
fi ; : end of overwriting check
echo 'x - compall.bat'
if test -f compall.bat; then echo 'shar: not overwriting compall.bat'; else
sed 's/^X//' << '________This_Is_The_END________' > compall.bat
Xfor %%f in (*.c) do call compold %%f
Xq \tmp\*.c
________This_Is_The_END________
if test `wc -c < compall.bat` -ne 48; then
echo 'shar: compall.bat was damaged during transit (should have been 48 bytes)'
fi
fi ; : end of overwriting check
echo 'x - compold.bat'
if test -f compold.bat; then echo 'shar: not overwriting compold.bat'; else
sed 's/^X//' << '________This_Is_The_END________' > compold.bat
X at echo off
Xfc %1 old\%1 >\tmp\%1
________This_Is_The_END________
if test `wc -c < compold.bat` -ne 32; then
echo 'shar: compold.bat was damaged during transit (should have been 32 bytes)'
fi
fi ; : end of overwriting check
echo 'x - doall.bat'
if test -f doall.bat; then echo 'shar: not overwriting doall.bat'; else
sed 's/^X//' << '________This_Is_The_END________' > doall.bat
Xrem translate all sample programs to c
Xset tptc=-l -wj: -sc:\inc -i
Xfor %%f in (tptcsys minicrt acker dia dial fmap puzzle qsort sieve test test2 unsq) do tptc %%f
Xfor %%f in (varrec timedat4 smallrec subrange sets pointers point4 linklist findchrs) do tptc %%f
Xtptc mtplus -m
________This_Is_The_END________
if test `wc -c < doall.bat` -ne 277; then
echo 'shar: doall.bat was damaged during transit (should have been 277 bytes)'
fi
fi ; : end of overwriting check
echo 'x - dostd.bat'
if test -f dostd.bat; then echo 'shar: not overwriting dostd.bat'; else
sed 's/^X//' << '________This_Is_The_END________' > dostd.bat
Xrem translate standard unit specifications
Xset tptc=-l -wj: -sc:\inc -i
Xtptc tptcsys
Xtptc \tp\system.doc system
Xtptc \tp\dos.doc dos
Xtptc \tp\crt.doc crt
Xtptc \tp\printer.doc printer
Xrem - note: you must edit graph.doc to properly comment the documentation
Xrem - blocks that were added
Xtptc \tp\graph.doc graph
________This_Is_The_END________
if test `wc -c < dostd.bat` -ne 322; then
echo 'shar: dostd.bat was damaged during transit (should have been 322 bytes)'
fi
fi ; : end of overwriting check
echo 'x - ftoa.inc'
if test -f ftoa.inc; then echo 'shar: not overwriting ftoa.inc'; else
sed 's/^X//' << '________This_Is_The_END________' > ftoa.inc
X
X(*
X * convert floating to ascii
X *
X *)
X
Xfunction ftoa(f: real; width,dec: integer): anystring;
Xvar
X buf: anystring;
Xbegin
X str(f:width:dec,buf);
X ftoa := buf;
Xend;
X
X
________This_Is_The_END________
if test `wc -c < ftoa.inc` -ne 173; then
echo 'shar: ftoa.inc was damaged during transit (should have been 173 bytes)'
fi
fi ; : end of overwriting check
echo 'x - getenv.inc'
if test -f getenv.inc; then echo 'shar: not overwriting getenv.inc'; else
sed 's/^X//' << '________This_Is_The_END________' > getenv.inc
X
X(*
X * get the value of an environment variable
X *
X * (C) 1987 Samuel H. Smith, 14-Dec-87 (rev. 27-Jan-88)
X *
X * example: path := get_environment_var('PATH=');
X *
X *)
X
Xfunction get_environment_var(id: string): string;
Xvar
X envseg: integer;
X i: integer;
X env: string;
X
Xbegin
X envseg := memw[PrefixSeg:$2c];
X i := 0;
X
X repeat
X env := '';
X while mem[envseg:i] <> 0 do
X begin
X env := env + chr(mem[envseg:i]);
X i := i + 1;
X end;
X
X if copy(env,1,length(id)) = id then
X begin
X get_environment_var := copy(env,length(id)+1,255);
X exit;
X end;
X
X i := i + 1;
X until mem[envseg:i] = 0;
X
X(* not found *)
X get_environment_var := '';
Xend;
X
________This_Is_The_END________
if test `wc -c < getenv.inc` -ne 726; then
echo 'shar: getenv.inc was damaged during transit (should have been 726 bytes)'
fi
fi ; : end of overwriting check
echo 'x - go.bat'
if test -f go.bat; then echo 'shar: not overwriting go.bat'; else
sed 's/^X//' << '________This_Is_The_END________' > go.bat
Xe:\tc\tcc unsq >err
________This_Is_The_END________
if test `wc -c < go.bat` -ne 20; then
echo 'shar: go.bat was damaged during transit (should have been 20 bytes)'
fi
fi ; : end of overwriting check
echo 'x - history.doc'
if test -f history.doc; then echo 'shar: not overwriting history.doc'; else
sed 's/^X//' << '________This_Is_The_END________' > history.doc
X
XRevision history of TPTC
X------------------------
X
X09/09/85 v0.0 (paspp)
X Initial coding by Samuel H. Smith. Never released.
X
X12/19/86 v1.0
X First distributed as TPC10 under shareware concept.
X
X04/15/87 v1.1
X Corrected handling of unary minus. Improved error messages; added
X error messages to object file. Added handler for integer subrange
X types. Added handling for goto statement and numeric labels. The
X macro header, tpcmac.h, now contains more declarations. Distributed
X as TPC11.
X
X04/22/87 v1.2
X Corrected an error that led to a crash on lines with more than 40
X leading spaces. Distributed as TPC12.
X
X05/20/87 v1.3
X Added support for pascal/MT+: external procedures and variables,
X special write/read indirect syntax, & and ! operators, default string
X size for string declarations. Distributed as TPC13.
X
X05/26/87 v1.4
X Additional support for pascal/MT+. The translator "shifts" into a
X MT+ specific mode when it recognizes the 'MODULE' statement. The '|'
X operator is recognized for bitwise OR. The '\', '?' and '~' operators
X are all translated into a unary not. Read(ln) and Write(ln) now
X support the special case of "[]" for the I/O routine. Long integer
X literals are translated from '#nnn' to 'nnnL'
X
X06/01/87 v1.5
X Added new command-line parser. Added -lower option to map identifiers
X to lower case. Added -mt option to force pascal/mt+ mode. Added
X partial var-parameter translation. Mem, MemW, Port and PortW are all
X translated into Turbo C. Turbo-c procedure declaration syntax is now
X used. Arrays may now be subscripted by enumeration types. Null else
X clause now handled properly in IF and CASE statements. For .. downto
X is now translated correctly. The VAL..VAL form is now translated in
X case statements.
X
X---------------
X-- detect concat(concat... and replace with a sprintf variant
X-- changed sprintf calls to sbld calls to preserve sources during build
X-- pos(c,str) and pos(str,str) are now separately translated
X-- added 'base' to symbol table; use to add base-subscript offset
X in all subscript references.
X-- moved typename translations to tpcmac.h header
X-- fixed bug in non-translation of tshell directives
X-- forward pointer declarations
X-- translate inline into asm statements
X-- complete forward translation
X
X10/13/87
X-- improved string and array parameter translations
X-- string returns are now translated into char *
X
X10/15/87
X-- corrected error in typed constant translation where nested records
X are initialized.
X-- variant record declarations are translated into unions but no variant
X expression translations are done.
X-- changed nested procedure error messages to include procedure name.
X
X---------------
X02/13/88 v1.6
X Converted to TPAS 4.0 format; released under the SourceWare concept
X (see README and LICENSE.DOC).
X
X---------------
X03/10/88 v1.6a
X-- corrected recent errors in #include translation and -include processing.
X-- changes in status display and error message formats.
X-- translation of multi-dimensional and nested array declarations.
X-- translation of untyped var parameters.
X-- partial translation of absolute variable declarations.
X-- improved data type declaration in expressions with subscripts.
X
X03/11/88
X-- new method of expression type tracking; type botching is greatly
X reduced while speeding execution.
X-- rewrote include file handler to allow nested includes.
X
X03/12/88
X-- implemented proper procedure ordering for nested procedures (inmost
X procedures are output first, followed by outer procedures).
X-- shortened command-line options to single letters.
X-- added -W option to allow specification of a RAMDISK for work files.
X
X03/13/88
X-- added translation of :(expression) parameters in write statements.
X-- corrected translation of 'actual' VAR and untyped parameters.
X-- improved type detection in record member references.
X-- created 'uninc' postprocessor to split up output into original
X include files (placed in a user specified destination directory).
X-- added 't2c.bat' batch file to combine translation and include processing.
X-- added code to ignore tp4.0 interface sections.
X
X03/14/88
X-- improved indentation in generated code for variant record decls (remember,
X tptc is NOT a pretty printer! use CB or INDENT to get pretty indentation).
X
X03/15/88
X-- added boolean as a basic type; this allows automatic selection of &, |
X and &&, || in expressions.
X-- implemented translation for 'str' standard procedure.
X-- partial translation of 'val' procedure.
X-- better implementation of subscript base value translation.
X-- better type tracking in subscripted variables.
X
X03/16/88
X-- added macros for paramcount and paramstr instead of specific translations.
X-- corrected implementation of mt+ translation for write([proc],...) form.
X-- added unique prefix on local #define's to prevent name clashes.
X-- added specific translations for \r, \n, \b, \e character constants.
X-- added translation for intr() and msdos() calls.
X-- implemented constant folding in trivial cases where index bases are added.
X-- added translation of @(...) operator.
X
X03/17/88
X-- corrected translation of pointers to simple types.
X-- improved translation of character and numeric subrange types.
X-- partial translation of set expressions.
X-- corrected enumeration-type subscript range calculation.
X-- added -Tnn command option to control tabstops in declarations.
X-- changes in symbol table and parser for 20% faster operation.
X
X03/18/88
X-- disable '#...' translation (tshell passing) without -# option.
X-- exit all nested procs in fatal error handler.
X-- added symbol table entries for 'builtin' procedure translations (allows
X user redefinition of 'pos', for example).
X-- predefined symbol table entries are reported only if -DP option is used.
X-- partial translation of 'with' statements.
X
X03/19/88
X-- slight improvement in recovery from syntax errors.
X-- corrected parsing of initialized set constants.
X
X03/21/88
X-- added -B option for deBug trace while scanning source file.
X-- changed numeric character literals from octal to hex.
X-- added warning if pascal string length byte is used in expressions.
X-- implemented translation of ^c^c (multiple control character literals).
X-- eliminated recursion in scanning consecutive comments.
X-- added specific translations for \a, \f, \t, \v character literals.
X-- corrected translation of ^., ^[, and #$hex character literals.
X-- added ".pas" default on include filenames.
X-- corrected translation of "external 'file.ext'..." procedure option.
X
X03/22/88
X-- corrected parsing error that could cause lockup at end of translation.
X-- added translation from chr(lit) to character literals where possible.
X-- allowed redefinition of 'exit' procedure.
X-- corrected empty case statement and empty then-before-else translation.
X-- corrected &* possibility in fscanv.
X-- improved output format in inline translation.
X-- added -BP option for deBug trace of statement Parsing.
X-- implemented proper local symbol tables in nested functions.
X
X03/23/88
X-- corrected translation of :(expr) in write when expr starts with a digit.
X-- added runtime check for too many procedure parameters.
X-- better handling of nested with statements.
X-- partial translation of with dependant expressions.
X-- changed constant declarations from #define to 'const' to allow full
X scoping rules. (this doesn't work with tc1.0!)
X
X03/24/88
X-- partial translation of expressions accessing variant record members.
X-- better handling of forward redeclarations that are incomplete.
X-- implemented translation of TP4 units
X -- 'interface' section creates .UNS file with TPTC symbol table
X information saved for later use.
X -- 'interface' section creates .UNH header file for inclusion
X in C sources using the unit
X -- 'uses' section generates include of .UNH header and loads
X the .UNS data into the current symbol table
X you must translate SYSTEM.DOC, DOS.DOC, etc, before units USING these
X can be translated.
X-- implemented translations for $DEFINE, $IFDEF, $IFNDEF, $ELSE and $ENDIF.
X-- moved standard symbol table entries to the special unit TPTCSYS.PAS,
X which is implicitly "used" in each translation. TPTCSYS.UNS must be
X in the default directory when TPTC is called. this eliminates the need
X for special translations for val, intr, msdos and many other standard
X procedures with VAR parameters.
X-- implemented translation of 'inline' procedures (tp4).
X
X---------------
X03/25/88 v1.7
X-- repackaged into three archives: tptc17 (main file; translator, docs and
X supporting files), tptc17sc (source code), tptc17tc (test cases).
X-- cosmetic changes in code generation for interface sections.
X-- implemented 'as new_name' clause for specification of a different
X procedure/function name in the translated code (see tptcsys.pas).
X-- inline procedures in an interface section generate a warning since
X they cannot be translated in this context.
X-- added -Sdir option to specify a search directory for .UNS symbol files
X that are not in the default directory.
X-- default command-line options can be specified through the TPTC
X environment variable from dos.
X
X03/26/88
X-- changes in $i parsing (fixed case where '$i fxxx' parsed as '$ifdef xxx')
X-- changed untyped constants back to #defines despite the scoping problems
X (sure wish borland had fully implemented 'const' declarations).
X-- corrected translation of 'type mine = ^simple' where simple is already
X defined (tptc was doing a forward-type translation sometimes).
X
________This_Is_The_END________
if test `wc -c < history.doc` -ne 9576; then
echo 'shar: history.doc was damaged during transit (should have been 9576 bytes)'
fi
fi ; : end of overwriting check
echo 'x - itoa.inc'
if test -f itoa.inc; then echo 'shar: not overwriting itoa.inc'; else
sed 's/^X//' << '________This_Is_The_END________' > itoa.inc
X
X(*
X * return the string equivelant of an integer value
X *
X *)
X
Xfunction itoa (int: integer): string;
Xvar
X tstr: string;
Xbegin
X str(int, tstr);
X itoa := tstr;
Xend;
X
Xfunction ltoa (int: longint): string;
Xvar
X tstr: string;
Xbegin
X str(int, tstr);
X ltoa := tstr;
Xend;
X
X
________This_Is_The_END________
if test `wc -c < itoa.inc` -ne 283; then
echo 'shar: itoa.inc was damaged during transit (should have been 283 bytes)'
fi
fi ; : end of overwriting check
echo 'x - keypress.inc'
if test -f keypress.inc; then echo 'shar: not overwriting keypress.inc'; else
sed 's/^X//' << '________This_Is_The_END________' > keypress.inc
X
X (* -------------------------------------------------------- *)
X function ReadKey: Char;
X var
X reg: registers;
X begin
X reg.ax := $0700; {direct console input}
X msdos(reg);
X ReadKey := chr(reg.al);
X end;
X
X
X (* -------------------------------------------------------- *)
X function KeyPressed: Boolean;
X var
X reg: registers;
X begin
X reg.ax := $0b00; {ConInputStatus}
X msdos(reg);
X KeyPressed := (reg.al = $FF);
X end;
X
________This_Is_The_END________
if test `wc -c < keypress.inc` -ne 480; then
echo 'shar: keypress.inc was damaged during transit (should have been 480 bytes)'
fi
fi ; : end of overwriting check
echo 'x - license.doc'
if test -f license.doc; then echo 'shar: not overwriting license.doc'; else
sed 's/^X//' << '________This_Is_The_END________' > license.doc
X
XLICENSE
X=======
X
X SourceWare: What is it?
X -----------------------
X
X SourceWare is my name for a unique concept in user supported
X software.
X
X Programs distributed under the SourceWare concept always offer
X complete source code.
X
X This package can be freely distributed so long as it is not
X modified or sold for profit. If you find that this program is
X valuable, you can send me a donation for what you think it is
X worth. I suggest 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
X Why do I include source code? Why isn't the donation
X manditory? The value of good software should be self-evident.
X The source code is the key to complete understanding of a
X program. You can read it to find out how things are done. You
X can also change it to suit your needs, so long as you do not
X distribute the modified version without my consent.
X
X
X Copyright
X ---------
X
X If you modify this program, I would appreciate a copy of the
X new source code. I am holding the copyright on the source
X code, so please don't delete my name from the program files or
X from the documentation.
X
X
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
X bugs, and will generally fix reported problems within a few
X days.
X
X Since this is user supported software under the SourceWare
X concept, I don't expect you to contribute if you don't like it
X or if it doesn't meet your needs.
X
X If you have any questions, bugs, or suggestions, please contact
X me at:
X The Tool Shop BBS
X (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
________This_Is_The_END________
if test `wc -c < license.doc` -ne 1921; then
echo 'shar: license.doc was damaged during transit (should have been 1921 bytes)'
fi
fi ; : end of overwriting check
echo 'x - ljust.inc'
if test -f ljust.inc; then echo 'shar: not overwriting ljust.inc'; else
sed 's/^X//' << '________This_Is_The_END________' > ljust.inc
X
X(*
X * ljust - macro for left justified strings in writeln format
X *
X *)
X
Xfunction ljust(s: string; w: integer): string;
Xbegin
X repeat
X s := s + ' ';
X until length(s) >= w;
X
X ljust := s;
Xend;
X
________This_Is_The_END________
if test `wc -c < ljust.inc` -ne 204; then
echo 'shar: ljust.inc was damaged during transit (should have been 204 bytes)'
fi
fi ; : end of overwriting check
echo 'x - look.bat'
if test -f look.bat; then echo 'shar: not overwriting look.bat'; else
sed 's/^X//' << '________This_Is_The_END________' > look.bat
Xfind "%1" *.inc tptc.pas >t
Xq t
________This_Is_The_END________
if test `wc -c < look.bat` -ne 32; then
echo 'shar: look.bat was damaged during transit (should have been 32 bytes)'
fi
fi ; : end of overwriting check
echo 'x - make.bat'
if test -f make.bat; then echo 'shar: not overwriting make.bat'; else
sed 's/^X//' << '________This_Is_The_END________' > make.bat
Xtpc tptc/q
________This_Is_The_END________
if test `wc -c < make.bat` -ne 11; then
echo 'shar: make.bat was damaged during transit (should have been 11 bytes)'
fi
fi ; : end of overwriting check
echo 'x - readme'
if test -f readme; then echo 'shar: not overwriting readme'; else
sed 's/^X//' << '________This_Is_The_END________' > readme
X
X
X
X TPTC - Turbo Pascal to C translator
X Version 1.7, 25-Mar-88
X
X Copyright 1988 Samuel H. Smith; ALL RIGHTS RESERVED
X
X
X These files are distributed under the SourceWare concept.
X Do not distribute modified versions without my permission.
X Do not use any of this in a commercial product.
X Do not remove this notice or any other copyright notice.
X
X
X
X
XTptc is delivered in three archives:
X
XTPTC17.ARC 67244 03-26-88 Translate Pascal to C. Exe+DOC files. v1.7
X This is the main distribution archive. It contains the
X translator, documentation and a few supporting files. See
X HISTORY.DOC for the revision history, including changes since
X the manual was last updated. See TODO.DOC for a list of changes
X that are planned in the near future.
X
XTPTC17SC.ARC 63947 03-26-88 Full Source Code for TPTC. SourceWare. v1.7
X This is the complete source code for TPTC. This is distributed
X under the SourceWare concept. See the file LICENSE.DOC for
X details.
X
XTPTC17TC.ARC 34428 03-26-88 A number of Test Cases for TPTC. v1.7
X This archive contains a number of "test cases" used to verify
X the operation of TPTC. New test cases are added as the
X translator development proceeds.
X
X
X
X
X
X
X
X DISCLAIMER
X ==========
X
X IN NO EVENT WILL I BE LIABLE TO YOU FOR ANY DAMAGES, INCLUDING ANY
X LOST PROFITS, LOST SAVINGS OR OTHER INCIDENTAL OR CONSEQUENTIAL
X DAMAGES ARISING OUT OF YOUR USE OR INABILITY TO USE THE PROGRAM, OR
X FOR ANY CLAIM BY ANY OTHER PARTY.
X
X
X
X
Xi
X
X
X
X
X ----------------
X Turbo Pascal is a registered trademark of Borland International.
X
X
X LICENSE
X =======
X SourceWare: What is it?
X -----------------------
X SourceWare is my name for a unique concept in user supported
X software.
X
X Programs distributed under the SourceWare concept always offer
X complete 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. The donation is manditory if you are using this program
X in a comercial setting.
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? The value of good software should be
X self-evident. The source code is the key to complete understanding
X of a program. You can read it to find out how things are done. You
X can also change it to suit your needs, so long as you do not
X distribute the modified version without 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
X SUPPORT
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,
X and 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:
X The Tool Shop BBS
X (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
________This_Is_The_END________
if test `wc -c < readme` -ne 3939; then
echo 'shar: readme was damaged during transit (should have been 3939 bytes)'
fi
fi ; : end of overwriting check
echo 'x - stoupper.inc'
if test -f stoupper.inc; then echo 'shar: not overwriting stoupper.inc'; else
sed 's/^X//' << '________This_Is_The_END________' > stoupper.inc
X
X(*--------------------------------------------------------
X * map string to upper case (tpas 4.0)
X *)
X
X{$F+} procedure stoupper(var st: string); {$F-}
Xbegin
X
X Inline(
X $C4/$7E/$06/ { les di,[bp]6 ;es:di -> st[0]}
X $26/ { es:}
X $8A/$0D/ { mov cl,[di] ;cl = length}
X $FE/$C1/ { inc cl}
X
X {next:}
X $47/ { inc di}
X $FE/$C9/ { dec cl}
X $74/$12/ { jz ends}
X
X $26/ { es:}
X $8A/$05/ { mov al,[di]}
X $3C/$61/ { cmp al,'a'}
X $72/$F4/ { jb next}
X $3C/$7A/ { cmp al,'z'}
X $77/$F0/ { ja next}
X
X $2C/$20/ { sub al,' '}
X $26/ { es:}
X $88/$05/ { mov [di],al}
X $EB/$E9); { jmp next}
X
X {ends:}
Xend;
X
________This_Is_The_END________
if test `wc -c < stoupper.inc` -ne 1009; then
echo 'shar: stoupper.inc was damaged during transit (should have been 1009 bytes)'
fi
fi ; : end of overwriting check
echo 'x - t2c.bat'
if test -f t2c.bat; then echo 'shar: not overwriting t2c.bat'; else
sed 's/^X//' << '________This_Is_The_END________' > t2c.bat
Xecho off
Xrem batch driver to translate pascal to c with include file post-processing
X
Xrem insert your desired "default options" here
Xset tptc=-l -wj: -sc:\inc -i
X
Xrem check for proper command-line options
Xif .%2 == . goto usage
Xif exist %1 goto usage
X
Xtptc %1 %3 %4 %5 %6 %7 %8 %9
Xif errorlevel 1 goto exit
X
Xuninc %1.c %2
Xgoto exit
X
X:usage
Xecho.
Xecho usage: t2c SOURCEFILE DESTDIR
Xecho ex: t2c tptc \dest
Xecho (do not specify input file extension)
X
X:exit
Xecho.
X
________This_Is_The_END________
if test `wc -c < t2c.bat` -ne 468; then
echo 'shar: t2c.bat was damaged during transit (should have been 468 bytes)'
fi
fi ; : end of overwriting check
echo 'x - tpcdecl.inc'
if test -f tpcdecl.inc; then echo 'shar: not overwriting tpcdecl.inc'; else
sed 's/^X//' << '________This_Is_The_END________' > tpcdecl.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 * process pascal data type specifications
X *
X *)
X
Xfunction psimpletype: string80;
X {parse a simple (single keyword and predefined) type; returns the
X translated type specification; sets the current data type}
Xvar
X sym: symptr;
X
Xbegin
X if debug_parse then write(' <simpletype>');
X
X sym := locatesym(ltok);
X if sym <> nil then
X begin
X curtype := sym^.symtype;
X if cursuptype = ss_none then
X cursuptype := sym^.suptype;
X curlimit := sym^.limit;
X curbase := sym^.base;
X curpars := sym^.parcount;
X end;
X
X psimpletype := usetok;
Xend;
X
X
X(********************************************************************)
Xprocedure pdatatype(stoclass: anystring;
X var vars: paramlist;
X prefix: anystring;
X suffix: anystring;
X addsemi: boolean);
X {parse any full data type specification; input is a list of variables
X to be declared with this data type; stoclass is a storage class prefix
X (usually 'static ', '', 'typedef ', or 'extern '. prefix and suffix
X are variable name modifiers used in pointer and subscript translations;
X recursive for complex data types}
X
Xconst
X forward_typedef: anystring = '';
X forward_undef: anystring = '';
X
Xvar
X i: integer;
X ts: anystring;
X ex: anystring;
X sym: symptr;
X nbase: integer;
X bbase: integer;
X nsuper: supertypes;
X
X procedure pvarlist;
X var
X i: integer;
X pcnt: integer;
X
X begin
X ts := '';
X pcnt := -1;
X
X if tok = 'ABSOLUTE' then
X begin
X if debug_parse then write(' <abs>');
X gettok; {consume the ABSOLUTE}
X ts := pexpr; {get the absolute lvalue}
X
X if tok[1] = ':' then {absolute addressing}
X begin
X gettok;
X ts := ' = MK_FP('+ts+','+pexpr+')';
X end
X
X else {variable aliasing}
X begin
X if ts[1] = '*' then
X ts := ' = ' + copy(ts,2,255)
X else
X ts := ' = &(' + ts + ')';
X end;
X
X {convert new variable into a pointer if needed}
X if length(prefix) = 0 then
X prefix := '*';
X
X {force automatic pointer dereference in expressions}
X pcnt := -2;
X end;
X
X if cursuptype = ss_none then
X cursuptype := ss_scalar;
X
X for i := 1 to vars.n do
X begin
X newsym(vars.id[i],curtype,cursuptype,pcnt,withlevel,curlimit,nbase);
X puts(prefix+vars.id[i]+suffix+ts);
X if i < vars.n then
X puts(', ');
X end;
X end;
X
X
X procedure parray;
X begin
X if debug_parse then write(' <array>');
X gettok; {consume the ARRAY}
X
X repeat
X gettok; {consume the [ or ,}
X
X ts := pexpr; {consume the lower subscript expression}
X if isnumber(ts) then
X nbase := atoi(ts)
X else
X nbase := curbase;
X
X if tok = '..' then
X begin
X gettok; {consume the ..}
X ts := pexpr;
X
X subtract_base(ts,nbase-1);
X end
X else
X
X begin {subscript by typename - look up type range}
X sym := locatesym(ts);
X if sym <> nil then
X begin
X nbase := sym^.base;
X if (sym^.limit > 0) and (sym^.suptype <> ss_const) then
X ts := ' /* ' + ts + ' */ ' + itoa(sym^.limit-nbase+1);
X end;
X end;
X
X suffix := suffix + '[' + ts + ']';
X
X until tok[1] <> ',';
X
X gettok; {consume the ]}
X gettok; {consume the OF}
X
X cursuptype := ss_array;
X end;
X
X
X procedure pstring;
X begin
X if debug_parse then write(' <string>');
X gettok; {consume the STRING}
X
X if tok[1] = '[' then
X begin
X gettok; {consume the [}
X
X nsuper := cursuptype;
X ts := pexpr;
X cursuptype := nsuper;
X subtract_base(ts,-1); {increment string size by one}
X suffix := suffix + '[' + ts + ']';
X
X gettok; {consume the ]}
X end
X else
X suffix := suffix + '[STRSIZ]';
X
X puts(ljust(stoclass+'char',identlen));
X curtype := s_string;
X nbase := 1;
X pvarlist;
X end;
X
X
X procedure ptext;
X begin
X if debug_parse then write(' <text>');
X gettok; {consume the TEXT}
X
X if tok[1] = '[' then
X begin
X gettok; {consume the [}
X nsuper := cursuptype;
X ts := pexpr;
X cursuptype := nsuper;
X gettok; {consume the ]}
X end;
X
X puts(ljust(stoclass+'text',identlen));
X curtype := s_file;
X pvarlist;
X end;
X
X
X procedure pfile;
X begin
X if debug_parse then write(' <file>');
X gettok; {consume the FILE}
X
X if tok = 'OF' then
X begin
X gettok; {consume the OF}
X ts := tok;
X gettok; {consume the recordtype}
X ts := '/* file of '+ts+' */ ';
X end
X else
X ts := '/* untyped file */ ';
X
X puts(ljust(stoclass+'int',identlen)+ts);
X curtype := s_file;
X pvarlist;
X end;
X
X
X procedure pset;
X begin
X if debug_parse then write(' <set>');
X gettok; {consume the SET}
X gettok; {consume the OF}
X
X ts := '/* ';
X if toktype = identifier then
X ts := ts + usetok
X else
X
X if tok = '(' then
X begin
X repeat
X ts := ts + usetok
X until (tok[1] = ')') or recovery;
X ts := ts + usetok;
X end
X
X else
X ts := ts + psetof;
X
X puts(ljust(stoclass+'setrec',identlen)+ts+' */ ');
X curtype := s_struct;
X pvarlist;
X end;
X
X
X procedure pvariant;
X begin
X if debug_parse then write(' <variant>');
X gettok; {consume the CASE}
X
X ts := ltok;
X gettok; {consume the selector identifier}
X
X if tok[1] = ':' then
X begin
X gettok; {consume the :}
X puts(ltok+' '+ts+ '; /* Selector */');
X gettok; {consume the selector type}
X end
X else
X puts(' /* Selector is '+ts+' */');
X
X gettok;
X puts('union { ');
X newline;
X
X while (tok <> '}') and not recovery do
X begin
X ts := pexpr; {parse the selector constant}
X while tok[1] = ',' do
X begin
X gettok;
X ts := pexpr;
X end;
X
X gettok; {consume the :}
X
X puts(' struct { ');
X
X ts := 's' + ts;
X decl_prefix := 'v.'+ts+'.';
X pvar;
X decl_prefix := '';
X
X gettok; {consume the ')'}
X
X puts(' } '+ts+';');
X
X {arrange for reference translation}
X newsym(ts,s_void,ss_struct,-1,0,0,0);
X cursym^.repid := ts;
X
X if tok[1] = ';' then
X gettok;
X end;
X
X puts(' } v;');
X newline;
X end;
X
X
X procedure precord;
X begin
X if debug_parse then write(' <record>');
X puts(stoclass+'struct '+vars.id[1]+' { ');
X
X inc(withlevel);
X pvar; {process each record member}
X
X if tok = 'CASE' then {process the variant part, if any}
X pvariant;
X dec(withlevel);
X
X puttok; {output the closing brace}
X gettok; {and consume it}
X
X curtype := s_struct;
X cursuptype := ss_struct;
X pvarlist; {output any variables of this record type}
X
X {convert a #define into a typedef in case of a forward pointer decl}
X if length(forward_typedef) > 0 then
X begin
X puts(';');
X newline;
X puts(forward_undef);
X newline;
X puts(forward_typedef);
X forward_typedef := '';
X end;
X end;
X
X
X procedure penum;
X var
X members: integer;
X
X begin
X if debug_parse then write(' <enum>');
X puts(stoclass+'enum { ');
X
X gettok;
X members := 0;
X repeat
X puts(ltok);
X if toktype = identifier then
X inc(members);
X gettok;
X until (tok[1] = ')') or recovery;
X
X puts(' } ');
X gettok; {consume the )}
X
X curtype := s_int;
X curlimit := members-1;
X nbase := 0;
X pvarlist;
X end;
X
X
X procedure pintrange;
X begin
X if debug_parse then write(' <int.range>');
X ex := pexpr; {consume the lower limit expression}
X nbase := atoi(ex);
X
X if tok <> '..' then
X begin
X syntax('".." expected');
X exit;
X end;
X
X gettok; {consume the ..}
X ts := pexpr; {consume the number}
X
X sym := locatesym(ts);
X if sym <> nil then
X if sym^.limit > 0 then
X ts := itoa(sym^.limit);
X
X curtype := s_int;
X curlimit := atoi(ts);
X puts(ljust(stoclass+'int',identlen)+'/* '+ex+'..'+ts+' */ ');
X pvarlist;
X end;
X
X procedure pcharrange;
X begin
X if debug_parse then write(' <char.range>');
X ex := pexpr; {consume the lower limit expression}
X nbase := ord(ex[2]);
X
X if tok <> '..' then
X begin
X syntax('".." expected');
X exit;
X end;
X
X gettok; {consume the ..}
X ts := pexpr; {consume the number}
X
X sym := locatesym(ts);
X if sym <> nil then
X if sym^.limit > 0 then
X ts := itoa(sym^.limit);
X
X curtype := s_char;
X curlimit := ord(ts[2]);
X puts(ljust(stoclass+'char',identlen)+'/* '+ex+'..'+ts+' */ ');
X pvarlist;
X end;
X
X procedure psimple;
X begin
X ex := psimpletype;
X if cursuptype <> ss_array then
X nbase := curbase;
X
X if tok = '..' then
X begin
X if debug_parse then write(' <range>');
X gettok; {consume the ..}
X ts := pexpr; {consume the high limit}
X
X sym := locatesym(ts);
X if sym <> nil then
X if sym^.limit > 0 then
X ts := itoa(sym^.limit);
X
X curtype := s_int;
X curlimit := curbase;
X puts(ljust(stoclass+'int',identlen)+'/* '+ex+'..'+ex+' */ ');
X pvarlist;
X exit;
X end;
X
X {pointer to simpletype?}
X i := pos('^',ex);
X if i <> 0 then
X begin
X if debug_parse then write(' <pointer>');
X delete(ex,i,1);
X prefix := '*';
X cursuptype := ss_pointer;
X end;
X
X sym := locatesym(ex);
X
X {potential forward pointer reference?}
X if (stoclass = 'typedef ') and (vars.n = 1) and
X (prefix = '*') and (sym = nil) then
X begin
X if debug_parse then write(' <forward>');
X newsym(vars.id[1],curtype,cursuptype,-1,0,curlimit,0);
X puts(ljust('#define '+vars.id[1],identlen)+'struct '+ex+' *');
X forward_undef := '#undef '+vars.id[1];
X forward_typedef := 'typedef struct '+ex+' *'+vars.id[1];
X addsemi := false;
X end
X else
X
X {ordinary simple types}
X begin
X if debug_parse then write(' <simple>');
X puts(ljust(stoclass+ex,identlen));
X pvarlist;
X end;
X end;
X
Xbegin
X cursuptype := ss_none;
X curlimit := 0;
X nbase := 0;
X
X if tok = 'EXTERNAL' then
X begin
X gettok; {consume the EXTERNAL}
X stoclass := 'extern '+stoclass;
X end;
X
X if tok = 'PACKED' then
X gettok;
X while tok = 'ARRAY' do
X parray;
X if tok = 'PACKED' then
X gettok;
X
X if tok = 'STRING' then pstring
X else if tok = 'TEXT' then ptext
X else if tok = 'FILE' then pfile
X else if tok = 'SET' then pset
X else if tok = '(' then penum
X else if tok = 'RECORD' then precord
X else if toktype = number then pintrange
X else if toktype = chars then pcharrange
X else psimple;
X
X if addsemi then
X puts(';');
X puts(' ');
X
X if tok[1] = ';' then
X gettok;
Xend;
X
X
X(********************************************************************)
X(*
X * declaration keyword processors
X * const, type, var, label
X *
X * all enter with tok=section type
X * exit with tok=new section or begin or proc or func
X *
X *)
X
Xprocedure pconst;
X {parse and translate a constant section}
Xvar
X vars: paramlist;
X parlev: integer;
X exp: string;
X dup: boolean;
X
Xbegin
X if debug_parse then write(' <const>');
X gettok;
X
X while (toktype <> keyword) and not recovery do
X begin
X nospace := false;
X vars.n := 1;
X vars.id[1] := ltok;
X
X gettok; {consume the id}
X
X if tok[1] = '=' then {untyped constant}
X begin
X if debug_parse then write(' <untyped.const>');
X
X {$b-} {requires short-circuit evaluation}
X dup := (unitlevel > 0) and (cursym <> nil) and
X (cursym^.suptype = ss_const);
X
X gettok; {consume the =}
X
X exp := pexpr;
X curtype := cexprtype;
X if isnumber(exp) then
X curlimit := atoi(exp);
X
X {prefix identifier if needed to prevent conflict with other defines}
X newsym(vars.id[1],curtype,ss_const,-1,0,curlimit,0);
X if dup then
X begin
X vars.id[1] := procnum + '_' + vars.id[1];
X cursym^.repid := vars.id[1];
X end;
X
X puts(ljust('#define '+vars.id[1],identlen));
X puts(exp);
X puts(' ');
X
X gettok; {consume the ;}
X end
X else
X
X begin {typed constants}
X if debug_parse then write(' <typed.const>');
X
X gettok; {consume the :}
X
X pdatatype('',vars,'','',false);
X
X if tok[1] <> '=' then
X begin
X syntax('"=" expected');
X exit;
X end;
X
X gettok; {consume the =}
X
X puts(' = ');
X parlev := 0;
X
X repeat
X if tok[1] = '[' then
X begin
X gettok;
X exp := psetof;
X gettok;
X puts(exp);
X end
X else
X
X if tok[1] = '(' then
X begin
X inc(parlev);
X puts('{');
X gettok;
X end
X else
X
X if tok[1] = ')' then
X begin
X dec(parlev);
X puts('}');
X gettok;
X end
X else
X
X if tok[1] = ',' then
X begin
X puttok;
X gettok;
X end
X else
X
X if (parlev > 0) and (tok[1] = ';') then
X begin
X puts(',');
X gettok;
X end
X else
X
X if tok[1] <> ';' then
X begin
X exp := pexpr;
X if tok[1] = ':' then
X gettok {discard 'member-identifier :'}
X else
X puts(exp);
X end;
X
X until ((parlev = 0) and (tok[1] = ';')) or recovery;
X
X puttok; {output the final ;}
X gettok;
X end;
X end;
Xend;
X
X
X(********************************************************************)
Xprocedure ptype;
X {parse and translate a type section}
Xvar
X vars: paramlist;
X
Xbegin
X if debug_parse then write(' <type>');
X gettok;
X
X while (toktype <> keyword) do
X begin
X vars.n := 1;
X vars.id[1] := usetok;
X
X if tok = '=' then
X gettok
X else
X begin
X syntax('"=" expected');
X exit;
X end;
X
X nospace := false;
X pdatatype('typedef ',vars,'','',true);
X end;
X
Xend;
X
X
X(********************************************************************)
Xprocedure pvar;
X {parse and translate a variable section}
Xvar
X vars: paramlist;
X sto: string20;
Xbegin
X if debug_parse then write(' <var>');
X
X if in_interface and (withlevel = 0) then
X sto := 'extern '
X else
X sto := '';
X
X vars.n := 0;
X gettok;
X
X while (toktype <> keyword) and (tok[1] <> '}') and (tok[1] <> ')') do
X begin
X nospace := true;
X
X repeat
X if tok[1] = ',' then
X gettok;
X
X inc(vars.n);
X if vars.n > maxparam then
X fatal('Too many identifiers (pvar)');
X vars.id[vars.n] := ltok;
X gettok;
X until tok[1] <> ',';
X
X if tok[1] <> ':' then
X begin
X syntax('":" expected');
X exit;
X end;
X
X gettok; {consume the :}
X nospace := false;
X pdatatype(sto,vars,'','',true);
X vars.n := 0;
X end;
Xend;
X
X
________This_Is_The_END________
if test `wc -c < tpcdecl.inc` -ne 16589; then
echo 'shar: tpcdecl.inc was damaged during transit (should have been 16589 bytes)'
fi
fi ; : end of overwriting check
exit 0
More information about the Comp.sources.misc
mailing list