home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / src / runtime / fstr.r < prev    next >
Text File  |  2002-01-18  |  18KB  |  721 lines
  1. /*
  2.  * File: fstr.r
  3.  *  Contents: center, detab, entab, left, map, repl, reverse, right, trim
  4.  */
  5.  
  6.  
  7. /*
  8.  * macro used by center, left, right
  9.  */
  10. #begdef FstrSetup
  11.    /*
  12.     * s1 must be a string.  n must be a non-negative integer and defaults
  13.     *  to 1.  s2 must be a string and defaults to a blank.
  14.     */
  15.    if !cnv:string(s1) then
  16.       runerr(103,s1)
  17.    if !def:C_integer(n,1) then
  18.       runerr(101, n)
  19.    if !def:tmp_string(s2,blank) then
  20.       runerr(103, s2)
  21.  
  22.    abstract {
  23.       return string
  24.       }
  25.    body {
  26.       register char *s, *st;
  27.       word slen;
  28.       char *sbuf, *s3;
  29.  
  30.       if (n < 0) {
  31.          irunerr(205,n);
  32.          errorfail;
  33.          }
  34.       /*
  35.        * The padding string is null; make it a blank.
  36.        */
  37.       if (StrLen(s2) == 0)
  38.          s2 = blank;
  39.    /* } must be supplied */
  40. #enddef
  41.  
  42.  
  43. "center(s1,i,s2) - pad s1 on left and right with s2 to length i."
  44.  
  45. function{1} center(s1,n,s2)
  46.    FstrSetup /* includes body { */
  47.       {
  48.       word hcnt;
  49.  
  50.       /*
  51.        * If we are extracting the center of a large string (not padding),
  52.        * just construct a descriptor.
  53.        */
  54.       if (n <= StrLen(s1)) {
  55.          return string(n, StrLoc(s1) + ((StrLen(s1)-n+1)>>1));
  56.          }
  57.  
  58.       /*
  59.        * Get space for the new string.  Start at the right
  60.        *  of the new string and copy s2 into it from right to left as
  61.        *  many times as will fit in the right half of the new string.
  62.        */
  63.       Protect(sbuf = alcstr(NULL, n), runerr(0));
  64.  
  65.       slen = StrLen(s2);
  66.       s3 = StrLoc(s2);
  67.       hcnt = n / 2;
  68.       s = sbuf + n;
  69.       while (s > sbuf + hcnt) {
  70.          st = s3 + slen;
  71.          while (st > s3 && s > sbuf + hcnt)
  72.             *--s = *--st;
  73.          }
  74.  
  75.       /*
  76.        * Start at the left end of the new string and copy s1 into it from
  77.        *  left to right as many time as will fit in the left half of the
  78.        *  new string.
  79.        */
  80.       s = sbuf;
  81.       while (s < sbuf + hcnt) {
  82.          st = s3;
  83.          while (st < s3 + slen && s < sbuf + hcnt)
  84.             *s++ = *st++;
  85.          }
  86.  
  87.       slen = StrLen(s1);
  88.       if (n < slen) {
  89.          /*
  90.           * s1 is larger than the field to center it in.  The source for the
  91.           *  copy starts at the appropriate point in s1 and the destination
  92.           *  starts at the left end of of the new string.
  93.           */
  94.          s = sbuf;
  95.          st = StrLoc(s1) + slen/2 - hcnt + (~n&slen&1);
  96.          }
  97.       else {
  98.          /*
  99.           * s1 is smaller than the field to center it in.  The source for the
  100.           *  copy starts at the left end of s1 and the destination starts at
  101.           *  the appropriate point in the new string.
  102.           */
  103.          s = sbuf + hcnt - slen/2 - (~n&slen&1);
  104.          st = StrLoc(s1);
  105.          }
  106.       /*
  107.        * Perform the copy, moving min(*s1,n) bytes from st to s.
  108.        */
  109.       if (slen > n)
  110.          slen = n;
  111.       while (slen-- > 0)
  112.          *s++ = *st++;
  113.  
  114.       /*
  115.        * Return the new string.
  116.        */
  117.       return string(n, sbuf);
  118.       } }
  119. end
  120.  
  121.  
  122. "detab(s,i,...) - replace tabs with spaces, with stops at columns indicated."
  123.  
  124. function{1} detab(s,i[n])
  125.  
  126.    if !cnv:string(s) then
  127.       runerr(103,s)
  128.  
  129.    abstract {
  130.       return string
  131.       }
  132.  
  133.    body {
  134.       tended char *in, *out, *iend;
  135.       C_integer last, interval, col, target, expand, j;
  136.       dptr tablst;
  137.       dptr endlst;
  138.       int is_expanded = 0;
  139.       char c;
  140.  
  141.       /*
  142.        * Make sure all allocations for result will go in one region
  143.        */
  144.       reserve(Strings, StrLen(s) * 8);
  145.  
  146.       for (j=0; j<n; j++) {
  147.      if (!cnv:integer(i[j],i[j]))
  148.             runerr(101,i[j]);
  149.      if ((j>0) && IntVal(i[j])<=IntVal(i[j-1]))
  150.             runerr(210, i[j]);
  151.  
  152.          }
  153.       /*
  154.        * Start out assuming the result will be the same size as the argument.
  155.        */
  156.       Protect(StrLoc(result) = alcstr(NULL, StrLen(s)), runerr(0));
  157.       StrLen(result) = StrLen(s);
  158.  
  159.       /*
  160.        * Copy the string, expanding tabs.
  161.        */
  162.       last = 1;
  163.       if (n == 0)
  164.          interval = 8;
  165.       else {
  166.          if (!cnv:integer(i[0], i[0]))
  167.             runerr(101, i[0]);
  168.  
  169.          if (IntVal(i[0]) <= last)
  170.             runerr(210, i[0]);
  171.           }
  172.       tablst = i;
  173.       endlst = &i[n];
  174.       col = 1;
  175.       iend = StrLoc(s) + StrLen(s);
  176.       for (in = StrLoc(s), out = StrLoc(result); in < iend; )
  177.          switch (c = *out++ = *in++) {
  178.             case '\b':
  179.                col--;
  180.                tablst = i;  /* reset the list of remaining tab stops */
  181.                last = 1;
  182.                break;
  183.             case '\n':
  184.             case '\r':
  185.                col = 1;
  186.                tablst = i;  /* reset the list of remaining tab stops */
  187.                last = 1;
  188.                break;
  189.             case '\t':
  190.                is_expanded = 1;
  191.                out--;
  192.                target = col;
  193.                nxttab(&target, &tablst, endlst, &last, &interval);
  194.                expand = target - col - 1;
  195.                if (expand > 0) {
  196.                   Protect(alcstr(NULL, expand), runerr(0));
  197.                   StrLen(result) += expand;
  198.                   }
  199.                while (col < target) {
  200.                   *out++ = ' ';
  201.                   col++;
  202.                   }
  203.                break;
  204.             default:
  205.                if (isprint(c))
  206.                   col++;
  207.             }
  208.  
  209.       /*
  210.        * Return new string if indeed there were tabs; otherwise return original
  211.        *  string to conserve memory.
  212.        */
  213.       if (is_expanded)
  214.          return result;
  215.       else {
  216.      long n = DiffPtrs(StrLoc(result),strfree); /* note deallocation */
  217.      if (n < 0)
  218.         EVVal(-n, E_StrDeAlc);
  219.      else
  220.         EVVal(n, E_String);
  221.      strtotal += DiffPtrs(StrLoc(result),strfree);
  222.          strfree = StrLoc(result);        /* reset the free pointer */
  223.          return s;                /* return original string */
  224.          }
  225.       }
  226. end
  227.  
  228.  
  229.  
  230. "entab(s,i,...) - replace spaces with tabs, with stops at columns indicated."
  231.  
  232. function{1} entab(s,i[n])
  233.    if !cnv:string(s) then
  234.       runerr(103,s)
  235.  
  236.    abstract {
  237.       return string
  238.       }
  239.  
  240.    body {
  241.       C_integer last, interval, col, target, nt, nt1, j;
  242.       dptr tablst;
  243.       dptr endlst;
  244.       char *in, *out, *iend;
  245.       char c;
  246.       int inserted = 0;
  247.  
  248.       for (j=0; j<n; j++) {
  249.      if (!cnv:integer(i[j],i[j]))
  250.             runerr(101,i[j]);
  251.  
  252.      if ((j>0) && IntVal(i[j])<=IntVal(i[j-1]))
  253.             runerr(210, i[j]);
  254.          }
  255.  
  256.       /*
  257.        * Get memory for result at end of string space.  We may give some back
  258.        *  if not all needed, or all of it if no tabs can be inserted.
  259.        */
  260.       Protect(StrLoc(result) = alcstr(NULL, StrLen(s)), runerr(0));
  261.       StrLen(result) = StrLen(s);
  262.  
  263.       /*
  264.        * Copy the string, looking for runs of spaces.
  265.        */
  266.       last = 1;
  267.       if (n == 0)
  268.          interval = 8;
  269.       else {
  270.          if (!cnv:integer(i[0], i[0]))
  271.             runerr(101, i[0]);
  272.          if (IntVal(i[0]) <= last)
  273.             runerr(210, i[0]);
  274.          }
  275.       tablst = i;
  276.       endlst = &i[n];
  277.       col = 1;
  278.       target = 0;
  279.       iend = StrLoc(s) + StrLen(s);
  280.  
  281.       for (in = StrLoc(s), out = StrLoc(result); in < iend; )
  282.          switch (c = *out++ = *in++) {
  283.          case '\b':
  284.             col--;
  285.             tablst = i;  /* reset the list of remaining tab stops */
  286.             last = 1;
  287.             break;
  288.          case '\n':
  289.          case '\r':
  290.             col = 1;
  291.             tablst = i;  /* reset the list of remaining tab stops */
  292.             last = 1;
  293.             break;
  294.          case '\t':
  295.             nxttab(&col, &tablst, endlst, &last, &interval);
  296.             break;
  297.          case ' ':
  298.             target = col + 1;
  299.             while (in < iend && *in == ' ')
  300.                target++, in++;
  301.             if (target - col > 1) { /* never tab just 1; already copied space */
  302.                nt = col;
  303.                nxttab(&nt, &tablst, endlst, &last, &interval);
  304.                if (nt == col+1) {
  305.                   nt1 = nt;
  306.                   nxttab(&nt1, &tablst, endlst, &last, &interval);
  307.                   if (nt1 > target) {
  308.                      col++;    /* keep space to avoid 1-col tab then spaces */
  309.                      nt = nt1;
  310.                      }
  311.                   else
  312.                      out--;    /* back up to begin tabbing */
  313.                   }
  314.                else
  315.                   out--;    /* back up to begin tabbing */
  316.                while (nt <= target)  {
  317.                   inserted = 1;
  318.                   *out++ = '\t';    /* put tabs to tab positions */
  319.                   col = nt;
  320.                   nxttab(&nt, &tablst, endlst, &last, &interval);
  321.                   }
  322.                while (col++ < target)
  323.                   *out++ = ' ';        /* complete gap with spaces */
  324.                }
  325.             col = target;
  326.             break;
  327.          default:
  328.             if (isprint(c))
  329.                col++;
  330.          }
  331.  
  332.       /*
  333.        * Return new string if indeed tabs were inserted; otherwise return
  334.        *  original string (and reset strfree) to conserve memory.
  335.        */
  336.       if (inserted) {
  337.      long n;
  338.          StrLen(result) = DiffPtrs(out,StrLoc(result));
  339.      n = DiffPtrs(out,strfree);        /* note the deallocation */
  340.      if (n < 0)
  341.         EVVal(-n, E_StrDeAlc);
  342.      else
  343.         EVVal(n, E_String);
  344.      strtotal += DiffPtrs(out,strfree);
  345.          strfree = out;                /* give back unused space */
  346.          return result;                /* return new string */
  347.          }
  348.       else {
  349.      long n = DiffPtrs(StrLoc(result),strfree); /* note the deallocation */
  350.      if (n < 0)
  351.         EVVal(-n, E_StrDeAlc);
  352.      else
  353.         EVVal(n, E_String);
  354.      strtotal += DiffPtrs(StrLoc(result),strfree);
  355.          strfree = StrLoc(result);        /* reset free pointer */
  356.          return s;                /* return original string */
  357.      }
  358.       }
  359. end
  360.  
  361. /*
  362.  * nxttab -- helper routine for entab and detab, returns next tab
  363.  *   beyond col
  364.  */
  365.  
  366. void nxttab(col, tablst, endlst, last, interval)
  367. C_integer *col;
  368. dptr *tablst;
  369. dptr endlst;
  370. C_integer *last;
  371. C_integer *interval;
  372.    {
  373.    /*
  374.     * Look for the right tab stop.
  375.     */
  376.    while (*tablst < endlst && *col >= IntVal((*tablst)[0])) {
  377.       ++*tablst;
  378.       if (*tablst == endlst)
  379.          *interval = IntVal((*tablst)[-1]) - *last;
  380.       else {
  381.          *last = IntVal((*tablst)[-1]);
  382.          }
  383.       }
  384.    if (*tablst >= endlst)
  385.       *col = *col + *interval - (*col - *last) % *interval;
  386.    else
  387.       *col = IntVal((*tablst)[0]);
  388.    }
  389.  
  390.  
  391. "left(s1,i,s2) - pad s1 on right with s2 to length i."
  392.  
  393. function{1} left(s1,n,s2)
  394.    FstrSetup  /* includes body { */
  395.  
  396.       /*
  397.        * If we are extracting the left part of a large string (not padding),
  398.        * just construct a descriptor.
  399.        */
  400.       if (n <= StrLen(s1)) {
  401.      return string(n, StrLoc(s1));
  402.          }
  403.  
  404.       /*
  405.        * Get n bytes of string space.  Start at the right end of the new
  406.        *  string and copy s2 into the new string as many times as it fits.
  407.        *  Note that s2 is copied from right to left.
  408.        */
  409.       Protect(sbuf = alcstr(NULL, n), runerr(0));
  410.  
  411.       slen = StrLen(s2);
  412.       s3 = StrLoc(s2);
  413.       s = sbuf + n;
  414.       while (s > sbuf) {
  415.          st = s3 + slen;
  416.          while (st > s3 && s > sbuf)
  417.             *--s = *--st;
  418.          }
  419.  
  420.       /*
  421.        * Copy up to n bytes of s1 into the new string, starting at the left end
  422.        */
  423.       s = sbuf;
  424.       slen = StrLen(s1);
  425.       st = StrLoc(s1);
  426.       if (slen > n)
  427.          slen = n;
  428.       while (slen-- > 0)
  429.          *s++ = *st++;
  430.  
  431.       /*
  432.        * Return the new string.
  433.        */
  434.       return string(n, sbuf);
  435.       }
  436. end
  437.  
  438.  
  439. "map(s1,s2,s3) - map s1, using s2 and s3."
  440.  
  441. function{1} map(s1,s2,s3)
  442.    /*
  443.     * s1 must be a string; s2 and s3 default to (string conversions of)
  444.     *  &ucase and &lcase, respectively.
  445.     */
  446.    if !cnv:string(s1) then
  447.       runerr(103,s1)
  448. #if COMPILER
  449.    if !def:string(s2, ucase) then
  450.       runerr(103,s2)
  451.    if !def:string(s3, lcase) then
  452.       runerr(103,s3)
  453. #endif                        /* COMPILER */
  454.  
  455.    abstract {
  456.       return string
  457.       }
  458.    body {
  459.       register int i;
  460.       register word slen;
  461.       register char *str1, *str2, *str3;
  462.       static char maptab[256];
  463.  
  464. #if !COMPILER
  465.       if (is:null(s2))
  466.          s2 = ucase;
  467.       if (is:null(s3))
  468.          s3 = lcase;
  469. #endif                    /* !COMPILER */
  470.       /*
  471.        * If s2 and s3 are the same as for the last call of map,
  472.        *  the current values in maptab can be used. Otherwise, the
  473.        *  mapping information must be recomputed.
  474.        */
  475.       if (!EqlDesc(maps2,s2) || !EqlDesc(maps3,s3)) {
  476.          maps2 = s2;
  477.          maps3 = s3;
  478.  
  479. #if !COMPILER
  480.          if (!cnv:string(s2,s2))
  481.             runerr(103,s2);
  482.          if (!cnv:string(s3,s3))
  483.             runerr(103,s3);
  484. #endif                    /* !COMPILER */
  485.          /*
  486.           * s2 and s3 must be of the same length
  487.           */
  488.          if (StrLen(s2) != StrLen(s3))
  489.             runerr(208);
  490.  
  491.          /*
  492.           * The array maptab is used to perform the mapping.  First,
  493.           *  maptab[i] is initialized with i for i from 0 to 255.
  494.           *  Then, for each character in s2, the position in maptab
  495.           *  corresponding to the value of the character is assigned
  496.           *  the value of the character in s3 that is in the same
  497.           *  position as the character from s2.
  498.           */
  499.          str2 = StrLoc(s2);
  500.          str3 = StrLoc(s3);
  501.          for (i = 0; i <= 255; i++)
  502.             maptab[i] = i;
  503.          for (slen = 0; slen < StrLen(s2); slen++)
  504.             maptab[str2[slen]&0377] = str3[slen];
  505.          }
  506.  
  507.       if (StrLen(s1) == 0) {
  508.          return emptystr;
  509.          }
  510.  
  511.       /*
  512.        * The result is a string the size of s1; create the result
  513.        *  string, but specify no value for it.
  514.        */
  515.       StrLen(result) = slen = StrLen(s1);
  516.       Protect(StrLoc(result) = alcstr(NULL, slen), runerr(0));
  517.       str1 = StrLoc(s1);
  518.       str2 = StrLoc(result);
  519.  
  520.       /*
  521.        * Run through the string, using values in maptab to do the
  522.        *  mapping.
  523.        */
  524.       while (slen-- > 0)
  525.          *str2++ = maptab[(*str1++)&0377];
  526.  
  527.       return result;
  528.       }
  529. end
  530.  
  531.  
  532. "repl(s,i) - concatenate i copies of string s."
  533.  
  534. function{1} repl(s,n)
  535.  
  536.    if !cnv:string(s) then
  537.       runerr(103,s)
  538.  
  539.    if !cnv:C_integer(n) then
  540.       runerr(101,n)
  541.  
  542.    abstract {
  543.        return string
  544.        }
  545.  
  546.    body {
  547.       register C_integer cnt;
  548.       register C_integer slen;
  549.       register C_integer size;
  550.       register char * resloc, * sloc, *floc;
  551.  
  552.       if (n < 0) {
  553.          irunerr(205,n);
  554.          errorfail;
  555.          }
  556.  
  557.       slen = StrLen(s);
  558.       /*
  559.        * Return an empty string if n is 0 or if s is the empty string.
  560.        */
  561.       if ((n == 0) || (slen==0))
  562.          return emptystr;
  563.  
  564.       /*
  565.        * Make sure the resulting string will not be too long.
  566.        */
  567.       size = n * slen;
  568.       if (size > MaxStrLen) {
  569.          irunerr(205,n);
  570.          errorfail;
  571.          }
  572.  
  573.       /*
  574.        * Make result a descriptor for the replicated string.
  575.        */
  576.       Protect(resloc = alcstr(NULL, size), runerr(0));
  577.  
  578.       StrLoc(result) = resloc;
  579.       StrLen(result) = size;
  580.  
  581.       /*
  582.        * Fill the allocated area with copies of s.
  583.        */
  584.       sloc = StrLoc(s);
  585.       if (slen == 1)
  586.          memset(resloc, *sloc, size);
  587.       else {
  588.          while (--n >= 0) {
  589.             floc = sloc;
  590.             cnt = slen;
  591.             while (--cnt >= 0)
  592.                *resloc++ = *floc++;
  593.             }
  594.          }
  595.  
  596.       return result;
  597.       }
  598. end
  599.  
  600.  
  601. "reverse(s) - reverse string s."
  602.  
  603. function{1} reverse(s)
  604.  
  605.    if !cnv:string(s) then
  606.       runerr(103,s)
  607.  
  608.    abstract {
  609.       return string
  610.       }
  611.    body {
  612.       register char c, *floc, *lloc;
  613.       register word slen;
  614.  
  615.       /*
  616.        * Allocate a copy of s.
  617.        */
  618.       slen = StrLen(s);
  619.       Protect(StrLoc(result) = alcstr(StrLoc(s), slen), runerr(0));
  620.       StrLen(result) = slen;
  621.  
  622.       /*
  623.        * Point floc at the start of s and lloc at the end of s.  Work floc
  624.        *  and sloc along s in opposite directions, swapping the characters
  625.        *  at floc and lloc.
  626.        */
  627.       floc = StrLoc(result);
  628.       lloc = floc + --slen;
  629.       while (floc < lloc) {
  630.          c = *floc;
  631.          *floc++ = *lloc;
  632.          *lloc-- = c;
  633.          }
  634.       return result;
  635.       }
  636. end
  637.  
  638.  
  639. "right(s1,i,s2) - pad s1 on left with s2 to length i."
  640.  
  641. function{1} right(s1,n,s2)
  642.    FstrSetup  /* includes body { */
  643.       /*
  644.        * If we are extracting the right part of a large string (not padding),
  645.        * just construct a descriptor.
  646.        */
  647.       if (n <= StrLen(s1)) {
  648.      return string(n, StrLoc(s1) + StrLen(s1) - n);
  649.          }
  650.  
  651.       /*
  652.        * Get n bytes of string space.  Start at the left end of the new
  653.        *  string and copy s2 into the new string as many times as it fits.
  654.        */
  655.       Protect(sbuf = alcstr(NULL, n), runerr(0));
  656.  
  657.       slen = StrLen(s2);
  658.       s3 = StrLoc(s2);
  659.       s = sbuf;
  660.       while (s < sbuf + n) {
  661.          st = s3;
  662.          while (st < s3 + slen && s < sbuf + n)
  663.             *s++ = *st++;
  664.          }
  665.  
  666.       /*
  667.        * Copy s1 into the new string, starting at the right end and copying
  668.        * s2 from right to left.  If *s1 > n, only copy n bytes.
  669.        */
  670.       s = sbuf + n;
  671.       slen = StrLen(s1);
  672.       st = StrLoc(s1) + slen;
  673.       if (slen > n)
  674.          slen = n;
  675.       while (slen-- > 0)
  676.          *--s = *--st;
  677.  
  678.       /*
  679.        * Return the new string.
  680.        */
  681.       return string(n, sbuf);
  682.       }
  683. end
  684.  
  685.  
  686. "trim(s,c) - trim trailing characters in c from s."
  687.  
  688. function{1} trim(s,c)
  689.  
  690.    if !cnv:string(s) then
  691.       runerr(103, s)
  692.    /*
  693.     * c defaults to a cset containing a blank.
  694.     */
  695.    if !def:tmp_cset(c,blankcs) then
  696.       runerr(104, c)
  697.  
  698.    abstract {
  699.       return string
  700.       }
  701.  
  702.    body {
  703.       char *sloc;
  704.       C_integer slen;
  705.  
  706.       /*
  707.        * Start at the end of s and then back up until a character that is
  708.        *  not in c is found.  The actual trimming is done by having a
  709.        *  descriptor that points at a substring of s, but with the length
  710.        *  reduced.
  711.        */
  712.       slen = StrLen(s);
  713.       sloc = StrLoc(s) + slen - 1;
  714.       while (sloc >= StrLoc(s) && Testb(*sloc, c)) {
  715.          sloc--;
  716.          slen--;
  717.          }
  718.       return string(slen, StrLoc(s));
  719.       }
  720. end
  721.