/* * Routines needed for different systems. */ #include #include "..\h\config.h" #include "..\h\rt.h" #include "rproto.h" #include /* * The following code is operating-system dependent [@rlocal.01]. * Routines needed by different systems. */ #if PORT /* place for anything system-specific */ Deliberate Syntax Error #endif /* PORT */ #if AMIGA #if AZTEC_C /* * abs */ abs(i) int i; { return ((i<0)? (-i) : i); } /* * ldexp */ double ldexp(value,exp) double value; { double retval = 1.0; if(exp>0) { while(exp-->0) retval *= 2.0; } else if (exp<0) { while(exp++<0) retval = retval / 2.0; } return value * retval; } /* * abort() */ novalue abort() { fprintf(stderr,"ICON ERROR WITH ICONCORE SET\n"); fflush(stderr); exit(1); } #ifdef SystemFnc /* * Aztec C version 3.6 does not support system(), but here is a substitute. * This is a bonafide untested-original-it-just-compiles routine. * Manx will probably implement system() before we fix this version... */ #include #define KLUDGE1 256 #define KLUDGE2 64 int system(s) char *s; { char text[KLUDGE1], *cp=text; char **av[KLUDGE2]; int ac = 0; int l = strlen(s); if (l >= KLUDGE1) return -1; strcpy(text,s); av[ac++] = text; while(*cp && ac /* Structure necessary for handling system time. */ struct tm { short tm_year; short tm_mon; short tm_wday; short tm_mday; short tm_hour; short tm_min; short tm_sec; }; struct tm *localtime(clock) /* fill structure with clock time */ int clock; /* millisecond timer value, if supplied; not used */ { static struct tm tv; unsigned int time, date; time = Tgettime(); date = Tgetdate(); tv.tm_year = ((date >> 9) & 0x7f) + 80; tv.tm_mon = ((date >> 5) & 0xf) - 1; tv.tm_mday = date & 0x1f; tv.tm_hour = (time >> 11) & 0x1f; tv.tm_min = (time >> 5) & 0x3f; tv.tm_sec = 2 * (time & 0x1f); tv.tm_wday = weekday(tv.tm_mday,tv.tm_mon+1,tv.tm_year); return(&tv); } weekday(day,month,year) /* find day of week from */ short day, month, year; /* day, month, and year */ { /* Sunday..Saturday is 0..6 */ int index, yrndx, mondx; if(month <= 2) { /* Jan or Feb month adjust */ month += 12; year -= 1; } yrndx = year + (year / 4) - (year / 100) + (year / 400); mondx = 2 * month + (3 * (month + 1)) / 5; index = day + mondx + yrndx + 2; return(index % 7); } time(ptime) /* return value of millisecond timer */ int *ptime; { int tmp, ssp; /* value of supervisor stack pointer */ static int *tmr = (int *) 0x04ba; /* addr of timer */ ssp = gemdos(0x20,0); /* enter supervisor mode */ tmp = *tmr * 5; /* get millisecond timer */ ssp = gemdos(0x20,ssp); /* enter programmer mode */ if(ptime != NULL) *ptime = tmp; return(tmp); } int brk(p) char *p; { char *sbrk(); long int l, m; l = (long int)p; m = (long int)sbrk(0); return((lsbrk((long) (l - m)) == 0) ? -1 : 0); } #ifdef LocalQsort /* Shell sort with some enhancements from Knuth.. */ void qsort( base, nel, width, cmp ) /* was llqsort( ... */ char *base; /*-also kqsort( ...-*/ int nel; int width; int (*cmp)(); { register int i, j; long int gap; int k, tmp ; char *p1, *p2; for( gap=1; gap <= nel; gap = 3*gap + 1 ) ; for( gap /= 3; gap > 0 ; gap /= 3 ) for( i = gap; i < nel; i++ ) for( j = i-gap; j >= 0 ; j -= gap ) { p1 = base + ( j * width); p2 = base + ((j+gap) * width); if( (*cmp)( p1, p2 ) <= 0 ) break; for( k = width; --k >= 0 ;) { tmp = *p1; *p1++ = *p2; *p2++ = tmp; } } } #endif /* LocalQsort */ #endif /* LATTICE */ #endif /* ATARI_ST */ #if HIGHC_386 #endif /* HIGHC_386 */ #if MACINTOSH #if MPW /* ** Special routines for Macintosh Programmer's Workshop ** implementation of the Icon Programming Language */ #include #include #include #define MaxBlockX MaxBlock /* MaxBlock Icon definition conflicts */ #undef MaxBlock /* with Mac Toolbox routine */ #include #define MaxBlock MaxBlockX #undef MaxBlockX #include /* ** Initialization and Termination Routines */ /* ** MacExit -- This function is installed by an onexit() call in MacInit ** -- it is called automatically when the program terminates. */ void MacExit() { void ResetStack(); extern Ptr MemBlock; ResetStack(); if (MemBlock != NULL) DisposPtr(MemBlock); } /* ** MacInit -- This function is called near the beginning of execution of ** iconx. It is called by our own brk/sbrk initialization routine. */ void MacInit() { atexit(MacExit); } /* ** Brk and Sbrk Equivalents */ typedef Ptr caddr_t; static caddr_t MemBlock, Break, Limit; word xcodesize; init_brk() { static short init = 0; Size max, grow, size; char *v; extern word mstksize, statsize, ssize, abrsize; if (!init) { init = 1; MacInit(); if ((v = getenv("ICONSIZE")) != NULL) { /* if ICONSIZE defined */ if ((size = atol(v)) <= 0) { /* if ICONSIZE negative */ max = MaxMem(&grow); size = max + grow - (size < 0 ? -size : max / 4); } } else { /* if ICONSIZE undefined */ size = xcodesize + mstksize + statsize + ssize + abrsize + 512; } if ((MemBlock = NewPtr(size)) == NULL) { syserr("problem allocating Mac memory"); } Break = MemBlock; Limit = MemBlock + size; } return 1; } caddr_t brk(addr) caddr_t addr; { Size newsize; if (!init_brk()) return (caddr_t)-1; if (addr < MemBlock) return (caddr_t)-1; if (addr < Limit) Break = addr; else { newsize = addr - MemBlock; SetPtrSize(MemBlock, newsize); if (MemError() != noErr) return (caddr_t)-1; Break = Limit = addr; } return (caddr_t)0; } caddr_t sbrk(incr) int incr; { caddr_t start; if (!init_brk()) return (caddr_t)-1; start = Break; if (incr != 0) { if (brk(start + incr) == (caddr_t)-1) return (caddr_t)-1; } return start; } #endif /* MPW */ #endif /* MACINTOSH */ #if MSDOS #if TURBO extern unsigned _stklen = 8 * 1024; #endif /* TURBO */ #if LATTICE #include int _stack = (8 * 1024); long int _mneed = (20 * 1024); extern long int *sp; long int **xsp = &sp; /* Used for rswitch.asm .. since 'sp' is a reserved */ /* symbol for the assembler.. */ extern char *statend; /* Indicator for when to use malloc for _GETBF */ int brk(p) char *p; { char *sbrk(); long int l, m; l = (long int)p; m = (long int)sbrk((word)0); if( lsbrk((long) (l - m) ) == 0) return -1; else return 0; } novalue abort() /* Abort set to 'dump' icon data area.. */ { #ifdef DeBugIconx blkdump(); #endif /* DeBugIconx */ fflush(stderr); fcloseall(); _exit(1); } #endif /* LATTICE */ #endif /* MSDOS */ #if MVS || VM #if SASC #include char _linkage = _OPTIMIZE; #if MVS char *_style = "tso:"; /* use dsnames as file names */ #define SYS_OSVS #else /* MVS */ #define SYS_CMS #endif /* MVS */ int _mneed = 512000; /* size of sbrk-managed region */ #define RES_SIGNAL #define RES_COPROC #define RES_IOUTIL #define RES_DSNAME #define RES_FILEDEF #define RES_UNITREC #if VM #define BIMODAL_CMS #endif /* VM */ #include #endif /* SASC */ #ifdef WATERLOO_C_V3_0 const int _staksize = (64*1024); #endif /* WATERLOO_C_V3_0 */ #endif /* MVS || VM */ #if OS2 #endif /* OS2 */ #if UNIX #ifdef ATTM32 /* * This file contains the routine necessary to allocate legal AT&T * 3B2/15/4000 stack space for co-expression stacks. * * Legal stack region begins at 0xC0020000, and UNIX will grow stack space * up to 50 Megabytes. 0xC0030000 should provide plenty of room for * main C stack growth. Each time coexpr_salloc() is called, it * adds mstksize (max main stack size) and returns a new address, * meaning each coexpression stack is potentially as large as the main stack. */ /* * coexp_salloc() - return pointer in legal stack space for start * of a coexpression stack. */ pointer coexp_salloc() { static pointer sp = 0xC0030000 ; /* pointer to stack region */ sp += mstksize; return sp; } #endif /* ATTM32 */ #if CONVEX /* replacement pow() that allows negative ** integer */ #undef pow double pow0 (base, exp) double base, exp; { if (base >= 0) return pow (base, exp); else { long n = exp; if (n != exp) runerr (-206, 0); else if (n & 1) return -pow (-base, exp); else return pow (-base, exp);}} #endif /* CONVEX */ #endif /* UNIX */ #if VMS #include dvidef #include iodef typedef struct _descr { int length; char *ptr; } descriptor; typedef struct _pipe { long pid; /* process id of child */ long status; /* exit status of child */ long flags; /* LIB$SPAWN flags */ int channel; /* MBX channel number */ int efn; /* Event flag to wait for */ char mode; /* the open mode */ FILE *fptr; /* file pointer (for fun) */ unsigned running : 1; /* 1 if child is running */ } Pipe; Pipe _pipes[_NFILE]; /* one for every open file */ #define NOWAIT 1 #define NOCLISYM 2 #define NOLOGNAM 4 #define NOKEYPAD 8 #define NOTIFY 16 #define NOCONTROL 32 #define SFLAGS (NOWAIT|NOKEYPAD|NOCONTROL) /* * popen - open a pipe command * Last modified 2-Apr-86/chj * * popen("command", mode) */ FILE *popen(cmd, mode) char *cmd; char *mode; { FILE *pfile; /* the Pfile */ Pipe *pd; /* _pipe database */ descriptor mbxname; /* name of mailbox */ descriptor command; /* command string descriptor */ descriptor nl; /* null device descriptor */ char mname[65]; /* mailbox name string */ int chan; /* mailbox channel number */ int status; /* system service status */ int efn; struct { short len; short code; char *address; char *retlen; int last; } itmlst; if (!cmd || !mode) return (0); LIB$GET_EF(&efn); if (efn == -1) return (0); if (_tolower(mode[0]) != 'r' && _tolower(mode[0]) != 'w') return (0); /* create and open the mailbox */ status = SYS$CREMBX(0, &chan, 0, 0, 0, 0, 0); if (!(status & 1)) { LIB$FREE_EF(&efn); return (0); } itmlst.last = mbxname.length = 0; itmlst.address = mbxname.ptr = mname; itmlst.retlen = &mbxname.length; itmlst.code = DVI$_DEVNAM; itmlst.len = 64; status = SYS$GETDVIW(0, chan, 0, &itmlst, 0, 0, 0, 0); if (!(status & 1)) { LIB$FREE_EF(&efn); return (0); } mname[mbxname.length] = '\0'; pfile = fopen(mname, mode); if (!pfile) { LIB$FREE_EF(&efn); SYS$DASSGN(chan); return (0); } /* Save file information now */ pd = &_pipes[fileno(pfile)]; /* get Pipe pointer */ pd->mode = _tolower(mode[0]); pd->fptr = pfile; pd->pid = pd->status = pd->running = 0; pd->flags = SFLAGS; pd->channel = chan; pd->efn = efn; /* fork the command */ nl.length = strlen("_NL:"); nl.ptr = "_NL:"; command.length = strlen(cmd); command.ptr = cmd; status = LIB$SPAWN(&command, (pd->mode == 'r') ? 0 : &mbxname, /* input file */ (pd->mode == 'r') ? &mbxname : 0, /* output file */ &pd->flags, 0, &pd->pid, &pd->status, &pd->efn, 0, 0, 0, 0); if (!(status & 1)) { LIB$FREE_EF(&efn); SYS$DASSGN(chan); return (0); } else { pd->running = 1; } return (pfile); } /* * pclose - close a pipe * Last modified 2-Apr-86/chj * */ pclose(pfile) FILE *pfile; { Pipe *pd; int status; int fstatus; pd = fileno(pfile) ? &_pipes[fileno(pfile)] : 0; if (pd == NULL) return (-1); fflush(pd->fptr); /* flush buffers */ fstatus = fclose(pfile); if (pd->mode == 'w') { status = SYS$QIOW(0, pd->channel, IO$_WRITEOF, 0, 0, 0, 0, 0, 0, 0, 0, 0); SYS$WFLOR(pd->efn, 1 << (pd->efn % 32)); } SYS$DASSGN(pd->channel); LIB$FREE_EF(&pd->efn); pd->running = 0; return (fstatus); } /* * redirect(&argc,argv,nfargs) - redirect standard I/O * int *argc number of command arguments (from call to main) * char *argv[] command argument list (from call to main) * int nfargs number of filename arguments to process * * argc and argv will be adjusted by redirect. * * redirect processes a program's command argument list and handles redirection * of stdin, and stdout. Any arguments which redirect I/O are removed from the * argument list, and argc is adjusted accordingly. redirect would typically be * called as the first statement in the main program. * * Files are redirected based on syntax or position of command arguments. * Arguments of the following forms always redirect a file: * * file redirects standard output to write to the given file * >>file redirects standard output to append to the given file * * It is often useful to allow alternate input and output files as the * first two command arguments without requiring the file * syntax. If the nfargs argument to redirect is 2 or more then the * first two command arguments, if supplied, will be interpreted in this * manner: the first argument replaces stdin and the second stdout. * A filename of "-" may be specified to occupy a position without * performing any redirection. * * If nfargs is 1, only the first argument will be considered and will * replace standard input if given. Any arguments processed by setting * nfargs > 0 will be removed from the argument list, and again argc will * be adjusted. Positional redirection follows syntax-specified * redirection and therefore overrides it. * */ redirect(argc,argv,nfargs) int *argc, nfargs; char *argv[]; { int i; i = 1; while (i < *argc) { /* for every command argument... */ switch (argv[i][0]) { /* check first character */ case '<': /* ': /* >file or >>file redirects stdout */ if (argv[i][1] == '>') filearg(argc,argv,i,2,stdout,"a"); else filearg(argc,argv,i,1,stdout,"w"); break; default: /* not recognized, go on to next arg */ i++; } } if (nfargs >= 1 && *argc > 1) /* if positional redirection & 1 arg */ filearg(argc,argv,1,0,stdin,"r"); /* then redirect stdin */ if (nfargs >= 2 && *argc > 1) /* likewise for 2nd arg if wanted */ filearg(argc,argv,1,0,stdout,"w");/* redirect stdout */ } /* filearg(&argc,argv,n,i,fp,mode) - redirect and remove file argument * int *argc number of command arguments (from call to main) * char *argv[] command argument list (from call to main) * int n argv entry to use as file name and then delete * int i first character of file name to use (skip '<' etc.) * FILE *fp file pointer for file to reopen (typically stdin etc.) * char mode[] file access mode (see freopen spec) */ filearg(argc,argv,n,i,fp,mode) int *argc, n, i; char *argv[], mode[]; FILE *fp; { if (strcmp(argv[n]+i,"-")) /* alter file if arg not "-" */ fp = freopen(argv[n]+i,mode,fp); if (fp == NULL) { /* abort on error */ fprintf(stderr,"%%can't open %s",argv[n]+i); exit(ErrorExit); } for ( ; n < *argc; n++) /* move down following arguments */ argv[n] = argv[n+1]; *argc = *argc - 1; /* decrement argument count */ } /* Special versions of sbrk() and brk() for use by Icon under VMS. * #defines in define.h actually rename these to vms_brk and vms_sbrk. * * For historical reasons, Icon assumes it can repeatedly call brk/sbrk * and always get contiguous chunks. This was made to work under Unix by * overloading the definitions of malloc and friends, the only other callers * of sbrk, and making them return Icon-managed memory. * Under VMS, sbrk is not the lowest-level system interface. It gets memory * from underlying VMS routines such as SYS$EXPREG. These routines are also * called by others, for example when a file is opened; so successive sbrk * calls may return nonadjacent chunks. This makes overloading malloc and * friends futile. * * The routines below replace sbrk and brk for Icon (only) under VMS. They * provide the continuously growing memory Icon needs without relying on * special privileges or unusually large quotas. Like the Unix solution and * earlier VMS attempts, this is an empirical solution and may need further * revision as the system changes. But we hope not. * * The Icon interpreter is loaded beginning at address 0 and grows upward as * it requests more memory through sbrk. The C stack grows downward from * 0x7FFFFFFF. We're going to draw a line to divide the address space, then * force the C and VMS runtime systems to put anything they need above it; * then sbrk can grow the program region unimpeded up to the line. * * The line is drawn MAXMEM bytes beyond the start of the sbrk region. MAXMEM * is an environment variable (logical name to VMS) with a default as given in * define.h. Large values cost CPU and real time expended at process exit; we * don't know why. On an 8600 the cost was very roughly .04 CP sec / megabyte. * * When first called, sbrk expands the program region by one page to get a * starting address. A limit address is calculated by adding MAXMEM. A single * page created just below the limit address "draws the line" and causes the * VMS runtime system to allocate anything it needs above that point. sbrk * creates pages between base and limit as needed. * * Possible errors and their manifestations: * * MAXMEM too large to initialize sbrk: * error in startup code: value of MAXMEM too large * * MAXMEM too small to initialize sbrk: * error in startup code: value of MAXMEM too small * * MAXMEM too small for subsequent brk/sbrk growth * Run-time error 351: insufficient MAXMEM limit * * MAXMEM okay but insufficient user quota for needed memory: * Run-time error 303: unable to expand memory region * * unexpected ("can't happen") failures of system calls: * these produce their standard VMS error message * * unexpected intrusion into the sbrk region by the runtime system: * unknown, but undoubtedly ugly */ #define PageSize 512 /* size of a VMS page */ #define MaxP0 0x40000000 /* first address beyond the P0 region */ #include word memsize = MaxMem; /* set from environment variable MAXMEM */ /* sbrk(incr) - adjust the break value by incr, rounding up to a page. * returns the new break value, or -1 if unsuccessful. */ char * sbrk(incr) int incr; { static char *base; /* base of the sbrk region */ static char *curr; /* current break value (end+1) */ static char *limit; /* region limit ("the line") */ char *range[2], *p; /* scratch for system calls */ int s; /* status return from calls */ /* initialization code */ if (!base) { s = sys$expreg(1,range,0,0); /* expand P0 to get base address */ if (!(s & STS$M_SUCCESS)) exit(s); /* couldn't get one page?! */ base = curr = range[0]; /* initialize empty sbrk region */ memsize = (memsize + PageSize - 1) & -PageSize; /* round memsize to page boundary */ limit = base + memsize; /* calculate sbrk region limit*/ if (limit > MaxP0) limit = MaxP0; /* limit to legal values */ if (limit <= base) error("value of MAXMEM too small"); /* can't even start */ range[0] = range[1] = limit-1; s = sys$cretva(range,range,0); /* get a page there to draw the line */ if (!(s & STS$M_SUCCESS)) error("value of MAXMEM too large"); /* can't even start */ } if (incr > 0) { /* grow the region */ if (curr + incr > limit) /* check address space available */ fatalerr(-351,NULL); /* oops, MAXMEM too small */ range[0] = curr; range[1] = curr + incr - 1; s = sys$cretva(range,range,0); /* ask for the pages */ if (!(s & STS$M_SUCCESS)) return (char *) -1; /* failed, quota exceeded */ curr = range[1] + 1; /* set new break value as returned */ } else if (incr < 0) { /* shrink the region (not expected to be used). does not actually * return the memory, but does make it available for reuse. */ curr -= -incr & -PageSize; } /* return the current break value */ return curr; } /* brk(addr) - set the break address to the given value, rounded up to a page. * returns 0 if successful, -1 if not. */ char * brk(addr) char *addr; { return ((sbrk(addr-sbrk(0))) == (char *) -1 ? (char *) -1 : 0); } #endif /* VMS */ /* * End of operating-system specific code. */ static char x; /* avoid empty module */