alan@leadsv.UUCP (Alan Strassberg) (08/15/88)
Posting-number: Volume 4, Issue 22 Submitted-by: "Alan Strassberg" <alan@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@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