home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / C / common.c < prev    next >
Encoding:
C/C++ Source or Header  |  1989-03-04  |  15.8 KB  |  744 lines
  1. /*-------------------------------*/
  2. /*   TOOLPACK/1   Release: 1.1   */
  3. /*-------------------------------*/
  4. #include <ctype.h>
  5. #include "define.h"
  6.  
  7.  
  8. #include <sys/time.h>
  9. #ifdef sgi
  10. #include <time.h>
  11. #endif
  12.  
  13. /* mask and shift for VAX 11/750 */
  14. #define VPSHIFT  0
  15. #define VPMASK   0x20202000
  16.  
  17.  
  18. #include "globals1.h"
  19. addset_(char1,set,point,max)
  20. int *set, *point, *max, *char1;
  21.  
  22. {
  23.  /* if point is less than max add IST character char to set set at point
  24.     point, increment point and return yes. Otherwise return no.
  25.     Note this routine may also be used for adding integer into arrays */
  26.  
  27.   if( *point > *max)
  28.     return(NO);
  29.  
  30.  *(set + *point - 1) = *char1;
  31.  (*point)++;
  32.  return(YES);
  33.  
  34. }
  35.  
  36. alldig_(s)
  37. int *s;
  38.  
  39. {
  40.  /* check that all elements of IST-string are digits.
  41.     return YES if so. NO otherwise.
  42.     For null string return NO  */
  43.  
  44.    if( *s == EOS)return(NO);
  45.  
  46.    while(isdigit( *s))
  47.         s++;
  48.  
  49.    if( *s == EOS) return(YES);
  50.  
  51.    return(NO);
  52.  
  53. }
  54.  
  55. ctoi_(line,point)
  56. int *line, *point;
  57.  
  58. {
  59.  /* convert the characters in line starting at point to an integer
  60.     update point to indicate the first non-digit character after
  61.     the number. Preceding whitespace is skipped, the number must
  62.     be unsigned. If the first non-white space character after point
  63.    is not a digit then the value zero is returned           */
  64.  
  65.  int n;
  66.  int *ptr;
  67.  
  68.  /* step leading whitespace  */
  69.  
  70.  skipbl_(line,point);
  71.  ptr = line + *point -1;
  72.  
  73.  /* collect the number */
  74.  
  75.  n = 0;
  76.  while(isdigit( *ptr))
  77.   {
  78.     n=10*n + *ptr - '0';
  79.     ptr++;
  80.      (*point)++; /* increment the value of point - *point because */
  81.                  /* it's coming from fortran 77                   */
  82.   }
  83.   return(n);
  84. }
  85.  
  86. equal_(s1,s2)
  87. int *s1, *s2;
  88.  
  89. {
  90.  /* compare two strings for equality length and content.
  91.     return YES if equal NO otherwise */
  92.  if( *s1 != *s2)return(NO);
  93.  
  94.  while( *s1 != EOS && *s2 != EOS)
  95.       if(*s1++ != *s2++) return(NO);
  96.  
  97.  if(*s1 == EOS &&  *s2 == EOS)return(YES);
  98.  return(NO);
  99.  
  100. }
  101.  
  102. getwrd_(line,point,string)
  103. int *line, *point, *string;
  104.  
  105.  
  106.  /* copy the next word from LINE starting at point in string.
  107.  Preceding white space is ignored. A word is defined as any sequence
  108.  of characters delimited by whitespace, 'newline' or 'eos'.
  109.  
  110.  The length of the word is returned. */
  111.  
  112. {
  113. int *val, i;
  114.  
  115.  /* clear preceding white space */
  116.  
  117.  skipbl_(line,point);
  118.  val = line + *point -1 ;
  119.  
  120.  for(i=0; *val != EOS && *val != BLANK && *val != TAB && *val
  121.                != NEWLINE && *point<=MAXLINE; val++,i++)
  122.   string[i] = *val ;
  123.  
  124.   string[i] = EOS; /* this line may need to change */
  125.   *point = *point + i ;
  126.   return(i);          /* see bob Iles notes */
  127. }
  128.  
  129. indexx_(string,char1)
  130. int *string, *char1;
  131.  
  132. {
  133.  /* return the position of the first occurrence of the character
  134.  char in the string string. Return zero if char not in string.  */
  135.  int i;
  136.  if( *string == EOS)return(0);
  137.  for(i=0; *string != *char1 && *string != EOS ; i++, string++);
  138.  
  139.  return(( *string == EOS) ? 0:i+1);
  140.  
  141. }
  142.  
  143. itoc_(value,string,size)
  144. int *value, *string, *size ;
  145.  
  146. {
  147.  /* convert the integer value to an IST-string representation
  148.     in array string using up to size characters (inc.eos). If more
  149.     than size characters are lost digits will be lost (most
  150.     significant). The value may be negative. The length of the
  151.     resulting string is returned                   */
  152.  
  153. int sign,i,j,k,n,c, *temp ;
  154.  
  155.  temp = string;
  156.  n = *value;
  157.  if( (sign = n)<0)
  158.          n = -n;        /* work with absolute value */
  159.  
  160.  *temp++ = EOS;
  161.  i=0;
  162.  do {
  163.       i++;
  164.       *temp++ = n%10 + '0';
  165.     }while ((n/=10)>0 && i < *size -1); /*strip off digits least sigf first */
  166.  
  167.     if(sign<0 && i<*size-1){
  168.        *temp++ = MINUS;
  169.        i++;             /* deal with the sign*/
  170.       }
  171.  for(j=0,k=i;j<k;j++,k--){  /*reverse the string */
  172.      c=string[j];
  173.      string[j]=string[k];
  174.      string[k]=c;
  175.      }
  176. return(i);
  177. }
  178.  
  179. length_(s)
  180. int *s;
  181.  
  182. { /* returns the length of an IST-string */
  183.  int i;
  184.  
  185.  for(i=0 ; s[i] != EOS ; i++);
  186.  return(i);
  187.  
  188. }
  189.  
  190. scopy_(from,i,to,j)
  191. int *from, *to ;
  192. int *i, *j ;
  193.  
  194. {
  195.  /* copy from from(i) into array to starting at j up to an 'eos'
  196.     leave i and j alone. The 'eos' goes as well
  197.   */
  198.  
  199.       register int *k, *l ;
  200.  
  201.      for(k = from + *i - 1,l = to + *j - 1; *k != EOS; *l++ = *k++)
  202.             ;
  203.  
  204.     *l = EOS;
  205.  
  206. }
  207.  
  208. set_(param,value,type,defalt,min,max)
  209. int *param, *value, *type, *defalt, *min, *max;
  210.  
  211. {
  212.  /* set the value of the argument PARAM to a new value and ensure
  213.     it is in the range MIN to MAX (a value outside this range is
  214.     set to the appropriate limit value). The value of PARAM is set
  215.     according to the value of the type as follows :
  216.  
  217.     type = 'newline'     param = defalt
  218.     type = 'plus'        param = param + value
  219.     type = 'minus'       param = value                          */
  220.  
  221.  switch( *type) {
  222.  
  223.     case NEWLINE :
  224.                *param = *defalt;
  225.                break;
  226.  
  227.     case PLUS :
  228.                *param = *param + *value;
  229.                break;
  230.  
  231.     case MINUS :
  232.                *param = *param - *value;
  233.                break;
  234.  
  235.     default    :
  236.                *param = *value;
  237.  
  238. }
  239.  *param = (*param > *max) ? *max : *param ;
  240.  *param = (*param < *min) ? *min : *param ;
  241.  
  242. }
  243.  
  244. skipbl_(line,point)
  245. int *line, *point;
  246.  
  247. {
  248.    int *ptr;
  249.    ptr = line + *point -1;
  250.  /* ptr now points at line(point) */
  251.  /* move the pointer point to the next non-whitespace character
  252.     in line    */
  253.  for(; *ptr == TAB || *ptr == BLANK ; ptr++,(*point)++);
  254.  
  255.                       /* next character */
  256.                    /* update value of pointer */
  257. }
  258.  
  259. type_(c)
  260. int *c;
  261.  
  262. {
  263.   /* type of c is 'digit'  if c belongs to [0 - 9]
  264.                   'letter' if c belongs to [A-Z a-z]
  265.                     c      if c is any other character */
  266.  
  267.  
  268.  if(*c < 0 || *c > 127) return(*c);
  269.  if(isalpha(*c)) return(LETTER);
  270.  if(isdigit(*c)) return(DIGIT);
  271.  return(*c);
  272. }
  273.  
  274. xindex_(string,ch,allbut,lastto)
  275. int *string, *ch, *allbut, *lastto ;
  276.  
  277. {
  278.  /* a more versatile (?) version of indexx. If the value of allbut is set
  279.     then reverse the sense of indexx
  280.  
  281.     viz if ch in string return zero
  282.         else return lastto+1
  283.  
  284.   if ch = eof then result is set to no        */
  285.  
  286.   if( *ch == EOF) return(0);
  287.  
  288.   if( *allbut == NO) return(indexx_(string,ch));
  289.  
  290.  /* allbut = YES */
  291.  
  292.  return((indexx_(string,ch)) ? 0 : *lastto + 1);
  293.  
  294. }
  295.  
  296. zbyte_(integ,byte,flag)
  297. int *byte, *flag;
  298. unsigned *integ;
  299.  
  300. {
  301.  /* return specified byte(byte) from integer (integ) leaving int unchanged
  302.  
  303.     if flag = yes value = small integer
  304.             = no value is an A1 format
  305.  
  306.  N.B. These are the same for VAX 11/780 4.2 Berkely f77 */
  307.  
  308.  return( (*byte < 1 || *byte > 4) ? 0 : ( *integ << (4- *byte)*8) >>24 );
  309.  
  310.  /* get required byte by left shift to top followed by right shift
  311.     to bottom. note both shifts bring in zeros.
  312.  
  313.     We are assuming 4 3 2 1 ordering    */
  314.  
  315.  
  316. }
  317.  
  318. zcbyte_(integ,byte,newval)
  319.  
  320. int *byte ;
  321. int *integ, *newval;
  322.  
  323. {
  324.  /* change the value of the specified byte (BYTE) in the integer (VALUE)
  325.     to be newval. Bytes are numbered 1 to cpi. Byte 1 contains the
  326.     character in 1H or A1 format. The byte packing order is that used
  327.     by the host machine in the packing of characters or holleriths
  328.     into integers. The value of newval is restricted to the range
  329.     0 - 2** 'bpc' -1 by masking if necessary */
  330.  
  331.   if( *byte < 1 || *byte > 4)
  332.      return(ERR);
  333.  
  334.  *integ = (*integ & ~(255 << (*byte - 1)*8 )) |
  335.            ((*newval & 255) << (*byte - 1)*8 );
  336.   return(NOERR);
  337.  
  338. }
  339.  
  340. zcctoi_(from,to)
  341. char *from;
  342. int *to;
  343.  
  344. {
  345.  /* converts a fortran 77 character to an IST character. Neither character
  346.     set expansion nor compression is performed. It is assumed all f77
  347.     characters can be represented as IST characters. If not a space should
  348.     be returned.
  349.  
  350.     The result is the IST-character           */
  351.  
  352.   return( (*to = *from) );
  353. }
  354.  
  355. zchtoi_(hol,ist)
  356. int *hol;
  357. int *ist;
  358.  
  359. {
  360.  /* convert a hollerith character to an IST character. Neither character
  361.     set expansion nor compression is performed. If the input character
  362.     cannot be represented as an IST character, it is converted to a
  363.     space.
  364.  
  365.     The ist character is returned via the function name */
  366.  *ist = *hol;
  367.  
  368.  *ist = (*ist >> VPSHIFT) & 0x000000ff ;
  369.  /* check - since hol can be any old integer       */
  370.  
  371.  if( *ist > NCHARS)
  372.  {
  373.     *ist = BLANK;
  374.  }
  375.  return( *ist);
  376.  
  377. }
  378.  
  379. zcitoc_(result,length,ist,ch)
  380. char *result;
  381. long int length;
  382. unsigned *ist;
  383. char *ch;
  384.  
  385. {
  386.  /* convert an IST character to a fortran 77 character. Neither character
  387.     set expansion nor compression is performed. If the input IST string
  388.     cannot be represented as a fortran 77 character it is converted
  389.     to a space.
  390.  
  391.     The result is also returned through the function name */
  392.  
  393.  
  394.  
  395.  *result = ( ( *ch = (( *ist < 0 || *ist > NCHARS) ? ' ' : *ist) ) );
  396.  
  397. }
  398.  
  399. zcitoh_(ist,hol,pad)
  400. int *ist, *hol, *pad ;
  401.  
  402. {
  403.  /* convert an IST character to a hollerith constant. Neither character
  404.     set expansion nor compression is performed. If the input IST
  405.     character cannot be represented as a hollerith constant it is
  406.     converted to space. PAD is set to 'yes' to pad the constant with
  407.     spaces; 'no' to leave the bytes zero, and 'host' to pad in the
  408.     'natural' host manner, i.e. as when 1Hx assignment is made.
  409.  
  410.      The result is also returned through the function name */
  411.  
  412.  /* mask used is machine dependent */
  413.  
  414.  return( ( *hol = ( *pad == NO) ? *ist : (*ist << VPSHIFT) |  VPMASK ) );
  415.  
  416.  
  417. }
  418.  
  419. zcompr_(s1,s2)
  420. int *s1, *s2;
  421.  
  422. {
  423.  /* compare two IST strings for equality. The two strings are allowed
  424.     to be of separate lengths; only the number of characters in the
  425.     shorter string are compared.                               */
  426.  
  427.   for(; *s1 != EOS && *s2 != EOS && *s1 == *s2; s1++, s2++) ;
  428.  
  429.   return( ( *s1 == EOS || *s2 == EOS) ? YES : NO);
  430.  
  431. }
  432.  
  433. zfield_(n,msb,lsb)
  434. int *msb, *lsb ;
  435. unsigned *n;
  436.  
  437. {
  438.  /* Return the specified field of the integer value n.The result is
  439.     the bits of n between bit MSB and bit LSB shifted into the least
  440.     significant part of the result. Bits in n are numbered 1 to 'bpi'.
  441.     msb = most significant bit and lsb = least significant bit.
  442.     The result is returned through the function name. */
  443.  
  444.  /* this routine bears a strong resemblence to getbits p 45 */
  445.  
  446.   if( *msb > BPI || *lsb < 1 || *msb < *lsb)
  447.     return(0);
  448.  
  449.     return(( *n >> ( *lsb -1)) & ~(~0 << ( *msb - *lsb +1)));
  450.  
  451. }
  452.  
  453. zhost_(bpi,cpi,bpc,rjust)
  454. int *bpi, *cpi, *bpc, *rjust;
  455.  
  456. {
  457.  /* return a set of host-system-specific values */
  458.  
  459.  /* number of bits per integer */
  460.  
  461.     *bpi = BPI;
  462.  
  463.  /* number of characters packed into an integer */
  464.  
  465.     *cpi = CPI;
  466.  
  467.  /* number of bits per character */
  468.  
  469.     *bpc = BPC;
  470.  
  471. /* 'yes' if machine right-justifies characters in integers
  472.    'no ' if machine left-justifies characters in integers
  473.    'err' if BPC*CPI != BPI or it neither left or right justifies */
  474.  
  475.      *rjust = RJUST;
  476.  
  477. }
  478.  
  479. ziand_(v1,v2)
  480. int *v1, *v2 ;
  481.  
  482. {
  483.  /* return a bitwise logical 'and' through the function name */
  484.  
  485.  return( *v1 & *v2);
  486.  
  487. }
  488.  
  489. zimpls_(s)
  490. int *s;
  491.  
  492. {
  493.  /* return an IST string in s which describes the current
  494.     implementation of TIE in use */
  495.  char s1[81] ;
  496.  
  497.     strcpy(s1, "TOOLPACK/1  RELEASE: 1.1  -  (TIEC).");
  498.     chist_(s1, s, strlen(s1));
  499. }
  500.  
  501. zindex_(s,t)
  502. int *s, *t ;
  503.  
  504. {
  505.  /* Find the first occurence of the string t in the line s. The
  506.     value of the function is 0 if t can not be found in the s.
  507.     Otherwise the value is the location of the first character
  508.     of the match in the line. If t is null (i.e. only 'eos')
  509.     then it matches the first character in s              */
  510.  
  511.    int i,j,k;
  512.  
  513.  /* the next line may have to be removed since it is a fudge to get
  514.      same result as fortran */
  515.  
  516.   if( t[0] == EOS && s[0] != EOS) return(1);
  517.  
  518.   for(i=0 ; s[i] != EOS;i++) {
  519.  
  520.      for(j=i,k=0; t[k] != EOS && s[j] == t[k];j++,k++);
  521.  
  522.       if(t[k] == EOS)
  523.          return((k == 0) ? 0:i+1); /* take care of null t */
  524.  
  525.        }
  526.  return(0);
  527.  
  528. }
  529.  
  530. zinot_(v1)
  531. int *v1 ;
  532.  
  533. {
  534.  /* return the result of a 1's complement negation
  535.     in the argument    */
  536.  
  537.   return(~( *v1)) ;
  538.  
  539. }
  540.  
  541. zior_(v1,v2)
  542. int *v1, *v2 ;
  543.  
  544. {
  545.  /* return a bitwise logical or through the function name */
  546.  
  547.  return( *v1 | *v2);
  548.  
  549. }
  550.  
  551. zitocp_( value, string, width, pad)
  552. int *value, *string, *width, *pad;
  553.  
  554. {
  555.     /* convert the integer value to an IST string in array
  556.        string using up to width characters (excluding EOS).
  557.        If the string version requires less than width characters
  558.        pad with the character PAD */
  559.  
  560.     int *ptrend, *strend;
  561.     int length, i, size;
  562.  
  563.     /* use itoc to generate the IST string */
  564.         size = *width + 1;
  565.     length = itoc_(value, string, &size);
  566.  
  567.     /* ptrend points at the EOS - returned from itoc
  568.        strend points at the end of the string to be made up */
  569.     ptrend = string + length;
  570.     strend = string + *width;
  571.  
  572.     /* right justify */
  573.     for (i = 0; i <= length; i++, *strend-- = *ptrend--);
  574.     
  575.     /* and pad */
  576.     while (string <= strend)
  577.            *string++ = *pad;
  578.  
  579. }
  580.  
  581. zlls_(v1,bits)
  582. unsigned int *v1, *bits ;
  583.  
  584. {
  585.  /* return the result of a logical left shift on v1 by bits bit
  586.     positions. Bits shifted out of a word are lost, zeros are
  587.     shifted in */
  588.  
  589.  return( *v1 << *bits);
  590.  
  591. }
  592.  
  593. zlrs_(v1,bits)
  594. unsigned int *v1, *bits ;
  595.  
  596. {
  597.  /* return the result of a logical right shift on v1 by bits bit
  598.     positions. Bits shifted out of a word are lost, zeros are
  599.     shifted in */
  600.  
  601.  return( *v1 >> *bits);
  602.  
  603. }
  604.  
  605. zlower_(ch)
  606. int *ch ;
  607.  
  608. {
  609.  /*returns the lower case version of ch if it is upper case
  610.   or ch if it is any of character         */
  611.  
  612.  
  613.  return( isupper(*ch) ? tolower( *ch): *ch);
  614.  
  615. }
  616.  
  617. zorder_(s1,s2)
  618. int *s1, *s2;
  619.  
  620. {
  621.  /* evaluate the lexical order of two IST format strings
  622.     result of the comparision is 'less','greater'or'equals'.
  623.     'less' implies s1 lexically precedes s2  */
  624.  
  625. /* rip off of strcmp white book p102 */
  626.       if( *s1 == EOS && *s2 != EOS)return(LESS);
  627.       if( *s2 == EOS && *s1 != EOS)return(GREATER);
  628.  
  629.   for(; *s1 == *s2 ; s1++,s2++)
  630.       if( *s1 == EOS)
  631.        return(EQUALS);
  632.  
  633. /* special cases */
  634.   if(*s1 == EOS) return(LESS);
  635.   if(*s2 == EOS) return(GREATER);
  636.  
  637.  return( (*s1 > *s2) ? GREATER : LESS);
  638.  
  639. }
  640.  
  641. zsbstr_(from,beg,length,to,tbeg)
  642. int *from, *beg, *length, *to, *tbeg ;
  643.  
  644. {
  645.  /* copy maximum of length characters starting at from[beg] to to
  646.     starting at to[tbeg] */
  647.  
  648.  int *if1, *it, i;
  649.  
  650.  /* check for default parameters */
  651.  
  652.  if( *beg<1 || *tbeg<1)
  653.     return;
  654.  
  655.  /* set if1 and it to point at heads of arrays */
  656.  
  657.  if1 = from + *beg -1 ;
  658.  it = to + *tbeg -1 ;
  659.  
  660.  for(i=1;i<= *length ; i++)
  661.  {
  662.  
  663.      *it++ = *if1;
  664.      if( *if1 == EOS)return;
  665.      if1++;
  666.   }
  667.  
  668. }
  669.  
  670. ztime_(y, m, d, h, min, s, mil)
  671. int *y, *m, *d, *h, *min, *s, *mil;
  672. {
  673.  
  674.     /* Get the current time (according to the host system clock).
  675.        The millisecond variable may not change incrementally
  676.        depending on the information available from the host system */
  677.  
  678.  
  679. {
  680.     struct timeval tp;
  681.     struct timezone tz;
  682.     struct tm tmstr, *localtime();
  683.  
  684.     gettimeofday(&tp, &tz);
  685.     tmstr = *localtime(&tp.tv_sec);
  686.     *y = tmstr.tm_year + 1900;
  687.     *m = tmstr.tm_mon +1;
  688.     *d = tmstr.tm_mday;
  689.     *h = tmstr.tm_hour;
  690.     *min = tmstr.tm_min;
  691.     *s = tmstr.tm_sec;
  692.     /* 4.2 presents ...... microseconds !! */
  693.     *mil = tp.tv_usec/1000;
  694.     return;
  695. }
  696.  
  697. }
  698.  
  699. ztimes_(date, time, buffer)
  700. int *date, *time, *buffer;
  701. {
  702.  
  703.     /* convert a time stamp of the form returned by ZSTAMP to an
  704.        IST string representation of the date and time in the form
  705.  
  706.            15:36:49 13 dec 1983
  707.  
  708.        The string is fixed length at 20 characters plus an EOS */
  709.  
  710.     int i, j, junk;
  711.     char *ctime(), *p, temp[30];
  712.  
  713.     /* ctime returns a pointer to a string of the form
  714.  
  715.         Sun Sep 16 01:03:52 1983\n\0
  716.  
  717.         so we need to rearrange it a bit */
  718.  
  719.     p = ctime(&zstclk);
  720.     j = 0;
  721.     for (i=11; i<=19; i++) temp[j++] = p[i-1];
  722.     for (i=8; i<=10; i++) temp[j++] = p[i-1];
  723.     for (i=4; i<=7; i++) temp[j++] = p[i-1];
  724.     for (i=21; i<=24; i++) temp[j++] = p[i-1];
  725.     temp[j] = EOSCH;
  726.  
  727.     chist_(temp, buffer, strlen(temp));
  728.     return;
  729.  
  730.  
  731. }
  732.  
  733. zupper_(ch)
  734. int *ch ;
  735.  
  736. {
  737.  /*returns the upper case version of ch if it is lower case
  738.   or ch if it is any of character         */
  739.  
  740.  
  741.  return( islower(*ch) ? toupper(*ch) : *ch);
  742.  
  743. }
  744.