
RLOCAL                                                           8-APR-1988 17:40:02    VAX C      V2.3-024                 Page 1
V1.0                                                            18-JAN-1988 09:58:46    LTSIG2:[ICON.V7.SRC.ICONX]RLOCAL.C;1 (1)



    1        	/*
    2        	 * rlocal.c - special runtime functions for the VMS version of Icon
    3        	 */
    4        	
    5        	#include "../h/config.h"
  205        	#include <stdio.h>
  263        	#include <ctype.h>
  296        	#include dvidef
  500        	#include iodef
  885        	
  886        	typedef struct _descr {
  887        	   int length;
  888        	   char *ptr;
  889        	} descriptor;
  890        	
  891        	typedef struct _pipe {
  892        	   long pid;			/* process id of child */
  893        	   long status;			/* exit status of child */
  894        	   long flags;			/* LIB$SPAWN flags */
  895        	   int channel;			/* MBX channel number */
  896        	   int efn;			/* Event flag to wait for */
  897        	   char mode;			/* the open mode */
  898        	   FILE *fptr;			/* file pointer (for fun) */
  899        	   unsigned running : 1;	/* 1 if child is running */
  900        	} Pipe;
  901        	
  902        	Pipe _pipes[_NFILE];		/* one for every open file */
  903        	
  904        	#define NOWAIT		1
  905        	#define NOCLISYM	2
  906        	#define NOLOGNAM	4
  907        	#define NOKEYPAD	8
  908        	#define NOTIFY		16
  909        	#define NOCONTROL	32
  910        	#define SFLAGS	(NOWAIT|NOKEYPAD|NOCONTROL)
  911        	

RLOCAL                                                           8-APR-1988 17:40:02    VAX C      V2.3-024                 Page 2
V1.0                                                            18-JAN-1988 09:58:46    LTSIG2:[ICON.V7.SRC.ICONX]RLOCAL.C;1 (2)

             	
  912        	/*
  913        	 * popen - open a pipe command
  914        	 * Last modified 2-Apr-86/chj
  915        	 *
  916        	 *	popen("command", mode)
  917        	 */
  918        	
  919        	FILE *popen(cmd, mode)
  920        	char *cmd;
  921        	char *mode;
  922        	{
  923    1   	   FILE *pfile;			/* the Pfile */
  924    1   	   Pipe *pd;			/* _pipe database */
  925    1   	   descriptor mbxname;		/* name of mailbox */
  926    1   	   descriptor command;		/* command string descriptor */
  927    1   	   descriptor nl;		/* null device descriptor */
  928    1   	   char mname[65];		/* mailbox name string */
  929    1   	   int chan;			/* mailbox channel number */
  930    1   	   int status;			/* system service status */
  931    1   	   int efn;
  932    1   	   struct {
  933    1   	      short len;
  934    1   	      short code;
  935    1   	      char *address;
  936    1   	      char *retlen;
  937    1   	      int last;
  938    1   	   } itmlst;
  939    1   	
  940    1   	   if (!cmd || !mode)
  941    1   	      return (0);
  942    1   	   LIB$GET_EF(&efn);
  943    1   	   if (efn == -1)
  944    1   	      return (0);
  945    1   	   if (_tolower(mode[0]) != 'r' && _tolower(mode[0]) != 'w')
  946    1   	      return (0);
  947    1   	   /* create and open the mailbox */
  948    1   	   status = SYS$CREMBX(0, &chan, 0, 0, 0, 0, 0);
  949    1   	   if (!(status & 1)) {
  950    2   	      LIB$FREE_EF(&efn);
  951    2   	      return (0);
  952    2   	   }
  953    1   	   itmlst.last = mbxname.length = 0;
  954    1   	   itmlst.address = mbxname.ptr = mname;
  955    1   	   itmlst.retlen = &mbxname.length;
  956    1   	   itmlst.code = DVI$_DEVNAM;
  957    1   	   itmlst.len = 64;
  958    1   	   status = SYS$GETDVIW(0, chan, 0, &itmlst, 0, 0, 0, 0);
  959    1   	   if (!(status & 1)) {
  960    2   	      LIB$FREE_EF(&efn);

RLOCAL                                                           8-APR-1988 17:40:02    VAX C      V2.3-024                 Page 3
V1.0                                                            18-JAN-1988 09:58:46    LTSIG2:[ICON.V7.SRC.ICONX]RLOCAL.C;1 (2)

  961    2   	      return (0);
  962    2   	   }
  963    1   	   mname[mbxname.length] = '\0';
  964    1   	   pfile = fopen(mname, mode);
  965    1   	   if (!pfile) {
  966    2   	      LIB$FREE_EF(&efn);
  967    2   	      SYS$DASSGN(chan);
  968    2   	      return (0);
  969    2   	   }
  970    1   	   /* Save file information now */
  971    1   	   pd = &_pipes[fileno(pfile)];	/* get Pipe pointer */
  972    1   	   pd->mode = _tolower(mode[0]);
  973    1   	   pd->fptr = pfile;
  974    1   	   pd->pid = pd->status = pd->running = 0;
  975    1   	   pd->flags = SFLAGS;
  976    1   	   pd->channel = chan;
  977    1   	   pd->efn = efn;
  978    1   	   /* fork the command */
  979    1   	   nl.length = strlen("_NL:");
  980    1   	   nl.ptr = "_NL:";
  981    1   	   command.length = strlen(cmd);
  982    1   	   command.ptr = cmd;
  983    1   	   status = LIB$SPAWN(&command,
  984    1   	      (pd->mode == 'r') ? 0 : &mbxname,	/* input file */
  985    1   	      (pd->mode == 'r') ? &mbxname : 0,	/* output file */
  986    1   	      &pd->flags, 0, &pd->pid, &pd->status, &pd->efn, 0, 0, 0, 0);
  987    1   	   if (!(status & 1)) {
  988    2   	      LIB$FREE_EF(&efn);
  989    2   	      SYS$DASSGN(chan);
  990    2   	      return (0);
  991    2   	   } else {
  992    2   	      pd->running = 1;
  993    2   	   }
  994    1   	   return (pfile);
  995    1   	}
  996        	

RLOCAL                                                           8-APR-1988 17:40:02    VAX C      V2.3-024                 Page 4
V1.0                                                            18-JAN-1988 09:58:46    LTSIG2:[ICON.V7.SRC.ICONX]RLOCAL.C;1 (3)

             	
  997        	/*
  998        	 * pclose - close a pipe
  999        	 * Last modified 2-Apr-86/chj
 1000        	 *
 1001        	 */
 1002        	pclose(pfile)
 1003        	FILE *pfile;
 1004        	{
 1005    1   	   Pipe *pd;
 1006    1   	   int status;
 1007    1   	   int fstatus;
 1008    1   	
 1009    1   	   pd = fileno(pfile) ? &_pipes[fileno(pfile)] : 0;
 1010    1   	   if (pd == NULL)
 1011    1   	      return (-1);
 1012    1   	   fflush(pd->fptr);			/* flush buffers */
 1013    1   	   fstatus = fclose(pfile);
 1014    1   	   if (pd->mode == 'w') {
 1015    2   	      status = SYS$QIOW(0, pd->channel, IO$_WRITEOF, 0, 0, 0, 0, 0, 0, 0, 0, 0);
 1016    2   	      SYS$WFLOR(pd->efn, 1 << (pd->efn % 32));
 1017    2   	   }
 1018    1   	   SYS$DASSGN(pd->channel);
 1019    1   	   LIB$FREE_EF(&pd->efn);
 1020    1   	   pd->running = 0;
 1021    1   	   return (fstatus);
 1022    1   	}
 1023        	

RLOCAL                                                           8-APR-1988 17:40:02    VAX C      V2.3-024                 Page 5
V1.0                                                            18-JAN-1988 09:58:46    LTSIG2:[ICON.V7.SRC.ICONX]RLOCAL.C;1 (4)

             	
 1024        	/*
 1025        	 * redirect(&argc,argv,nfargs) - redirect standard I/O
 1026        	 *    int *argc		number of command arguments (from call to main)
 1027        	 *    char *argv[]	command argument list (from call to main)
 1028        	 *    int nfargs	number of filename arguments to process
 1029        	 *
 1030        	 * argc and argv will be adjusted by redirect.
 1031        	 *
 1032        	 * redirect processes a program's command argument list and handles redirection
 1033        	 * of stdin, and stdout.  Any arguments which redirect I/O are removed from the
 1034        	 * argument list, and argc is adjusted accordingly.  redirect would typically be
 1035        	 * called as the first statement in the main program.
 1036        	 *
 1037        	 * Files are redirected based on syntax or position of command arguments.
 1038        	 * Arguments of the following forms always redirect a file:
 1039        	 *
 1040        	 *    <file	redirects standard input to read the given file
 1041        	 *    >file	redirects standard output to write to the given file
 1042        	 *    >>file	redirects standard output to append to the given file
 1043        	 *
 1044        	 * It is often useful to allow alternate input and output files as the
 1045        	 * first two command arguments without requiring the <file and >file
 1046        	 * syntax.  If the nfargs argument to redirect is 2 or more then the
 1047        	 * first two command arguments, if supplied, will be interpreted in this
 1048        	 * manner:  the first argument replaces stdin and the second stdout.
 1049        	 * A filename of "-" may be specified to occupy a position without
 1050        	 * performing any redirection.
 1051        	 *
 1052        	 * If nfargs is 1, only the first argument will be considered and will
 1053        	 * replace standard input if given.  Any arguments processed by setting
 1054        	 * nfargs > 0 will be removed from the argument list, and again argc will
 1055        	 * be adjusted.  Positional redirection follows syntax-specified
 1056        	 * redirection and therefore overrides it.
 1057        	 *
 1058        	 */
 1059        	
 1060        	
 1061        	redirect(argc,argv,nfargs)
 1062        	int *argc, nfargs;
 1063        	char *argv[];
 1064        	{
 1065    1   	   int i;
 1066    1   	
 1067    1   	   i = 1;
 1068    1   	   while (i < *argc)  {		/* for every command argument... */
 1069    2   	      switch (argv[i][0])  {		/* check first character */
 1070    3   	         case '<':			/* <file redirects stdin */
 1071    3   	            filearg(argc,argv,i,1,stdin,"r");
 1072    3   	            break;

RLOCAL                                                           8-APR-1988 17:40:02    VAX C      V2.3-024                 Page 6
V1.0                                                            18-JAN-1988 09:58:46    LTSIG2:[ICON.V7.SRC.ICONX]RLOCAL.C;1 (4)

 1073    3   	         case '>':			/* >file or >>file redirects stdout */
 1074    3   	            if (argv[i][1] == '>')
 1075    3   	               filearg(argc,argv,i,2,stdout,"a");
 1076    3   	            else
 1077    3   	               filearg(argc,argv,i,1,stdout,"w");
 1078    3   	            break;
 1079    3   	         default:			/* not recognized, go on to next arg */
 1080    3   	            i++;
 1081    3   	      }
 1082    2   	   }
 1083    1   	   if (nfargs >= 1 && *argc > 1)	/* if positional redirection & 1 arg */
 1084    1   	      filearg(argc,argv,1,0,stdin,"r");	/* then redirect stdin */
 1085    1   	   if (nfargs >= 2 && *argc > 1)	/* likewise for 2nd arg if wanted */
 1086    1   	      filearg(argc,argv,1,0,stdout,"w");/* redirect stdout */
 1087    1   	}
 1088        	
 1089        	
 1090        	
 1091        	/* filearg(&argc,argv,n,i,fp,mode) - redirect and remove file argument
 1092        	 *    int *argc		number of command arguments (from call to main)
 1093        	 *    char *argv[]	command argument list (from call to main)
 1094        	 *    int n		argv entry to use as file name and then delete
 1095        	 *    int i		first character of file name to use (skip '<' etc.)
 1096        	 *    FILE *fp		file pointer for file to reopen (typically stdin etc.)
 1097        	 *    char mode[]	file access mode (see freopen spec)
 1098        	 */
 1099        	
 1100        	filearg(argc,argv,n,i,fp,mode)
 1101        	int *argc, n, i;
 1102        	char *argv[], mode[];
 1103        	FILE *fp;
 1104        	{
 1105    1   	   if (strcmp(argv[n]+i,"-"))		/* alter file if arg not "-" */
 1106    1   	      fp = freopen(argv[n]+i,mode,fp);
 1107    1   	   if (fp == NULL)  {			/* abort on error */
 1108    2   	      fprintf(stderr,"%%can't open %s",argv[n]+i);
 1109    2   	      exit(ErrorExit);
 1110    2   	   }
 1111    1   	   for ( ;  n < *argc;  n++)		/* move down following arguments */
 1112    1   	      argv[n] = argv[n+1];
 1113    1   	   *argc = *argc - 1;			/* decrement argument count */
 1114    1   	}
 1115        	

RLOCAL                                                           8-APR-1988 17:40:02    VAX C      V2.3-024                 Page 7
V1.0                                                            18-JAN-1988 09:58:46    LTSIG2:[ICON.V7.SRC.ICONX]RLOCAL.C;1 (5)

             	
 1116        	/* Special versions of sbrk() and brk() for use by Icon under VMS.
 1117        	 * #defines in define.h actually rename these to vms_brk and vms_sbrk.
 1118        	 *
 1119        	 * For historical reasons, Icon assumes it can repeatedly call brk/sbrk
 1120        	 * and always get contiguous chunks.  This was made to work under Unix by
 1121        	 * overloading the definitions of malloc and friends, the only other callers
 1122        	 * of sbrk, and making them return Icon-managed memory.
 1123        	
 1124        	 * Under VMS, sbrk is not the lowest-level system interface.  It gets memory
 1125        	 * from underlying VMS routines such as SYS$EXPREG.  These routines are also
 1126        	 * called by others, for example when a file is opened;  so successive sbrk
 1127        	 * calls may return nonadjacent chunks.  This makes overloading malloc and
 1128        	 * friends futile.
 1129        	 *
 1130        	 * The routines below replace sbrk and brk for Icon (only) under VMS.  They
 1131        	 * provide the continuously growing memory Icon needs without relying on
 1132        	 * special privileges or unusually large quotas.  Like the Unix solution and
 1133        	 * earlier VMS attempts, this is an empirical solution and may need further
 1134        	 * revision as the system changes.  But we hope not.
 1135        	 *
 1136        	 * The Icon interpreter is loaded beginning at address 0 and grows upward as
 1137        	 * it requests more memory through sbrk.  The C stack grows downward from
 1138        	 * 0x7FFFFFFF. We're going to draw a line to divide the address space, then
 1139        	 * force the C and VMS runtime systems to put anything they need above it;
 1140        	 * then sbrk can grow the program region unimpeded up to the line.
 1141        	 *
 1142        	 * The line is drawn MAXMEM bytes beyond the start of the sbrk region.  MAXMEM
 1143        	 * is an environment variable (logical name to VMS) with a default as given in
 1144        	 * define.h.  Large values cost CPU and real time expended at process exit; we
 1145        	 * don't know why.  On an 8600 the cost was very roughly .04 CP sec / megabyte.
 1146        	 *
 1147        	 * When first called, sbrk expands the program region by one page to get a
 1148        	 * starting address.  A limit address is calculated by adding MAXMEM.  A single
 1149        	 * page created just below the limit address "draws the line" and causes the
 1150        	 * VMS runtime system to allocate anything it needs above that point.  sbrk
 1151        	 * creates pages between base and limit as needed.
 1152        	 *
 1153        	 * Possible errors and their manifestations:
 1154        	 *
 1155        	 *    MAXMEM too large to initialize sbrk:
 1156        	 *       error in startup code: value of MAXMEM too large
 1157        	 *
 1158        	 *    MAXMEM too small to initialize sbrk:
 1159        	 *       error in startup code: value of MAXMEM too small
 1160        	 *
 1161        	 *    MAXMEM too small for subsequent brk/sbrk growth
 1162        	 *       Run-time error 351:  insufficient MAXMEM limit
 1163        	 *
 1164        	 *    MAXMEM okay but insufficient user quota for needed memory:

RLOCAL                                                           8-APR-1988 17:40:02    VAX C      V2.3-024                 Page 8
V1.0                                                            18-JAN-1988 09:58:46    LTSIG2:[ICON.V7.SRC.ICONX]RLOCAL.C;1 (5)

 1165        	 *       Run-time error 303:  unable to expand memory region
 1166        	 *
 1167        	 *    unexpected ("can't happen") failures of system calls:
 1168        	 *       these produce their standard VMS error message
 1169        	 *
 1170        	 *    unexpected intrusion into the sbrk region by the runtime system:
 1171        	 *       unknown, but undoubtedly ugly
 1172        	 */
 1173        	
 1174        	
 1175        	#define PageSize 512		/* size of a VMS page */
 1176        	#define MaxP0 0x40000000	/* first address beyond the P0 region */
 1177        	
 1178        	#include <stsdef.h>
 1230        	
 1231        	word memsize = MaxMem;		/* set from environment variable MAXMEM */
 1232        	
 1233        	
 1234        	/*  sbrk(incr) - adjust the break value by incr, rounding up to a page.
 1235        	 *  returns the new break value, or -1 if unsuccessful.
 1236        	 */
 1237        	
 1238        	char *
 1239        	sbrk(incr)
 1240        	int incr;
 1241        	{
 1242    1   	   static char *base;		/* base of the sbrk region */
 1243    1   	   static char *curr;		/* current break value (end+1) */
 1244    1   	   static char *limit;		/* region limit ("the line") */
 1245    1   	   char *range[2], *p;		/* scratch for system calls */
 1246    1   	   int s;			/* status return from calls */
 1247    1   	
 1248    1   	   /*  initialization code */
 1249    1   	   if (!base)  {
 1250    2   	      s = sys$expreg(1,range,0,0);	/* expand P0 to get base address */
 1251    2   	      if (!(s & STS$M_SUCCESS))
 1252    2   	         exit(s);			/* couldn't get one page?! */
 1253    2   	      base = curr = range[0];		/* initialize empty sbrk region */
 1254    2   	      memsize = (memsize + PageSize - 1) & -PageSize;
 1255    2   						/* round memsize to page boundary */
 1256    2   	      limit = base + memsize;		/* calculate sbrk region limit*/
 1257    2   	      if (limit > MaxP0)
 1258    2   		 limit = MaxP0;			/* limit to legal values */
 1259    2   	      if (limit <= base)
 1260    2   	         error("value of MAXMEM too small");  /* can't even start */
 1261    2   	      range[0] = range[1] = limit-1;
 1262    2   	      s = sys$cretva(range,range,0);	/* get a page there to draw the line */
 1263    2   	      if (!(s & STS$M_SUCCESS))
 1264    2   	         error("value of MAXMEM too large");  /* can't even start */
 1265    2   	   }

RLOCAL                                                           8-APR-1988 17:40:02    VAX C      V2.3-024                 Page 9
V1.0                                                            18-JAN-1988 09:58:46    LTSIG2:[ICON.V7.SRC.ICONX]RLOCAL.C;1 (5)

 1266    1   	
 1267    1   	   if (incr > 0)  {
 1268    2   	
 1269    2   	      /* grow the region */
 1270    2   	      if (curr + incr > limit)		/* check address space available */
 1271    2   	         fatalerr(-351,NULL);		/* oops, MAXMEM too small */
 1272    2   	      range[0] = curr;
 1273    2   	      range[1] = curr + incr - 1;
 1274    2   	      s = sys$cretva(range,range,0);	/* ask for the pages */
 1275    2   	      if (!(s & STS$M_SUCCESS))
 1276    2   	         return (char *) -1;		/* failed, quota exceeded */
 1277    2   	      curr = range[1] + 1;		/* set new break value as returned */
 1278    2   	
 1279    2   	   } else if (incr < 0) {
 1280    2   	
 1281    2   	      /* shrink the region (not expected to be used).  does not actually
 1282    2   	       * return the memory, but does make it available for reuse.  */
 1283    2   	      curr -= -incr & -PageSize;
 1284    2   	   }
 1285    1   	
 1286    1   	   /* return the current break value */
 1287    1   	   return curr;
 1288    1   	}
 1289        	
 1290        	
 1291        	
 1292        	
 1293        	/*  brk(addr) - set the break address to the given value, rounded up to a page.
 1294        	 *  returns 0 if successful, -1 if not.
 1295        	 */
 1296        	
 1297        	char *
 1298        	brk(addr)
 1299        	char *addr;
 1300        	{
 1301    1   	   return ((sbrk(addr-sbrk(0))) == (char *) -1 ? (char *) -1 : 0);
 1302    1   	}

 
 
Command Line
------------
 
CC/LIS/DEB/NOOPT RLOCAL

