/* * Main program, initialization, termination, and such. */ #include #include "..\h\config.h" #include "..\h\rt.h" #include "rproto.h" #include "..\h\version.h" #include "..\h\header.h" #include "..\h\opdefs.h" #include /* * Prototype. */ hidden novalue env_err Params((char *msg,char *name,char *val)); /* * The following code is operating-system dependent [@imain.01]. Include files * and declarations that are system-dependent. */ #if PORT #include /* probably needs something more */ Deliberate Syntax Error #endif /* PORT */ #if AMIGA #include #include int chkbreak; /* if nonzero, check for ^C */ #endif /* AMIGA */ #if ATARI_ST #include #endif /* ATARI_ST */ #if HIGHC_386 #include int _fmode = 0; /* force CR-LF on std.. files */ #endif /* HIGHC_386 */ #if MACINTOSH #include #if MPW #include #include #include #include #include int NoOptions = 0; #endif /* MPW */ #endif /* MACINTOSH */ #if MSDOS #if !MWC #include #include #endif /* !MWC */ #if MICROSOFT #include #include #endif /* MICROSOFT */ #endif /* MSDOS */ #if MVS || VM #if SASC #include #else /* SASC */ #include #endif /* SASC */ #endif /* MVS || VM */ #if OS2 #include #include #endif /* OS2 */ #if UNIX #include #endif /* UNIX */ #if VMS #include #include #endif /* VMS */ static char icodebuf[BUFSIZ]; /* * End of operating-system specific code. */ #ifdef IconAlloc #define malloc mem_alloc #endif /* IconAlloc */ #ifndef MaxHeader #define MaxHeader MaxHdr #endif /* MaxHeader */ /* * A number of important variables follow. */ static struct b_coexpr *mainhead; /* &main */ extern struct errtab errtab[]; /* error numbers and messages */ #ifdef TraceBack extern struct b_proc *opblks[]; extern word lastop; /* last op-code */ extern dptr xargp; extern word xnargs; /* number of arguments */ #endif /* TraceBack */ #ifdef EvalTrace word lineno = 0; /* source line number */ word colmno = 0; /* source column number */ #endif /* EvalTrace */ #ifdef DumpIstream FILE *imons; #endif /* DumpIstream */ #ifdef DumpIcount #define MaxIcode 100 FILE *imonc; long icode[MaxIcode]; #endif /* DumpIcount */ #ifdef WATERLOO_C_V3_0 extern int *cw3defect; #endif /* WATERLOO_C_V3_0 */ #ifdef IconCalling int IDepth = 0; /* depth of icon_call calls */ int call_error = 0; /* called procedure not found */ int interp_status; /* interpreter status */ #endif /* IconCalling */ int set_up = 0; /* initialization switch */ int k_level = 0; /* &level */ int k_errornumber = 0; /* &errornumber */ char *k_errortext = ""; /* &errortext */ struct descrip k_errorvalue; /* &errorvalue */ struct descrip k_main; /* &main */ char *code; /* interpreter code buffer */ word *records; /* pointer to record procedure blocks */ word *ftabp; /* pointer to record/field table */ dptr fnames, efnames; /* pointer to field names */ dptr globals, eglobals; /* pointer to global variables */ dptr gnames, egnames; /* pointer to global variable names */ dptr statics, estatics; /* pointer to static variables */ char *strcons; /* pointer to string constant table */ struct ipc_fname *filenms, *efilenms; /* pointer to ipc/file name table */ struct ipc_line *ilines, *elines; /* pointer to ipc/line number table */ #ifdef TallyOpt word tallybin[16]; /* counters for tallying */ int tallyopt = 0; /* want tally results output? */ #endif /* TallyOpt */ word mstksize = MStackSize; /* initial size of main stack */ word stksize = StackSize; /* co-expression stack size */ struct b_coexpr *stklist; /* base of co-expression block list */ word statsize = MaxStatSize; /* size of static region */ word statincr = MaxStatSize/4; /* increment for static region */ char *statbase = NULL; /* start of static space */ char *statend; /* end of static space */ char *statfree; /* static space free pointer */ word ssize = MaxStrSpace; /* initial string space size (bytes) */ char *strbase; /* start of string space */ char *strend; /* end of string space */ char *strfree; /* string space free pointer */ char *currend = NULL; /* current end of memory region */ word abrsize = MaxAbrSize; /* initial size of allocated block region (bytes) */ char *blkbase; /* start of block region */ char *blkend; /* end of allocated blocks */ char *blkfree; /* block region free pointer */ #ifdef FixedRegions word qualsize = QualLstSize; /* size of quallist for fixed regions */ #endif /* FixedRegions */ uword statneed; /* stated need for static space */ uword strneed; /* stated need for string space */ uword blkneed; /* stated need for block space */ int dodump; /* if nonzero, core dump on error */ int noerrbuf; /* if nonzero, do not buffer stderr */ struct descrip k_current; /* current expression stack pointer */ struct descrip maps2; /* second cached argument of map */ struct descrip maps3; /* third cached argument of map */ int ntended = 0; /* number of active tended descrips */ #ifdef ExecImages int dumped = 0; /* non-zero if reloaded from dump */ #endif /* ExecImages */ word *stack; /* Interpreter stack */ word *stackend; /* End of interpreter stack */ /* * Initial icode sequence. This is used to invoke the main procedure with one * argument. If main returns, the Op_Quit is executed. */ word istart[3]; int mterm = Op_Quit; #ifdef IconCalling int fterm = Op_FQuit; #endif /* IconCalling */ #ifndef IconCalling novalue main(argc, argv) int argc; char **argv; { int i, slen; #if SASC quiet(1); /* suppress C library diagnostics */ #endif /* SASC */ ipc.opnd = NULL; #if VMS redirect(&argc, argv, 0); #endif /* VMS */ /* * Setup Icon interface. It's done this way to avoid duplication * of code, since the same thing has to be done if calling Icon * is enabled. See istart.c. */ #ifdef CRAY argv[0] = "iconx"; #endif /* CRAY */ icon_setup(argc, argv, &i); while (i--) { /* skip option arguments */ argc--; argv++; } if (!argc) error("no icode file specified"); /* * Call icon_init with the name of the icode file to execute. [[I?]] */ icon_init(argv[1]); /* * Point sp at word after b_coexpr block for &main, point ipc at initial * icode segment, and clear the gfp. */ stackend = stack + mstksize/WordSize; sp = stack + Wsizeof(struct b_coexpr); ipc.opnd = istart; *ipc.op++ = Op_Invoke; /* [[I?]] */ *ipc.opnd++ = 1; #ifdef WATERLOO_C_V3_0 /* * Workaround for compiler bug. */ cw3defect = ipc.op; *cw3defect = Op_Quit; #else /* WATERLOO_C_V3_0 */ *ipc.op = Op_Quit; #endif /* WATERLOO_C_V3_0 */ ipc.opnd = istart; gfp = 0; /* * Set up expression frame marker to contain execution of the * main procedure. If failure occurs in this context, control * is transferred to mterm, the address of an Op_Quit. */ efp = (struct ef_marker *)(sp); efp->ef_failure.op = &mterm; efp->ef_gfp = 0; efp->ef_efp = 0; efp->ef_ilevel = 1; sp += Wsizeof(*efp) - 1; pfp = 0; ilevel = 0; /* * The first global variable holds the value of "main". If it * is not of type procedure, this is noted as run-time error 117. * Otherwise, this value is pushed on the stack. */ if (globals[0].dword != D_Proc) fatalerr(-117, NULL); PushDesc(globals[0]); /* * Main is to be invoked with one argument, a list of the command * line arguments. The command line arguments are pushed on the * stack as a series of descriptors and llist is called to create * the list. The null descriptor first pushed serves as Arg0 for * Ollist and receives the result of the computation. */ PushNull; argp = (dptr)(sp - 1); for (i = 2; i < argc; i++) { slen = strlen(argv[i]); strreq((word)slen); PushVal(slen); PushAVal(alcstr(argv[i],(word)slen)); } Ollist(argc - 2, argp); sp = (word *)argp + 1; argp = 0; set_up = 1; /* post fact that iconx is initialized */ /* * Start things rolling by calling interp. This call to interp * returns only if an Op_Quit is executed. If this happens, * c_exit() is called to wrap things up. */ #ifdef CoProcesses codisp(); /* start up co-expr dispatcher, which will call interp */ #else /* CoProcesses */ interp(0,(dptr)NULL); /* [[I?]] */ #endif /* CoProcesses */ c_exit(NormalExit); } #endif /* IconCalling */ #ifdef IconCalling dptr icon_call(pname, argc, dargv) char *pname; int argc; dptr dargv; { int i; dptr retdesc; struct descrip pd; if (IDepth == 0) { /* * Perform first-time initializations. * Point sp at word after b_coexpr block for &main, point ipc at initial * icode segment, and clear the gfp. */ stackend = stack + mstksize/WordSize; sp = stack + Wsizeof(struct b_coexpr); sp--; /* point at last thing on stack, not beyond it */ interp_status = 0; argp = 0; pfp = 0; ilevel = 0; } /* * Point sp at word after b_coexpr block for &main, point ipc at initial * icode segment, and clear the gfp. */ ipc.opnd = istart; *ipc.op++ = Op_Invoke; *ipc.opnd++ = argc; /* number of arguments for call */ #ifdef WATERLOO_C_V3_0 /* * Workaround for compiler bug. */ cw3defect = ipc.op; *cw3defect = Op_Quit; #else /* WATERLOO_C_V3_0 */ *ipc.op = Op_Quit; #endif /* WATERLOO_C_V3_0 */ ipc.opnd = istart; gfp = 0; /* * Set up expression frame marker to contain execution of the * main procedure. If failure occurs in this context, control * is transferred to fterm, the address of an Op_FQuit. */ efp = (struct ef_marker *)(sp + 1); efp->ef_failure.op = &fterm; /* signals a failure to interp */ efp->ef_gfp = 0; efp->ef_efp = 0; efp->ef_ilevel = ilevel + 1; sp += Wsizeof(*efp); /* * "main" is no longer the default starting procedure. * Use procedure named pname as the main (starting) procedure. */ if (getvar(pname,&pd) == Failure) { fprintf(stderr, "Icon function/procedure \"%s\" not found\n", pname); fflush(stderr); call_error = 1; return (dptr)NULL; } DeRef(pd); /* get value (can't fail) */ /* * Must be of type procedure. */ if ((pd.dword != D_Proc)) { if (strcmp(pname,"main") == 0 && (pfp == 0)) fatalerr(-117, NULL); else { if (pfp == 0) fatalerr(-106, NULL); else fatalerr(106, NULL); } } PushDesc(pd); /* * The input arguments are pushed on the stack as a series * of descriptors and the indicated procedure. The procedure descriptor * is overwritten with the result of the call. */ for (i = 0; i < argc; i++) { /* i = 0, instead of 2 */ PushDesc(dargv[i]); } /* Pass on value of argp to current invocation. This will be 0 by * default on the first action, and the value of the current argp on * subsequent invocations. */ /* * Start things rolling by calling interp. This call to interp * returns only if an Op_Quit is executed. If this happens, * return the result of main. (Used to c_exit here). */ IDepth++; #ifdef CoProcesses codisp(); /* start up co-expr dispatcher, which calls interp */ #else /* CoProcesses */ interp(0,(dptr)NULL); #endif /* CoProcesses */ IDepth--; if (interp_status == A_Pfail_uw) return (dptr)NULL; /* failure no value */ else /* NOTE: suspension not identified */ { retdesc = (dptr)(sp - 1); sp = (word *) efp - 1; return retdesc; /* success, return top sp */ } } #endif /* IconCalling */ novalue icon_setup(argc,argv,ip) int argc; char **argv; int *ip; { #ifdef TallyOpt extern int tallyopt; #endif /* TallyOpt */ *ip = 0; /* number of arguments processed */ #ifdef ExecImages if (dumped) { /* * This is a restart of a dumped interpreter. Normally, argv[0] is * iconx, argv[1] is the icode file, and argv[2:(argc-1)] are the * arguments to pass as a list to main(). For a dumped interpreter * however, argv[0] is the executable binary, and the first argument * for main() is argv[1]. The simplest way to handle this is to * back up argv to point at argv[-1] and increment argc, giving the * illusion of an additional argument at the head of the list. Note * that this argument is never referenced. */ argv--; argc++; (*ip)--; } #endif /* ExecImages */ #ifdef MaxLevel maxilevel = 0; maxplevel = 0; maxsp = 0; #endif /* MaxLevel */ #ifdef DumpIstream imons = fopen("icodes.mon",WriteText); if (imons == NULL) { fprintf(stderr,"cannot open icodes.mon\n"); fflush(stderr); abort(); } #endif /* DumpIstream */ #ifdef DumpIcount imonc = fopen("icodec.mon",WriteText); if (imonc == NULL) { fprintf(stderr,"cannot open icodec.mon\n"); fflush(stderr); abort(); } #endif /* DumpIcount */ #if MACINTOSH #if MPW InitCursorCtl(NULL); /* * To support the icode and iconx interpreter bundled together in * the same file, we might have to use this code file as the icode * file, too. We do this if the command name is not 'iconx'. */ { char *p,*q,c,fn[6]; /* * Isolate the filename from the path. */ q = strrchr(*argv,':'); if (q == NULL) q = *argv; else ++q; /* * See if it's the real iconx -- case independent compare. */ p = fn; if (strlen(q) == 5) while (c = *q++) *p++ = tolower(c); *p = '\0'; if (strcmp(fn,"iconx") != 0) { /* * This technique of shifting arguments relies on the fact that * argv[0] is never referenced, since this will make it invalid. */ --argv; ++argc; /* * We don't want to look for any command line options in this * case. They could interfere with options for the icon * program. */ NoOptions = 1; } } #endif /* MPW */ #endif /* MACINTOSH */ /* * Handle command-line options. */ /* * Handle command line options. */ #if MACINTOSH && MPW if (!NoOptions) while (!NoOptions && argv[1] != 0 && *argv[1] == '-' ) { #else /* MACINTOSH && MPW */ while ( argv[1] != 0 && *argv[1] == '-' ) { #endif /* MACINTOSH && MPW */ switch ( *(argv[1]+1) ) { #ifdef TallyOpt /* * Set tallying flag if -T option given */ case 'T': tallyopt = 1; break; #endif /* TallyOpt */ /* * Set stderr to new file if -e option is given. */ case 'e': { char *p; if ( *(argv[1]+2) != '\0' ) p = argv[1]+2; else { argv++; argc--; (*ip)++; p = argv[1]; if ( !p ) error("no file name given for redirection of &errout"); } if ( *p == '-' ) { /* let - be stdout */ /* * The following code is operating-system dependent [@imain.02]. Redirect * stderr to stdout. */ #if PORT /* may not be possible */ Deliberate Syntax Error #endif /* PORT */ #if AMIGA #if AZTEC_C /* * Try the same hack as above for Manx and cross fingers. * If it doesn't work, try trick used for HIGH_C, below. */ stderr->_unit = stdout->_unit; stderr->_flags = stdout->_flags; #endif /* AZTEC C */ #if LATTICE /* * The following code is for Lattice 4.0. It was different * for Lattice 3.10 and probably won't work for other * C compilers. */ stderr->_file = 1; stderr->_flag = stdout->_flag; #endif /* LATTICE */ #endif /* AMIGA */ #if ATARI_ST || MSDOS || OS2 || VMS dup2(fileno(stdout),fileno(stderr)); #endif /* ATARI_ST || MSDOS || OS2 ... */ #if HIGHC_386 /* * Don't like doing this, but it seems to work. */ setbuf(stdout,NULL); setbuf(stderr,NULL); stderr->_fd = stdout->_fd; #endif /* HIGHC_386 */ #if MACINTOSH #if LSC /* cannot do */ #endif /* LSC */ #if MPW close(fileno(stderr)); dup(fileno(stdout)); #endif /* MPW */ #endif /* MACINTOSH */ #if MVS || VM /* Cannot do. */ #endif /* MVS || VM */ #if UNIX /* * This relies on the way UNIX assigns file numbers. */ close(fileno(stderr)); dup(fileno(stdout)); #endif /* UNIX */ /* * End of operating-system specific code. */ } else /* redirecting to named file */ if (freopen(p, "w", stderr) == NULL) syserr("Unable to redirect &errout\n"); break; } } argc--; (*ip)++; argv++; } } /* * icon_init - initialize memory and prepare for Icon execution. */ novalue icon_init(name) char *name; { int n; struct header hdr; FILE *fname = NULL; word cbread, longread(); extern struct astkblk *alcactiv(); /* * Catch floating point traps and memory faults. */ /* * The following code is operating-system dependent [@imain.03]. Set traps. */ #if PORT /* probably needs something */ Deliberate Syntax Error #endif /* PORT */ #if AMIGA signal(SIGFPE,fpetrap); #endif /* AMIGA */ #if ATARI_ST #endif /* ATARI_ST */ #if HIGHC_386 /* signals not supported */ #endif /* HIGHC_386 */ #if MACINTOSH #if MPW /* This is equivalent to SIGFPE signal in the Standard Apple Numeric Environment (SANE) */ { environment e; getenvironment(&e); #ifdef mc68881 e.FPCR |= CURUNDERFLOW|CUROVERFLOW|CURDIVBYZERO; #else /* mc68881 */ e |= UNDERFLOW|OVERFLOW|DIVBYZERO; #endif /* mc68881 */ setenvironment(e); #ifdef mc68881 { static trapvector tv = {fpetrap,fpetrap,fpetrap,fpetrap,fpetrap,fpetrap,fpetrap}; settrapvector(&tv); } #else /* mc6881 */ sethaltvector((haltvector)fpetrap); #endif /* mc6881 */ } #endif /* MPW */ #endif /* MACINTOSH */ #if MSDOS #if LATTICE || MICROSOFT || TURBO signal(SIGFPE, fpetrap); #endif /* LATTICE || MICROSOFT || TURBO */ #endif /* MSDOS */ #if MVS || VM #if SASC cosignal(SIGFPE, fpetrap); /* catch in all coprocs */ cosignal(SIGSEGV, segvtrap); #endif /* SASC */ #ifdef WATERLOO_C_V3_0 /* Note that the following is the same as SIGFPE except that it doesn't capture significance exceptions (caused when ever a floating point register is loaded with a 0.0 */ signal(( _FLOAT_UNDER + _FLOAT_OVER + _FLOAT_DIVIDE), fpetrap); #endif /* WATERLOO_C_V3_0 */ #endif /* MVS || VM */ #if OS2 signal(SIGFPE, fpetrap); signal(SIGSEGV, segvtrap); #endif /* OS2 */ #if UNIX || VMS signal(SIGSEGV, segvtrap); #ifdef PYRAMID { struct sigvec a; a.sv_handler = fpetrap; a.sv_mask = 0; a.sv_onstack = 0; sigvec(SIGFPE, &a, 0); sigsetmask(1 << SIGFPE); } #else /* PYRAMID */ signal(SIGFPE, fpetrap); #endif /* PYRAMID */ #endif /* UNIX || VMS */ /* * End of operating-system specific code. */ #ifdef ExecImages /* * If reloading from a dumped out executable, skip most of init and * just set up the buffer for stderr and do the timing initializations. */ if (dumped) goto btinit; #endif /* ExecImages */ /* * Initialize data that can't be intialized statically. */ datainit(); /* * Open the icode file and read the header. [[I?]] */ if (!name) error("no interpreter file supplied"); /* * Try adding the suffix if the file name doesn't end in it. */ n = strlen(name); if (n <= 4 || (strcmp(name+n-4,IcodeSuffix) != 0) && strcmp(name+n-4,IcodeASuffix) != 0) { char tname[100]; if (strlen(name) + 5 > 100) error("icode file name too long"); strcpy(tname,name); #if MVS /* for any compiler which allows PDS members */ { char *p; if (p = index(name, '(')) { tname[p-name] = '\0'; } #endif /* MVS */ #ifdef WATERLOO_C_V3_0 strcat(tname," ICX * (BIN"); fname = fopen(tname,ReadText); #else /* WATERLOO_C_V3_0 */ strcat(tname,IcodeSuffix); #if MVS if (p) strcat(tname,p); } #endif /* MVS */ fname = fopen(tname,ReadBinary); #endif /* WATERLOO_C_V3_0 */ } if (fname == NULL) /* try the name as given */ #ifdef WATERLOO_C_V3_0 { /* * Prevent interpretation of \n in binary files. */ char tname[100]; strcpy(tname,name); strcat(tname," (BIN"); fname = fopen(tname,ReadText); } #else /* WATERLOO_C_V3_0 */ fname = fopen(name,ReadBinary); #endif /* WATERLOO_C_V3_0 */ if (fname == NULL) error("cannot open interpreter file"); setbuf(fname,icodebuf); #ifdef Header if (fseek(fname, (long)MaxHeader, 0) == -1) error("can't read interpreter file header"); #endif /* Header */ if (fread((char *)&hdr, sizeof(char), sizeof(hdr), fname) != sizeof(hdr)) error("can't read interpreter file header"); k_trace = hdr.trace; #ifdef EnvVars /* * Examine the environment and make appropriate settings. [[I?]] */ envset(); #endif /* EnvVars */ /* * Convert stack sizes from words to bytes. */ #ifndef SCO_XENIX stksize *= WordSize; mstksize *= WordSize; #else /* SCO_XENIX */ /* * This is a work-around for bad generated code for *= (as above) * produced by the SCO XENIX C Compiler for the large memory model. * It relies on the fact that WordSize is 4. */ stksize += stksize; stksize += stksize; mstksize += mstksize; mstksize += mstksize; #endif /* SCO_XENIX */ #if IntBits == 16 if (mstksize > MaxBlock) fatalerr(-316, NULL); if (stksize > MaxBlock) fatalerr(-318, NULL); #endif /* IntBits == 16 */ /* * Allocate memory for various regions. */ initalloc(hdr.hsize); /* * Establish pointers to icode data regions. [[I?]] */ records = (word *)(code + hdr.records); ftabp = (word *)(code + hdr.ftab); fnames = (dptr)(code + hdr.fnames); globals = efnames = (dptr)(code + hdr.globals); gnames = eglobals = (dptr)(code + hdr.gnames); statics = egnames = (dptr)(code + hdr.statics); estatics = (dptr)(code + hdr.filenms); filenms = (struct ipc_fname *)estatics; efilenms = (struct ipc_fname *)(code + hdr.linenums); ilines = (struct ipc_line *)efilenms; elines = (struct ipc_line *)(code + hdr.strcons); strcons = (char *)elines; /* * Allocate stack and initialize &main. */ stack = (word *)malloc((msize)mstksize); if (stack == NULL) fatalerr(-303, NULL); mainhead = (struct b_coexpr *)stack; mainhead->title = T_Coexpr; #ifdef Coexpr mainhead->es_actstk = alcactiv(); if (mainhead->es_actstk == NULL) fatalerr(0, NULL); if (pushact(mainhead, mainhead) == Error) fatalerr(0, NULL); #endif /* Coexpr */ mainhead->id = 1; mainhead->size = 1; /* pretend main() does an activation */ mainhead->freshblk = nulldesc; /* &main has no refresh block. */ /* This really is a bug. */ /* * Point &main at the co-expression block for the main procedure and set * k_current, the pointer to the current co-expression, to &main. */ k_main.dword = D_Coexpr; BlkLoc(k_main) = (union block *) mainhead; k_current = k_main; /* * Read the interpretable code and data into memory. */ if ((cbread = longread(code, sizeof(char), (long)hdr.hsize, fname)) != hdr.hsize) { fprintf(stderr,"Tried to read %ld bytes of code, got %ld\n", (long)hdr.hsize,(long)cbread); error("can't read interpreter code"); } fclose(fname); /* * Make sure the version number of the icode matches the interpreter version. */ if (strcmp((char *)hdr.config,IVersion)) { fprintf(stderr,"icode version mismatch\n"); fprintf(stderr,"\ticode version: %s\n",(char *)hdr.config); fprintf(stderr,"\texpected version: %s\n",IVersion); error("cannot run"); } /* * Resolve references from icode to run-time system. */ resolve(); #ifdef ExecImages btinit: #endif /* ExecImages */ /* * The following code is operating-system dependent [@imain.04]. Allocate and * assign a buffer to stderr if possible. */ #if PORT /* probably nothing */ Deliberate Syntax Error #endif /* PORT */ #if AMIGA || HIGHC_386 || MVS || VM /* not done */ #endif /* AMIGA */ #if ATARI_ST || MACINTOSH || UNIX || MSDOS || OS2 || VMS if (noerrbuf) setbuf(stderr, NULL); else { char *buf; buf = (char *)malloc((msize)BUFSIZ); if (buf == NULL) fatalerr(-305, NULL); setbuf(stderr, buf); } #endif /* ATARI_ST || MACINTOSH || UNIX ... */ /* * End of operating-system specific code. */ #ifdef MemMon /* * Initialize the memory monitoring system, if configured. */ MMInit(name); #endif /* MemMon */ #ifdef EvalTrace /* * Initialize evaluation tracing system */ TRInit(name); #endif /* EvalTrace */ /* * Start timing execution. */ millisec(); } /* * Service routines related to getting things started. */ /* * resolve - perform various fix-ups on the data read from the icode * file. */ novalue resolve() { register word i; register struct b_proc *pp; register dptr dp; extern Omkrec(); extern int ftsize; extern struct b_proc *functab[]; /* * Scan the global variable array for procedures and fill in appropriate * addresses. */ for (dp = globals; dp < eglobals; dp++) { if ((*dp).dword != D_Proc) continue; /* * The second word of the descriptor for procedure variables tells * where the procedure is. Negative values are used for built-in * procedures and positive values are used for Icon procedures. */ i = IntVal(*dp); if (i < 0) { /* * *dp names a built-in function, negate i and use it as an index * into functab to get the location of the procedure block. */ i = -i; if (i > ftsize) { *dp = nulldesc; /* undefined, set to &null */ continue; } BlkLoc(*dp) = (union block *)functab[i-1]; } else { /* * *dp names an Icon procedure or a record. i is an offset to * location of the procedure block in the code section. Point * pp at the block and replace BlkLoc(*dp). */ pp = (struct b_proc *)(code + i); BlkLoc(*dp) = (union block *)pp; /* * Relocate the address of the name of the procedure. */ StrLoc(pp->pname) = strcons + (uword)StrLoc(pp->pname); if (pp->ndynam == -2) /* * This procedure is a record constructor. Make its entry point * be the entry point of Omkrec(). */ pp->entryp.ccode = Omkrec; else { /* * This is an Icon procedure. Relocate the entry point and * the names of the parameters, locals, and static variables. */ pp->entryp.icode = code + pp->entryp.ioff; for (i = 0; i < abs((int)pp->nparam)+pp->ndynam+pp->nstatic; i++) StrLoc(pp->lnames[i]) = strcons + (uword)StrLoc(pp->lnames[i]); } #ifndef BoundFunctions } #endif /* BoundFunctions */ } /* * Relocate the names of the fields. */ for (dp = fnames; dp < efnames; dp++) StrLoc(*dp) = strcons + (uword)StrLoc(*dp); /* * Relocate the names of the global variables. */ for (dp = gnames; dp < egnames; dp++) StrLoc(*dp) = strcons + (uword)StrLoc(*dp); } #ifdef EnvVars /* * Check for environment variables that Icon uses and set system * values as is appropriate. */ novalue envset() { register char *p; if ((p = getenv("NOERRBUF")) != NULL) noerrbuf++; env_int("TRACE", &k_trace, 0, (uword)0); env_int("COEXPSIZE", &stksize, 1, (uword)MaxUnsigned); env_int("STRSIZE", &ssize, 1, (uword)MaxBlock); env_int("HEAPSIZE", &abrsize, 1, (uword)MaxBlock); env_int("BLOCKSIZE", &abrsize, 1, (uword)MaxBlock); /* synonym */ env_int("BLKSIZE", &abrsize, 1, (uword)MaxBlock); /* synonym */ env_int("STATSIZE", &statsize, 1, (uword)MaxBlock); env_int("STATINCR", &statincr, 1, (uword)MaxBlock); env_int("MSTKSIZE", &mstksize, 1, (uword)MaxUnsigned); #ifdef FixedRegions env_int("QLSIZE", &qualsize, 1, (uword)MaxBlock); #endif /* FixedRegions */ /* * The following code is operating-system dependent [@imain.05]. Check any * system-dependent environment variables. */ #if PORT /* nothing to do */ Deliberate Syntax Error #endif /* PORT */ #if AMIGA if ((p = getenv("CHECKBREAK")) != NULL) chkbreak++; #endif /* AMIGA */ #if ATARI_ST || HIGHC_386 || MACINTOSH || MSDOS || MVS || OS2 || UNIX || VM /* nothing to do */ #endif /* ATARI_ST || HIGHC_386 || ... */ #if VMS { extern word memsize; env_int("MAXMEM", &memsize, 1, MaxBlock); } #endif /* VMS */ /* * End of operating-system specific code. */ if ((p = getenv("ICONCORE")) != NULL && *p != '\0') { /* * The following code is operating-system dependent [@imain.06]. Set trap to * give dump on abnormal termination if ICONCORE is set. */ #if PORT /* can't handle */ Deliberate Syntax Error #endif /* PORT */ #if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH /* can't handle */ #endif /* AMIGA || ATARI_ST || ... */ #if MSDOS #if LATTICE || TURBO signal(SIGFPE, SIG_DFL); #endif /* LATTICE || TURBO */ #endif /* MSDOS */ #if MVS || VM /* Really nothing to do. */ #endif /* MVS || VM */ #if OS2 signal(SIGSEGV, SIG_DFL); signal(SIGFPE, SIG_DFL); #endif /* OS2 */ #if UNIX || VMS signal(SIGSEGV, SIG_DFL); #endif /* UNIX || VMS */ /* * End of operating-system specific code. */ dodump++; } } static novalue env_err(msg, name, val) char *msg; char *name; char *val; { char msg_buf[100]; strncpy(msg_buf, msg, 99); strncat(msg_buf, ": ", 99 - strlen(msg_buf)); strncat(msg_buf, name, 99 - strlen(msg_buf)); strncat(msg_buf, "=", 99 - strlen(msg_buf)); strncat(msg_buf, val, 99 - strlen(msg_buf)); error(msg_buf); } /* * env_int - get the value of an integer-valued environment variable. */ novalue env_int(name, variable, non_neg, limit) char *name; word *variable; int non_neg; uword limit; { char *value; char *s; register uword n = 0; register uword d; int sign = 1; if ((value = getenv(name)) == NULL || *value == '\0') return; s = value; if (*s == '-') { if (non_neg) env_err("environment variable out of range", name, value); sign = -1; ++s; } else if (*s == '+') ++s; while (isdigit(*s)) { d = *s++ - '0'; /* * See if 10 * n + d > limit, but do it so there can be no overflow. */ if ((d > (uword)(limit / 10 - n) * 10 + limit % 10) && (limit > 0)) env_err("environment variable out of range", name, value); n = n * 10 + d; } if (*s != '\0') env_err("environment variable not numeric", name, value); *variable = sign * n; } #endif /* EnvVars */ /* * Termination routines. */ /* * Produce run-time error 204 on floating-point traps. */ novalue fpetrap() { fatalerr(-204, NULL); } /* * Produce run-time error 320 on ^C interrupts. Not used at present, * since malfunction may occur during traceback. */ novalue inttrap() { fatalerr(-320, NULL); } /* * Produce run-time error 302 on segmentation faults. */ novalue segvtrap() { fatalerr(-302, NULL); } #if MVS || VM novalue fixtrap() { fatalerror(-203, NULL); } #endif /* MVS || VM */ /* * error - print error message s; used only in startup code. */ novalue error(s) char *s; { fprintf(stderr, "error in startup code\n%s\n", s); fflush(stderr); if (dodump) abort(); c_exit(ErrorExit); } /* * syserr - print s as a system error. */ novalue syserr(s) char *s; { if (pfp != 0) fprintf(stderr, "System error at line %ld in %s\n%s\n", (long)findline(ipc.opnd), findfile(ipc.opnd), s); else fprintf(stderr, "System error in startup code\n%s\n", s); fflush(stderr); if (dodump) abort(); c_exit(ErrorExit); } /* * runerr - print message corresponding to error |n|; if n > 0, * print it as the offending value. */ novalue runerr(n, v) register int n; dptr v; { register struct errtab *p; if (n != 0) { k_errornumber = n; if (n > 0) k_errorvalue = *v; else k_errorvalue = nulldesc; } /* * Take absolute value of error number */ n = (k_errornumber > 0 ? k_errornumber : -k_errornumber); k_errortext = ""; for (p = errtab; p->err_no > 0; p++) if (p->err_no == n) { k_errortext = p->errmsg; break; } if (pfp != 0) { if (k_error == 0) { fprintf(stderr, "Run-time error %d\nFile %s; Line %ld\n", n, findfile(ipc.opnd), (long)findline(ipc.opnd)); } else { k_error--; return; } } else fprintf(stderr, "Run-time error %d in startup code\n", n); fprintf(stderr, "%s\n", k_errortext); if (k_errornumber > 0) { fprintf(stderr, "offending value: "); outimage(stderr, &k_errorvalue, 0); putc('\n', stderr); } fflush(stderr); #ifdef MemMon { char buf[40]; sprintf(buf,"Run-time error %d: ",n); MMTerm(buf,k_errortext); } #endif /* MemMon */ #ifdef EvalTrace { char buf[40]; sprintf(buf,"Run-time error %d: ",n); TRTerm(buf,k_errortext); } #endif /* EvalTrace */ #ifdef TraceBack if (pfp == 0) { /* skip if start-up problem */ if (dodump) abort(); c_exit(ErrorExit); } { struct pf_marker *origpfp = pfp; dptr arg; struct b_proc *cproc; inst cipc; fprintf(stderr, "Trace back:\n"); /* * Chain back through the procedure frame markers, looking for the * first one, while building a foward chain of pointers through * the expression frame pointers. */ for (pfp->pf_efp = NULL; pfp->pf_pfp != NULL; pfp = pfp->pf_pfp) { (pfp->pf_pfp)->pf_efp = (struct ef_marker *)pfp; } /* Now start from the base procedure frame marker, producing a listing * of the procedure calls up through the last one. */ while (pfp) { arg = &((dptr)pfp)[-(pfp->pf_nargs) - 1]; cproc = (struct b_proc *)BlkLoc(arg[0]); /* * The ipc in the procedure frame points after the "invoke n". */ cipc = pfp->pf_ipc; --cipc.opnd; --cipc.op; xtrace(cproc, pfp->pf_nargs, &arg[0], findline(cipc.opnd), findfile(cipc.opnd)); /* * On the last call, show both the call and the offending expression. */ if (pfp == origpfp) { ttrace(); break; } pfp = (struct pf_marker *)(pfp->pf_efp); } } #endif /* TraceBack */ if (dodump) abort(); c_exit(ErrorExit); } /* * c_exit(i) - flush all buffers and exit with status i. */ novalue c_exit(i) int i; { #ifdef MemMon MMTerm("",""); #endif /* MemMon */ #ifdef EvalTrace TRTerm("",""); #endif /* EvalTrace */ #ifdef TallyOpt { int j; if (tallyopt) { fprintf(stderr,"tallies: "); for (j=0; j<16; j++) fprintf(stderr," %ld", (long)tallybin[j]); fprintf(stderr,"\n"); } } #endif /* TallyOpt */ exit(i); } /* * err() is called if an erroneous situation occurs in the virtual * machine code. It is typed as int to avoid declaration problems * elsewhere. */ int err() { syserr("call to 'err'\n"); return 1; /* unreachable; make compilers happy */ } novalue fatalerr(n, v) int n; dptr v; { k_error = 0; runerr(n, v); } novalue datainit() { /* * Initializations that cannot be performed statically (at least for * some compilers). [[I?]] */ k_errout.fd = stderr; k_errout.fname.dword = 7; StrLoc(k_errout.fname) = "&errout"; k_errout.status = Fs_Write; k_input.fd = stdin; k_input.fname.dword = 6; StrLoc(k_input.fname) = "&input"; k_input.status = Fs_Read; k_output.fd = stdout; k_output.fname.dword = 7; StrLoc(k_output.fname) = "&output"; k_output.status = Fs_Write; IntVal(tvky_pos.kyval) = 1; StrLen(tvky_pos.kyname) = 4; StrLoc(tvky_pos.kyname) = "&pos"; IntVal(tvky_ran.kyval) = 0; StrLen(tvky_ran.kyname) = 7; StrLoc(tvky_ran.kyname) = "&random"; StrLen(tvky_sub.kyval) = 0; StrLoc(tvky_sub.kyval) = ""; StrLen(tvky_sub.kyname) = 8; StrLoc(tvky_sub.kyname) = "&subject"; IntVal(tvky_trc.kyval) = 0; StrLen(tvky_trc.kyname) = 6; StrLoc(tvky_trc.kyname) = "&trace"; IntVal(tvky_err.kyval) = 0; StrLen(tvky_err.kyname) = 6; StrLoc(tvky_err.kyname) = "&error"; StrLen(blank) = 1; StrLoc(blank) = " "; StrLen(emptystr) = 0; StrLoc(emptystr) = ""; BlkLoc(errout) = (union block *) &k_errout; BlkLoc(input) = (union block *) &k_input; StrLen(lcase) = 26; StrLoc(lcase) = "abcdefghijklmnopqrstuvwxyz"; StrLen(letr) = 1; StrLoc(letr) = "r"; IntVal(nulldesc) = 0; k_errorvalue = nulldesc; IntVal(onedesc) = 1; StrLen(ucase) = 26; StrLoc(ucase) = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; IntVal(zerodesc) = 0; maps2 = nulldesc; maps3 = nulldesc; #ifdef MultipleRuns mstksize = MStackSize; /* initial size of main stack */ stksize = StackSize; /* co-expression stack size */ ssize = MaxStrSpace; /* initial string space size (bytes) */ abrsize = MaxAbrSize; /* initial size of allocated block region (bytes) */ #ifdef FixedRegions qualsize = QualLstSize; /* size of quallist for fixed regions */ #endif /* FixedRegions */ ntended = 0; /* number of active tended descrips */ dodump = 0; /* produce dump on error */ mterm = Op_Quit; #ifdef IconCalling fterm = Op_FQuit; #endif /* IconCalling */ #ifdef ExecImages dumped = 0; /* This is a dumped image. */ #endif /* ExecImages */ /* In module interp.c: */ pfp = 0; /* Procedure frame pointer */ sp = NULL; /* Stack pointer */ /* In module rmemmgt.c: */ coexp_ser = 2; list_ser = 1; set_ser = 1; table_ser = 1; coll_stat = 0; coll_str = 0; coll_blk = 0; coll_tot = 0; #endif /* MultipleRuns */ }