alan@leadsv.UUCP (Alan Strassberg) (08/15/88)
Posting-number: Volume 4, Issue 25 Submitted-by: "Alan Strassberg" <alan@leadsv.UUCP> Archive-name: tptc/Part4 [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 17240 Aug 14 16:46 tptc.pas # -rw-r--r-- 1 allbery System 5336 Aug 14 16:46 tptcmac.h # -rw-r--r-- 1 allbery System 4474 Aug 14 16:46 tptcsys.pas # -rw-r--r-- 1 allbery System 4673 Aug 14 16:46 uninc.pas # -rw-r--r-- 1 allbery System 149 Aug 14 16:46 upd.bat # echo 'x - tptc.pas' if test -f tptc.pas; then echo 'shar: not overwriting tptc.pas'; else sed 's/^X//' << '________This_Is_The_END________' > tptc.pas X X(* X * TPTC - Turbo Pascal to C translator X * X * S.H.Smith, 9/9/85 (rev. 2/13/88) X * X * Copyright 1986, 1988 by Samuel H. Smith; All rights reserved. X * X * See HISTORY.DOC for complete revision history. X * See TODO.DOC for pending changes. X * X *) X X{$T+} {Produce mapfile} X{$R-} {Range checking} X{$B-} {Boolean complete evaluation} X{$S-} {Stack checking} X{$I+} {I/O checking} X{$N-} {Numeric coprocessor} X{$V-} {Relax string rules} X{$M 65500,16384,655360} {stack, minheap, maxhep} X X Xprogram translate_tp_to_c; X Xuses Dos; X Xconst X version1 = 'TPTC - Translate Pascal to C'; X version2 = 'Version 1.7 03/26/88 (C) 1988 S.H.Smith'; X X minstack = 4000; {minimum free stack space needed} X outbufsiz = 10000; {size of top level output file buffer} X inbufsiz = 2000; {size of input file buffers} X maxparam = 16; {max number of parameters to process} X maxnest = 10; {maximum procedure nesting-1} X maxincl = 2; {maximum source file nesting-1} X statrate = 5; {clock ticks between status displays} X ticks_per_second = 18.2; X X Xconst X nestfile = 'p$'; {scratchfile for nested procedures} X Xtype X anystring = string [127]; X string255 = string [255]; X string80 = string [80]; X string64 = string [64]; X string40 = string [40]; X string20 = string [20]; X string10 = string [10]; X X X(* command options *) X Xconst X debug: boolean = false; {-B trace scan} X debug_parse: boolean = false; {-BP trace parse} X mt_plus: boolean = false; {-M true if translating Pascal/MT+} X map_lower: boolean = false; {-L true to map idents to lower case} X dumpsymbols: boolean = false; {-D dump tables to object file} X dumppredef: boolean = false; {-DP dump predefined system symbols} X includeinclude:boolean = false; {-I include include files in output} X quietmode: boolean = false; {-Q disable warnings?} X identlen: integer = 13; {-Tnn nominal length of identifiers} X workdir: string64 = ''; {-Wd: work/scratch file directory} X tshell: boolean = false; {-# pass lines starting with '#'} X pass_comments: boolean = true; {-NC no comments in output} X X Xtype X toktypes = (number, identifier, X strng, keyword, X chars, comment, X unknown); X X symtypes = (s_int, s_long, X s_double, s_string, X s_char, s_struct, X s_file, s_bool, X s_void ); X X supertypes = (ss_scalar, ss_const, X ss_func, ss_struct, X ss_array, ss_pointer, X ss_builtin, ss_none ); X X symptr = ^symrec; X symrec = record X symtype: symtypes; { simple type } X suptype: supertypes; { scalar,array etc. } X id: string40; { name of entry } X repid: string40; { replacement ident } X X parcount: integer; { parameter count, X >=0 -- procedure/func pars X >=1 -- array level X -1 -- simple variable X -2 -- implicit deref var } X X pvar: word; { var/val reference bitmap, or X structure member nest level } X X base: integer; { base value for subscripts } X limit: word; { limiting value for scalars } X X next: symptr; { link to next symbol in table } X end; X X paramlist = record X n: integer; X id: array [1..maxparam] of string80; X stype: array [1..maxparam] of symtypes; X sstype: array [1..maxparam] of supertypes; X end; X Xconst X X (* names of symbol types *) X typename: array[symtypes] of string40 = X ('int', 'long', X 'double', 'strptr', X 'char', 'struct', X 'file', 'boolean', X 'void' ); X X supertypename: array[supertypes] of string40 = X ('scalar', 'constant', X 'function', 'structure', X 'array', 'pointer', X 'builtin', 'none' ); X X X (* these words start new statements or program sections *) X nkeywords = 14; X keywords: array[1..nkeywords] of string40 = ( X 'PROGRAM', 'PROCEDURE', 'FUNCTION', X 'VAR', 'CONST', 'TYPE', X 'LABEL', 'OVERLAY', 'FORWARD', X 'MODULE', 'EXTERNAL', 'CASE', X 'INTERFACE', 'IMPLEMENTATION'); X Xtype X byteptr = ^byte; X Xvar X inbuf: array [0..maxincl] of byteptr; X srcfd: array [0..maxincl] of text; X srclines: array [0..maxincl] of integer; X srcfiles: array [0..maxincl] of string64; X X outbuf: array [0..maxnest] of byteptr; X ofd: array [0..maxnest] of text; X X inname: string64; {source filename} X outname: string64; {output filename} X unitname: string64; {output filename without extention} X symdir: string64; {.UNS symbol search directory} X ltok: string80; {lower/upper current token} X tok: string80; {all upper case current token} X ptok: string80; {previous token} X spaces: anystring; {leading spaces on current line} X decl_prefix: anystring; {declaration identifier prefix, if any} X Xconst X starttime: longint = 0; {time translation was started} X curtime: longint = 0; {current time} X statustime: longint = 0; {time of last status display} X X nextc: char = ' '; X toktype: toktypes = unknown; X ptoktype: toktypes = unknown; X linestart: boolean = true; X extradot: boolean = false; X nospace: boolean = false; X X cursym: symptr = nil; X curtype: symtypes = s_void; X cexprtype: symtypes = s_void; X cursuptype: supertypes = ss_scalar; X curlimit: integer = 0; X curbase: integer = 0; X curpars: integer = 0; X X withlevel: integer = 0; X unitlevel: integer = 0; X srclevel: integer = 0; X srctotal: integer = 1; X objtotal: integer = 0; X X procnum: string[2] = 'AA'; X recovery: boolean = false; X X in_interface: boolean = false; X top_interface: symptr = nil; X X globals: symptr = nil; X locals: symptr = nil; X X X X(* nonspecific library includes *) X X{$I ljust.inc} {left justify writeln strings} X{$I atoi.inc} {ascii to integer conversion} X{$I itoa.inc} {integer to ascii conversion} X{$I ftoa.inc} {float to ascii conversion} X{$I stoupper.inc} {map string to upper case} X{$I keypress.inc} {msdos versions of keypressed and readkey} X{$I getenv.inc} {get environment variables} X X X Xprocedure fatal (message: string); forward; Xprocedure warning (message: string); forward; Xprocedure scan_tok; forward; Xprocedure gettok; forward; Xprocedure puttok; forward; Xprocedure putline; forward; Xprocedure puts(s: string); forward; Xprocedure putln(s: string); forward; Xfunction plvalue: string; forward; Xfunction pexpr: string; forward; Xprocedure exit_procdef; forward; Xprocedure pblock; forward; Xprocedure pstatement; forward; Xprocedure pimplementation; forward; Xprocedure punit; forward; Xprocedure pvar; forward; Xprocedure pident; forward; X X X(********************************************************************) X X{$I tpcsym.inc} {symbol table handler} X{$I tpcmisc.inc} {misc functions} X{$I tpcscan.inc} {scanner; lexical analysis} X{$I tpcexpr.inc} {expression parser and translator} X{$I tpcstmt.inc} {statement parser and translator} X{$I tpcdecl.inc} {declaration parser and translator} X{$I tpcunit.inc} {program unit parser and translator} X X X X(********************************************************************) Xprocedure initialize; X {initializations before translation can begin} X X procedure enter(name: anystring; etype: symtypes; elimit: integer); X begin X newsym(name, etype, ss_scalar, -1, 0, elimit, 0); X end; X Xbegin X srclines[srclevel] := 1; X srcfiles[srclevel] := inname; X assign(srcfd[srclevel],inname); X {$I-} reset(srcfd[srclevel]); {$I+} X if ioresult <> 0 then X begin X writeln('Can''t open input file: ',inname); X halt(88); X end; X X getmem(inbuf[srclevel],inbufsiz); X SetTextBuf(srcfd[srclevel],inbuf[srclevel]^,inbufsiz); X X assign(ofd[unitlevel],outname); X{$I-} X rewrite(ofd[unitlevel]); X{$I+} X if ioresult <> 0 then X begin X writeln('Can''t open output file: ',outname); X halt(88); X end; X X getmem(outbuf[unitlevel],outbufsiz); X SetTextBuf(ofd[unitlevel],outbuf[unitlevel]^,outbufsiz); X mark_time(starttime); X X {enter predefined types into symbol table} X enter('boolean', s_bool,1); X enter('integer', s_int,maxint); X enter('word', s_int,0); X enter('longint', s_long,0); X enter('real', s_double,0); X enter('char', s_char,255); X enter('byte', s_int,255); X enter('file', s_file,0); X enter('text', s_file,0); X enter('true', s_bool,1); X enter('false', s_bool,1); X newsym('string', s_string, ss_scalar, -1, 0, 0, 1); X newsym('not', s_int, ss_builtin, 0, 0, 0, 0); X X {enter predefined functions into symbol table} X newsym('chr', s_char, ss_builtin, 1, 0, 0, 0); X newsym('pos', s_int, ss_builtin, 2, 0, 0, 0); X newsym('str', s_void, ss_builtin, 2, 0, 0, 0); X newsym('port', s_int, ss_builtin, 1, 0, 0, 0); X newsym('portw', s_int, ss_builtin, 1, 0, 0, 0); X newsym('mem', s_int, ss_builtin, 2, 0, 0, 0); X newsym('memw', s_int, ss_builtin, 2, 0, 0, 0); X newsym('exit', s_void, ss_builtin, 1, 0, 0, 0); X X {load the standard 'system' unit unit symbol table} X load_unitfile('TPTCSYS.UNS',globals); X X {mark the end of predefined entries in the symbol table} X newsym('<predef>', s_void, ss_builtin,-1, 0, 0, 0); Xend; X X X(********************************************************************) Xprocedure usage(why: anystring); X {print usage instructions and copyright} X X procedure pause; X var X answer: string20; X begin X writeln; X write('More: (Enter)=yes? '); X answer := 'Y'; X readln(answer); X writeln; X if upcase(answer[1]) = 'N' then X halt; X end; X Xbegin X writeln('Copyright 1986, 1988 by Samuel H. Smith; All rights reserved.'); X writeln; X writeln('Please refer all inquiries to:'); X writeln(' Samuel H. Smith The Tool Shop BBS'); X writeln(' 5119 N 11 Ave 332 (602) 279-2673'); X writeln(' Phoenix, AZ 85013'); X writeln; X writeln('You may copy and distribute this program freely, provided that:'); X writeln(' 1) No fee is charged for such copying and distribution, and'); X writeln(' 2) It is distributed ONLY in its original, unmodified state.'); X writeln; X writeln('If you like this program, and find it of use, then your contribution'); X writeln('will be appreciated. If you are using this product in a commercial'); X writeln('environment then the contribution is not voluntary.'); X writeln; X writeln('Error: ',why); X pause; X X writeln; X writeln('Usage: TPTC input_file [output_file] [options]'); X writeln; X writeln('Where: input_file specifies the main source file, .PAS default'); X writeln(' output_file specifies the output file, .C default'); X writeln(' -B deBug trace during scan'); X writeln(' -BP deBug trace during Parse'); X writeln(' -D Dump user symbols'); X writeln(' -DP Dump Predefined system symbols'); X writeln(' -I output Include files'' contents'); X writeln(' -L map all identifiers to Lower case'); X writeln(' -M use Pascal/MT+ specific translations'); X writeln(' -NC No Comments passed to output file'); X writeln(' -Q Quiet mode; suppress warnings'); X writeln(' -Sdir\ search dir\ for .UNS symbol files'); X writeln(' -Tnn Tab nn columns in declarations'); X writeln(' -Wdrive: use drive: for Work/scratch files (ramdrive)'); X writeln(' -# don''t translate lines starting with "#"'); X pause; X X writeln('Default command parameters are loaded from TPTC environment variable.'); X writeln; X writeln('Example: tptc fmap'); X writeln(' tptc fmap -L -d -wj:\tmp\'); X writeln(' tptc -l -d -wj: -i -q -t15 fmap.pas fmap.out'); X writeln; X writeln(' set tptc=-wj: -i -l -sc:\libs'); X writeln(' tptc test ;uses options specified earlier'); X halt(88); Xend; X X X(********************************************************************) Xprocedure process_option(par: anystring); Xbegin X stoupper(par); X X if (par[1] = '-') or (par[1] = '/') then X begin X delete(par,1,1); X par[length(par)+1] := ' '; X X case(par[1]) of X 'B': begin X if par[2] = 'P' then X debug_parse := true; X debug := true; X end; X X 'D': begin X if par[2] = 'P' then X dumppredef := true; X dumpsymbols := true; X end; X X 'I': includeinclude := true; X 'L': map_lower := true; X 'M': mt_plus := true; X X 'N': if par[2] = 'C' then X pass_comments := false; X X 'Q': quietmode := true; X X 'S': begin X symdir := copy(par,2,65); X if symdir[length(symdir)] <> '\' then X symdir := symdir + '\'; X end; X X 'T': identlen := atoi(copy(par,2,10)); X X 'W': begin X workdir := copy(par,2,65); X if workdir[length(workdir)] <> '\' then X workdir := workdir + '\'; X end; X X '#': tshell := true; X X else usage('invalid option: -'+par); X end; X end X else X X if inname = '' then X inname := par X else X X if outname = '' then X outname := par X else X usage('extra output name: '+par); Xend; X X X(********************************************************************) Xprocedure decode_options; Xvar X i: integer; X options: string; X opt: string; X Xbegin X inname := ''; X outname := ''; X unitname := ''; X symdir := ''; X ltok := ''; X tok := ''; X ptok := ''; X spaces := ''; X decl_prefix := ''; X X (* build option list from TPTC environment variable and from X all command line parameters *) X options := get_environment_var('TPTC='); X for i := 1 to paramcount do X options := options + ' ' + paramstr(i); X options := options + ' '; X X X (* parse the options into spaces and process each one *) X repeat X i := pos(' ',options); X opt := copy(options,1,i-1); X options := copy(options,i+1,255); X if length(opt) > 0 then X process_option(opt); X until length(options) = 0; X X X (* verify all required options have been specified *) X if inname = '' then X usage('missing input name'); X X if outname = '' then X begin X outname := inname; X i := pos('.',outname); X if i > 0 then X outname := copy(outname,1,i-1); X end; X X if pos('.',outname) = 0 then X outname := outname + '.C'; X X i := pos('.',outname); X unitname := copy(outname,1,i-1); X X if pos('.',inname) = 0 then X inname := inname + '.PAS'; X X if inname = outname then X usage('duplicate input/output name'); Xend; X X X X(********************************************************************) X(* main program *) X Xbegin X assign(output,''); X rewrite(output); X writeln; X writeln(version1,' ',version2); X X(* do initializations *) X decode_options; X initialize; X X(* process the source file(s) *) X pprogram; X X(* clean up and leave *) X closing_statistics; Xend. X ________This_Is_The_END________ if test `wc -c < tptc.pas` -ne 17240; then echo 'shar: tptc.pas was damaged during transit (should have been 17240 bytes)' fi fi ; : end of overwriting check echo 'x - tptcmac.h' if test -f tptcmac.h; then echo 'shar: not overwriting tptcmac.h'; else sed 's/^X//' << '________This_Is_The_END________' > tptcmac.h X X/* X * TPTCMAC.H - Macro Header for use with Turbo Pascal --> C Translator X * X * (C) 1986 S.H.Smith (rev. 24-Mar-88) X * X */ X X#include <stdio.h> X#include <stdlib.h> X#include <string.h> X#include <stdarg.h> X#include <dos.h> X#include <conio.h> X#include <ctype.h> X X X/* define some simple keyword replacements */ X X X#define pred(v) ((v)-1) X#define succ(v) ((v)+1) X#define chr(n) (n) X#define ord(c) (c) X#define lo(v) (v & 0xff) X#define hi(v) (v >> 8) X#define inc(v) ++(v) X#define dec(v) --(v) X X#define maxint 0x7fff X#define integer int X#define word unsigned X#define longint long X#define byte char X#define real double X#define boolean int Xtypedef void *pointer; X X#define false 0 X#define true 1 X#define nil NULL X X X#define delete(s,p,num) strcpy(s+p-1,s+p+num) X#define val(s,res,code) code=0, res=atof(s) X Xtypedef char *charptr; X#define STRSIZ 255 /* default string length */ X X#define paramstr(n) (argv[n]) X#define paramcount (argc-1) X X X/* X * file access support X */ X Xchar _CURNAME[64]; Xint ioresult = 0; X Xtypedef FILE *text; X#define kbd stdin X#define input stdin X#define con stdout X#define output stdout X X#define assign(fd,name) strcpy(_CURNAME,name) X Xvoid reset(text *fd) X{ X *fd = fopen(_CURNAME,"r"); X ioresult = (*fd == NULL); X} X Xvoid rewrite(text *fd) X{ X *fd = fopen(_CURNAME,"w"); X ioresult = (*fd == NULL); X} X Xvoid append(text *fd) X{ X *fd = fopen(_CURNAME,"a"); X ioresult = (*fd == NULL); X} X X X/* X * setrec setof(a,b,...,-1) X * construct and return a set of the specified character values X * X * inset(ex,setrec) X * predicate returns true if expression ex is a member of X * the set parameter X * X */ X#define __ -2 /* thru .. */ X#define _E -1 /* end of set marker */ X Xtypedef struct { X char setstub[16]; X } setrec; X X X X/* X * copy len bytes from the dynamic string dstr starting at position from X * X */ Xcharptr copy(charptr str, X int from, X int len) X{ X static char buf[STRSIZ]; X buf[0]=0; X if (from>strlen(str)) /* copy past end gives null string */ X return buf; X X strcpy(buf,str+from-1); /* skip over first part of string */ X buf[len] = 0; /* truncate after len characters */ X return buf; X} X X X/* X * String/character concatenation function X * X * This function takes a sprintf-like control string, a variable number of X * parameters, and returns a pointer a static location where the processed X * string is to be stored. X * X */ X Xcharptr scat(charptr control, ...) X{ X static char buf[STRSIZ]; X char buf2[STRSIZ]; X va_list args; X X va_start(args, control); /* get variable arg pointer */ X vsprintf(buf2,control,args); /* format into buf with variable args */ X va_end(args); /* finish the arglist */ X X strcpy(buf,buf2); X return buf; /* return a pointer to the string */ X} X X X#define ctos(ch) scat("%c",ch) /* character to string conversion */ X X X/* X * string build - like scat, sprintf, but will not over-write any X * input parameters X */ X Xvoid sbld(charptr dest, X charptr control, ...) X{ X char buf[STRSIZ]; X va_list args; X X va_start(args, control); /* get variable arg pointer */ X vsprintf(buf,control,args); /* format into buf with variable args */ X va_end(args); /* finish the arglist */ X X strcpy(dest,buf); /* copy result */ X} X X X X/* X * spos(str1,str2) - returns index of first occurence of str1 within str2; X * 1=first char of str2 X * 0=nomatch X */ X Xint spos(charptr str1, X charptr str2) X{ X charptr res; X res = strstr(str2,str1); X if (res == NULL) X return 0; X else X return res - str2 + 1; X} X X X/* X * cpos(str1,str2) - returns index of first occurence of c within str2; X * 1=first char of str2 X * 0=nomatch X */ X Xint cpos(char c, X charptr str2) X{ X charptr res; X res = strchr(str2,c); X if (res == NULL) X return 0; X else X return res - str2 + 1; X} X X X X/* X * Scanf/Fscanf support X * X * These functions operate like scanf and fscanf except for an added control X * code used for full-line reads. X * X */ X Xint fscanv(text fd, X charptr control, ...) X{ X va_list args; X charptr arg1; X int i; X X va_start(args, control); /* get variable arg pointer */ X X /* process special case for full-line reads (why doesn't scanf allow X full-line string reads? why don't gets and fgets work the same?) */ X if (*control == '#') { X arg1 = va_arg(args,charptr); X fgets(arg1,STRSIZ,fd); X arg1[strlen(arg1)-1] = 0; X return 1; X } X X /* pass the request on to fscanf */ X i = vfscanf(fd,control,args); /* scan with variable args */ X va_end(args); /* finish the arglist */ X X return i; /* return a pointer to the string */ X} X X#undef atoi /* in case of user ident clash */ X#undef getchar X X X/* X * rename some tp4 calls that conflict with tc1.0 functions X * X */ X X#define intr Pintr X#define getdate Pgetdate X#define gettime Pgettime X#define setdate Psetdate X#define settime Psettime X#define keep Pkeep X ________This_Is_The_END________ if test `wc -c < tptcmac.h` -ne 5336; then echo 'shar: tptcmac.h was damaged during transit (should have been 5336 bytes)' fi fi ; : end of overwriting check echo 'x - tptcsys.pas' if test -f tptcsys.pas; then echo 'shar: not overwriting tptcsys.pas'; else sed 's/^X//' << '________This_Is_The_END________' > tptcsys.pas X X(* X * TPTCSYS.PAS - System unit for use with Turbo Pascal --> C Translator X * X * (C) 1988 S.H.Smith (rev. 23-Mar-88) X * X * This unit is compiled to create 'TPTCSYS.UNS', which is automatically X * loaded on each TPTC run. It defines the predefined environment from X * which programs are translated. X * X * Compile with: X * tptc tptcsys -lower X * X * Create an empty tptcsys.uns if the file does not already exist. X * X * Note the special 'as replacement_name' clause used in some cases. X * When present, this clause causes the replacement_name to be used in X * place of the original name in the translated output. X * X *) X Xunit tptc_system_unit; X Xinterface X X (* X * Standard functions provided in Borland's system unit X * X *) X X function Sin(n: real): real; X function Cos(n: real): real; X function Tan(n: real): real; X function Sqr(n: real): real; X function Sqrt(n: real): real; X function Trunc(r: real): longint; X function Round(r: real): real; X function Int(r: real): real; X X function Pred(b: integer): integer; X function Succ(b: integer): integer; X function Ord(c: char): integer; X function Hi(w: word): word; X function Lo(w: word): word; X X function MemAvail: longint; X function MaxAvail: longint; X procedure Dispose(var ptr); X procedure Mark(var ptr); X procedure Release(var ptr); X X procedure Assign(fd: text; name: string); X procedure Reset(var fd: text); X procedure ReWrite(var fd: text); X procedure Append(var fd: text); X procedure SetTextBuf(fd: text; var buffer; size: word); X procedure Seek(fd: text; rec: word); X function SeekEof(fd: text): boolean; X X var ParamCount: integer; X function ParamStr(n: integer): string; X X procedure Delete(s: string; posit,number: integer); X function Copy(s: string; from,len: integer): string; X procedure Val(s: string; var res: real; var code: integer); X procedure Move(var tomem; var fmmem; bytes: word); X procedure FillChar(var dest; size: integer; value: char); X X X (* X * Standard procedures with replacement names or modified X * parameter types X * X *) X X function Eof(fd: text): boolean as feof; X procedure Flush(fd: text) as fflush; X procedure Close(fd: text) as fclose; X function UpCase(c: char): char as toupper; X function Length(s: string): integer as strlen; X X procedure Inc(b: byte); {tptcmac.h macros} X procedure Dec(b: byte); X X X (* X * Additional procedures called by translated code X * X *) X X type X setrec = set of char; X X function setof(element: byte {...}): setrec; X function inset(theset: setrec; item: byte): boolean; X X function scat(control: string {...}): string; X {concatenate strings according to printf style control and X return pointer to the result} X X function ctos(c: char): string; X {convert a character into a string} X X procedure sbld(dest: string; control: string {...}); X {build a string according to a control string (works like sprintf X with with special handling to allow source and destination X variables to be the same)} X X function spos(key: string; str: string): integer; X {returns the position of a substring within a longer string} X X function cpos(key: char; str: string): integer; X {returns the position of a character within a string} X X function fscanv(var fd: text; control: string {...}): integer; X {functions like fscanf but allows whole-line reads into X string variables} X X X (* The following identfiers are 'builtin' to the translator and X should not be defined here. If any of these are redefined, the X corresponding special translation will be disabled. *) X X (* X * function Pos(key: string; line: string): integer; X * procedure Chr(i: integer): char; X * procedure Str(v: real; dest: string); X * procedure Exit; X * X * var X * Mem: array[0..$FFFF:0..$FFFF] of byte; X * MemW: array[0..$FFFF:0..$FFFF] of word; X * Port: array[0..$1000] of byte; {i/o ports} X * PortW: array[0..$1000] of word; X * X *) X X X (* X * Extra identifiers needed when translating tpas3.0 sources X * X *) X X procedure MsDos(var reg); X procedure Intr(fun: integer; var reg); X X var X Lst: text; X Con: text; X Output: text; X Input: text; X X Ximplementation X ________This_Is_The_END________ if test `wc -c < tptcsys.pas` -ne 4474; then echo 'shar: tptcsys.pas was damaged during transit (should have been 4474 bytes)' fi fi ; : end of overwriting check echo 'x - uninc.pas' if test -f uninc.pas; then echo 'shar: not overwriting uninc.pas'; else sed 's/^X//' << '________This_Is_The_END________' > uninc.pas X X(* X * uninc - post-processor for TPTC X * X * This program will read a TPTC output file and produce a new X * file without the inline include file contents. The include X * files will be written along with the main file to the specified X * destination directory. X * X * S.H.Smith, 3/13/88 (rev. 3/13/88) X * X * Copyright 1988 by Samuel H. Smith; All rights reserved. X * X *) X X{$T+} {Produce mapfile} X{$R-} {Range checking} X{$B-} {Boolean complete evaluation} X{$S-} {Stack checking} X{$I+} {I/O checking} X{$N-} {Numeric coprocessor} X{$V-} {Relax string rules} X{$M 65500,16384,655360} {stack, minheap, maxhep} X X Xprogram TPTC_post_processor; X Xconst X version1 = 'UNINC - Post-processor for TPTC'; X version2 = 'Version 1.1 03/25/88 (C) 1988 S.H.Smith'; Xiconst X max_incl = 3; {maximum include nesting} X bufsize = 20000; {input file buffer size} X obufsize = 4000; {output file buffer size} X X {1234567890123456} X start_include = '/* TPTC: include'; X end_include = '/* TPTC: end of '; X key_length = 16; {length(start_include)} X Xvar X line: string; {current source line} X key: string; {current keyword} X name: string; {filenames} X X infd: text; {input file and buffer} X inbuf: array[1..bufsize] of byte; X X destdir: string; {output directory and files} X ofd: array[1..max_incl] of text; X obuf: array[1..max_incl] of array[1..obufsize] of byte; X level: integer; X X X X(* ------------------------------------------------------------------ *) Xprocedure init; X {parse command line, initialize global variables, open files} Xbegin X if paramcount <> 2 then X begin X writeln('Usage: uninc INFILE DESTDIR'); X writeln('Example: unint test.c c:\tran'); X halt; X end; X X {process input file} X name := paramstr(1); X assign(infd,name); X {$i-} reset(infd); {$i+} X if ioresult <> 0 then X begin X writeln('Can''t open input file: ',name); X halt; X end; X setTextBuf(infd,inbuf); X X {process destination directory specification} X destdir := paramstr(2); X if destdir[length(destdir)] <> '\' then X destdir := destdir + '\'; X X {process initial output file} X name := destdir + name; X writeln(name); X level := 1; X assign(ofd[level],name); X {$i-} rewrite(ofd[level]); {$i+} X if ioresult <> 0 then X begin X writeln('Can''t create output file: ',name); X halt; X end; X X setTextBuf(ofd[level],obuf[level]); Xend; X X X(* ------------------------------------------------------------------ *) Xprocedure enter_include; Xvar X i: integer; Xbegin X {determine new include filename} X name := copy(line,18,99); {/* tptc: include <filename> */} X name := copy(name,1,pos(' ',name)-1); X X {remove any directory specification fron the include filename} X if name[2] = ':' then X name := copy(name,3,99); X repeat X i := pos('\',name); X if i > 0 then name := copy(name,i+1,99); X until i = 0; X X {generate include statement in main file} X write(ofd[level],'#include "',name,'"'); X X {display new include filename on screen} X name := destdir + name; X writeln(name); X X {create the new include file} X inc(level); X assign(ofd[level],name); X {$i-} rewrite(ofd[level]); {$i+} X if ioresult <> 0 then X begin X writeln('Can''t create include file: ',name); X halt; X end; X X setTextBuf(ofd[level],obuf[level]); Xend; X X X(* ------------------------------------------------------------------ *) Xprocedure exit_include; Xbegin X if level < 2 then X writeln('Improper include nesting (too many exits) (',line,')') X else X begin X close(ofd[level]); X dec(level); X end; Xend; X X X(* ------------------------------------------------------------------ *) X(* X * main procedure - initialize, process input, cleanup X * X *) X Xbegin X {get things rolling} X writeln; X writeln(version1,' ',version2); X init; X X {process each line in the file} X while not eof(infd) do X begin X readln(infd,line); X X if pos('/* TPTC:',line) > 0 then X while line[1] = ' ' do X delete(line,1,1); X X key := copy(line,1,key_length); X X if key = start_include then X enter_include X else X if key = end_include then X exit_include X else X writeln(ofd[level],line); X end; X X {close files and terminate} X close(ofd[level]); X if level > 1 then X begin X writeln('unint: Premature eof'); X repeat X dec(level); X close(ofd[level]); X until level = 1; X end; Xend. X ________This_Is_The_END________ if test `wc -c < uninc.pas` -ne 4673; then echo 'shar: uninc.pas was damaged during transit (should have been 4673 bytes)' fi fi ; : end of overwriting check echo 'x - upd.bat' if test -f upd.bat; then echo 'shar: not overwriting upd.bat'; else sed 's/^X//' << '________This_Is_The_END________' > upd.bat X@echo off Xbac tptc.exe \bin1 Xbac uninc.exe \bin1 X%1 pkarc /ot f d:\shsbox\tptc17 X%1 pkarc /ot f d:\shsbox\tptc17sc X%1 pkarc /ot f d:\shsbox\tptc17tc ________This_Is_The_END________ if test `wc -c < upd.bat` -ne 149; then echo 'shar: upd.bat was damaged during transit (should have been 149 bytes)' fi fi ; : end of overwriting check exit 0