Subject: v21i060: Pascal to C translator, Part15/32 Newsgroups: comp.sources.unix Approved: rsalz@uunet.UU.NET X-Checksum-Snefru: cbd36541 57b10fe5 c53c1567 14a79c4c Submitted-by: Dave Gillespie 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 'src/trans.c' <<'END_OF_FILE' X/* "p2c", a Pascal to C translator. X Copyright (C) 1989 David Gillespie. X Author's address: daveg@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 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< 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< %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, ""); 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, ""); 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, "", 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("", (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("", (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("", (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("", (int) kind); X} X X X Xvoid dumptype(tp) XType *tp; X{ X if (!tp) { X fprintf(outf, "\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, "\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 : ""), 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, ""); 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, ""); 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, "\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