v04i025: Turbo Pascal to C, part 4/4
Alan Strassberg
alan at leadsv.UUCP
Mon Aug 15 08:56:58 AEST 1988
Posting-number: Volume 4, Issue 25
Submitted-by: "Alan Strassberg" <alan at 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 at 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
More information about the Comp.sources.misc
mailing list