v21i060: Pascal to C translator, Part15/32
Rich Salz
rsalz at uunet.uu.net
Wed Mar 28 08:16:50 AEST 1990
Submitted-by: Dave Gillespie <daveg at csvax.caltech.edu>
Posting-number: Volume 21, Issue 60
Archive-name: p2c/part15
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 15 (of 32)."
# Contents: src/trans.c
# Wrapped by rsalz at litchi.bbn.com on Mon Mar 26 14:29:38 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'src/trans.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'src/trans.c'\"
else
echo shar: Extracting \"'src/trans.c'\" \(40387 characters\)
sed "s/^X//" >'src/trans.c' <<'END_OF_FILE'
X/* "p2c", a Pascal to C translator.
X Copyright (C) 1989 David Gillespie.
X Author's address: daveg at csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
X
XThis program is free software; you can redistribute it and/or modify
Xit under the terms of the GNU General Public License as published by
Xthe Free Software Foundation (any version).
X
XThis program is distributed in the hope that it will be useful,
Xbut WITHOUT ANY WARRANTY; without even the implied warranty of
XMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
XGNU General Public License for more details.
X
XYou should have received a copy of the GNU General Public License
Xalong with this program; see the file COPYING. If not, write to
Xthe Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
X
X
X
X
X#define define_globals
X#define PROTO_TRANS_C
X#include "trans.h"
X
X#include <time.h>
X
X
X
X
X
X
X/* Roadmap:
X
X trans.h Declarations for all public global variables, types,
X and macros. Functions are declared in separate
X files p2c.{proto,hdrs} which are created
X mechanically by the makeproto program.
X
X trans.c Main program. Parses the p2crc file. Also reserves
X storage for public globals in trans.h.
X
X stuff.c Miscellaneous support routines.
X
X out.c Routines to handle the writing of C code to the output
X file. This includes line breaking and indentation
X support.
X
X comment.c Routines for managing comments and comment lists.
X
X lex.c Lexical analyzer. Manages input files and streams,
X splits input stream into Pascal tokens. Parses
X compiler directives and special comments. Also keeps
X the symbol table.
X
X parse.c Parsing and writing statements and blocks.
X
X decl.c Parsing and writing declarations.
X
X expr.c Manipulating expressions.
X
X pexpr.c Parsing and writing expressions.
X
X funcs.c Built-in special functions and procedures.
X
X dir.c Interface file to "external" functions and procedures
X such as hpmods and citmods.
X
X hpmods.c Definitions for HP-supplied Pascal modules.
X
X citmods.c Definitions for some Caltech-local Pascal modules.
X (Outside of Caltech this file is mostly useful
X as a large body of examples of how to write your
X own translator extensions.)
X
X
X p2crc Control file (read when p2c starts up).
X
X p2c.h Header file used by translated programs.
X
X p2clib.c Run-time library used by translated programs.
X
X*/
X
X
X
X
XStatic Strlist *tweaksymbols, *synonyms;
XStrlist *addmacros;
X
X
X
XStatic void initrc()
X{
X int i;
X
X for (i = 0; i < numparams; i++) {
X switch (rctable[i].kind) {
X case 'S':
X case 'B':
X *((short *)rctable[i].ptr) = rctable[i].def;
X break;
X case 'I':
X case 'D':
X *((int *)rctable[i].ptr) = rctable[i].def;
X break;
X case 'L':
X *((long *)rctable[i].ptr) = rctable[i].def;
X break;
X case 'R':
X *((double *)rctable[i].ptr) = rctable[i].def/100.0;
X break;
X case 'U':
X case 'C':
X *((char *)rctable[i].ptr) = 0;
X break;
X case 'A':
X *((Strlist **)rctable[i].ptr) = NULL;
X break;
X case 'X':
X if (rctable[i].def == 1)
X *((Strlist **)rctable[i].ptr) = NULL;
X break;
X }
X rcprevvalues[i] = NULL;
X }
X tweaksymbols = NULL;
X synonyms = NULL;
X addmacros = NULL;
X varmacros = NULL;
X constmacros = NULL;
X fieldmacros = NULL;
X funcmacros = NULL;
X}
X
X
X
XStatic int readrc(rcname, need)
Xchar *rcname;
Xint need;
X{
X FILE *rc;
X char buf[500], *cp, *cp2;
X long val = 0;
X int i;
X Strlist *sl;
X
X rc = fopen(rcname, "r");
X if (!rc) {
X if (need)
X perror(rcname);
X return 0;
X }
X while (fgets(buf, 500, rc)) {
X cp = my_strtok(buf, " =\t\n");
X if (cp && *cp != '#') {
X upc(cp);
X i = numparams;
X while (--i >= 0 && strcmp(rctable[i].name, cp)) ;
X if (i >= 0) {
X if (rctable[i].kind != 'M') {
X cp = my_strtok(NULL, " =\t\n");
X if (cp && *cp == '#')
X cp = NULL;
X if (cp && (isdigit(*cp) || *cp == '-' || *cp == '+'))
X val = atol(cp);
X else
X val = rctable[i].def;
X }
X switch (rctable[i].kind) {
X
X case 'S':
X *((short *)rctable[i].ptr) = val;
X break;
X
X case 'I':
X *((int *)rctable[i].ptr) = val;
X break;
X
X case 'D':
X *((int *)rctable[i].ptr) =
X parsedelta(cp, rctable[i].def);
X break;
X
X case 'L':
X *((long *)rctable[i].ptr) = val;
X break;
X
X case 'R':
X if (cp && (isdigit(*cp) || *cp == '-' || *cp == '.'))
X *((double *)rctable[i].ptr) = atof(cp);
X else
X *((double *)rctable[i].ptr) = rctable[i].def/100.0;
X break;
X
X case 'U':
X if (cp)
X upc(cp);
X
X /* fall through */
X case 'C':
X val = rctable[i].def;
X strncpy((char *)rctable[i].ptr, cp ? cp : "", val-1);
X ((char *)rctable[i].ptr)[val-1] = 0;
X break;
X
X case 'F':
X while (cp && *cp != '#') {
X sl = strlist_append(&tweaksymbols,
X format_s("*%s", cp));
X sl->value = rctable[i].def;
X cp = my_strtok(NULL, " \t\n");
X }
X break;
X
X case 'G':
X while (cp && *cp != '#') {
X sl = strlist_append(&tweaksymbols, cp);
X sl->value = rctable[i].def;
X cp = my_strtok(NULL, " \t\n");
X }
X break;
X
X case 'A':
X while (cp && *cp != '#') {
X strlist_insert((Strlist **)rctable[i].ptr, cp);
X cp = my_strtok(NULL, " \t\n");
X }
X break;
X
X case 'M':
X cp = my_strtok(NULL, "\n");
X if (cp) {
X while (isspace(*cp)) cp++;
X for (cp2 = cp; *cp2 && *cp2 != '#'; cp2++) ;
X *cp2 = 0;
X if (*cp) {
X sl = strlist_append(&addmacros, cp);
X sl->value = rctable[i].def;
X }
X }
X break;
X
X case 'B':
X if (cp)
X val = parse_breakstr(cp);
X if (val != -1)
X *((short *)rctable[i].ptr) = val;
X break;
X
X case 'X':
X switch (rctable[i].def) {
X
X case 1: /* strlist with string values */
X if (cp) {
X sl = strlist_append((Strlist **)rctable[i].ptr, cp);
X cp = my_strtok(NULL, " =\t\n");
X if (cp && *cp != '#')
X sl->value = (long)stralloc(cp);
X }
X break;
X
X case 2: /* Include */
X if (cp)
X readrc(format_s(cp, infname), 1);
X break;
X
X case 3: /* Synonym */
X if (cp) {
X sl = strlist_append(&synonyms, cp);
X cp = my_strtok(NULL, " =\t\n");
X if (cp && *cp != '#')
X sl->value = (long)stralloc(cp);
X }
X break;
X
X }
X }
X } else
X fprintf(stderr, "warning: can't understand %s in %s\n", cp, rcname);
X }
X }
X fclose(rc);
X return 1;
X}
X
X
XStatic void postrc()
X{
X int longbits;
X long val;
X
X which_unix = UNIX_ANY;
X if (!strcmp(target, "CHIPMUNK") ||
X !strcmp(target, "HPUX-300") ||
X !strcmp(target, "SUN-68K") ||
X !strcmp(target, "BSD-VAX")) {
X signedchars = 1;
X sizeof_char = 8;
X sizeof_short = 16;
X sizeof_int = sizeof_long = sizeof_pointer = 32;
X sizeof_enum = 32;
X sizeof_float = 32;
X sizeof_double = 64;
X if (!strcmp(target, "CHIPMUNK") ||
X !strcmp(target, "HPUX-300"))
X which_unix = UNIX_SYSV;
X else
X which_unix = UNIX_BSD;
X } else if (!strcmp(target, "LSC-MAC")) {
X signedchars = 1;
X if (prototypes < 0)
X prototypes = 1;
X if (fullprototyping < 0)
X fullprototyping = 0;
X if (voidstar < 0)
X voidstar = 1;
X sizeof_char = 8;
X sizeof_short = sizeof_int = 16;
X sizeof_long = sizeof_pointer = 32;
X } else if (!strcmp(target, "BSD")) {
X which_unix = UNIX_BSD;
X } else if (!strcmp(target, "SYSV")) {
X which_unix = UNIX_SYSV;
X } else if (*target) {
X fprintf(stderr, "p2c: warning: don't understand target name %s\n", target);
X }
X if (ansiC > 0) {
X if (sprintf_value < 0)
X sprintf_value = 0;
X if (castnull < 0)
X castnull = 0;
X }
X if (useenum < 0)
X useenum = (ansiC != 0) ? 1 : 0;
X if (void_args < 0)
X void_args = (ansiC > 0 && prototypes != 0) ? 1 : 0;
X if (prototypes < 0)
X prototypes = (cplus > 0) ? 2 : (ansiC > 0) ? 1 : 0;
X if (prototypes == 0)
X fullprototyping = 0;
X else if (fullprototyping < 0)
X fullprototyping = 1;
X if (useAnyptrMacros < 0)
X useAnyptrMacros = (ansiC > 0 || cplus > 0) ? 2 : 1;
X if (usePPMacros < 0)
X usePPMacros = (ansiC > 0 || cplus > 0) ? 0 : 2;
X if (voidstar < 0)
X voidstar = (ansiC > 0 || cplus > 0) ? 1 : 0;
X if (hassignedchar < 0)
X hassignedchar = (ansiC > 0) ? 1 : 0;
X if (useconsts < 0)
X useconsts = (ansiC > 0 || cplus > 0) ? 1 : 0;
X if (copystructs < 0)
X copystructs = (ansiC != 0 || cplus > 0) ? 3 : 0;
X if (copystructfuncs < 0)
X copystructfuncs = (ansiC > 0 || cplus > 0) ? 0 : 1;
X if (starfunctions < 0)
X starfunctions = (ansiC > 0) ? 0 : 1;
X if (variablearrays < 0)
X variablearrays = (ansiC > 1) ? 1 : 0;
X if (*memcpyname) {
X if (ansiC > 0 || which_unix == UNIX_SYSV)
X strcpy(memcpyname, "memcpy");
X else if (which_unix == UNIX_BSD)
X strcpy(memcpyname, "bcopy");
X }
X sizeof_integer = (sizeof_int >= 32) ? sizeof_int : sizeof_long;
X integername = (sizeof_int >= 32) ? "int" : "long";
X if (sizeof_integer && sizeof_integer < 32)
X fprintf(stderr, "Warning: long integers have less than 32 bits\n");
X if (sizeof_int >= 32 && sizeof_long > sizeof_int && prototypes == 0)
X fprintf(stderr, "Warning: translated code assumes int and long are the same");
X if (setbits < 0)
X setbits = (sizeof_integer > 0) ? sizeof_integer : 32;
X ucharname = (*name_UCHAR) ? name_UCHAR :
X (signedchars == 0) ? "char" : "unsigned char";
X scharname = (*name_SCHAR) ? name_SCHAR :
X (signedchars == 1) ? "char" :
X (useAnyptrMacros == 1) ? "Signed char" : "signed char";
X for (longbits = 1, val = LONG_MAX; val >>= 1; longbits++) ;
X if (sizeof_char) {
X if (sizeof_char < 8 && ansiC > 0)
X fprintf(stderr, "Warning: chars have less than 8 bits\n");
X if (sizeof_char > longbits) {
X min_schar = LONG_MIN;
X max_schar = LONG_MAX;
X } else {
X min_schar = - (1<<(sizeof_char-1));
X max_schar = (1<<(sizeof_char-1)) - 1;
X }
X if (sizeof_char >= longbits)
X max_uchar = LONG_MAX;
X else
X max_uchar = (1<<sizeof_char) - 1;
X } else {
X min_schar = -128; /* Ansi-required minimum maxima */
X max_schar = 127;
X max_uchar = 255;
X }
X if (sizeof_short) {
X if (sizeof_short < 16 && ansiC > 0)
X fprintf(stderr, "Warning: shorts have less than 16 bits\n");
X if (sizeof_short > longbits) {
X min_sshort = LONG_MIN;
X max_sshort = LONG_MAX;
X } else {
X min_sshort = - (1<<(sizeof_short-1));
X max_sshort = (1<<(sizeof_short-1)) - 1;
X }
X if (sizeof_short >= longbits)
X max_ushort = LONG_MAX;
X else
X max_ushort = (1<<sizeof_short) - 1;
X } else {
X min_sshort = -32768; /* Ansi-required minimum maxima */
X max_sshort = 32767;
X max_ushort = 65535;
X }
X if (symcase < 0)
X symcase = 1;
X if (smallsetconst == -2)
X smallsetconst = (*name_SETBITS) ? -1 : 1;
X hpux_lang = 0;
X if (!strcmp(language, "TURBO")) {
X which_lang = LANG_TURBO;
X } else if (!strcmp(language, "UCSD")) {
X which_lang = LANG_UCSD;
X } else if (!strcmp(language, "MPW")) {
X which_lang = LANG_MPW;
X } else if (!strcmp(language, "HPUX") || !strcmp(language, "HP-UX")) {
X which_lang = LANG_HP;
X hpux_lang = 1;
X } else if (!strcmp(language, "OREGON")) {
X which_lang = LANG_OREGON;
X } else if (!strcmp(language, "VAX") || !strcmp(language, "VMS")) {
X which_lang = LANG_VAX;
X } else if (!strncmp(language, "MODULA", 6)) {
X which_lang = LANG_MODULA;
X } else if (!strncmp(language, "BERK", 4) ||
X !strcmp(language, "SUN")) {
X which_lang = LANG_BERK;
X } else {
X if (*language && strcmp(language, "HP") && strcmp(language, "MODCAL"))
X fprintf(stderr, "Warning: Language %s not recognized, using HP\n", language);
X which_lang = LANG_HP;
X }
X if (modula2 < 0)
X modula2 = (which_lang == LANG_MODULA) ? 1 : 0;
X if (pascalcasesens < 0)
X pascalcasesens = (which_lang == LANG_MODULA) ? 2 :
X (which_lang == LANG_BERK) ? 3 : 0;
X if (implementationmodules < 0)
X implementationmodules = (which_lang == LANG_VAX) ? 1 : 0;
X if (integer16 < 0)
X integer16 = (which_lang == LANG_TURBO ||
X which_lang == LANG_MPW) ? 1 : 0;
X if (doublereals < 0)
X doublereals = (hpux_lang ||
X which_lang == LANG_OREGON ||
X which_lang == LANG_VAX) ? 0 : 1;
X if (pascalenumsize < 0)
X pascalenumsize = (which_lang == LANG_HP) ? 16 : 8;
X if (storefilenames < 0)
X storefilenames = (which_lang == LANG_TURBO) ? 1 : 0;
X if (charfiletext < 0)
X charfiletext = (which_lang == LANG_BERK) ? 1 : 0;
X if (readwriteopen < 0)
X readwriteopen = (which_lang == LANG_TURBO) ? 1 : 0;
X if (literalfilesflag < 0)
X literalfilesflag = (which_lang == LANG_BERK) ? 2 : 0;
X if (newlinespace < 0)
X newlinespace = (which_lang == LANG_TURBO) ? 0 : 1;
X if (nestedcomments < 0)
X nestedcomments = (which_lang == LANG_TURBO ||
X which_lang == LANG_MPW ||
X which_lang == LANG_UCSD ||
X which_lang == LANG_BERK) ? 2 : 0;
X if (importall < 0)
X importall = (which_lang == LANG_HP) ? 1 : 0;
X if (seek_base < 0)
X seek_base = (which_lang == LANG_TURBO ||
X which_lang == LANG_MPW ||
X which_lang == LANG_UCSD) ? 0 : 1;
X if (unsignedchar < 0 && signedchars == 0)
X unsignedchar = 2;
X if (hasstaticlinks < 0)
X hasstaticlinks = (which_lang == LANG_HP) ? 1 : 0;
X if (dollar_idents < 0)
X dollar_idents = (which_lang == LANG_OREGON ||
X which_lang == LANG_VAX) ? 1 : 0;
X if (ignorenonalpha < 0)
X ignorenonalpha = (which_lang == LANG_UCSD) ? 1 : 0;
X if (stringtrunclimit < 0)
X stringtrunclimit = (which_lang == LANG_TURBO) ? 80 : 0;
X if (defaultsetsize < 0)
X defaultsetsize = (which_lang == LANG_VAX) ? 256 :
X (which_lang == LANG_BERK) ? 128 :
X (which_lang == LANG_MPW) ? 2040 : 8192;
X if (enumbyte < 0)
X enumbyte = (which_lang == LANG_HP) ? 0 : 1;
X if (!*filenamefilter && (which_lang == LANG_OREGON ||
X which_lang == LANG_BERK))
X strcpy(filenamefilter, "P_trimname");
X charname = (useAnyptrMacros) ? "Char" :
X (unsignedchar == 1) ? ucharname :
X (unsignedchar == 0) ? scharname : "char";
X if (!*memcpyname)
X strcpy(memcpyname, "memcpy");
X if (!*mallocname)
X strcpy(mallocname, "malloc");
X if (!*freename)
X strcpy(freename, "free");
X fix_parameters();
X}
X
X
X
X
Xvoid saveoldfile(fname)
Xchar *fname;
X{
X#if defined(unix) || defined(__unix) || defined(CAN_LINK)
X (void) unlink(format_s("%s~", fname));
X if (link(fname, format_s("%s~", fname)) == 0)
X (void) unlink(fname);
X#endif
X}
X
X
X
X#ifndef __STDC__
X# ifdef NO_GETENV
X# define getenv(x) NULL
X# else
Xextern char *getenv PP((char *));
X# endif
X#endif
X
XStatic long starting_time;
X
XStatic void openlogfile()
X{
X char *name, *uname;
X
X if (*codefname == '<')
X name = format_ss(logfnfmt, infname, infname);
X else
X name = format_ss(logfnfmt, infname, codefname);
X if (!name)
X name = format_s("%s.log", codefname);
X saveoldfile(name);
X logf = fopen(name, "w");
X if (logf) {
X fprintf(logf, "\nTranslation of %s to %s by p2c %s\n",
X infname, codefname, P2C_VERSION);
X fprintf(logf, "Translated");
X uname = getenv("USER");
X if (uname)
X fprintf(logf, " by %s", uname);
X time(&starting_time);
X fprintf(logf, " on %s", ctime(&starting_time));
X fprintf(logf, "\n\n");
X } else {
X perror(name);
X verbose = 0;
X }
X}
X
X
Xvoid closelogfile()
X{
X long ending_time;
X
X if (logf) {
X fprintf(logf, "\n\n");
X#if defined(unix) || defined(__unix)
X fprintf(logf, "Total memory used: %ld bytes.\n", (long)sbrk(0));
X#endif
X time(&ending_time);
X fprintf(logf, "Processed %d source lines in %ld:%ld seconds.\n",
X inf_ltotal,
X (ending_time - starting_time) / 60,
X (ending_time - starting_time) % 60);
X fprintf(logf, "\n\nTranslation completed on %s", ctime(&ending_time));
X fclose(logf);
X }
X}
X
X
X
X
Xvoid showinitfile()
X{
X FILE *f;
X int ch;
X char *name;
X
X name = format_s("%H/%s", "p2crc");
X printf("# Copy of file %%H/p2crc => %s:\n\n", name);
X f = fopen(name, "r");
X if (!f) {
X perror(name);
X exit(1);
X }
X while ((ch = getc(f)) != EOF)
X putchar(ch);
X fclose(f);
X exit(0);
X}
X
X
X
X
Xvoid usage()
X{
X fprintf(stderr, "usage: p2c [options] file [modulename] [-h file.h] [-o file.c]\n");
X exit(EXIT_FAILURE);
X}
X
X
X
Xint main(argc, argv)
Xint argc;
Xchar **argv;
X{
X int numsearch;
X char *searchlist[50];
X char infnbuf[200], codefnbuf[200], hdrfnbuf[200], *cp;
X Symbol *sp;
X Strlist *sl;
X int i, nobuffer = 0, savequiet;
X
X i = 0;
X while (i < argc && strcmp(argv[i], "-H")) i++;
X if (i < argc-1)
X p2c_home = argv[i+1];
X else {
X cp = getenv("P2C_HOME");
X if (cp)
X p2c_home = cp;
X }
X init_stuff();
X i = 0;
X while (i < argc && strcmp(argv[i], "-i")) i++;
X if (i < argc)
X showinitfile();
X initrc();
X setup_dir();
X infname = infnbuf;
X *infname = 0;
X i = 0;
X while (i < argc && argv[i][0] == '-') i++;
X if (i >= argc)
X strcpy(infname, argv[i]);
X i = 0;
X while (i < argc && strcmp(argv[i], "-v")) i++;
X if (i >= argc) {
X cp = getenv("P2CRC");
X if (cp)
X readrc(cp, 1);
X else
X readrc(format_s("%H/%s", "p2crc"), 1);
X }
X i = 0;
X while (i < argc && strcmp(argv[i], "-c")) i++;
X if (i < argc-1) {
X if (strcmp(argv[i+1], "-"))
X readrc(argv[i+1], 1);
X } else
X if (!readrc("p2crc", 0))
X readrc(".p2crc", 0);
X codefname = codefnbuf;
X *codefname = 0;
X hdrfname = hdrfnbuf;
X *hdrfname = 0;
X requested_module = NULL;
X found_module = 0;
X error_crash = 0;
X#ifdef CONSERVE_MEMORY
X conserve_mem = CONSERVE_MEMORY;
X#else
X conserve_mem = 1;
X#endif
X regression = 0;
X verbose = 0;
X partialdump = 1;
X numsearch = 0;
X argc--, argv++;
X while (argc > 0) {
X if (**argv == '-' && (*argv)[1]) {
X if (!strcmp(*argv, "-a")) {
X ansiC = 1;
X } else if (argv[0][1] == 'L') {
X if (strlen(*argv) == 2 && argc > 1) {
X strcpy(language, ++*argv);
X --argc;
X } else
X strcpy(language, *argv + 2);
X upc(language);
X } else if (!strcmp(*argv, "-q")) {
X quietmode = 1;
X } else if (!strcmp(*argv, "-o")) {
X if (*codefname || --argc <= 0)
X usage();
X strcpy(codefname, *++argv);
X } else if (!strcmp(*argv, "-h")) {
X if (*hdrfname || --argc <= 0)
X usage();
X strcpy(hdrfname, *++argv);
X } else if (!strcmp(*argv, "-s")) {
X if (--argc <= 0)
X usage();
X cp = *++argv;
X if (!strcmp(cp, "-"))
X librfiles = NULL;
X else
X searchlist[numsearch++] = cp;
X } else if (!strcmp(*argv, "-c")) {
X if (--argc <= 0)
X usage();
X argv++;
X /* already done above */
X } else if (!strcmp(*argv, "-v")) {
X /* already done above */
X } else if (!strcmp(*argv, "-H")) {
X /* already done above */
X } else if (argv[0][1] == 'I') {
X if (strlen(*argv) == 2 && argc > 1) {
X strlist_append(&importdirs, ++*argv);
X --argc;
X } else
X strlist_append(&importdirs, *argv + 2);
X } else if (argv[0][1] == 'p') {
X if (strlen(*argv) == 2)
X showprogress = 25;
X else
X showprogress = atoi(*argv + 2);
X nobuffer = 1;
X } else if (!strcmp(*argv, "-e")) {
X copysource++;
X } else if (!strcmp(*argv, "-t")) {
X tokentrace++;
X } else if (!strcmp(*argv, "-x")) {
X error_crash++;
X } else if (argv[0][1] == 'E') {
X if (strlen(*argv) == 2)
X maxerrors = 0;
X else
X maxerrors = atoi(*argv + 2);
X } else if (!strcmp(*argv, "-F")) {
X partialdump = 0;
X } else if (argv[0][1] == 'd') {
X nobuffer = 1;
X if (strlen(*argv) == 2)
X debug = 1;
X else
X debug = atoi(*argv + 2);
X } else if (argv[0][1] == 'B') {
X if (strlen(*argv) == 2)
X i = 1;
X else
X i = atoi(*argv + 2);
X if (argc == 2 &&
X strlen(argv[1]) > 2 &&
X !strcmp(argv[1] + strlen(argv[1]) - 2, ".c")) {
X testlinebreaker(i, argv[1]);
X exit(EXIT_SUCCESS);
X } else
X testlinebreaker(i, NULL);
X } else if (argv[0][1] == 'C') {
X if (strlen(*argv) == 2)
X cmtdebug = 1;
X else
X cmtdebug = atoi(*argv + 2);
X } else if (!strcmp(*argv, "-R")) {
X regression = 1;
X } else if (argv[0][1] == 'V') {
X if (strlen(*argv) == 2)
X verbose = 1;
X else
X verbose = atoi(*argv + 2);
X } else if (argv[0][1] == 'M') {
X if (strlen(*argv) == 2)
X conserve_mem = 1;
X else
X conserve_mem = atoi(*argv + 2);
X } else
X usage();
X } else if (!*infname) {
X strcpy(infname, *argv);
X } else if (!requested_module) {
X requested_module = stralloc(*argv);
X } else
X usage();
X argc--, argv++;
X }
X if (requested_module && !*codefname)
X strcpy(codefname, format_ss(modulefnfmt, infname, requested_module));
X if (*infname && strcmp(infname, "-")) {
X if (strlen(infname) > 2 &&
X !strcmp(infname + strlen(infname) - 2, ".c")) {
X fprintf(stderr, "What is wrong with this picture?\n");
X exit(EXIT_FAILURE);
X }
X inf = fopen(infname, "r");
X if (!inf) {
X perror(infname);
X exit(EXIT_FAILURE);
X }
X if (!*codefname)
X strcpy(codefname, format_s(codefnfmt, infname));
X } else {
X strcpy(infname, "<stdin>");
X inf = stdin;
X if (!*codefname)
X strcpy(codefname, "-");
X }
X if (strcmp(codefname, "-")) {
X saveoldfile(codefname);
X codef = fopen(codefname, "w");
X if (!codef) {
X perror(codefname);
X exit(EXIT_FAILURE);
X }
X fprintf(codef, "/* Output from p2c, the Pascal-to-C translator */\n");
X } else {
X strcpy(codefname, "<stdout>");
X codef = stdout;
X }
X if (nobuffer)
X setbuf(codef, NULL); /* for debugging */
X outf = codef;
X outf_lnum = 1;
X logf = NULL;
X if (verbose)
X openlogfile();
X setup_complete = 0;
X init_lex();
X leadingcomments();
X postrc();
X setup_comment(); /* must call this first */
X setup_lex(); /* must call this second */
X setup_out();
X setup_decl(); /* must call *after* setup_lex() */
X setup_parse();
X setup_funcs();
X for (sl = tweaksymbols; sl; sl = sl->next) {
X cp = sl->s;
X if (*cp == '*') {
X cp++;
X if (!pascalcasesens)
X upc(cp);
X }
X sp = findsymbol(cp);
X if (sl->value & FUNCBREAK)
X sp->flags &= ~FUNCBREAK;
X sp->flags |= sl->value;
X }
X strlist_empty(&tweaksymbols);
X for (sl = synonyms; sl; sl = sl->next) {
X if (!pascalcasesens)
X upc(sl->s);
X sp = findsymbol(sl->s);
X sp->flags |= SSYNONYM;
X if (sl->value) {
X if (!pascalcasesens)
X upc((char *)sl->value);
X strlist_append(&sp->symbolnames, "===")->value =
X (long)findsymbol((char *)sl->value);
X } else
X strlist_append(&sp->symbolnames, "===")->value = 0;
X }
X strlist_empty(&synonyms);
X for (sl = addmacros; sl; sl = sl->next) {
X defmacro(sl->s, sl->value, "<macro>", 0);
X }
X strlist_empty(&addmacros);
X handle_nameof();
X setup_complete = 1;
X savequiet = quietmode;
X quietmode = 1;
X for (sl = librfiles; sl; sl = sl->next)
X (void)p_search(format_none(sl->s), "pas", 0);
X for (i = 0; i < numsearch; i++)
X (void)p_search(format_none(searchlist[i]), "pas", 1);
X quietmode = savequiet;
X p_program();
X end_source();
X flushcomments(NULL, -1, -1);
X showendnotes();
X check_unused_macros();
X printf("\n");
X if (!showprogress)
X fprintf(stderr, "\n");
X output("\n");
X if (requested_module && !found_module)
X error(format_s("Module \"%s\" not found in file", requested_module));
X if (codef != stdout)
X output("\n\n/* End. */\n");
X if (inf != stdin)
X fclose(inf);
X if (codef != stdout)
X fclose(codef);
X closelogfile();
X mem_summary();
X if (!quietmode)
X fprintf(stderr, "Translation completed.\n");
X exit(EXIT_SUCCESS);
X}
X
X
X
X
Xint outmem()
X{
X fprintf(stderr, "p2c: Out of memory!\n");
X exit(EXIT_FAILURE);
X}
X
X
X
X#if !defined(NO_ISBOGUS) && (defined(mc68000) || defined(m68k) || defined(vax))
Xint ISBOGUS(p)
Xchar *p;
X{
X unsigned long ip = (unsigned long)p;
X
X if (ip < 0) {
X if (ip < (unsigned long)&ip)
X return 1; /* below the start of the stack */
X } else if (ip >= 512) {
X if (ip > (unsigned long)sbrk(0))
X return 1; /* past the end of memory */
X } else
X return 1;
X return 0;
X}
X#else
X#define ISBOGUS(p) 0
X#endif
X
X
X
X
X
X
Xchar *meaningkindname(kind)
Xenum meaningkind kind;
X{
X#ifdef HASDUMPS
X if ((unsigned int)kind < (unsigned int)MK_LAST)
X return meaningkindnames[(int) kind];
X else
X#endif /*HASDUMPS*/
X return format_d("<meaning %d>", (int) kind);
X}
X
Xchar *typekindname(kind)
Xenum typekind kind;
X{
X#ifdef HASDUMPS
X if ((unsigned int)kind < (unsigned int)TK_LAST)
X return typekindnames[(int) kind];
X else
X#endif /*HASDUMPS*/
X return format_d("<type %d>", (int) kind);
X}
X
Xchar *exprkindname(kind)
Xenum exprkind kind;
X{
X#ifdef HASDUMPS
X if ((unsigned int)kind < (unsigned int)EK_LAST)
X return exprkindnames[(int) kind];
X else
X#endif /*HASDUMPS*/
X return format_d("<expr %d>", (int) kind);
X}
X
Xchar *stmtkindname(kind)
Xenum stmtkind kind;
X{
X#ifdef HASDUMPS
X if ((unsigned int)kind < (unsigned int)SK_LAST)
X return stmtkindnames[(int) kind];
X else
X#endif /*HASDUMPS*/
X return format_d("<stmt %d>", (int) kind);
X}
X
X
X
Xvoid dumptype(tp)
XType *tp;
X{
X if (!tp) {
X fprintf(outf, "<NULL>\n");
X return;
X }
X if (ISBOGUS(tp)) {
X fprintf(outf, "0x%lX\n", tp);
X return;
X }
X fprintf(outf, " Type %lx, kind=%s", tp, typekindname(tp->kind));
X#ifdef HASDUMPS
X fprintf(outf, ", meaning=%lx, basetype=%lx, indextype=%lx\n",
X tp->meaning, tp->basetype, tp->indextype);
X tp->dumped = 1;
X if (tp->basetype)
X dumptype(tp->basetype);
X if (tp->indextype)
X dumptype(tp->indextype);
X#else
X fprintf(outf, "\n");
X#endif /*HASDUMPS*/
X}
X
X
Xvoid dumpmeaning(mp)
XMeaning *mp;
X{
X if (!mp) {
X fprintf(outf, "<NULL>\n");
X return;
X }
X if (ISBOGUS(mp)) {
X fprintf(outf, "0x%lX\n", mp);
X return;
X }
X fprintf(outf, " Meaning %lx, name=%s, kind=%s", mp, ((mp->name) ? mp->name : "<null>"),
X meaningkindname(mp->kind));
X#ifdef HASDUMPS
X fprintf(outf, ", ctx=%lx, cbase=%lx, cnext=%lx, type=%lx\n",
X mp->ctx, mp->cbase, mp->cnext, mp->type);
X if (mp->type && !mp->type->dumped)
X dumptype(mp->type);
X mp->dumped = 1;
X#else
X fprintf(outf, "\n");
X#endif /*HASDUMPS*/
X}
X
X
Xvoid dumpsymtable(sym)
XSymbol *sym;
X{
X Meaning *mp;
X
X if (sym) {
X dumpsymtable(sym->left);
X#ifdef HASDUMPS
X if ((sym->mbase && !sym->mbase->dumped) ||
X (sym->fbase && !sym->fbase->dumped))
X#endif
X {
X fprintf(outf, "Symbol %s:\n", sym->name);
X for (mp = sym->mbase; mp; mp = mp->snext)
X dumpmeaning(mp);
X for (mp = sym->fbase; mp; mp = mp->snext)
X dumpmeaning(mp);
X fprintf(outf, "\n");
X }
X dumpsymtable(sym->right);
X }
X}
X
X
Xvoid dumptypename(tp, waddr)
XType *tp;
Xint waddr;
X{
X#ifdef HASDUMPS
X if (!tp) {
X fprintf(outf, "<NULL>");
X return;
X }
X if (ISBOGUS(tp)) {
X fprintf(outf, "0x%lX", tp);
X return;
X }
X if (tp == tp_int) fprintf(outf, "I");
X else if (tp == tp_sint) fprintf(outf, "SI");
X else if (tp == tp_uint) fprintf(outf, "UI");
X else if (tp == tp_integer) fprintf(outf, "L");
X else if (tp == tp_unsigned) fprintf(outf, "UL");
X else if (tp == tp_char) fprintf(outf, "C");
X else if (tp == tp_schar) fprintf(outf, "UC");
X else if (tp == tp_uchar) fprintf(outf, "SC");
X else if (tp == tp_boolean) fprintf(outf, "B");
X else if (tp == tp_longreal) fprintf(outf, "R");
X else if (tp == tp_real) fprintf(outf, "F");
X else if (tp == tp_anyptr) fprintf(outf, "A");
X else if (tp == tp_void) fprintf(outf, "V");
X else if (tp == tp_text) fprintf(outf, "T");
X else if (tp == tp_sshort) fprintf(outf, "SS");
X else if (tp == tp_ushort) fprintf(outf, "US");
X else if (tp == tp_abyte) fprintf(outf, "AB");
X else if (tp == tp_sbyte) fprintf(outf, "SB");
X else if (tp == tp_ubyte) fprintf(outf, "UB");
X else if (tp == tp_str255) fprintf(outf, "S");
X else if (tp == tp_strptr) fprintf(outf, "SP");
X else if (tp == tp_charptr) fprintf(outf, "CP");
X else if (tp == tp_smallset) fprintf(outf, "SMS");
X else if (tp == tp_proc) fprintf(outf, "PR");
X else if (tp == tp_jmp_buf) fprintf(outf, "JB");
X else {
X if (tp->meaning && !ISBOGUS(tp->meaning) &&
X tp->meaning->name && !ISBOGUS(tp->meaning->name) &&
X tp->meaning->name[0]) {
X fprintf(outf, "%s", tp->meaning->name);
X if (tp->dumped)
X return;
X fprintf(outf, "=");
X waddr = 1;
X }
X if (waddr) {
X fprintf(outf, "%lX", tp);
X if (tp->dumped)
X return;
X fprintf(outf, ":");
X tp->dumped = 1;
X }
X switch (tp->kind) {
X
X case TK_STRING:
X fprintf(outf, "Str");
X if (tp->structdefd)
X fprintf(outf, "Conf");
X break;
X
X case TK_SUBR:
X dumptypename(tp->basetype, 0);
X break;
X
X case TK_POINTER:
X fprintf(outf, "^");
X dumptypename(tp->basetype, 0);
X break;
X
X case TK_SMALLARRAY:
X fprintf(outf, "Sm");
X /* fall through */
X
X case TK_ARRAY:
X fprintf(outf, "Ar");
X if (tp->structdefd)
X fprintf(outf, "Conf");
X fprintf(outf, "{");
X dumptypename(tp->indextype, 0);
X fprintf(outf, "}");
X if (tp->smin) {
X fprintf(outf, "Skip(");
X dumpexpr(tp->smin);
X fprintf(outf, ")");
X }
X if (tp->smax) {
X fprintf(outf, "/");
X if (!ISBOGUS(tp->smax))
X dumptypename(tp->smax->val.type, 0);
X fprintf(outf, "{%d%s}", tp->escale,
X tp->issigned ? "S" : "U");
X }
X fprintf(outf, ":");
X dumptypename(tp->basetype, 0);
X break;
X
X case TK_SMALLSET:
X fprintf(outf, "Sm");
X /* fall through */
X
X case TK_SET:
X fprintf(outf, "Set{");
X dumptypename(tp->indextype, 0);
X fprintf(outf, "}");
X break;
X
X case TK_FILE:
X fprintf(outf, "File{");
X dumptypename(tp->basetype, 0);
X fprintf(outf, "}");
X break;
X
X case TK_FUNCTION:
X fprintf(outf, "Func");
X if (tp->issigned)
X fprintf(outf, "Link");
X fprintf(outf, "{");
X dumptypename(tp->basetype, 0);
X fprintf(outf, "}");
X break;
X
X case TK_CPROCPTR:
X fprintf(outf, "C");
X /* fall through */
X
X case TK_PROCPTR:
X fprintf(outf, "Proc%d{", tp->escale);
X dumptypename(tp->basetype, 0);
X fprintf(outf, "}");
X break;
X
X default:
X fprintf(outf, "%s", typekindname(tp->kind));
X break;
X
X }
X if (tp->kind != TK_ARRAY && tp->kind != TK_SMALLARRAY &&
X (tp->smin || tp->smax)) {
X fprintf(outf, "{");
X dumpexpr(tp->smin);
X fprintf(outf, "..");
X dumpexpr(tp->smax);
X fprintf(outf, "}");
X }
X }
X#else
X fprintf(outf, "%lX", tp);
X#endif
X}
X
X
Xvoid dumptypename_file(f, tp)
XFILE *f;
XType *tp;
X{
X FILE *save = outf;
X outf = f;
X dumptypename(tp, 1);
X outf = save;
X}
X
X
Xvoid dumpexpr(ex)
XExpr *ex;
X{
X int i;
X Type *type;
X char *name;
X
X if (!ex) {
X fprintf(outf, "<NULL>");
X return;
X }
X if (ISBOGUS(ex)) {
X fprintf(outf, "0x%lX", ex);
X return;
X }
X if (ex->kind == EK_CONST && ex->val.type == tp_integer &&
X ex->nargs == 0 && !ex->val.s) {
X fprintf(outf, "%ld", ex->val.i);
X return;
X }
X if (ex->kind == EK_LONGCONST && ex->val.type == tp_integer &&
X ex->nargs == 0 && !ex->val.s) {
X fprintf(outf, "%ldL", ex->val.i);
X return;
X }
X name = exprkindname(ex->kind);
X if (!strncmp(name, "EK_", 3))
X name += 3;
X fprintf(outf, "%s", name);
X#ifdef HASDUMPS
X
X type = ex->val.type;
X fprintf(outf, "/");
X dumptypename(type, 1);
X if (ex->val.i) {
X switch (ex->kind) {
X
X case EK_VAR:
X case EK_FUNCTION:
X case EK_CTX:
X if (ISBOGUS(ex->val.i))
X fprintf(outf, "[0x%lX]", ex->val.i);
X else
X fprintf(outf, "[\"%s\"]", ((Meaning *)ex->val.i)->name);
X break;
X
X default:
X fprintf(outf, "[i=%ld]", ex->val.i);
X break;
X }
X }
X if (ISBOGUS(ex->val.s))
X fprintf(outf, "[0x%lX]", ex->val.s);
X else if (ex->val.s) {
X switch (ex->kind) {
X
X case EK_BICALL:
X case EK_NAME:
X case EK_DOT:
X fprintf(outf, "[s=\"%s\"]", ex->val.s);
X break;
X
X default:
X switch (ex->val.type ? ex->val.type->kind : TK_VOID) {
X case TK_STRING:
X fprintf(outf, "[s=%s]", makeCstring(ex->val.s, ex->val.i));
X break;
X case TK_REAL:
X fprintf(outf, "[s=%s]", ex->val.s);
X break;
X default:
X fprintf(outf, "[s=%lx]", ex->val.s);
X }
X break;
X }
X }
X if (ex->nargs > 0) {
X fprintf(outf, "(");
X if (ex->nargs < 10) {
X for (i = 0; i < ex->nargs; i++) {
X if (i)
X fprintf(outf, ", ");
X dumpexpr(ex->args[i]);
X }
X } else
X fprintf(outf, "...");
X fprintf(outf, ")");
X }
X#endif
X}
X
X
Xvoid dumpexpr_file(f, ex)
XFILE *f;
XExpr *ex;
X{
X FILE *save = outf;
X outf = f;
X dumpexpr(ex);
X outf = save;
X}
X
X
Xvoid innerdumpstmt(sp, indent)
XStmt *sp;
Xint indent;
X{
X#ifdef HASDUMPS
X if (!sp) {
X fprintf(outf, "<NULL>\n");
X return;
X }
X while (sp) {
X if (ISBOGUS(sp)) {
X fprintf(outf, "0x%lX\n", sp);
X return;
X }
X fprintf(outf, "%s", stmtkindname(sp->kind));
X if (sp->exp1) {
X fprintf(outf, ", exp1=");
X dumpexpr(sp->exp1);
X }
X if (sp->exp2) {
X fprintf(outf, ", exp2=");
X dumpexpr(sp->exp2);
X }
X if (sp->exp3) {
X fprintf(outf, ", exp3=");
X dumpexpr(sp->exp3);
X }
X fprintf(outf, "\n");
X if (sp->stm1) {
X fprintf(outf, "%*sstm1=", indent, "");
X innerdumpstmt(sp->stm1, indent+5);
X }
X if (sp->stm2) {
X fprintf(outf, "%*sstm2=", indent, "");
X innerdumpstmt(sp->stm2, indent+5);
X }
X sp = sp->next;
X if (sp) {
X if (indent > 5)
X fprintf(outf, "%*s", indent-5, "");
X fprintf(outf, "next=");
X }
X }
X#endif
X}
X
X
Xvoid dumpstmt(sp, indent)
XStmt *sp;
Xint indent;
X{
X fprintf(outf, "%*s", indent, "");
X innerdumpstmt(sp, indent);
X}
X
X
Xvoid dumpstmt_file(f, sp)
XFILE *f;
XStmt *sp;
X{
X FILE *save = outf;
X Stmt *savenext = NULL;
X outf = f;
X if (sp) {
X savenext = sp->next;
X sp->next = NULL;
X }
X dumpstmt(sp, 5);
X if (sp)
X sp->next = savenext;
X outf = save;
X}
X
X
X
Xvoid wrapup()
X{
X int i;
X
X for (i = 0; i < SYMHASHSIZE; i++)
X dumpsymtable(symtab[i]);
X}
X
X
X
X
Xvoid mem_summary()
X{
X#ifdef TEST_MALLOC
X printf("Summary of memory allocated but not freed:\n");
X printf("Total bytes = %d of %d\n", final_bytes, total_bytes);
X printf("Expressions = %d of %d\n", final_exprs, total_exprs);
X printf("Meanings = %d of %d (%d of %d)\n",
X final_meanings, total_meanings,
X final_meanings / sizeof(Meaning),
X total_meanings / sizeof(Meaning));
X printf("Strings = %d of %d\n", final_strings, total_strings);
X printf("Symbols = %d of %d\n", final_symbols, total_symbols);
X printf("Types = %d of %d (%d of %d)\n", final_types, total_types,
X final_types / sizeof(Type), total_types / sizeof(Type));
X printf("Statements = %d of %d (%d of %d)\n", final_stmts, total_stmts,
X final_stmts / sizeof(Stmt), total_stmts / sizeof(Stmt));
X printf("Strlists = %d of %d\n", final_strlists, total_strlists);
X printf("Literals = %d of %d\n", final_literals, total_literals);
X printf("Ctxstacks = %d of %d\n", final_ctxstacks, total_ctxstacks);
X printf("Temp vars = %d of %d\n", final_tempvars, total_tempvars);
X printf("Input recs = %d of %d\n", final_inprecs, total_inprecs);
X printf("Parens = %d of %d\n", final_parens, total_parens);
X printf("Ptr Descs = %d of %d\n", final_ptrdescs, total_ptrdescs);
X printf("Other = %d of %d\n", final_misc, total_misc);
X printf("\n");
X#endif
X}
X
X
X#ifdef TEST_MALLOC
X
Xanyptr memlist;
X
Xanyptr test_malloc(size, total, final)
Xint size, *total, *final;
X{
X anyptr p;
X
X p = malloc(size + 3*sizeof(long));
X#if 1
X ((anyptr *)p)[0] = memlist;
X memlist = p;
X ((long *)p)[1] = size;
X ((int **)p)[2] = final;
X total_bytes += size;
X final_bytes += size;
X *total += size;
X *final += size;
X#endif
X return (anyptr)((long *)p + 3);
X}
X
Xvoid test_free(p)
Xanyptr p;
X{
X#if 1
X final_bytes -= ((long *)p)[1-3];
X *((int **)p)[2-3] -= ((long *)p)[1-3];
X ((long *)p)[1-3] *= -1;
X#endif
X}
X
Xanyptr test_realloc(p, size)
Xanyptr p;
Xint size;
X{
X anyptr p2;
X
X p2 = test_malloc(size, &total_misc, &final_misc);
X memcpy(p2, p, size);
X test_free(p);
X return p2;
X}
X
X#endif /* TEST_MALLOC */
X
X
X
X
X/* End. */
X
X
END_OF_FILE
if test 40387 -ne `wc -c <'src/trans.c'`; then
echo shar: \"'src/trans.c'\" unpacked with wrong size!
fi
# end of 'src/trans.c'
fi
echo shar: End of archive 15 \(of 32\).
cp /dev/null ark15isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 32 archives.
echo "Now see PACKNOTES and the README"
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
--
Please send comp.sources.unix-related mail to rsalz at uunet.uu.net.
Use a domain-based address or give alternate paths, or you may lose out.
More information about the Comp.sources.unix
mailing list