Return to imain.c CVS log

Up to [Research Unix] / researchv10dc / cmd / icon / src / iconx

Annotation of researchv10dc/cmd/icon/src/iconx/imain.c, revision 1.1

1.1     ! root        1: /*
        !             2:  * Initialization and error routines.
        !             3:  */
        !             4: 
        !             5: #include "../h/rt.h"
        !             6: #include "../h/version.h"
        !             7: #include "gc.h"
        !             8: #include "../h/header.h"
        !             9: #include <signal.h>
        !            10: #include <ctype.h>
        !            11: #ifndef VMS
        !            12: #ifndef MSDOS
        !            13: #include <sys/types.h>
        !            14: #include <sys/times.h>
        !            15: #else MSDOS
        !            16: #ifdef LATTICE
        !            17: #include <fcntl.h>
        !            18: #include <time.h>
        !            19: #endif LATTICE
        !            20: #ifdef MSoft
        !            21: #include <sys/types.h>
        !            22: #include <fcntl.h>
        !            23: #include SysTime
        !            24: #endif MSoft
        !            25: #endif MSDOS
        !            26: #else VMS
        !            27: #include <types.h>
        !            28: struct tms {
        !            29:    time_t    tms_utime;                /* user time */
        !            30:    time_t    tms_stime;                /* system time */
        !            31:    time_t    tms_cutime;               /* user time, children */
        !            32:    time_t    tms_cstime;               /* system time, children */
        !            33:    };
        !            34: #endif VMS
        !            35: 
        !            36: /*
        !            37:  * A number of important variables follow.
        !            38:  */
        !            39: 
        !            40: #ifndef MaxHeader
        !            41: #define MaxHeader MaxHdr
        !            42: #endif MaxHeader
        !            43: 
        !            44: extern putpos();                       /* assignment function for &pos */
        !            45: extern putran();                       /* assignment function for &random */
        !            46: extern putsub();                       /* assignment function for &subject */
        !            47: extern puttrc();                       /* assignment function for &trace */
        !            48: 
        !            49: word *stack;                           /* interpreter stack */
        !            50: int line = 0;                          /* source program line number */
        !            51: int k_level = 0;                       /* &level */
        !            52: struct descrip k_main;                 /* &main */
        !            53: char *code;                            /* interpreter code buffer */
        !            54: word *records;                         /* pointer to record procedure blocks */
        !            55: word *ftab;                            /* pointer to record/field table */
        !            56: struct descrip *globals, *eglobals;    /* pointer to global variables */
        !            57: struct descrip *gnames, *egnames;      /* pointer to global variable names */
        !            58: struct descrip *statics, *estatics;    /* pointer to static variables */
        !            59: char *ident;                           /* pointer to identifier table */
        !            60: 
        !            61: int numbufs = NumBuf;                  /* number of i/o buffers */
        !            62: char (*bufs)[BUFSIZ];                  /* pointer to buffers */
        !            63: FILE **bufused;                                /* pointer to buffer use markers */
        !            64: 
        !            65: word tallybin[16];                     /* counters for tallying */
        !            66: int tallyopt = 0;                      /* want tally results output? */
        !            67: 
        !            68: int mstksize = MStackSize;             /* initial size of main stack */
        !            69: int stksize = StackSize;               /* co-expression stack size */
        !            70: struct b_coexpr *stklist;              /* base of co-expression block list */
        !            71: 
        !            72: word statsize = MaxStatSize;           /* size of static region */
        !            73: word statincr = MaxStatSize/4;         /* increment for static region */
        !            74: char *statbase;                                /* start of static space */
        !            75: char *statend;                         /* end of static space */
        !            76: char *statfree;                                /* static space free pointer */
        !            77: 
        !            78: word ssize = MaxStrSpace;              /* initial string space size (bytes) */
        !            79: char *strbase;                         /* start of string space */
        !            80: char *strend;                          /* end of string space */
        !            81: char *strfree;                         /* string space free pointer */
        !            82: char *currend;                         /* current end of memory region */
        !            83: 
        !            84: word abrsize = MaxAbrSize;             /* initial size of allocated block
        !            85:                                           region (bytes) */
        !            86: char *blkbase;                         /* start of block region */
        !            87: char *maxblk;                          /* end of allocated blocks */
        !            88: char *blkfree;                         /* block region free pointer */
        !            89: 
        !            90: uword statneed;                                /* stated need for static space */
        !            91: uword strneed;                         /* stated need for string space */
        !            92: uword blkneed;                         /* stated need for block space */
        !            93: 
        !            94: struct descrip **quallist;             /* string qualifier list */
        !            95: struct descrip **qualfree;             /* qualifier list free pointer */
        !            96: struct descrip **equallist;            /* end of qualifier list */
        !            97: 
        !            98: int dodump;                            /* if non-zero, core dump on error */
        !            99: int noerrbuf;                          /* if non-zero, do not buffer stderr */
        !           100: 
        !           101: struct descrip current;                        /* current expression stack pointer */
        !           102: struct descrip maps2;                  /* second cached argument of map */
        !           103: struct descrip maps3;                  /* third cached argument of map */
        !           104: 
        !           105: int ntended = 0;                       /* number of active tended descrips */
        !           106: long starttime;                                /* start time of job in milliseconds */
        !           107: 
        !           108: /*
        !           109:  * Next there are several structures for built-in values.  Parts of some
        !           110:  * of these structures are initialized later.
        !           111:  */
        !           112: 
        !           113: /*
        !           114:  * Built-in csets
        !           115:  */
        !           116: 
        !           117: /*
        !           118:  * &ascii; 128 bits on, second 128 bits off.
        !           119:  */
        !           120: struct b_cset  k_ascii = {
        !           121:    T_Cset,
        !           122:    128,
        !           123:    cset_display(~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0,
        !           124:                  0,  0,  0,  0,  0,  0,  0,  0)
        !           125:    };
        !           126: 
        !           127: /*
        !           128:  * &cset; all 256 bits on.
        !           129:  */
        !           130: struct b_cset  k_cset = {
        !           131:    T_Cset,
        !           132:    256,
        !           133:    cset_display(~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0,
        !           134:                 ~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0)
        !           135:    };
        !           136: 
        !           137: 
        !           138: 
        !           139: /*
        !           140:  * Cset for &lcase; bits corresponding to lowercase letters are on.
        !           141:  */
        !           142: struct b_cset  k_lcase = {
        !           143:    T_Cset,
        !           144:    26,
        !           145:    cset_display( 0,  0,  0,  0,  0,  0, ~01, 03777,
        !           146:                  0,  0,  0,  0,  0,  0,  0,  0)
        !           147:    };
        !           148: 
        !           149: /*
        !           150:  * &ucase; bits corresponding to uppercase characters are on.
        !           151:  */
        !           152: struct b_cset  k_ucase = {
        !           153:    T_Cset,
        !           154:    26,
        !           155:     cset_display(0,  0,  0,  0, ~01, 03777, 0, 0,
        !           156:                  0,  0,  0,  0,  0,  0,  0,  0)
        !           157:    };
        !           158: 
        !           159: /*
        !           160:  * Built-in files.
        !           161:  */
        !           162: 
        !           163: struct b_file  k_errout;               /* &errout */
        !           164: struct b_file  k_input;                        /* &input */
        !           165: struct b_file  k_output;               /* &outout */
        !           166: 
        !           167: /*
        !           168:  * Keyword trapped variables.
        !           169:  */
        !           170: 
        !           171: /*
        !           172:  * &pos.
        !           173:  */
        !           174: struct b_tvkywd tvky_pos = {
        !           175:    T_Tvkywd,
        !           176:    /* putpos, */
        !           177:    /* D_Integer, */
        !           178:    /* 1, */
        !           179:    /* 4, */
        !           180:    /* "&pos" */
        !           181:    };
        !           182: 
        !           183: /*
        !           184:  * &random.
        !           185:  */
        !           186: struct b_tvkywd tvky_ran = {
        !           187:    T_Tvkywd,
        !           188:    /* putran, */
        !           189:    /* D_Integer, */
        !           190:    /* 0, */
        !           191:    /* 7, */
        !           192:    /* "&random" */
        !           193:    };
        !           194: 
        !           195: /*
        !           196:  * &subject.
        !           197:  */
        !           198: struct b_tvkywd tvky_sub = {
        !           199:    T_Tvkywd,
        !           200:    /* putsub, */
        !           201:    /* 0, */
        !           202:    /* 0, */
        !           203:    /* 8, */
        !           204:    /* "&subject" */
        !           205:    };
        !           206: 
        !           207: /*
        !           208:  * &trace.
        !           209:  */
        !           210: struct b_tvkywd tvky_trc = {
        !           211:    T_Tvkywd,
        !           212:    /* puttrc, */
        !           213:    /* D_Integer, */
        !           214:    /* 0, */
        !           215:    /* 6, */
        !           216:    /* "&trace" */
        !           217:    };
        !           218: 
        !           219: /*
        !           220:  * Co-expression block header for &main.
        !           221:  */
        !           222: 
        !           223: static struct b_coexpr *mainhead;
        !           224: 
        !           225: #if IntSize == 16
        !           226: /*
        !           227:  * Long integer block for &random.
        !           228:  */
        !           229: struct b_int long_ran = {
        !           230:    T_Longint,
        !           231:    0L
        !           232:    };
        !           233: #endif IntSize == 16
        !           234: 
        !           235: /*
        !           236:  * Various constant descriptors.
        !           237:  */
        !           238: 
        !           239: struct descrip blank = {1, /*" "*/};
        !           240: struct descrip emptystr = {0, /*""*/};
        !           241: struct descrip errout = {D_File, /*&k_errout*/};
        !           242: struct descrip input = {D_File, /*&k_input*/};
        !           243: struct descrip lcase = {26, /*lowercase*/};
        !           244: struct descrip letr = {1, /*"r"*/};
        !           245: struct descrip nulldesc = {D_Null, /*0*/};
        !           246: struct descrip onedesc = {D_Integer, /*1*/};
        !           247: struct descrip ucase = {26, /*uppercase*/};
        !           248: struct descrip zerodesc = {D_Integer, /*0*/};
        !           249: 
        !           250: #ifdef RunStats
        !           251: #endif RunStats
        !           252: 
        !           253: /*
        !           254:  * init - initialize memory and prepare for Icon execution.
        !           255:  */
        !           256: 
        !           257: init(name)
        !           258: char *name;
        !           259:    {
        !           260:    register int i;
        !           261:    word cbread;
        !           262:    int f;
        !           263:    char c, *p;
        !           264:    struct descrip *dp;
        !           265:    struct header hdr;
        !           266: #ifndef MSDOS
        !           267:    struct tms tp;
        !           268:    extern char *brk(), *sbrk(), *index();
        !           269: #else MSDOS
        !           270: #ifdef LPTR
        !           271:    long longread();
        !           272: #endif LPTR
        !           273: #endif MSDOS
        !           274:    extern fpetrap(), segvtrap();
        !           275: 
        !           276:    /*
        !           277:     * Catch floating point traps and memory faults.
        !           278:     */
        !           279: #ifndef MSoft
        !           280:    signal(SIGFPE, fpetrap);
        !           281: #endif MSoft
        !           282: #ifndef MSDOS
        !           283: #ifdef PYRAMID
        !           284: {
        !           285:    struct sigvec a;
        !           286: 
        !           287:    a.sv_handler = fpetrap;
        !           288:    a.sv_mask = 0;
        !           289:    a.sv_onstack = 0;
        !           290:    sigvec(SIGFPE, &a, 0);
        !           291:    sigsetmask(1 << SIGFPE);
        !           292: }
        !           293: #else PYRAMID
        !           294:    signal(SIGFPE, fpetrap);
        !           295: #endif PYRAMID
        !           296: #endif MSDOS
        !           297: 
        !           298:    /*
        !           299:     * Initializations that cannot be performed statically (at least for
        !           300:     * some compilers).
        !           301:     */
        !           302: 
        !           303:    k_errout.title = T_File;
        !           304:    k_errout.fd = stderr;
        !           305:    k_errout.status = Fs_Write;
        !           306:    k_errout.fname.dword = 7;
        !           307:    StrLoc(k_errout.fname) = "&errout";
        !           308: 
        !           309:    k_input.title = T_File;
        !           310:    k_input.fd = stdin;
        !           311:    k_input.status = Fs_Read;
        !           312:    k_input.fname.dword = 6;
        !           313:    StrLoc(k_input.fname) = "&input";
        !           314: 
        !           315:    k_output.title = T_File;
        !           316:    k_output.fd = stdout;
        !           317:    k_output.status = Fs_Write;
        !           318:    k_output.fname.dword = 7;
        !           319:    StrLoc(k_output.fname) = "&output";
        !           320: 
        !           321:    tvky_pos.putval = putpos;
        !           322:    ((tvky_pos.kyval).dword) = D_Integer;
        !           323:    IntVal(tvky_pos.kyval) = 1;
        !           324:    StrLen(tvky_pos.kyname) = 4;
        !           325:    StrLoc(tvky_pos.kyname) = "&pos";
        !           326: 
        !           327:    tvky_ran.putval = putran;
        !           328: #if IntSize == 16
        !           329:    ((tvky_ran.kyval).dword) = D_Longint;
        !           330: #else IntSize == 16
        !           331:    ((tvky_ran.kyval).dword) = D_Integer;
        !           332: #endif IntSize == 16
        !           333:    StrLen(tvky_ran.kyname) = 7;
        !           334:    StrLoc(tvky_ran.kyname) = "&random";
        !           335: 
        !           336:    tvky_sub.putval = putsub;
        !           337:    StrLen(tvky_sub.kyval) = 0;
        !           338:    StrLen(tvky_sub.kyname) = 8;
        !           339:    StrLoc(tvky_sub.kyname) = "&subject";
        !           340: 
        !           341:    tvky_trc.putval = puttrc;
        !           342:    ((tvky_trc.kyval).dword) = D_Integer;
        !           343:    StrLen(tvky_trc.kyname) = 6;
        !           344:    StrLoc(tvky_trc.kyname) = "&trace";
        !           345: #if IntSize == 16
        !           346:    BlkLoc(tvky_ran.kyval) = (union block *) &long_ran;
        !           347: #else IntSize == 16
        !           348:    IntVal(tvky_ran.kyval) = 0;
        !           349: #endif IntSize == 16
        !           350:    IntVal(tvky_trc.kyval) = 0;
        !           351:    StrLoc(tvky_sub.kyval) = "";
        !           352: 
        !           353: 
        !           354:    StrLoc(k_subject) = "";
        !           355:    IntVal(nulldesc) = 0;
        !           356:    maps2 = nulldesc;
        !           357:    maps3 = nulldesc;
        !           358:    IntVal(zerodesc) = 0;
        !           359:    IntVal(onedesc) = 1;
        !           360:    StrLoc(emptystr) = "";
        !           361:    StrLoc(blank) = " ";
        !           362:    StrLoc(letr) = "r";
        !           363:    BlkLoc(input) = (union block *) &k_input;
        !           364:    BlkLoc(errout) = (union block *) &k_errout;
        !           365:    StrLoc(lcase) = "abcdefghijklmnopqrstuvwxyz";
        !           366:    StrLoc(ucase) = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
        !           367:    
        !           368:    /*
        !           369:     * Open the icode file and read the header.
        !           370:     */
        !           371:    i = strlen(name);
        !           372: #ifndef MSDOS
        !           373:    f = open(name, 0);
        !           374: #else MSDOS
        !           375: #ifdef LATTICE
        !           376:    f = open(name,O_RDONLY | O_RAW);
        !           377: #endif LATTICE
        !           378: #ifdef MSoft
        !           379:    f = open(name,O_RDONLY | O_BINARY);
        !           380: #endif MSoft
        !           381: #endif MSDOS
        !           382:    if (f < 0)
        !           383:       error("can't open interpreter file");
        !           384: #ifndef NoHeader
        !           385:    lseek(f, (long)MaxHeader, 0);
        !           386: #endif NoHeader
        !           387:    if (read(f, (char *)&hdr, sizeof(hdr)) != sizeof(hdr))
        !           388:       error("can't read interpreter file header");
        !           389:     
        !           390:    /*
        !           391:     * Establish pointers to data regions.
        !           392:     */
        !           393:    code = (char *)sbrk((word)0);
        !           394:    k_trace = hdr.trace;
        !           395:    records = (word *) (word)(code + hdr.records);
        !           396:    ftab = (word *) (word)(code + hdr.ftab);
        !           397:    globals = (struct descrip *) (code + hdr.globals);
        !           398:    gnames = eglobals = (struct descrip *) (code + hdr.gnames);
        !           399:    statics = egnames = (struct descrip *) (code + hdr.statics);
        !           400:    estatics = (struct descrip *) (code + hdr.ident);
        !           401:    ident = (char *) estatics;
        !           402: 
        !           403:    /*
        !           404:     * Examine the environment and make appropriate settings.
        !           405:     */
        !           406:    envlook();
        !           407: 
        !           408:    /*
        !           409:     * Convert stack sizes from words to bytes.
        !           410:     */
        !           411:    stksize *= WordSize;
        !           412:    mstksize *= WordSize;
        !           413:  
        !           414:    /*
        !           415:     * Set up allocated memory.  The regions are:
        !           416:     *
        !           417:     *  Static memory region
        !           418:     *  Allocated string region
        !           419:     *  Allocate block region
        !           420:     *  String qualifier list
        !           421:     */
        !           422:    /*
        !           423:     * Align bufs on a word boundary
        !           424:     */
        !           425:    bufs = (char **)((word)(code + hdr.hsize + 3) & ~03);
        !           426:    bufused = (FILE **) (bufs + numbufs);
        !           427:    statfree = statbase = (char *)(((word)(bufused + numbufs) + 63)  & ~077);
        !           428:    statend = statbase + mstksize + statsize;
        !           429:    strfree = strbase = (char *)((word)(statend + 63) & ~077);
        !           430:    blkfree = blkbase = strend = (char *)((word)(strbase + ssize + 63) & ~077);
        !           431:    quallist = qualfree = equallist =
        !           432:     (struct descrip **)(maxblk = (char *)((word)(blkbase + abrsize + 63) & ~077));
        !           433: 
        !           434:    /*
        !           435:     * Try to move the break back to the end of memory to allocate (the
        !           436:     *  end of the string qualifier list) and die if the space isn't
        !           437:     *  available.
        !           438:     */
        !           439:    if ((int)brk(equallist) == -1)
        !           440:       error("insufficient memory");
        !           441:    currend = sbrk(0);                  /* keep track of end of memory */
        !           442: 
        !           443:    /*
        !           444:     * Allocate stack and initialize &main.
        !           445:     */
        !           446:    stack = (word *)malloc(mstksize);
        !           447:    mainhead = (struct b_coexpr *)stack;
        !           448:    mainhead->title = T_Coexpr;
        !           449:    mainhead->activator.dword = D_Coexpr;
        !           450:    BlkLoc(mainhead->activator) = (union block *)mainhead;
        !           451:    mainhead->size = 0;
        !           452:    mainhead->freshblk = nulldesc;      /* &main has no refresh block. */
        !           453:                                        /*  This really is a bug. */
        !           454: 
        !           455:    /*
        !           456:     * Point &main at the stack for the main procedure and set current,
        !           457:     *  the pointer to the current co-expression to &main.
        !           458:     */
        !           459:    k_main.dword = D_Coexpr;
        !           460:    BlkLoc(k_main) = (union block *) mainhead;
        !           461:    current = k_main;
        !           462:    
        !           463:    /*
        !           464:     * Read the interpretable code and data into memory.
        !           465:     */
        !           466: #ifndef MSDOS
        !           467:    if ((cbread = read(f, code, hdr.hsize)) != hdr.hsize) {
        !           468: #else MSDOS
        !           469: #ifdef SPTR
        !           470:    if ((cbread = read(f, code, hdr.hsize)) != hdr.hsize) {
        !           471: #else /* Handle the case where hdr.hsize is long */
        !           472:    if ((cbread = longread(f, code, hdr.hsize)) != hdr.hsize) {
        !           473: #endif SPTR
        !           474: #endif MSDOS
        !           475:       fprintf(stderr,"Tried to read %ld bytes of code, and got %ld\n",
        !           476:        (long)hdr.hsize,(long)cbread);
        !           477:       error("can't read interpreter code");
        !           478:       }
        !           479:    close(f);
        !           480: 
        !           481: /*
        !           482:  * Make sure the version number of the icode matches the interpreter version.
        !           483:  */
        !           484: 
        !           485:    if (strcmp((char *)hdr.config,IVersion)) {
        !           486:       fprintf(stderr,"icode version mismatch\n");
        !           487:       fprintf(stderr,"\ticode version: %s\n",(char *)hdr.config);
        !           488:       fprintf(stderr,"\texpected version: %s\n",IVersion);
        !           489:       fflush(stderr);
        !           490:       if (dodump)
        !           491:          abort();
        !           492:       c_exit(ErrorExit);
        !           493:       }
        !           494: 
        !           495:    /*
        !           496:     * Resolve references from icode to runtime system.
        !           497:     */
        !           498:    resolve();
        !           499: 
        !           500:    /*
        !           501:     * Mark all buffers as available.
        !           502:     */
        !           503:    c = (char) NULL;
        !           504:    for (i = 0; i < numbufs; i++)
        !           505:       bufused[i] = (FILE *) c;
        !           506: 
        !           507:    /*
        !           508:     * Buffer stdin if a buffer is available.
        !           509:     */
        !           510: #ifndef VMS
        !           511:    if (numbufs >= 1) {
        !           512:       setbuf(stdin, bufs[0]);
        !           513:       bufused[0] = stdin;
        !           514:       }
        !           515:    else
        !           516:       setbuf(stdin, NULL);
        !           517: 
        !           518:    /*
        !           519:     * Buffer stdout if a buffer is available.
        !           520:     */
        !           521:    if (numbufs >= 2) {
        !           522:       setbuf(stdout, bufs[1]);
        !           523:       bufused[1] = stdout;
        !           524:       }
        !           525:    else
        !           526:       setbuf(stdout, NULL);
        !           527:    
        !           528:    /*
        !           529:     * Buffer stderr if a buffer is available.
        !           530:     */
        !           531:    if (numbufs >= 3 && !noerrbuf) {
        !           532:       setbuf(stderr, bufs[2]);
        !           533:       bufused[2] = stderr;
        !           534:       }
        !           535:    else
        !           536:       setbuf(stderr, NULL);
        !           537: #endif VMS
        !           538: 
        !           539:    /*
        !           540:     * Initialize memory monitoring if enabled.
        !           541:     */
        !           542:    MMInit();
        !           543: 
        !           544:    /*
        !           545:     * Get startup time.
        !           546:     */
        !           547: #ifndef MSDOS
        !           548:    times(&tp);
        !           549:    starttime = tp.tms_utime;
        !           550: #else MSDOS
        !           551:    time(&starttime);
        !           552: #endif MSDOS
        !           553:    }
        !           554: 
        !           555: /*
        !           556:  * Check for environment variables that Icon uses and set system
        !           557:  *  values as is appropriate.
        !           558:  */
        !           559: envlook()
        !           560:    {
        !           561:    register char *p;
        !           562:    extern char *getenv();
        !           563: 
        !           564:    if ((p = getenv("TRACE")) != NULL && *p != '\0')
        !           565:       k_trace = atoi(p);
        !           566:    if ((p = getenv("NBUFS")) != NULL && *p != '\0')
        !           567:       numbufs = atoi(p);
        !           568:    if ((p = getenv("COEXPSIZE")) != NULL && *p != '\0')
        !           569:       stksize = atoi(p);
        !           570:    if ((p = getenv("STRSIZE")) != NULL && *p != '\0')
        !           571:       ssize = atoi(p);
        !           572:    if ((p = getenv("HEAPSIZE")) != NULL && *p != '\0')
        !           573:       abrsize = atoi(p);
        !           574:    if ((p = getenv("STATSIZE")) != NULL && *p != '\0')
        !           575:       statsize = atoi(p);
        !           576:    if ((p = getenv("STATINCR")) != NULL && *p != '\0')
        !           577:       statincr = atoi(p);
        !           578:    if ((p = getenv("MSTKSIZE")) != NULL && *p != '\0')
        !           579:       mstksize = atoi(p);
        !           580:    if ((p = getenv("ICONCORE")) != NULL && *p != '\0') {
        !           581: #ifndef MSoft
        !           582:       signal(SIGFPE, SIG_DFL);
        !           583: #endif MSoft
        !           584: #ifndef MSDOS
        !           585:       signal(SIGSEGV, SIG_DFL);
        !           586: #endif MSDOS
        !           587:       dodump++;
        !           588:       }
        !           589:    if ((p = getenv("NOERRBUF")) != NULL)
        !           590:       noerrbuf++;
        !           591:    }
        !           592: 
        !           593: /*
        !           594:  * Produce run-time error 204 on floating point traps.
        !           595:  */
        !           596: #ifdef PYRAMID
        !           597: fpetrap(code, subcode, sp)
        !           598: int code, subcode, sp;
        !           599:    {
        !           600:    runerr(subcode == FPE_wordOVF_EXC ? 203 : 204, NULL);
        !           601:    }
        !           602: #else PYRAMID
        !           603: fpetrap()
        !           604:    {
        !           605:    runerr(204, NULL);
        !           606:    }
        !           607: #endif PYRAMID
        !           608: 
        !           609: /*
        !           610:  * Produce run-time error 302 on segmentation faults.
        !           611:  */
        !           612: segvtrap()
        !           613:    {
        !           614:    runerr(302, NULL);
        !           615:    }
        !           616: 
        !           617: /*
        !           618:  * error - print error message s; used only in startup code.
        !           619:  */
        !           620: error(s)
        !           621: char *s;
        !           622:    {
        !           623:    fprintf(stderr, "error in startup code\n%s\n", s);
        !           624:    fflush(stderr);
        !           625:    if (dodump)
        !           626:       abort();
        !           627:    c_exit(ErrorExit);
        !           628:    }
        !           629: 
        !           630: /*
        !           631:  * syserr - print s as a system error.
        !           632:  */
        !           633: syserr(s)
        !           634: char *s;
        !           635:    {
        !           636:    struct b_proc *bp;
        !           637: 
        !           638:    bp = (struct b_proc *)BlkLoc(argp[0]);
        !           639:    if (line > 0)
        !           640:       fprintf(stderr, "System error at line %ld in %s\n%s\n", (long)line,
        !           641:          bp->filename, s);
        !           642:    else
        !           643:       fprintf(stderr, "System error in startup code\n%s\n", s);
        !           644:    fflush(stderr);
        !           645:    if (dodump)
        !           646:       abort();
        !           647:    c_exit(ErrorExit);
        !           648:    }
        !           649: 
        !           650: /*
        !           651:  * errtab maps run-time error numbers into messages.
        !           652:  */
        !           653: struct errtab {
        !           654:    int errno;
        !           655:    char *errmsg;
        !           656:    } errtab[] = {
        !           657:    101, "integer expected",
        !           658:    102, "numeric expected",
        !           659:    103, "string expected",
        !           660:    104, "cset expected",
        !           661:    105, "file expected",
        !           662:    106, "procedure or integer expected",
        !           663:    107, "record expected",
        !           664:    108, "list expected",
        !           665:    109, "string or file expected",
        !           666:    110, "string or list expected",
        !           667:    111, "variable expected",
        !           668:    112, "invalid type to size operation",
        !           669:    113, "invalid type to random operation",
        !           670:    114, "invalid type to subscript operation",
        !           671:    115, "list or table expected",
        !           672:    116, "invalid type to element generator",
        !           673:    117, "missing main procedure",
        !           674:    118, "co-expression expected",
        !           675:    119, "set expected",
        !           676: 
        !           677:    201, "division by zero",
        !           678:    202, "remaindering by zero",
        !           679:    203, "integer overflow",
        !           680:    204, "real overflow, underflow, or division by zero",
        !           681:    205, "value out of range",
        !           682:    206, "negative first operand to real exponentiation",
        !           683:    207, "invalid field name",
        !           684:    208, "second and third arguments to map of unequal length",
        !           685:    209, "invalid second argument to open",
        !           686:    210, "argument to system function too long",
        !           687:    211, "by clause equal to zero",
        !           688:    212, "attempt to read file not open for reading",
        !           689:    213, "attempt to write file not open for writing",
        !           690:    214, "recursive co-expression activation",
        !           691: 
        !           692:    301, "interpreter stack overflow",
        !           693:    302, "C stack overflow",
        !           694:    303, "unable to expand memory region",
        !           695:    304, "memory region size changed",
        !           696: 
        !           697:    0,   0
        !           698:    };
        !           699: 
        !           700: /*
        !           701:  * runerr - print message corresponding to error n and if v is nonnull,
        !           702:  *  print it as the offending value.
        !           703:  */
        !           704: #ifdef PCIX
        !           705: /*
        !           706:  * For PC/IX, runerr is an assembly language routine that jumps into this
        !           707:  * xruner procedure past the call to csv which occurs at the beginning of
        !           708:  * all C procedures. This is necessary to defeat the stack data collision
        !           709:  * testing which is done in csv in pc/ix and which would cause a loop,
        !           710:  * since one of the possible reasons for calling runerr in the first place
        !           711:  * might be stack/data collision.
        !           712:  */
        !           713: xruner(n, v)
        !           714: #else PCIX
        !           715: runerr(n, v)
        !           716: #endif PCIX
        !           717: register int n;
        !           718: struct descrip *v;
        !           719:    {
        !           720:    register struct errtab *p;
        !           721:    struct b_proc *bp;
        !           722: 
        !           723:    if (line > 0) {
        !           724:       bp = (struct b_proc *)BlkLoc(argp[0]);
        !           725:       fprintf(stderr, "Run-time error %d at line %ld in %s\n", n,
        !           726:          (long)line, bp->filename);
        !           727:       }
        !           728:    else
        !           729:       fprintf(stderr, "Run-time error %d in startup code\n", n);
        !           730:    for (p = errtab; p->errno > 0; p++)
        !           731:       if (p->errno == n) {
        !           732:          fprintf(stderr, "%s\n", p->errmsg);
        !           733:          break;
        !           734:          }
        !           735:    if (v != NULL) {
        !           736:       fprintf(stderr, "offending value: ");
        !           737:       outimage(stderr, v, 0);
        !           738:       putc('\n', stderr);
        !           739:       }
        !           740:    fflush(stderr);
        !           741:    if (dodump)
        !           742:       abort();
        !           743:    c_exit(ErrorExit);
        !           744:    }
        !           745: 
        !           746: /*
        !           747:  * resolve - perform various fixups on the data read from the interpretable
        !           748:  *  file.
        !           749:  */
        !           750: resolve()
        !           751:    {
        !           752:    register word i;
        !           753:    register struct b_proc *pp;
        !           754:    register struct descrip *dp;
        !           755:    extern mkrec();
        !           756:    extern struct b_proc *functab[];
        !           757: 
        !           758:    /*
        !           759:     * Scan the global variable list for procedures and fill in appropriate
        !           760:     *  addresses.
        !           761:     */
        !           762:    for (dp = globals; dp < eglobals; dp++) {
        !           763:       if ((*dp).dword != D_Proc)
        !           764:          continue;
        !           765:       /*
        !           766:        * The second word of the descriptor for procedure variables tells
        !           767:        *  where the procedure is.  Negative values are used for built-in
        !           768:        *  procedures and positive values are used for Icon procedures.
        !           769:        */
        !           770:       i = IntVal(*dp);
        !           771:       if (i < 0) {
        !           772:          /*
        !           773:           * *dp names a built-in function, negate i and use it as an index
        !           774:           *  into functab to get the location of the procedure block.
        !           775:           */
        !           776:          BlkLoc(*dp) = (union block *) functab[-i-1];
        !           777:          }
        !           778:       else {
        !           779:          /*
        !           780:           * *dp names an Icon procedure or a record.  i is an offset to
        !           781:           *  location of the procedure block in the code section.  Point
        !           782:           *  pp at the block and replace BlkLoc(*dp).
        !           783:           */
        !           784:          pp = (struct b_proc *) (code + i);
        !           785:          BlkLoc(*dp) = (union block *) pp;
        !           786:          /*
        !           787:           * Relocate the address of the name of the procedure.
        !           788:           */
        !           789:          StrLoc(pp->pname) += (word)ident;
        !           790:          if (pp->ndynam == -2)
        !           791:             /*
        !           792:              * This procedure is a record constructor.  Make its entry point
        !           793:              *  be the entry point of mkrec().
        !           794:              */
        !           795:             pp->entryp.ccode = mkrec;
        !           796:          else {
        !           797:             /*
        !           798:              * This is an Icon procedure.  Relocate the entry point and
        !           799:              *  the names of the parameters, locals, and static variables.
        !           800:              */
        !           801:             pp->entryp.icode = code + (word)pp->entryp.icode;
        !           802:             if (pp->ndynam >= 0)
        !           803:                pp->filename += (word)ident;
        !           804:             for (i = 0; i < pp->nparam+pp->ndynam+pp->nstatic; i++)
        !           805:                StrLoc(pp->lnames[i]) += (word)ident;
        !           806:             }
        !           807:          }
        !           808:       }
        !           809:    /*
        !           810:     * Relocate the names of the global variables.
        !           811:     */
        !           812:    for (dp = gnames; dp < egnames; dp++)
        !           813:       StrLoc(*dp) += (word)ident;
        !           814:    }
        !           815: 
        !           816: 
        !           817: /*
        !           818:  * c_exit(i) - flush all buffers and exit with status i.
        !           819:  */
        !           820: c_exit(i)
        !           821: int i;
        !           822: {
        !           823:        int j;
        !           824: 
        !           825: #ifdef MemMon
        !           826:        MMTerm();
        !           827: #endif MemMon
        !           828:        if (tallyopt) {
        !           829:                fprintf(stderr,"tallies: ");
        !           830:                for (j=0; j<16; j++)
        !           831:                        fprintf(stderr," %ld", (long)tallybin[j]);
        !           832:                fprintf(stderr,"\n");
        !           833:        }
        !           834:        exit(i);
        !           835: }
        !           836: 
        !           837: err()
        !           838: {
        !           839:    syserr("call to 'err'\n");
        !           840: }
        !           841: 
        !           842: #ifdef MSDOS
        !           843: #ifdef LPTR
        !           844: /* Write a long string in 32k chunks */
        !           845: long longread(file,s,len)
        !           846: int file;
        !           847: char *s;
        !           848: long int len;
        !           849: {
        !           850:    long int loopnum;
        !           851:    long int leftover;
        !           852:    long int tally;
        !           853:    unsigned i;
        !           854:    char *p;
        !           855: 
        !           856:    tally = 0;
        !           857:    leftover = len % 32768;
        !           858:    for(p = s, loopnum = len/32768;loopnum;loopnum--) {
        !           859:        i = read(file,p,32768);
        !           860:        tally += i;
        !           861:        if (i != 32768) return tally;
        !           862:        p += 32768;
        !           863:    }
        !           864:    if(leftover) tally += read(file,p,leftover);
        !           865:    return tally;
        !           866: }
        !           867: #endif LPTR
        !           868: #endif MSDOS

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.