BSD 4_2 development

author CSRG <csrg@ucbvax.Berkeley.EDU>

Wed, 11 May 1983 14:21:48 +0000 (06:21 -0800)

committer CSRG <csrg@ucbvax.Berkeley.EDU>

Wed, 11 May 1983 14:21:48 +0000 (06:21 -0800)
author CSRG <csrg@ucbvax.Berkeley.EDU>
Wed, 11 May 1983 14:21:48 +0000 (06:21 -0800)
committer CSRG <csrg@ucbvax.Berkeley.EDU>
Wed, 11 May 1983 14:21:48 +0000 (06:21 -0800)
diff --git a/usr/src/new/new/icon/cmp/functions/abs.c b/usr/src/new/new/icon/cmp/functions/abs.c

new file mode 100644 (file)

index 0000000..c164cd9
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/abs.c
@@ -0,0 +1,40 @@
+#include "../h/rt.h"
+
+/*
+ * abs(x) - absolute value of x.
+ */
+
+Xabs(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   union numeric result;
+
+   switch (cvnum(&arg1, &result)) {
+      case T_LONGINT:
+         if (result.i < 0L)
+            result.i = -result.i;
+        mkint(result.i, &arg0);
+         break;
+
+      case T_REAL:
+         if (result.r < 0.0)
+           result.r = -result.r;
+         mkreal(result.r, &arg0);
+         break;
+
+      default:
+         runerr(102, &arg1);
+      }
+   }
+
+struct b_iproc Babs = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xabs),
+   1,
+   -1,
+   0,
+   0,
+   {3, "abs"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/any.c b/usr/src/new/new/icon/cmp/functions/any.c

new file mode 100644 (file)

index 0000000..df46f8d
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/any.c
@@ -0,0 +1,45 @@
+#include "../h/rt.h"
+
+/*
+ * any(c,s,i,j) - test if first character of s[i:j] is in c.
+ */
+
+Xany(nargs, arg4, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg4, arg3, arg2, arg1, arg0;
+   {
+   register int i, j;
+   long l1, l2;
+   int *cs, csbuf[CSETSIZE];
+   char sbuf[MAXSTRING];
+
+   if (cvcset(&arg1, &cs, csbuf) == NULL)
+      runerr(104, &arg1);
+   if (defstr(&arg2, sbuf, &k_subject))
+      defint(&arg3, &l1, k_pos);
+   else
+      defint(&arg3, &l1, 1);
+   defint(&arg4, &l2, 0);
+
+   i = cvpos(l1, STRLEN(arg2));
+   j = cvpos(l2, STRLEN(arg2));
+   if (i > j)
+      i = j;
+
+   if (!tstb(STRLOC(arg2)[i-1], cs))
+      fail();
+
+   arg0.type = D_INTEGER;
+   INTVAL(arg0) = i + 1;
+   }
+
+struct b_iproc Bany = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xany),
+   4,
+   -1,
+   0,
+   0,
+   {3, "any"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/bal.c b/usr/src/new/new/icon/cmp/functions/bal.c

new file mode 100644 (file)

index 0000000..0177269
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/bal.c
@@ -0,0 +1,69 @@
+#include "../h/rt.h"
+
+/*
+ * bal(c1,c2,c3,s,i,j) - match a balanced substring of s[i:j].
+ * Generator.
+ */
+
+Xbal(nargs, arg6, arg5, arg4, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg6, arg5, arg4, arg3, arg2, arg1, arg0;
+   {
+   register int i, j, cnt;
+   register c;
+   int t;
+   long l1, l2;
+   int *cs1, *cs2, *cs3;
+   int csbuf1[CSETSIZE], csbuf2[CSETSIZE], csbuf3[CSETSIZE];
+   char sbuf[MAXSTRING];
+   static int lpar[CSETSIZE] =
+      cset_display(0, 0, 0400, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
+   static int rpar[CSETSIZE] =
+      cset_display(0, 0, 01000, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
+
+   defcset(&arg1, &cs1, csbuf1, k_cset.bits);
+   defcset(&arg2, &cs2, csbuf2, lpar);
+   defcset(&arg3, &cs3, csbuf3, rpar);
+   if (defstr(&arg4, sbuf, &k_subject))
+      defint(&arg5, &l1, k_pos);
+   else
+      defint(&arg5, &l1, 1);
+   defint(&arg6, &l2, 0);
+
+   i = cvpos(l1, STRLEN(arg4));
+   j = cvpos(l2, STRLEN(arg4));
+   if (i > j) {
+      t = i;
+      i = j;
+      j = t;
+      }
+
+   cnt = 0;
+   while (i < j) {             /* suspend for each occurrence */
+      c = STRLOC(arg4)[i-1];
+      if (cnt == 0 && tstb(c, cs1)) {
+         arg0.type = D_INTEGER;
+         INTVAL(arg0) = i;
+        suspend();
+        }
+      if (tstb(c, cs2))
+         cnt++;
+      else if (tstb(c, cs3))
+         cnt--;
+      if (cnt < 0)
+         fail();
+      i++;
+      }
+   fail();
+   }
+
+struct b_iproc Bbal = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xbal),
+   6,
+   -1,
+   0,
+   0,
+   {3, "bal"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/center.c b/usr/src/new/new/icon/cmp/functions/center.c

new file mode 100644 (file)

index 0000000..70315bd
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/center.c
@@ -0,0 +1,79 @@
+#include "../h/rt.h"
+
+/*
+ * center(s1,n,s2) - pad s1 on left and right with s2 to length n.
+ */
+
+Xcenter(nargs, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg3, arg2, arg1, arg0;
+   {
+   register char *s, *st;
+   int cnt, slen;
+   int tmp, hcnt;
+   char *sbuf, *s3;
+   char sbuf1[MAXSTRING], sbuf2[MAXSTRING];
+   extern char *alcstr();
+
+   if (cvstr(&arg1, sbuf1) == NULL)
+      runerr(103, &arg1);
+   defshort(&arg2, 1);
+   if ((cnt = arg2.value.integer) < 0)
+      runerr(205, &arg2);
+   defstr(&arg3, sbuf2, &blank);
+
+   sneed(cnt);
+   if (STRLEN(arg3) == 0) {
+      slen = 1;
+      s3 = " ";
+      }
+   else {
+      slen = STRLEN(arg3);
+      s3 = STRLOC(arg3);
+      }
+
+   sbuf = alcstr(NULL, cnt);            /* use string space as buffer */
+   hcnt = cnt / 2;
+   s = sbuf + cnt ;                          /* pad on right */
+   while (s > sbuf + hcnt) {
+      st = s3 + slen;
+      while (st > s3 && s > sbuf + hcnt)
+         *--s = *--st;
+      }
+
+   s = sbuf;                                 /* pad on left */
+   while (s < sbuf + hcnt) {
+      st = s3;
+      while (st < s3 + slen && s < sbuf + hcnt)
+         *s++ = *st++;
+      }
+
+   slen = STRLEN(arg1);
+
+   if (cnt < slen) { /* s1 is larger than field to center it in */
+      s = sbuf;
+      st = STRLOC(arg1) + slen/2 - hcnt + (~cnt&slen&1);
+      }
+   else {
+      s = sbuf + hcnt - slen/2 - (~cnt&slen&1);
+      st = STRLOC(arg1);
+      }
+   if (slen > cnt)
+      slen = cnt;
+   while (slen-- > 0)
+      *s++ = *st++;
+
+   STRLEN(arg0) = cnt;
+   STRLOC(arg0) = sbuf;
+   }
+
+struct b_iproc Bcenter = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xcenter),
+   3,
+   -1,
+   0,
+   0,
+   {6, "center"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/close.c b/usr/src/new/new/icon/cmp/functions/close.c

new file mode 100644 (file)

index 0000000..d6e6874
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/close.c
@@ -0,0 +1,40 @@
+#include "../h/rt.h"
+
+/*
+ * close(f) - close file f.
+ */
+
+Xclose(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register int i;
+
+   deref(&arg1);
+   if (QUAL(arg1) || TYPE(arg1) != T_FILE)
+      runerr(105, &arg1);
+
+   for (i = 0; i < numbufs; i++) {
+      if (bufused[i] == BLKLOC(arg1)->file.fd) {
+         bufused[i] = NULL;
+         break;
+         }
+      }
+   if (BLKLOC(arg1)->file.status & FS_PIPE)
+      pclose(BLKLOC(arg1)->file.fd);
+   else
+      fclose(BLKLOC(arg1)->file.fd);
+   BLKLOC(arg1)->file.status = 0;
+   arg0 = arg1;
+   }
+
+struct b_iproc Bclose = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xclose),
+   1,
+   -1,
+   0,
+   0,
+   {5, "close"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/copy.c b/usr/src/new/new/icon/cmp/functions/copy.c

new file mode 100644 (file)

index 0000000..65c427c
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/copy.c
@@ -0,0 +1,87 @@
+#include "../h/rt.h"
+#include "../h/record.h"
+
+/*
+ * copy(x) - make a copy of object x.
+ */
+
+Xcopy(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register int i, j;
+   struct descrip d, *dp, *d1, *d2;
+   union block *bp, *ep, **tp;
+   extern struct b_table *alctable();
+   extern struct b_telem *alctelem();
+   extern union block *allocate();
+
+   deref(&arg1);
+
+   if (NULLDESC(arg1) || QUAL(arg1))
+      arg0 = arg1;
+   else {
+      switch (TYPE(arg1)) {
+         case T_INTEGER:
+#ifndef BIT32
+         case T_LONGINT:
+#endif
+         case T_REAL:
+         case T_FILE:
+         case T_CSET:
+         case T_PROC:
+         case T_ESTACK:
+            arg0 = arg1;
+            break;
+
+         case T_LIST:
+           cplist(&arg1, &arg0, 1, BLKLOC(arg1)->list.cursize + 1);
+            break;
+
+         case T_TABLE:
+           hneed((sizeof(struct b_table)) +
+                 (sizeof(struct b_telem)) * BLKLOC(arg1)->table.cursize);
+            bp = alctable(0);
+            bp->table = BLKLOC(arg1)->table;
+            for (i = 0; i < NBUCKETS; i++) {
+               tp = &(BLKLOC(bp->table.buckets[i]));
+               for (ep = *tp; ep != NULL; ep = *tp) {
+                  *tp = alctelem();
+                  (*tp)->telem = ep->telem;
+                  tp = &(BLKLOC((*tp)->telem.blink));
+                  }
+               }
+            arg0.type = D_TABLE;
+            BLKLOC(arg0) = bp;
+            break;
+
+         case T_RECORD:
+           i = BLKLOC(arg1)->record.size;
+           hneed(i);
+           bp = allocate(i);
+            bp->record = BLKLOC(arg1)->record;
+            i = bp->record.recptr->nfields;
+            d1 = bp->record.fields;
+           d2 = BLKLOC(arg1)->record.fields;
+           while (i--)
+               *d1++ = *d2++;
+            arg0.type = D_RECORD;
+            BLKLOC(arg0) = bp;
+            break;
+
+         default:
+            syserr("copy: illegal datatype.");
+         }
+      }
+   }
+
+struct b_iproc Bcopy = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xcopy),
+   1,
+   -1,
+   0,
+   0,
+   {4, "copy"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/cset.c b/usr/src/new/new/icon/cmp/functions/cset.c

new file mode 100644 (file)

index 0000000..e3156d2
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/cset.c
@@ -0,0 +1,41 @@
+#include "../h/rt.h"
+
+/*
+ * cset(x) - convert x to cset.
+ */
+
+Xcset(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register int i;
+   register struct b_cset *bp;
+   int *cs, csbuf[CSETSIZE];
+   extern struct b_cset *alccset();
+
+   hneed(sizeof(struct b_cset));
+
+   deref(&arg1);
+
+   if (!QUAL(arg1) && TYPE(arg1) == T_CSET)
+      arg0 = arg1;
+   else if (cvcset(&arg1, &cs, csbuf) != NULL) {
+      arg0.type = D_CSET;
+      BLKLOC(arg0) = bp = alccset();
+      for (i = 0; i < CSETSIZE; i++)
+        bp->bits[i] = cs[i];
+      }
+   else
+      fail();
+   }
+
+struct b_iproc Bcset = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xcset),
+   1,
+   -1,
+   0,
+   0,
+   {4, "cset"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/display.c b/usr/src/new/new/icon/cmp/functions/display.c

new file mode 100644 (file)

index 0000000..9b44dbb
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/display.c
@@ -0,0 +1,236 @@
+#include "../h/rt.h"
+#ifdef VAX
+/*
+ * display(i,f) - display local variables of i most recent
+ * procedure activations, plus global variables.
+ * Output to file f (default &errout).
+ */
+
+Xdisplay(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register int *ap, *r5; /* Note that position is important, we assume
+                       that ap is in r11, and r5 is in r10 */
+   register struct descrip *dp;
+   register struct descrip *np;
+   register int n;
+   long l;
+   int count;
+   FILE *f;
+   struct b_proc *bp;
+   extern int *boundary;
+#ifdef INT
+   extern struct descrip *globals, *eglobals;
+   extern struct descrip *gnames;
+   extern struct descrip *statics;
+#endif INT
+#ifdef CMP
+   extern struct descrip globals[], eglobals[];
+   extern struct descrip gnames[];
+   extern struct descrip statics[];
+#endif CMP
+
+   defint(&arg1, &l, k_level);
+   deffile(&arg2, &errout);
+   f = BLKLOC(arg2)->file.fd;
+   if ((BLKLOC(arg2)->file.status & FS_WRITE) == 0)
+      runerr(213, &arg2);
+
+   if (l < 0)
+      runerr(205, &arg1);
+   else if (l > k_level)
+      count = k_level;
+   else
+      count = l;
+
+   r5 = boundary;              /* start r5 at most recent procedure frame */
+   while (count--) {
+      ap = r5[2];
+      r5 = r5[3];
+      n = ap[1];               /* get number of arguments */
+      dp = ap + 2 + 2*n;       /* calculate address of procedure descriptor*/
+      bp = BLKLOC(*dp);                /* get address of procedure block */
+
+      /* print procedure name */
+      putstr(f, STRLOC(bp->pname), STRLEN(bp->pname));
+      fprintf(f, " local identifiers:\n");
+
+      /* print arguments */
+      np = bp->lnames;
+      for (n = bp->nparam; n > 0; n--) {
+        fprintf(f, "   ");
+        putstr(f, STRLOC(*np), STRLEN(*np));
+         fprintf(f, " = ");
+        outimage(f, --dp, 0);
+        putc('\n', f);
+        np++;
+        }
+
+      /* print local dynamics */
+      dp = r5 - 2;
+      for (n = bp->ndynam; n > 0; n--) {
+        fprintf(f, "   ");
+        putstr(f, STRLOC(*np), STRLEN(*np));
+         fprintf(f, " = ");
+        outimage(f, --dp, 0);
+        putc('\n', f);
+        np++;
+        }
+
+      /* print local statics */
+      dp = &statics[bp->fstatic];
+      for (n = bp->nstatic; n > 0; n--) {
+        fprintf(f, "   ");
+        putstr(f, STRLOC(*np), STRLEN(*np));
+         fprintf(f, " = ");
+        outimage(f, dp++, 0);
+        putc('\n', f);
+        np++;
+        }
+
+      }
+
+   fprintf(f, "global identifiers:\n");
+   dp = globals;
+   np = gnames;
+   while (dp < eglobals) {
+      fprintf(f, "   ");
+      putstr(f, STRLOC(*np), STRLEN(*np));
+      fprintf(f, " = ");
+      outimage(f, dp++, 0);
+      putc('\n', f);
+      np++;
+      }
+   fflush(f);
+   arg0 = nulldesc;            /* return &null */
+   }
+
+struct b_iproc Bdisplay = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xdisplay),
+   2,
+   -1,
+   0,
+   0,
+   {7, "display"}
+   };
+#endif VAX
+#ifdef PDP11
+/*
+ * display(i,f) - display local variables of i most recent
+ * procedure activations, plus global variables.
+ * Output to file f (default &errout).
+ */
+
+Xdisplay(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register struct descrip *dp;
+   register struct descrip *np;
+   register int n;
+   register int *r5;
+   long l;
+   int count;
+   static struct descrip errout = {D_FILE, &k_errout};
+   FILE *f;
+   struct b_proc *bp;
+   extern int *boundary;
+#ifdef INT
+   extern struct descrip *globals, *eglobals;
+   extern struct descrip *gnames;
+   extern struct descrip *statics;
+#endif INT
+#ifdef CMP
+   extern struct descrip globals[], eglobals[];
+   extern struct descrip gnames[];
+   extern struct descrip statics[];
+#endif CMP
+
+   defint(&arg1, &l, k_level);
+   deffile(&arg2, &errout);
+   f = BLKLOC(arg2)->file.fd;
+   if ((BLKLOC(arg2)->file.status & FS_WRITE) == 0)
+      runerr(213, &arg2);
+
+   if (l < 0)
+      runerr(205, &arg1);
+   else if (l > k_level)
+      count = k_level;
+   else
+      count = l;
+
+   r5 = *boundary;             /* start r5 at most recent procedure frame */
+   while (count--) {
+      n = r5[2];               /* get number of arguments */
+      dp = r5 + 3 + 2*n;       /* calculate address of procedure descriptor */
+      bp = BLKLOC(*dp);                /* get address of procedure block */
+
+      /* print procedure name */
+      putstr(f, STRLOC(bp->pname), STRLEN(bp->pname));
+      fprintf(f, " local identifiers:\n");
+
+      /* print arguments */
+      np = bp->lnames;
+      for (n = bp->nparam; n > 0; n--) {
+        fprintf(f, "   ");
+        putstr(f, STRLOC(*np), STRLEN(*np));
+         fprintf(f, " = ");
+        outimage(f, --dp, 0);
+        putc('\n', f);
+        np++;
+        }
+
+      /* print local dynamics */
+      dp = r5 - 5;
+      for (n = bp->ndynam; n > 0; n--) {
+        fprintf(f, "   ");
+        putstr(f, STRLOC(*np), STRLEN(*np));
+         fprintf(f, " = ");
+        outimage(f, --dp, 0);
+        putc('\n', f);
+        np++;
+        }
+
+      /* print local statics */
+      dp = &statics[bp->fstatic];
+      for (n = bp->nstatic; n > 0; n--) {
+        fprintf(f, "   ");
+        putstr(f, STRLOC(*np), STRLEN(*np));
+         fprintf(f, " = ");
+        outimage(f, dp++, 0);
+        putc('\n', f);
+        np++;
+        }
+
+      r5 = *r5;
+      }
+
+   fprintf(f, "global identifiers:\n");
+   dp = globals;
+   np = gnames;
+   while (dp < eglobals) {
+      fprintf(f, "   ");
+      putstr(f, STRLOC(*np), STRLEN(*np));
+      fprintf(f, " = ");
+      outimage(f, dp++, 0);
+      putc('\n', f);
+      np++;
+      }
+   fflush(f);
+   arg0 = nulldesc;            /* return &null */
+   }
+
+struct b_iproc Bdisplay = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xdisplay),
+   2,
+   -1,
+   0,
+   0,
+   {7, "display"}
+   };
+#endif PDP11
diff --git a/usr/src/new/new/icon/cmp/functions/exit.c b/usr/src/new/new/icon/cmp/functions/exit.c

new file mode 100644 (file)

index 0000000..d900573
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/exit.c
@@ -0,0 +1,24 @@
+#include "../h/rt.h"
+
+/*
+ * exit(status) - exit process with status.
+ */
+
+Xexit(nargs, arg1)
+int nargs;
+struct descrip arg1;
+   {
+   defshort(&arg1, 0);
+   c_exit(arg1.value.integer);
+   }
+
+struct b_iproc Bexit = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xexit),
+   1,
+   -1,
+   0,
+   0,
+   {4, "exit"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/find.c b/usr/src/new/new/icon/cmp/functions/find.c

new file mode 100644 (file)

index 0000000..afc7e03
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/find.c
@@ -0,0 +1,62 @@
+#include "../h/rt.h"
+
+/*
+ * find(s1,s2,i,j) - find string s1 in s2[i:j].
+ * Returns position in s2 of beginning of s1.
+ * Generator.
+ */
+
+Xfind(nargs, arg4, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg4, arg3, arg2, arg1, arg0;
+   {
+   register int l;
+   register char *s1, *s2;
+   int i, j, t;
+   long l1, l2;
+   char sbuf1[MAXSTRING], sbuf2[MAXSTRING];
+
+   if (cvstr(&arg1, sbuf1) == NULL)
+      runerr(103, &arg1);
+   if (defstr(&arg2, sbuf2, &k_subject))
+      defint(&arg3, &l1, k_pos);
+   else
+      defint(&arg3, &l1, 1);
+   defint(&arg4, &l2, 0);
+
+   i = cvpos(l1, STRLEN(arg2));
+   j = cvpos(l2, STRLEN(arg2));
+   if (i > j) {
+      t = i;
+      i = j;
+      j = t;
+      }
+
+   while (i <= j - STRLEN(arg1)) {
+      s1 = STRLOC(arg1);
+      s2 = STRLOC(arg2) + i - 1;
+      l = STRLEN(arg1);
+      do {
+        if (l-- <= 0) {
+           arg0.type = D_INTEGER;
+           INTVAL(arg0) = i;
+            suspend();
+           break;
+           }
+        } while (*s1++ == *s2++);
+      i++;
+      }
+
+   fail();
+   }
+
+struct b_iproc Bfind = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xfind),
+   4,
+   -1,
+   0,
+   0,
+   {4, "find"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/get.c b/usr/src/new/new/icon/cmp/functions/get.c

new file mode 100644 (file)

index 0000000..941696f
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/get.c
@@ -0,0 +1,19 @@
+#include "../h/rt.h"
+
+/*
+ * get(x) - get an element from end of list x.
+ * Synonym for pop(x).
+ */
+
+extern Xpop();
+
+struct b_iproc Bget = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xpop),
+   1,
+   -1,
+   0,
+   0,
+   {3, "get"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/image.c b/usr/src/new/new/icon/cmp/functions/image.c

new file mode 100644 (file)

index 0000000..80bc199
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/image.c
@@ -0,0 +1,276 @@
+#include "../h/rt.h"
+#include "../h/record.h"
+
+/*
+ * image(x) - return string giving image of object x.
+ */
+
+Ximage(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register int len, outlen, rnlen;
+   register char *s;
+   register union block *bp;
+   char *type;
+   extern char *alcstr();
+   extern struct descrip *cstos();
+   char sbuf[MAXSTRING];
+   FILE *fd;
+
+   deref(&arg1);
+
+   if (NULLDESC(arg1)) {
+      STRLOC(arg0) = "&null";
+      STRLEN(arg0) = 5;
+      return;
+      }
+
+   if (QUAL(arg1)) {
+      sneed(prescan(&arg1) + 2);
+      len = STRLEN(arg1);
+      s = STRLOC(arg1);
+      outlen = 2;
+      STRLOC(arg0) = alcstr("\"", 1);
+                     while (len-- > 0)
+                        outlen += doimage(*s++, '"');
+                     alcstr("\"", 1);
+      STRLEN(arg0) = outlen;
+      return;
+      }
+
+   switch (TYPE(arg1)) {
+      case T_INTEGER:
+#ifndef BIT32
+      case T_LONGINT:
+#endif
+      case T_REAL:
+         cvstr(&arg1, sbuf);
+        len = STRLEN(arg1);
+         sneed(len);
+        STRLOC(arg0) = alcstr(STRLOC(arg1), len);
+        STRLEN(arg0) = len;
+         return;
+
+      case T_CSET:
+         if (BLKLOC(arg1) == &k_ascii) {
+            STRLOC(arg0) = "&ascii";
+            STRLEN(arg0) = 6;
+            return;
+            }
+         else if (BLKLOC(arg1) == &k_cset) {
+            STRLOC(arg0) = "&cset";
+            STRLEN(arg0) = 5;
+            return;
+            }
+         else if (BLKLOC(arg1) == &k_lcase) {
+            STRLOC(arg0) = "&lcase";
+            STRLEN(arg0) = 6;
+            return;
+            }
+         else if (BLKLOC(arg1) == &k_ucase) {
+            STRLOC(arg0) = "&ucase";
+            STRLEN(arg0) = 6;
+            return;
+            }
+         cvstr(&arg1, sbuf);
+         sneed(prescan(&arg1) + 2);
+         len = STRLEN(arg1);
+         s = STRLOC(arg1);
+         outlen = 2;
+         STRLOC(arg0) = alcstr("'", 1);
+                        while (len-- > 0)
+                           outlen += doimage(*s++, '\'');
+                        alcstr("'", 1);
+         STRLEN(arg0) = outlen;
+         return;
+
+      case T_FILE:
+         if ((fd = BLKLOC(arg1)->file.fd) == stdin) {
+            STRLEN(arg0) = 6;
+            STRLOC(arg0) = "&input";
+            }
+         else if (fd == stdout) {
+            STRLEN(arg0) = 7;
+            STRLOC(arg0) = "&output";
+            }
+         else if (fd == stderr) {
+            STRLEN(arg0) = 7;
+            STRLOC(arg0) = "&errout";
+            }
+         else {
+            sneed(prescan(&BLKLOC(arg1)->file.fname)+6);
+            len = STRLEN(BLKLOC(arg1)->file.fname);
+            s = STRLOC(BLKLOC(arg1)->file.fname);
+            outlen = 6;
+            STRLOC(arg0) = alcstr("file(", 5);
+                           while (len-- > 0)
+                              outlen += doimage(*s++, '\0');
+                          alcstr(")", 1);
+            STRLEN(arg0) = outlen;
+            }
+         return;
+
+      case T_PROC:
+         len = STRLEN(BLKLOC(arg1)->proc.pname);
+         s = STRLOC(BLKLOC(arg1)->proc.pname);
+        switch (BLKLOC(arg1)->proc.ndynam) {
+           default:  type = "procedure "; break;
+           case -1:  type = "function "; break;
+           case -2:  type = "record constructor "; break;
+           }
+         outlen = strlen(type);
+         sneed(len + outlen);
+        STRLOC(arg0) = alcstr(type, outlen);
+                        alcstr(s, len);
+         STRLEN(arg0) = len + outlen;
+         return;
+
+      case T_LIST:
+         bp = BLKLOC(arg1);
+         sprintf(sbuf, "list(%d)", bp->list.cursize);
+         len = strlen(sbuf);
+         sneed(len);
+         STRLOC(arg0) = alcstr(sbuf, len);
+         STRLEN(arg0) = len;
+         return;
+
+      case T_TABLE:
+         bp = BLKLOC(arg1);
+         sprintf(sbuf, "table(%d)", bp->table.cursize);
+         len = strlen(sbuf);
+         sneed(len);
+         STRLOC(arg0) = alcstr(sbuf, len);
+         STRLEN(arg0) = len;
+         return;
+
+      case T_RECORD:
+         bp = BLKLOC(arg1);
+         rnlen = STRLEN(bp->record.recptr->proc.recname);
+         sneed(15 + rnlen);
+         bp = BLKLOC(arg1);
+         sprintf(sbuf, "(%d)", bp->record.recptr->proc.nfields);
+         len = strlen(sbuf);
+         STRLOC(arg0) = alcstr("record ", 7);
+                        alcstr(STRLOC(bp->record.recptr->proc.recname),
+                               rnlen);
+                        alcstr(sbuf, len);
+         STRLEN(arg0) = 7 + len + rnlen;
+         return;
+
+      case T_ESTACK:
+         sneed(22);
+         sprintf(sbuf, "(%d)", BLKLOC(arg1)->estack.nresults);
+         len = strlen(sbuf);
+         STRLOC(arg0) = alcstr("co-expression", 13);
+                        alcstr(sbuf, len);
+         STRLEN(arg0) = 13 + len;
+         return;
+
+      default:
+         syserr("image: unknown type.");
+      }
+   }
+
+struct b_iproc Bimage = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Ximage),
+   1,
+   -1,
+   0,
+   0,
+   {5, "image"}
+   };
+
+/*
+ * doimage(c,q) - allocate character c in string space, with escape
+ * conventions if c is unprintable, '\', or equal to q.
+ * Returns number of characters allocated.
+ */
+
+doimage(c, q)
+int c, q;
+   {
+   static char *cbuf = "\\\0\0\0";
+   extern char *alcstr();
+
+   if (c >= ' ' && c < '\177') {
+      switch (c) {
+         case '"':                         /*      d. quote     */
+            if (c != q) goto def;
+           alcstr("\\\"", 2);
+            return (2);
+         case '\'':                        /*      s. quote     */
+            if (c != q) goto def;
+            alcstr("\\'", 2);
+            return (2);
+         case '\\':                        /*      backslash    */
+            alcstr("\\\\", 2);
+            return (2);
+         default:                          /*      normal ch.   */
+        def:
+            cbuf[0] = c;
+            cbuf[1] = '\0'; /* Do we need this? --whm */
+            alcstr(cbuf,1);
+            return (1);
+         }
+      }
+
+   switch (c) {                         /* special character */
+      case '\b':                        /*      backspace    */
+         alcstr("\\b", 2);
+         return (2);
+      case '\177':                      /*      delete       */
+         alcstr("\\d", 2);
+         return (2);
+      case '\33':                       /*      escape       */
+         alcstr("\\e", 2);
+         return (2);
+      case '\f':                        /*      form feed    */
+         alcstr("\\f", 2);
+         return (2);
+      case '\n':                        /*      new line     */
+         alcstr("\\n", 2);
+         return (2);
+      case '\r':                        /*      return       */
+         alcstr("\\r", 2);
+         return (2);
+      case '\t':                        /*      hor. tab     */
+         alcstr("\\t", 2);
+         return (2);
+      case '\13':                       /*      ver. tab     */
+         alcstr("\\v", 2);
+         return (2);
+      default:                          /*      octal cons.  */
+        cbuf[0] = '\\';
+         cbuf[1] = ((c&0300) >> 6) + '0';
+         cbuf[2] = ((c&070) >> 3) + '0';
+         cbuf[3] = (c&07) + '0';
+         alcstr(cbuf, 4);
+         return (4);
+      }
+   }
+
+/*
+ * prescan(d) - return upper bound on length of expanded string.
+ */
+
+prescan(d)
+struct descrip *d;
+   {
+   register int slen, len;
+   register char *s, c;
+
+   s = STRLOC(*d);
+   len = 0;
+   for (slen = STRLEN(*d); slen > 0; slen--)
+      if ((c = (*s++)) < ' ' || c >= 0177)
+         len += 4;
+      else if (c == '"' || c == '\\' || c == '\'')
+         len += 2;
+      else
+         len++;
+
+   return (len);
+   }
diff --git a/usr/src/new/new/icon/cmp/functions/integer.c b/usr/src/new/new/icon/cmp/functions/integer.c

new file mode 100644 (file)

index 0000000..f068c2f
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/integer.c
@@ -0,0 +1,34 @@
+#include "../h/rt.h"
+
+/*
+ * integer(x) - convert x to integer.
+ */
+
+Xinteger(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   long l;
+
+   switch (cvint(&arg1, &l)) {
+      case T_INTEGER:
+#ifndef BIT32
+      case T_LONGINT:
+#endif
+        mkint(l, &arg0);
+        break;
+      default:
+        fail();
+      }
+   }
+
+struct b_iproc Binteger = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xinteger),
+   1,
+   -1,
+   0,
+   0,
+   {7, "integer"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/left.c b/usr/src/new/new/icon/cmp/functions/left.c

new file mode 100644 (file)

index 0000000..0c24d5f
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/left.c
@@ -0,0 +1,62 @@
+#include "../h/rt.h"
+
+/*
+ * left(s1,n,s2) - pad s1 on right with s2 to length n.
+ */
+
+Xleft(nargs, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg3, arg2, arg1, arg0;
+   {
+   register char *s, *st;
+   int cnt, slen, i;
+   char *sbuf, *s3, sbuf1[MAXSTRING], sbuf2[MAXSTRING];
+   extern char *alcstr();
+
+   if (cvstr(&arg1, sbuf1) == NULL)
+      runerr(103, &arg1);
+   defshort(&arg2, 1);
+   if ((cnt = arg2.value.integer) < 0)
+      runerr(205, &arg2);
+   defstr(&arg3, sbuf2, &blank);
+
+   sneed(cnt);
+   if (STRLEN(arg3) == 0) {
+      slen = 1;
+      s3 = " ";
+      }
+   else {
+      slen = STRLEN(arg3);
+      s3 = STRLOC(arg3);
+      }
+
+   sbuf = alcstr(NULL, cnt);
+   s = sbuf + cnt;
+   while (s > sbuf) {
+      st = s3 + slen;
+      while (st > s3 && s > sbuf)
+         *--s = *--st;
+      }
+
+   s = sbuf;
+   slen = STRLEN(arg1);
+   st = STRLOC(arg1);
+   if (slen > cnt)
+      slen = cnt;
+   while (slen-- > 0)
+      *s++ = *st++;
+
+   STRLEN(arg0) = cnt;
+   STRLOC(arg0) = sbuf;
+   }
+
+struct b_iproc Bleft = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xleft),
+   3,
+   -1,
+   0,
+   0,
+   {4, "left"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/list.c b/usr/src/new/new/icon/cmp/functions/list.c

new file mode 100644 (file)

index 0000000..0daa64e
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/list.c
@@ -0,0 +1,49 @@
+#include "../h/rt.h"
+
+/*
+ * list(n,x) - create a list of size n, with initial value x.
+ */
+
+Xlist(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register int i, size;
+   register struct b_listb *bp;
+   register struct b_list *hp;
+   int nelem;
+   extern struct b_list *alclist();
+   extern struct b_listb *alclstb();
+
+   defshort(&arg1, 0);
+   deref(&arg2);
+
+   nelem = size = arg1.value.integer;
+   if (size < 0)
+      runerr(205, &arg1);
+   if (nelem < LISTBLKSIZE)
+      nelem = LISTBLKSIZE;
+
+   hneed(sizeof(struct b_list) + sizeof(struct b_listb) +
+         nelem * sizeof(struct descrip));
+
+   hp = alclist(size);
+   bp = alclstb(nelem, 0, size);
+   hp->listhead.type = hp->listtail.type = D_LISTB;
+   BLKLOC(hp->listhead) = BLKLOC(hp->listtail) = bp;
+   for (i = 0; i < size; i++)
+      bp->lelem[i] = arg2;
+   arg0.type = D_LIST;
+   BLKLOC(arg0) = hp;
+   }
+
+struct b_iproc Blist = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xlist),
+   2,
+   -1,
+   0,
+   0,
+   {4, "list"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/many.c b/usr/src/new/new/icon/cmp/functions/many.c

new file mode 100644 (file)

index 0000000..d18f873
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/many.c
@@ -0,0 +1,54 @@
+#include "../h/rt.h"
+
+/*
+ * many(c,s,i,j) - find longest prefix of s[i:j] of characters in c.
+ */
+
+Xmany(nargs, arg4, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg4, arg3, arg2, arg1, arg0;
+   {
+   register int i, j;
+   int t, *cs, csbuf[CSETSIZE];
+   long l1, l2;
+   char sbuf[MAXSTRING];
+
+   if (cvcset(&arg1, &cs, csbuf) == NULL)
+      runerr(104, &arg1);
+   if (defstr(&arg2, sbuf, &k_subject))
+      defint(&arg3, &l1, k_pos);
+   else
+      defint(&arg3, &l1, 1);
+   defint(&arg4, &l2, 0);
+
+   i = cvpos(l1, STRLEN(arg2));
+   j = cvpos(l2, STRLEN(arg2));
+   if (i == j)
+      fail();
+   if (i > j) {
+      t = i;
+      i = j;
+      j = t;
+      }
+
+   if (!tstb(STRLOC(arg2)[i-1], cs))
+      fail();
+
+   i++;
+   while (i < j && tstb(STRLOC(arg2)[i-1], cs))
+      i++;
+
+   arg0.type = D_INTEGER;
+   INTVAL(arg0) = i;
+   }
+
+struct b_iproc Bmany = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xmany),
+   4,
+   -1,
+   0,
+   0,
+   {4, "many"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/map.c b/usr/src/new/new/icon/cmp/functions/map.c

new file mode 100644 (file)

index 0000000..3f3e331
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/map.c
@@ -0,0 +1,65 @@
+#include "../h/rt.h"
+
+/*
+ * map(s1,s2,s3) - map s1, using s2 and s3.
+ */
+
+Xmap(nargs, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg3, arg2, arg1, arg0;
+   {
+   register int i;
+   register char *s1, *s2, *s3;
+   char sbuf1[MAXSTRING], sbuf2[MAXSTRING], sbuf3[MAXSTRING];
+   static char maptab[MAXSTRING];
+   extern char *alcstr();
+
+   if (cvstr(&arg1, sbuf1) == NULL)
+      runerr(103, &arg1);
+   defany(&arg2, &ucase);
+   defany(&arg3, &lcase);
+
+   if (maps2.type != arg2.type || maps3.type != arg3.type ||
+       BLKLOC(maps2) != BLKLOC(arg2) || BLKLOC(maps3) != BLKLOC(arg3)) {
+      maps2 = arg2;
+      maps3 = arg3;
+      if (cvstr(&arg2, sbuf2) == NULL)
+         runerr(103, &arg2);
+      if (cvstr(&arg3, sbuf3) == NULL)
+         runerr(103, &arg3);
+      if (STRLEN(arg2) != STRLEN(arg3))
+         runerr(208, NULL);
+      s2 = STRLOC(arg2);
+      s3 = STRLOC(arg3);
+      for (i = MAXSTRING - 1; i >= 0; i--)
+         maptab[i] = i;
+      for (i = 0; i < STRLEN(arg2); i++)
+         maptab[s2[i]&0377] = s3[i];
+      }
+
+   if (STRLEN(arg1) == 0) {
+      arg0.type = D_NULL;
+      INTVAL(arg0) = 1;
+      return;
+      }
+
+   i = STRLEN(arg1);
+   sneed(i);
+   s1 = STRLOC(arg1);
+
+   STRLEN(arg0) = i;
+   STRLOC(arg0) = s2 = alcstr(NULL, i);
+   while (i-- > 0)
+      *s2++ = maptab[(*s1++)&0377];
+   }
+
+struct b_iproc Bmap = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xmap),
+   3,
+   -1,
+   0,
+   0,
+   {3, "map"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/match.c b/usr/src/new/new/icon/cmp/functions/match.c

new file mode 100644 (file)

index 0000000..d9bc6b0
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/match.c
@@ -0,0 +1,58 @@
+#include "../h/rt.h"
+
+/*
+ * match(s1,s2,i,j) - test if s1 is prefix of s2[i:j].
+ */
+
+Xmatch(nargs, arg4, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg4, arg3, arg2, arg1, arg0;
+   {
+   register int i;
+   register char *s1, *s2;
+   int j, t;
+   long l1, l2;
+   char sbuf1[MAXSTRING], sbuf2[MAXSTRING];
+
+   if (cvstr(&arg1, sbuf1) == NULL)
+      runerr(103, &arg1);
+   if (defstr(&arg2, sbuf2, &k_subject))
+      defint(&arg3, &l1, k_pos);
+   else
+      defint(&arg3, &l1, 1);
+   defint(&arg4, &l2, 0);
+
+   i = cvpos(l1, STRLEN(arg2));
+   j = cvpos(l2, STRLEN(arg2));
+
+   if (i > j) {                 /* convert to substring */
+      t = i;
+      i = j;
+      j = t - j;
+      }
+   else
+      j = j - i;
+
+   if (j < STRLEN(arg1))
+      fail();
+
+   s1 = STRLOC(arg1);
+   s2 = STRLOC(arg2) + i - 1;
+   for (j = STRLEN(arg1); j > 0; j--)
+      if (*s1++ != *s2++)
+         fail();
+
+   arg0.type = D_INTEGER;
+   INTVAL(arg0) = i + STRLEN(arg1);
+   }
+
+struct b_iproc Bmatch = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xmatch),
+   4,
+   -1,
+   0,
+   0,
+   {5, "match"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/move.c b/usr/src/new/new/icon/cmp/functions/move.c

new file mode 100644 (file)

index 0000000..93b4132
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/move.c
@@ -0,0 +1,55 @@
+#include "../h/rt.h"
+
+/*
+ * move(i) - move &pos by i, return substring of &subject spanned.
+ * Generator (reversible).
+ */
+
+Xmove(nargs, oldsubj, arg1, arg0)
+int nargs;
+struct descrip oldsubj, arg1, arg0;
+   {
+   register int i, j;
+   long l;
+   int oldpos;
+
+   switch (cvint(&arg1, &l)) {
+      case T_INTEGER:  j = (int)l; break;
+#ifndef BIT32
+      case T_LONGINT:  fail();
+#endif
+      default:         runerr(101, &arg1);
+      }
+
+   oldsubj = k_subject;                /* save old &subject and &pos */
+   oldpos = i = k_pos;
+
+   if (i + j <= 0 || i + j > STRLEN(k_subject) + 1)
+      fail();
+
+   k_pos += j;                 /* set new &pos */
+
+   if (j < 0) {                        /* make sure j >= 0 */
+      i += j;
+      j = -j;
+      }
+
+   STRLEN(arg0) = j;
+   STRLOC(arg0) = STRLOC(k_subject) + i - 1;
+   suspend();
+
+   k_subject = oldsubj;
+   k_pos = oldpos;
+   fail();
+   }
+
+struct b_iproc Bmove = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xmove),
+   2,
+   -1,
+   0,
+   0,
+   {4, "move"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/numeric.c b/usr/src/new/new/icon/cmp/functions/numeric.c

new file mode 100644 (file)

index 0000000..8b60ed2
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/numeric.c
@@ -0,0 +1,40 @@
+#include "../h/rt.h"
+
+/*
+ * numeric(x) - convert x to numeric type.
+ */
+
+Xnumeric(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   union numeric n1;
+
+   switch (cvnum(&arg1, &n1)) {
+#ifdef  BIT32
+      case T_INTEGER:
+#else
+      case T_LONGINT:
+#endif
+        mkint(n1.i, &arg0);
+        break;
+
+      case T_REAL:
+         mkreal(n1.r, &arg0);
+         break;
+
+      default:
+        fail();
+      }
+   }
+
+struct b_iproc Bnumeric = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xnumeric),
+   1,
+   -1,
+   0,
+   0,
+   {7, "numeric"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/open.c b/usr/src/new/new/icon/cmp/functions/open.c

new file mode 100644 (file)

index 0000000..594c1f1
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/open.c
@@ -0,0 +1,113 @@
+#include "../h/rt.h"
+
+/*
+ * open(s1,s2) - open file s1 with specification s2.
+ */
+int globals;
+Xopen(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register int slen, i;
+   register char *s;
+   int status;
+   char sbuf1[MAXSTRING], sbuf2[MAXSTRING], mode[3];
+   FILE *f;
+   extern struct b_file *alcfile();
+   extern FILE *fopen(), *popen();
+
+   switch (cvstr(&arg1, sbuf1)) {
+      case 1:
+         sneed(STRLEN(arg1));
+         STRLOC(arg1) = alcstr(STRLOC(arg1), STRLEN(arg1));
+        break;
+      case 2:
+         qtos(&arg1, sbuf1);
+        break;
+      default:
+         runerr(103, &arg1);
+      }
+   defstr(&arg2, sbuf2, &letr);
+
+   hneed(sizeof(struct b_file));
+   status = 0;
+
+   s = STRLOC(arg2);
+   slen = STRLEN(arg2);
+   for (i = 0; i < slen; i++) {
+      switch (*s++) {
+         case 'a': case 'A':
+            status |= FS_WRITE|FS_APPEND;
+            continue;
+         case 'b': case 'B':
+            status |= FS_READ|FS_WRITE;
+            continue;
+         case 'c': case 'C':
+            status |= FS_CREATE|FS_WRITE;
+            continue;
+         case 'p': case 'P':
+            status |= FS_PIPE;
+            continue;
+         case 'r': case 'R':
+            status |= FS_READ;
+            continue;
+         case 'w': case 'W':
+            status |= FS_WRITE;
+            continue;
+         default:
+            runerr(209, &arg2);
+         }
+      }
+
+   mode[0] = '\0';
+   mode[1] = '\0';
+   mode[2] = '\0';
+   if ((status & (FS_READ|FS_WRITE)) == 0)   /* default: read only */
+      status |= FS_READ;
+   if (status & FS_CREATE)
+      mode[0] = 'w';
+   else if (status & FS_APPEND)
+      mode[0] = 'a';
+   else if (status & FS_READ)
+      mode[0] = 'r';
+   else
+      mode[0] = 'w';
+   if ((status & (FS_READ|FS_WRITE)) == (FS_READ|FS_WRITE))
+      mode[1] = '+';
+
+   if (status & FS_PIPE) {
+      if (status != (FS_READ|FS_PIPE) && status != (FS_WRITE|FS_PIPE))
+         runerr(209, &arg2);
+      f = popen(sbuf1, mode);
+      }
+   else
+      f = fopen(sbuf1, mode);
+   if (f == NULL)
+      fail();
+   if (!isatty(fileno(f))) {
+      for (i = 0; i < numbufs; i++)
+         if (bufused[i] == NULL)
+            break;
+      if (i < numbufs) {              /* use buffer if any free */
+         setbuf(f, bufs[i]);
+         bufused[i] = f;
+         }
+      else
+         setbuf(f, NULL);
+      }
+   else
+      setbuf(f, NULL);
+   arg0.type = D_FILE;
+   BLKLOC(arg0) = alcfile(f, status, &arg1);
+   }
+
+struct b_iproc Bopen = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xopen),
+   2,
+   -1,
+   0,
+   0,
+   {4, "open"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/pop.c b/usr/src/new/new/icon/cmp/functions/pop.c

new file mode 100644 (file)

index 0000000..6bb4a98
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/pop.c
@@ -0,0 +1,47 @@
+#include "../h/rt.h"
+
+/*
+ * pop(x) - pop an element from beginning of list x.
+ */
+
+Xpop(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register int i;
+   register struct b_list *hp;
+   register struct b_listb *bp;
+   extern struct b_listb *alclstb();
+
+   deref(&arg1);
+   if (TYPE(arg1) != T_LIST)
+      runerr(108, &arg1);
+
+   hp = BLKLOC(arg1);
+   if (hp->cursize <= 0)
+      fail();
+   bp = BLKLOC(hp->listhead);
+   if (bp->nused <= 0) {
+      bp = BLKLOC(bp->listnext);
+      BLKLOC(hp->listhead) = bp;
+      bp->listprev = nulldesc;
+      }
+   i = bp->first;
+   arg0 = bp->lelem[i];
+   if (++i >= bp->nelem)
+      i = 0;
+   bp->first = i;
+   bp->nused--;
+   hp->cursize--;
+   }
+
+struct b_iproc Bpop = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xpop),
+   1,
+   -1,
+   0,
+   0,
+   {3, "pop"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/pos.c b/usr/src/new/new/icon/cmp/functions/pos.c

new file mode 100644 (file)

index 0000000..74377ef
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/pos.c
@@ -0,0 +1,32 @@
+#include "../h/rt.h"
+
+/*
+ * pos(i) - test if &pos is at position i in &subject.
+ */
+
+Xpos(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register int i;
+   long l;
+
+   if (cvint(&arg1, &l) == NULL)
+      runerr(101, &arg1);
+
+   if ((i = cvpos(l, STRLEN(k_subject))) != k_pos)
+      fail();
+   arg0.type = D_INTEGER;
+   BLKLOC(arg0) = i;
+   }
+
+struct b_iproc Bpos = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xpos),
+   1,
+   -1,
+   0,
+   0,
+   {3, "pos"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/pull.c b/usr/src/new/new/icon/cmp/functions/pull.c

new file mode 100644 (file)

index 0000000..b2a6645
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/pull.c
@@ -0,0 +1,46 @@
+#include "../h/rt.h"
+
+/*
+ * pull(x) - pull an element from end of list x.
+ */
+
+Xpull(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register int i;
+   register struct b_list *hp;
+   register struct b_listb *bp;
+   extern struct b_listb *alclstb();
+
+   deref(&arg1);
+   if (TYPE(arg1) != T_LIST)
+      runerr(108, &arg1);
+
+   hp = BLKLOC(arg1);
+   if (hp->cursize <= 0)
+      fail();
+   bp = BLKLOC(hp->listtail);
+   if (bp->nused <= 0) {
+      bp = BLKLOC(bp->listprev);
+      BLKLOC(hp->listtail) = bp;
+      bp->listnext = nulldesc;
+      }
+   i = bp->first + bp->nused - 1;
+   if (i >= bp->nelem)
+      i -= bp->nelem;
+   arg0 = bp->lelem[i];
+   bp->nused--;
+   hp->cursize--;
+   }
+
+struct b_iproc Bpull = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xpull),
+   1,
+   -1,
+   0,
+   0,
+   {4, "pull"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/push.c b/usr/src/new/new/icon/cmp/functions/push.c

new file mode 100644 (file)

index 0000000..815014e
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/push.c
@@ -0,0 +1,51 @@
+#include "../h/rt.h"
+
+/*
+ * push(x,val) - push val onto beginning of list x.
+ */
+
+Xpush(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register int i;
+   register struct b_list *hp;
+   register struct b_listb *bp;
+   extern struct b_listb *alclstb();
+
+   deref(&arg1);
+   deref(&arg2);
+   if (TYPE(arg1) != T_LIST)
+      runerr(108, &arg1);
+
+   hneed(sizeof(struct b_listb)+LISTBLKSIZE*sizeof(struct descrip));
+
+   hp = BLKLOC(arg1);
+   bp = BLKLOC(hp->listhead);
+   if (bp->nused >= bp->nelem) {
+      bp = alclstb(LISTBLKSIZE, 0, 0);
+      BLKLOC(hp->listhead)->listprev.type = D_LISTB;
+      BLKLOC(BLKLOC(hp->listhead)->listprev) = bp;
+      bp->listnext = hp->listhead;
+      BLKLOC(hp->listhead) = bp;
+      }
+   i = bp->first - 1;
+   if (i < 0)
+      i = bp->nelem - 1;
+   bp->lelem[i] = arg2;
+   bp->first = i;
+   bp->nused++;
+   hp->cursize++;
+   arg0 = arg1;
+   }
+
+struct b_iproc Bpush = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xpush),
+   2,
+   -1,
+   0,
+   0,
+   {4, "push"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/put.c b/usr/src/new/new/icon/cmp/functions/put.c

new file mode 100644 (file)

index 0000000..a687596
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/put.c
@@ -0,0 +1,50 @@
+#include "../h/rt.h"
+
+/*
+ * put(x,val) - put val onto end of list x.
+ */
+
+Xput(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register int i;
+   register struct b_list *hp;
+   register struct b_listb *bp;
+   extern struct b_listb *alclstb();
+
+   deref(&arg1);
+   deref(&arg2);
+   if (TYPE(arg1) != T_LIST)
+      runerr(108, &arg1);
+
+   hneed(sizeof(struct b_listb)+LISTBLKSIZE*sizeof(struct descrip));
+
+   hp = BLKLOC(arg1);
+   bp = BLKLOC(hp->listtail);
+   if (bp->nused >= bp->nelem) {
+      bp = alclstb(LISTBLKSIZE, 0, 0);
+      BLKLOC(hp->listtail)->listnext.type = D_LISTB;
+      BLKLOC(BLKLOC(hp->listtail)->listnext) = bp;
+      bp->listprev = hp->listtail;
+      BLKLOC(hp->listtail) = bp;
+      }
+   i = bp->first + bp->nused;
+   if (i >= bp->nelem)
+      i -= bp->nelem;
+   bp->lelem[i] = arg2;
+   bp->nused++;
+   hp->cursize++;
+   arg0 = arg1;
+   }
+
+struct b_iproc Bput = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xput),
+   2,
+   -1,
+   0,
+   0,
+   {3, "put"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/read.c b/usr/src/new/new/icon/cmp/functions/read.c

new file mode 100644 (file)

index 0000000..c38c1ef
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/read.c
@@ -0,0 +1,39 @@
+#include "../h/rt.h"
+
+/*
+ * read(f) - read line on file f.
+ */
+
+Xread(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register int slen;
+   int status;
+   char sbuf[MAXREADSTRING];
+   FILE *f;
+   extern char *alcstr();
+
+   deffile(&arg1, &input);
+   f = BLKLOC(arg1)->file.fd;
+   status = BLKLOC(arg1)->file.status;
+   if ((status & FS_READ) == 0)
+      runerr(212, &arg1);
+
+   if ((slen = getstr(sbuf,MAXREADSTRING,f)) < 0)
+      fail();
+   sneed(slen);
+   STRLEN(arg0) = slen;
+   STRLOC(arg0) = alcstr(sbuf,slen);
+   }
+
+struct b_iproc Bread = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xread),
+   1,
+   -1,
+   0,
+   0,
+   {4, "read"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/reads.c b/usr/src/new/new/icon/cmp/functions/reads.c

new file mode 100644 (file)

index 0000000..32bfefb
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/reads.c
@@ -0,0 +1,46 @@
+#include "../h/rt.h"
+
+/*
+ * reads(f,i) - read i chars on file f.
+ */
+
+Xreads(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register int i, cnt;
+   int status;
+   long l1;
+   FILE *f;
+
+   deffile(&arg1, &input);
+   defshort(&arg2, 1);
+
+   f = BLKLOC(arg1)->file.fd;
+   status = BLKLOC(arg1)->file.status;
+   if ((status & FS_READ) == 0)
+      runerr(212, &arg1);
+
+   if ((cnt = arg2.value.integer) <= 0)
+      runerr(205, &arg2);
+
+   sneed(cnt);
+   if (sfree + cnt > estrings)
+      runerr(302, NULL);
+   STRLOC(arg0) = sfree;
+   if ((cnt = fread(STRLOC(arg0), sizeof(char), cnt, f)) <= 0)
+      fail();
+   STRLEN(arg0) = cnt;
+   sfree += cnt;
+   }
+
+struct b_iproc Breads = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xreads),
+   2,
+   -1,
+   0,
+   0,
+   {5, "reads"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/real.c b/usr/src/new/new/icon/cmp/functions/real.c

new file mode 100644 (file)

index 0000000..dddbfe6
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/real.c
@@ -0,0 +1,31 @@
+#include "../h/rt.h"
+
+/*
+ * real(x) - convert x to real.
+ */
+
+Xreal(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   double r;
+
+   deref(&arg1);
+   if (!QUAL(arg1) && TYPE(arg1) == T_REAL)
+      arg0 = arg1;
+   else if (cvreal(&arg1, &r) == T_REAL)
+      mkreal(r, &arg0);
+   else
+      fail();
+   }
+
+struct b_iproc Breal = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xreal),
+   1,
+   -1,
+   0,
+   0,
+   {4, "real"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/repl.c b/usr/src/new/new/icon/cmp/functions/repl.c

new file mode 100644 (file)

index 0000000..9579fd1
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/repl.c
@@ -0,0 +1,53 @@
+#include "../h/rt.h"
+
+/*
+ * repl(s,n) - concatenate n copies of string s.
+ */
+
+Xrepl(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register int cnt, i;
+   register char *sloc;
+   long l1;
+   char sbuf[MAXSTRING];
+   extern char *alcstr();
+
+   if (cvstr(&arg1, sbuf) == NULL)
+      runerr(103, &arg1);
+   switch (cvint(&arg2, &l1)) {
+      case T_INTEGER:   if ((cnt = (int)l1) >= 0) break;
+#ifndef BIT32
+      case T_LONGINT:   runerr(205, &arg2);
+#endif
+      default:          runerr(101, &arg2);
+      }
+
+   if ((l1 * STRLEN(arg1)) > MAXSHORT)
+      runerr(302, NULL);
+   if (cnt == 0) {
+      arg0.type = D_NULL;
+      INTVAL(arg0) = 1;
+      }
+   else {
+      sneed(cnt * STRLEN(arg1));
+      sloc = alcstr(STRLOC(arg1), STRLEN(arg1));
+      cnt--;
+      while (cnt--)
+         alcstr(STRLOC(arg1), STRLEN(arg1));
+      STRLEN(arg0) = (int)l1 * STRLEN(arg1);
+      STRLOC(arg0) = sloc;
+      }
+   }
+
+struct b_iproc Brepl = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xrepl),
+   2,
+   -1,
+   0,
+   0,
+   {4, "repl"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/reverse.c b/usr/src/new/new/icon/cmp/functions/reverse.c

new file mode 100644 (file)

index 0000000..adabbf6
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/reverse.c
@@ -0,0 +1,42 @@
+#include "../h/rt.h"
+
+/*
+ * reverse(s) - reverse string s.
+ */
+
+Xreverse(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register char c, *floc, *lloc;
+   register int slen;
+   char sbuf[MAXSTRING];
+   extern char *alcstr();
+
+   if (cvstr(&arg1, sbuf) == NULL)
+      runerr(103, &arg1);
+
+   slen = STRLEN(arg1);
+   sneed(slen);
+   STRLEN(arg0) = slen;
+   STRLOC(arg0) = alcstr(STRLOC(arg1), slen);
+
+   floc = STRLOC(arg0);
+   lloc = floc + --slen;
+   while (floc < lloc) {
+      c = *floc;
+      *floc++ = *lloc;
+      *lloc-- = c;
+      }
+   }
+
+struct b_iproc Breverse = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xreverse),
+   1,
+   -1,
+   0,
+   0,
+   {7, "reverse"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/right.c b/usr/src/new/new/icon/cmp/functions/right.c

new file mode 100644 (file)

index 0000000..f91f332
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/right.c
@@ -0,0 +1,64 @@
+#include "../h/rt.h"
+
+/*
+ * right(s1,n,s2) - pad s1 on left with s2 to length n.
+ */
+
+Xright(nargs, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg3, arg2, arg1, arg0;
+   {
+   register char *s, *st;
+   int cnt, slen, i;
+   char *sbuf, *s3, sbuf1[MAXSTRING], sbuf2[MAXSTRING];
+   extern char *alcstr();
+
+   if (cvstr(&arg1, sbuf1) == NULL)
+      runerr(103, &arg1);
+   defshort(&arg2, 1);
+   if ((cnt = arg2.value.integer) < 0)
+      runerr(205, &arg2);
+   defstr(&arg3, sbuf2, &blank);
+
+   sneed(cnt);
+
+   if (STRLEN(arg3) == 0) {
+      slen = 1;
+      s3 = " ";
+      }
+   else {
+      slen = STRLEN(arg3);
+      s3 = STRLOC(arg3);
+      }
+
+   sbuf = alcstr(NULL, cnt);            /* use string space as buffer */
+
+   s = sbuf;
+   while (s < sbuf + cnt) {
+      st = s3;
+      while (st < s3 + slen && s < sbuf + cnt)
+         *s++ = *st++;
+      }
+
+   s = sbuf + cnt;
+   slen = STRLEN(arg1);
+   st = STRLOC(arg1) + slen;
+   if (slen > cnt)
+      slen = cnt;
+   while (slen-- > 0)
+      *--s = *--st;
+
+   STRLEN(arg0) = cnt;
+   STRLOC(arg0) = sbuf;
+   }
+
+struct b_iproc Bright = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xright),
+   3,
+   -1,
+   0,
+   0,
+   {5, "right"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/seq.c b/usr/src/new/new/icon/cmp/functions/seq.c

new file mode 100644 (file)

index 0000000..5510097
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/seq.c
@@ -0,0 +1,38 @@
+#include "../h/rt.h"
+#ifdef EXT
+/*
+ * seq(e1,e2) generate {e1, e1+e2, e1+e2+e2, ...}
+ * Generator.
+ */
+
+seq(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   DclSave
+   long from, by;
+
+   defint(&arg1, &from, 1);
+   defint(&arg2, &by, 1);
+   
+   if (by == 0)
+      runerr(211, &arg2);
+
+   while ((from <= MAXLONG && by > 0) || (from >= MINLONG && by < 0)) {
+      mkint(from, &arg0);
+      suspend();
+      from += by;
+      }
+   fail();
+   }
+struct b_iproc Bseq = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(seq),
+   2,
+   -1,
+   0,
+   0,
+   {3, "seq"}
+   };
+#endif EXT
diff --git a/usr/src/new/new/icon/cmp/functions/sort.c b/usr/src/new/new/icon/cmp/functions/sort.c

new file mode 100644 (file)

index 0000000..e224089
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/sort.c
@@ -0,0 +1,111 @@
+#include "../h/rt.h"
+
+/*
+ * sort(l) - sort list l.
+ * sort(t,i) - sort table on reference (i = 1) or value (i = 2) field.
+ */
+
+Xsort(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register struct descrip *d1, *dp;
+   register int size, i, j;
+   int nelem;
+   struct b_list *lp, *tp;
+   union block *bp, *ep;
+   long l;
+   extern struct b_list *alclist();
+   extern struct b_listb *alclstb();
+   extern anycmp(), trefcmp(), tvalcmp();
+
+   deref(&arg1);
+   if (arg1.type == D_LIST) {
+      size = BLKLOC(arg1)->list.cursize;
+      cplist(&arg1, &arg0, 1, size + 1);
+      qsort(BLKLOC(BLKLOC(arg0)->list.listhead)->listb.lelem, size,
+            sizeof(struct descrip), anycmp);
+      }
+   else if (arg1.type == D_TABLE) {
+      defshort(&arg2, 1);
+      if (arg2.value.integer != 1 && arg2.value.integer != 2)
+         runerr(205, &arg2);
+      nelem = size = BLKLOC(arg1)->table.cursize;
+      if (nelem < LISTBLKSIZE)
+        nelem = LISTBLKSIZE;
+      hneed(sizeof(struct b_list) + sizeof(struct b_listb) +
+           nelem * (sizeof(struct b_list) + sizeof(struct b_listb) +
+                    3 * sizeof(struct descrip)));
+      bp = BLKLOC(arg1);
+      lp = alclist(size);
+      lp->listhead.type = lp->listtail.type = D_LISTB;
+      BLKLOC(lp->listhead) = BLKLOC(lp->listtail) = alclstb(nelem, 0, size);
+      if (size > 0) {
+         d1 = BLKLOC(lp->listhead)->listb.lelem;
+         for (i = 0; i < NBUCKETS; i++) {
+            ep = BLKLOC(bp->table.buckets[i]);
+            while (ep != NULL) {
+               d1->type = D_LIST;
+               BLKLOC(*d1) = tp = alclist(2);
+               tp->listhead.type = tp->listtail.type = D_LISTB;
+               BLKLOC(tp->listhead) = BLKLOC(tp->listtail) = alclstb(2, 0, 2);
+               BLKLOC(tp->listhead)->listb.lelem[0] = ep->telem.tref;
+               BLKLOC(tp->listhead)->listb.lelem[1] = ep->telem.tval;
+               d1++;
+               ep = BLKLOC(ep->telem.blink);
+               }
+            }
+         if (arg2.value.integer == 1)
+            qsort(BLKLOC(lp->listhead)->listb.lelem, size,
+                  sizeof(struct descrip), trefcmp);
+         else
+            qsort(BLKLOC(lp->listhead)->listb.lelem, size,
+                  sizeof(struct descrip), tvalcmp);
+         }
+      arg0.type = D_LIST;
+      BLKLOC(arg0) = lp;
+      }
+   else
+      runerr(115, &arg1);
+   }
+
+/*
+ * trefcmp(d1,d2) - compare two element lists on first field.
+ */
+
+trefcmp(d1,d2)
+struct descrip *d1, *d2;
+   {
+   extern anycmp();
+
+   if (d1->type != D_LIST || d2->type != D_LIST)
+      syserr("trefcmp: internal consistency check fails.");
+   return (anycmp(&(BLKLOC(BLKLOC(*d1)->list.listhead)->listb.lelem[0]),
+                  &(BLKLOC(BLKLOC(*d2)->list.listhead)->listb.lelem[0])));
+   }
+
+/*
+ * tvalcmp(d1,d2) - compare two element lists on second field.
+ */
+
+tvalcmp(d1,d2)
+struct descrip *d1, *d2;
+   {
+   extern anycmp();
+
+   if (d1->type != D_LIST || d2->type != D_LIST)
+      syserr("tvalcmp: internal consistency check fails.");
+   return (anycmp(&(BLKLOC(BLKLOC(*d1)->list.listhead)->listb.lelem[1]),
+                  &(BLKLOC(BLKLOC(*d2)->list.listhead)->listb.lelem[1])));
+   }
+
+struct b_iproc Bsort = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xsort),
+   2,
+   -1,
+   0,
+   0,
+   {4, "sort"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/stop.c b/usr/src/new/new/icon/cmp/functions/stop.c

new file mode 100644 (file)

index 0000000..0c72cab
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/stop.c
@@ -0,0 +1,51 @@
+#include "../h/rt.h"
+
+/*
+ * stop(a,b,...) - stop and write arguments (starting on error output).
+ */
+
+Xstop(nargs)
+int nargs;
+   {
+   register int n;
+   char sbuf[MAXSTRING];
+   struct descrip arg;
+   FILE *f;
+
+   f = stderr;
+
+   for (n = 1; n <= nargs; n++) {
+      arg = ARG(n);
+      deref(&arg);
+
+      if (!QUAL(arg) && TYPE(arg) == T_FILE) {
+         if (n > 1)
+            putc('\n', f);
+         if ((BLKLOC(arg)->file.status & FS_WRITE) == 0)
+           runerr(213, &arg);
+         f = BLKLOC(arg)->file.fd;
+         }
+      else {
+        if (n == 1 && (k_output.status & FS_WRITE) == 0)
+           runerr(213, NULL);
+        defany(&arg, &nullstr);
+        if (cvstr(&arg, sbuf) == NULL)
+           runerr(109, &arg);
+         putstr(f, STRLOC(arg), STRLEN(arg));
+         }
+      }
+
+   putc('\n', f);
+   c_exit(1);
+   }
+
+struct b_iproc Bstop = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xstop),
+   -1,
+   -1,
+   0,
+   0,
+   {4, "stop"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/string.c b/usr/src/new/new/icon/cmp/functions/string.c

new file mode 100644 (file)

index 0000000..cc533e6
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/string.c
@@ -0,0 +1,35 @@
+#include "../h/rt.h"
+
+/*
+ * string(x) - convert x to string.
+ */
+
+Xstring(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   char sbuf[MAXSTRING];
+   extern char *alcstr();
+
+   arg0 = arg1;
+   switch (cvstr(&arg0, sbuf)) {
+      case 1:
+        sneed(STRLEN(arg0));
+         STRLOC(arg0) = alcstr(STRLOC(arg0), STRLEN(arg0));
+      case 2:
+        return;
+      default:
+        fail();
+      }
+   }
+
+struct b_iproc Bstring = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xstring),
+   1,
+   -1,
+   0,
+   0,
+   {6, "string"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/system.c b/usr/src/new/new/icon/cmp/functions/system.c

new file mode 100644 (file)

index 0000000..cb3108d
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/system.c
@@ -0,0 +1,33 @@
+#include "../h/rt.h"
+
+/*
+ * system(s) - execute string s as a system command.
+ */
+
+Xsystem(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   char sbuf[MAXSTRING];
+
+   deref(&arg1);
+
+   if (!QUAL(arg1) || STRLEN(arg1) < 0)
+      runerr(103, &arg1);
+   if (STRLEN(arg1) >= MAXSTRING)
+      runerr(210, &arg1);
+   qtos(&arg1, sbuf);
+
+   mkint((long)((system(sbuf) >> 8) & 0377), &arg0);
+   }
+
+struct b_iproc Bsystem = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xsystem),
+   1,
+   -1,
+   0,
+   0,
+   {6, "system"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/tab.c b/usr/src/new/new/icon/cmp/functions/tab.c

new file mode 100644 (file)

index 0000000..7666517
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/tab.c
@@ -0,0 +1,52 @@
+#include "../h/rt.h"
+
+/*
+ * tab(i) - set &pos to i, return substring of &subject spanned.
+ * Reversible.
+ */
+
+Xtab(nargs, oldsubj, arg1, arg0)
+int nargs;
+struct descrip oldsubj, arg1, arg0;
+   {
+   register int i, j;
+   int t, oldpos;
+   long l1;
+
+   if (cvint(&arg1,&l1) == NULL)
+      runerr(101, &arg1);
+
+   j = cvpos(l1, STRLEN(k_subject));
+
+   oldsubj = k_subject;                /* save old &subject and &pos */
+   oldpos = i = k_pos;
+
+   k_pos = j;                  /* set new &pos */
+
+   if (i > j) {                        /* convert section to substring */
+      t = i;
+      i = j;
+      j = t - j;
+      }
+   else
+      j = j - i;
+
+   STRLOC(arg0) = STRLOC(k_subject) + i - 1;
+   STRLEN(arg0) = j;
+   suspend();
+
+   k_subject = oldsubj;
+   k_pos = oldpos;
+   fail();
+   }
+
+struct b_iproc Btab = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xtab),
+   2,
+   -1,
+   0,
+   0,
+   {3, "tab"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/table.c b/usr/src/new/new/icon/cmp/functions/table.c

new file mode 100644 (file)

index 0000000..7b17142
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/table.c
@@ -0,0 +1,29 @@
+#include "../h/rt.h"
+
+/*
+ * table(def) - create a table of default value def.
+ */
+
+Xtable(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   extern struct b_table *alctable();
+
+   hneed(sizeof(struct b_table));
+
+   deref(&arg1);
+   arg0.type = D_TABLE;
+   BLKLOC(arg0) = alctable(&arg1);
+   }
+
+struct b_iproc Btable = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xtable),
+   1,
+   -1,
+   0,
+   0,
+   {5, "table"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/trim.c b/usr/src/new/new/icon/cmp/functions/trim.c

new file mode 100644 (file)

index 0000000..2c16d80
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/trim.c
@@ -0,0 +1,39 @@
+#include "../h/rt.h"
+
+/*
+ * trim(s1,c) - trim trailing characters in c from s1.
+ */
+
+Xtrim(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register i;
+   char *sloc;
+   char sbuf[MAXSTRING];
+   int *cs, csbuf[CSETSIZE];
+   static int spcset[CSETSIZE] = 
+      cset_display(0, 0, 01, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
+
+   if (cvstr(&arg1, sbuf) == NULL)
+      runerr(103, &arg1);
+   defcset(&arg2, &cs, csbuf, spcset);
+
+   arg0 = arg1;
+   sloc = STRLOC(arg1) + STRLEN(arg1) - 1;
+   while (sloc >= STRLOC(arg1) && tstb(*sloc, cs)) {
+      sloc--;
+      STRLEN(arg0)--;
+      }
+   }
+
+struct b_iproc Btrim = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xtrim),
+   2,
+   -1,
+   0,
+   0,
+   {4, "trim"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/type.c b/usr/src/new/new/icon/cmp/functions/type.c

new file mode 100644 (file)

index 0000000..aeb5f21
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/type.c
@@ -0,0 +1,77 @@
+#include "../h/rt.h"
+#include "../h/record.h"
+
+/*
+ * type(x) - return type of x as a string.
+ */
+
+Xtype(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   deref(&arg1);
+
+   if (NULLDESC(arg1)) {
+      STRLEN(arg0) = 4;
+      STRLOC(arg0) = "null";
+      }
+   else if (QUAL(arg1)) {
+      STRLEN(arg0) = 6;
+      STRLOC(arg0) = "string";
+      }
+   else {
+      switch (TYPE(arg1)) {
+         case T_INTEGER:
+#ifndef BIT32
+         case T_LONGINT:
+#endif
+            STRLEN(arg0) = 7;
+            STRLOC(arg0) = "integer";
+            break;
+         case T_REAL:
+            STRLEN(arg0) = 4;
+            STRLOC(arg0) = "real";
+            break;
+         case T_CSET:
+            STRLEN(arg0) = 4;
+            STRLOC(arg0) = "cset";
+            break;
+         case T_FILE:
+            STRLEN(arg0) = 4;
+            STRLOC(arg0) = "file";
+            break;
+         case T_PROC:
+            STRLEN(arg0) = 9;
+            STRLOC(arg0) = "procedure";
+            break;
+         case T_LIST:
+            STRLEN(arg0) = 4;
+            STRLOC(arg0) = "list";
+            break;
+         case T_TABLE:
+            STRLEN(arg0) = 5;
+            STRLOC(arg0) = "table";
+            break;
+         case T_RECORD:
+            arg0 = BLKLOC(arg1)->record.recptr->proc.recname;
+            break;
+         case T_ESTACK:
+            STRLEN(arg0) = 13;
+            STRLOC(arg0) = "co-expression";
+            break;
+         default:
+            syserr("type: unknown type.");
+         }
+      }
+   }
+
+struct b_iproc Btype = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xtype),
+   1,
+   -1,
+   0,
+   0,
+   {4, "type"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/upto.c b/usr/src/new/new/icon/cmp/functions/upto.c

new file mode 100644 (file)

index 0000000..4a2d280
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/upto.c
@@ -0,0 +1,55 @@
+#include "../h/rt.h"
+
+/*
+ * upto(c,s,i,j) - find each occurrence in s[i:j] of a character in c.
+ * Generator.
+ */
+
+Xupto(nargs, arg4, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg4, arg3, arg2, arg1, arg0;
+   {
+   register int i, j;
+   int t;
+   long l1, l2;
+   int *cs, csbuf[CSETSIZE];
+   char sbuf[MAXSTRING];
+
+   if (cvcset(&arg1, &cs, csbuf) == NULL)
+      runerr(104, &arg1);
+   if (defstr(&arg2, sbuf, &k_subject))
+      defint(&arg3, &l1, k_pos);
+   else
+      defint(&arg3, &l1, 1);
+   defint(&arg4, &l2, 0);
+
+   i = cvpos(l1, STRLEN(arg2));
+   j = cvpos(l2, STRLEN(arg2));
+
+   if (i > j) {
+      t = i;
+      i = j;
+      j = t;
+      }
+
+   while (i < j) {
+      if (tstb(STRLOC(arg2)[i-1], cs)) {
+         arg0.type = D_INTEGER;
+         INTVAL(arg0) = i;
+        suspend();
+        }
+      i++;
+      }
+   fail();
+   }
+
+struct b_iproc Bupto = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xupto),
+   4,
+   -1,
+   0,
+   0,
+   {4, "upto"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/write.c b/usr/src/new/new/icon/cmp/functions/write.c

new file mode 100644 (file)

index 0000000..708596f
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/write.c
@@ -0,0 +1,61 @@
+#include "../h/rt.h"
+
+/*
+ * write(a,b,...) - write arguments.
+ */
+
+Xwrite(nargs)
+int nargs;
+   {
+   register int n;
+   char sbuf[MAXSTRING];
+   struct descrip arg;
+   FILE *f;
+
+   f = stdout;
+   arg = nullstr;
+
+   for (n = 1; n <= nargs; n++) {
+      arg = ARG(n);
+      deref(&arg);
+
+      if (!QUAL(arg) && TYPE(arg) == T_FILE) {
+         if (n > 1) {
+            putc('\n', f);
+           /* Added fflush for buffering--whm Fri Feb 25 01:59:20 1983 */
+           fflush(f);
+           }
+         if ((BLKLOC(arg)->file.status & FS_WRITE) == 0)
+           runerr(213, &arg);
+         f = BLKLOC(arg)->file.fd;
+         arg = nullstr;
+        }
+      else {
+        if (n == 1 && (k_output.status & FS_WRITE) == 0)
+           runerr(213, NULL);
+        defany(&arg, &nullstr);
+        if (cvstr(&arg, sbuf) == NULL)
+           runerr(109, &arg);
+         putstr(f, STRLOC(arg), STRLEN(arg));
+        }
+      }
+   putc('\n', f);
+   /* Added fflush for buffering--whm */
+   fflush(f);
+   if (STRLOC(arg) >= sbuf && STRLOC(arg) < sbuf + MAXSTRING) {
+      sneed(STRLEN(arg));
+      STRLOC(arg) = alcstr(STRLOC(arg), STRLEN(arg));
+      }
+   ARG(0) = arg;
+   }
+
+struct b_iproc Bwrite = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xwrite),
+   -1,
+   -1,
+   0,
+   0,
+   {5, "write"}
+   };
diff --git a/usr/src/new/new/icon/cmp/functions/writes.c b/usr/src/new/new/icon/cmp/functions/writes.c

new file mode 100644 (file)

index 0000000..53d1078
--- /dev/null
+++ b/usr/src/new/new/icon/cmp/functions/writes.c
@@ -0,0 +1,58 @@
+#include "../h/rt.h"
+
+/*
+ * writes(a,b,...) - write arguments without newline terminator.
+ */
+
+Xwrites(nargs)
+int nargs;
+   {
+   register int n;
+   char sbuf[MAXSTRING];
+   struct descrip arg;
+   FILE *f;
+
+   f = stdout;
+   arg = nullstr;
+
+   for (n = 1; n <= nargs; n++) {
+      arg = ARG(n);
+      deref(&arg);
+
+      if (!QUAL(arg) && TYPE(arg) == T_FILE) {
+         if ((BLKLOC(arg)->file.status & FS_WRITE) == 0)
+           runerr(213, &arg);
+         f = BLKLOC(arg)->file.fd;
+         arg = nullstr;
+        }
+      else {
+        if (n == 1 && (k_output.status & FS_WRITE) == 0)
+           runerr(213, NULL);
+        defany(&arg, &nullstr);
+        if (cvstr(&arg, sbuf) == NULL)
+           runerr(109, &arg);
+         putstr(f, STRLOC(arg), STRLEN(arg));
+        /*
+         * Added following fflush(f) for buffering,
+         *  Fri Feb 25 01:58:23 1983--whm
+         */
+        fflush(f);
+         }
+      }
+   if (STRLOC(arg) >= sbuf && STRLOC(arg) < sbuf + MAXSTRING) {
+      sneed(STRLEN(arg));
+      STRLOC(arg) = alcstr(STRLOC(arg), STRLEN(arg));
+      }
+   ARG(0) = arg;
+   }
+
+struct b_iproc Bwrites = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xwrites),
+   -1,
+   -1,
+   0,
+   0,
+   {6, "writes"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/Makefile b/usr/src/new/new/icon/int/functions/Makefile

new file mode 100644 (file)

index 0000000..5970b3d
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/Makefile
@@ -0,0 +1,78 @@
+CFLAGS = -O -w
+
+Lib:           abs.o any.o bal.o center.o close.o copy.o cset.o \
+               display.o exit.o find.o get.o image.o integer.o \
+               left.o list.o many.o map.o match.o move.o numeric.o \
+               open.o pop.o pos.o pull.o push.o put.o read.o reads.o \
+               real.o repl.o reverse.o right.o seq.o sort.o stop.o \
+               string.o system.o tab.o table.o trim.o type.o upto.o \
+               write.o writes.o
+       ar r Lib $?
+       ranlib Lib
+
+abs.o:         ../h/rt.h
+any.o:         ../h/rt.h
+bal.o:         ../h/rt.h
+center.o:      ../h/rt.h
+close.o:       ../h/rt.h
+copy.o:                ../h/rt.h ../h/record.h
+cset.o:                ../h/rt.h
+display.o:     ../h/rt.h
+exit.o:                ../h/rt.h
+find.o:                ../h/rt.h
+get.o:         ../h/rt.h
+image.o:       ../h/rt.h ../h/record.h
+integer.o:     ../h/rt.h
+left.o:                ../h/rt.h
+list.o:                ../h/rt.h
+many.o:                ../h/rt.h
+map.o:         ../h/rt.h
+match.o:       ../h/rt.h
+move.o:                ../h/rt.h
+numeric.o:     ../h/rt.h
+open.o:                ../h/rt.h
+pop.o:         ../h/rt.h
+pos.o:         ../h/rt.h
+pull.o:                ../h/rt.h
+push.o:                ../h/rt.h
+put.o:         ../h/rt.h
+read.o:                ../h/rt.h
+reads.o:       ../h/rt.h
+real.o:                ../h/rt.h
+repl.o:                ../h/rt.h
+reverse.o:     ../h/rt.h
+right.o:       ../h/rt.h
+seq.o:         ../h/rt.h
+sort.o:                ../h/rt.h
+stop.o:                ../h/rt.h
+string.o:      ../h/rt.h
+system.o:      ../h/rt.h
+tab.o:         ../h/rt.h
+table.o:       ../h/rt.h
+trim.o:                ../h/rt.h
+type.o:                ../h/rt.h ../h/record.h
+upto.o:                ../h/rt.h
+write.o:       ../h/rt.h
+writes.o:      ../h/rt.h
+
+Listall:
+       @pr *.[cs]
+       @date >List
+
+List:          abs.c any.c bal.c center.c close.c copy.c cset.c \
+               display.c exit.c find.c get.c image.c integer.c \
+               left.c list.c many.c map.c match.c move.c numeric.c \
+               open.c pop.c pos.c pull.c push.c put.c read.c reads.c \
+               real.c repl.c reverse.c right.c sort.c stop.c \
+               string.c system.c tab.c table.c trim.c type.c upto.c \
+               write.c writes.c
+       @pr $?
+       @date >List
+
+.s.o:
+       as -o $@ ../h/defs.s $<
+clean:
+       rm -f Lib *.o
+
+dist-clean: clean
+       rm -f `gcomp Makefile *.c`
diff --git a/usr/src/new/new/icon/int/functions/abs.c b/usr/src/new/new/icon/int/functions/abs.c

new file mode 100644 (file)

index 0000000..c164cd9
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/abs.c
@@ -0,0 +1,40 @@
+#include "../h/rt.h"
+
+/*
+ * abs(x) - absolute value of x.
+ */
+
+Xabs(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   union numeric result;
+
+   switch (cvnum(&arg1, &result)) {
+      case T_LONGINT:
+         if (result.i < 0L)
+            result.i = -result.i;
+        mkint(result.i, &arg0);
+         break;
+
+      case T_REAL:
+         if (result.r < 0.0)
+           result.r = -result.r;
+         mkreal(result.r, &arg0);
+         break;
+
+      default:
+         runerr(102, &arg1);
+      }
+   }
+
+struct b_iproc Babs = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xabs),
+   1,
+   -1,
+   0,
+   0,
+   {3, "abs"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/any.c b/usr/src/new/new/icon/int/functions/any.c

new file mode 100644 (file)

index 0000000..df46f8d
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/any.c
@@ -0,0 +1,45 @@
+#include "../h/rt.h"
+
+/*
+ * any(c,s,i,j) - test if first character of s[i:j] is in c.
+ */
+
+Xany(nargs, arg4, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg4, arg3, arg2, arg1, arg0;
+   {
+   register int i, j;
+   long l1, l2;
+   int *cs, csbuf[CSETSIZE];
+   char sbuf[MAXSTRING];
+
+   if (cvcset(&arg1, &cs, csbuf) == NULL)
+      runerr(104, &arg1);
+   if (defstr(&arg2, sbuf, &k_subject))
+      defint(&arg3, &l1, k_pos);
+   else
+      defint(&arg3, &l1, 1);
+   defint(&arg4, &l2, 0);
+
+   i = cvpos(l1, STRLEN(arg2));
+   j = cvpos(l2, STRLEN(arg2));
+   if (i > j)
+      i = j;
+
+   if (!tstb(STRLOC(arg2)[i-1], cs))
+      fail();
+
+   arg0.type = D_INTEGER;
+   INTVAL(arg0) = i + 1;
+   }
+
+struct b_iproc Bany = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xany),
+   4,
+   -1,
+   0,
+   0,
+   {3, "any"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/bal.c b/usr/src/new/new/icon/int/functions/bal.c

new file mode 100644 (file)

index 0000000..0177269
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/bal.c
@@ -0,0 +1,69 @@
+#include "../h/rt.h"
+
+/*
+ * bal(c1,c2,c3,s,i,j) - match a balanced substring of s[i:j].
+ * Generator.
+ */
+
+Xbal(nargs, arg6, arg5, arg4, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg6, arg5, arg4, arg3, arg2, arg1, arg0;
+   {
+   register int i, j, cnt;
+   register c;
+   int t;
+   long l1, l2;
+   int *cs1, *cs2, *cs3;
+   int csbuf1[CSETSIZE], csbuf2[CSETSIZE], csbuf3[CSETSIZE];
+   char sbuf[MAXSTRING];
+   static int lpar[CSETSIZE] =
+      cset_display(0, 0, 0400, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
+   static int rpar[CSETSIZE] =
+      cset_display(0, 0, 01000, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
+
+   defcset(&arg1, &cs1, csbuf1, k_cset.bits);
+   defcset(&arg2, &cs2, csbuf2, lpar);
+   defcset(&arg3, &cs3, csbuf3, rpar);
+   if (defstr(&arg4, sbuf, &k_subject))
+      defint(&arg5, &l1, k_pos);
+   else
+      defint(&arg5, &l1, 1);
+   defint(&arg6, &l2, 0);
+
+   i = cvpos(l1, STRLEN(arg4));
+   j = cvpos(l2, STRLEN(arg4));
+   if (i > j) {
+      t = i;
+      i = j;
+      j = t;
+      }
+
+   cnt = 0;
+   while (i < j) {             /* suspend for each occurrence */
+      c = STRLOC(arg4)[i-1];
+      if (cnt == 0 && tstb(c, cs1)) {
+         arg0.type = D_INTEGER;
+         INTVAL(arg0) = i;
+        suspend();
+        }
+      if (tstb(c, cs2))
+         cnt++;
+      else if (tstb(c, cs3))
+         cnt--;
+      if (cnt < 0)
+         fail();
+      i++;
+      }
+   fail();
+   }
+
+struct b_iproc Bbal = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xbal),
+   6,
+   -1,
+   0,
+   0,
+   {3, "bal"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/center.c b/usr/src/new/new/icon/int/functions/center.c

new file mode 100644 (file)

index 0000000..70315bd
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/center.c
@@ -0,0 +1,79 @@
+#include "../h/rt.h"
+
+/*
+ * center(s1,n,s2) - pad s1 on left and right with s2 to length n.
+ */
+
+Xcenter(nargs, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg3, arg2, arg1, arg0;
+   {
+   register char *s, *st;
+   int cnt, slen;
+   int tmp, hcnt;
+   char *sbuf, *s3;
+   char sbuf1[MAXSTRING], sbuf2[MAXSTRING];
+   extern char *alcstr();
+
+   if (cvstr(&arg1, sbuf1) == NULL)
+      runerr(103, &arg1);
+   defshort(&arg2, 1);
+   if ((cnt = arg2.value.integer) < 0)
+      runerr(205, &arg2);
+   defstr(&arg3, sbuf2, &blank);
+
+   sneed(cnt);
+   if (STRLEN(arg3) == 0) {
+      slen = 1;
+      s3 = " ";
+      }
+   else {
+      slen = STRLEN(arg3);
+      s3 = STRLOC(arg3);
+      }
+
+   sbuf = alcstr(NULL, cnt);            /* use string space as buffer */
+   hcnt = cnt / 2;
+   s = sbuf + cnt ;                          /* pad on right */
+   while (s > sbuf + hcnt) {
+      st = s3 + slen;
+      while (st > s3 && s > sbuf + hcnt)
+         *--s = *--st;
+      }
+
+   s = sbuf;                                 /* pad on left */
+   while (s < sbuf + hcnt) {
+      st = s3;
+      while (st < s3 + slen && s < sbuf + hcnt)
+         *s++ = *st++;
+      }
+
+   slen = STRLEN(arg1);
+
+   if (cnt < slen) { /* s1 is larger than field to center it in */
+      s = sbuf;
+      st = STRLOC(arg1) + slen/2 - hcnt + (~cnt&slen&1);
+      }
+   else {
+      s = sbuf + hcnt - slen/2 - (~cnt&slen&1);
+      st = STRLOC(arg1);
+      }
+   if (slen > cnt)
+      slen = cnt;
+   while (slen-- > 0)
+      *s++ = *st++;
+
+   STRLEN(arg0) = cnt;
+   STRLOC(arg0) = sbuf;
+   }
+
+struct b_iproc Bcenter = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xcenter),
+   3,
+   -1,
+   0,
+   0,
+   {6, "center"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/close.c b/usr/src/new/new/icon/int/functions/close.c

new file mode 100644 (file)

index 0000000..d6e6874
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/close.c
@@ -0,0 +1,40 @@
+#include "../h/rt.h"
+
+/*
+ * close(f) - close file f.
+ */
+
+Xclose(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register int i;
+
+   deref(&arg1);
+   if (QUAL(arg1) || TYPE(arg1) != T_FILE)
+      runerr(105, &arg1);
+
+   for (i = 0; i < numbufs; i++) {
+      if (bufused[i] == BLKLOC(arg1)->file.fd) {
+         bufused[i] = NULL;
+         break;
+         }
+      }
+   if (BLKLOC(arg1)->file.status & FS_PIPE)
+      pclose(BLKLOC(arg1)->file.fd);
+   else
+      fclose(BLKLOC(arg1)->file.fd);
+   BLKLOC(arg1)->file.status = 0;
+   arg0 = arg1;
+   }
+
+struct b_iproc Bclose = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xclose),
+   1,
+   -1,
+   0,
+   0,
+   {5, "close"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/copy.c b/usr/src/new/new/icon/int/functions/copy.c

new file mode 100644 (file)

index 0000000..65c427c
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/copy.c
@@ -0,0 +1,87 @@
+#include "../h/rt.h"
+#include "../h/record.h"
+
+/*
+ * copy(x) - make a copy of object x.
+ */
+
+Xcopy(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register int i, j;
+   struct descrip d, *dp, *d1, *d2;
+   union block *bp, *ep, **tp;
+   extern struct b_table *alctable();
+   extern struct b_telem *alctelem();
+   extern union block *allocate();
+
+   deref(&arg1);
+
+   if (NULLDESC(arg1) || QUAL(arg1))
+      arg0 = arg1;
+   else {
+      switch (TYPE(arg1)) {
+         case T_INTEGER:
+#ifndef BIT32
+         case T_LONGINT:
+#endif
+         case T_REAL:
+         case T_FILE:
+         case T_CSET:
+         case T_PROC:
+         case T_ESTACK:
+            arg0 = arg1;
+            break;
+
+         case T_LIST:
+           cplist(&arg1, &arg0, 1, BLKLOC(arg1)->list.cursize + 1);
+            break;
+
+         case T_TABLE:
+           hneed((sizeof(struct b_table)) +
+                 (sizeof(struct b_telem)) * BLKLOC(arg1)->table.cursize);
+            bp = alctable(0);
+            bp->table = BLKLOC(arg1)->table;
+            for (i = 0; i < NBUCKETS; i++) {
+               tp = &(BLKLOC(bp->table.buckets[i]));
+               for (ep = *tp; ep != NULL; ep = *tp) {
+                  *tp = alctelem();
+                  (*tp)->telem = ep->telem;
+                  tp = &(BLKLOC((*tp)->telem.blink));
+                  }
+               }
+            arg0.type = D_TABLE;
+            BLKLOC(arg0) = bp;
+            break;
+
+         case T_RECORD:
+           i = BLKLOC(arg1)->record.size;
+           hneed(i);
+           bp = allocate(i);
+            bp->record = BLKLOC(arg1)->record;
+            i = bp->record.recptr->nfields;
+            d1 = bp->record.fields;
+           d2 = BLKLOC(arg1)->record.fields;
+           while (i--)
+               *d1++ = *d2++;
+            arg0.type = D_RECORD;
+            BLKLOC(arg0) = bp;
+            break;
+
+         default:
+            syserr("copy: illegal datatype.");
+         }
+      }
+   }
+
+struct b_iproc Bcopy = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xcopy),
+   1,
+   -1,
+   0,
+   0,
+   {4, "copy"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/cset.c b/usr/src/new/new/icon/int/functions/cset.c

new file mode 100644 (file)

index 0000000..e3156d2
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/cset.c
@@ -0,0 +1,41 @@
+#include "../h/rt.h"
+
+/*
+ * cset(x) - convert x to cset.
+ */
+
+Xcset(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register int i;
+   register struct b_cset *bp;
+   int *cs, csbuf[CSETSIZE];
+   extern struct b_cset *alccset();
+
+   hneed(sizeof(struct b_cset));
+
+   deref(&arg1);
+
+   if (!QUAL(arg1) && TYPE(arg1) == T_CSET)
+      arg0 = arg1;
+   else if (cvcset(&arg1, &cs, csbuf) != NULL) {
+      arg0.type = D_CSET;
+      BLKLOC(arg0) = bp = alccset();
+      for (i = 0; i < CSETSIZE; i++)
+        bp->bits[i] = cs[i];
+      }
+   else
+      fail();
+   }
+
+struct b_iproc Bcset = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xcset),
+   1,
+   -1,
+   0,
+   0,
+   {4, "cset"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/display.c b/usr/src/new/new/icon/int/functions/display.c

new file mode 100644 (file)

index 0000000..9b44dbb
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/display.c
@@ -0,0 +1,236 @@
+#include "../h/rt.h"
+#ifdef VAX
+/*
+ * display(i,f) - display local variables of i most recent
+ * procedure activations, plus global variables.
+ * Output to file f (default &errout).
+ */
+
+Xdisplay(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register int *ap, *r5; /* Note that position is important, we assume
+                       that ap is in r11, and r5 is in r10 */
+   register struct descrip *dp;
+   register struct descrip *np;
+   register int n;
+   long l;
+   int count;
+   FILE *f;
+   struct b_proc *bp;
+   extern int *boundary;
+#ifdef INT
+   extern struct descrip *globals, *eglobals;
+   extern struct descrip *gnames;
+   extern struct descrip *statics;
+#endif INT
+#ifdef CMP
+   extern struct descrip globals[], eglobals[];
+   extern struct descrip gnames[];
+   extern struct descrip statics[];
+#endif CMP
+
+   defint(&arg1, &l, k_level);
+   deffile(&arg2, &errout);
+   f = BLKLOC(arg2)->file.fd;
+   if ((BLKLOC(arg2)->file.status & FS_WRITE) == 0)
+      runerr(213, &arg2);
+
+   if (l < 0)
+      runerr(205, &arg1);
+   else if (l > k_level)
+      count = k_level;
+   else
+      count = l;
+
+   r5 = boundary;              /* start r5 at most recent procedure frame */
+   while (count--) {
+      ap = r5[2];
+      r5 = r5[3];
+      n = ap[1];               /* get number of arguments */
+      dp = ap + 2 + 2*n;       /* calculate address of procedure descriptor*/
+      bp = BLKLOC(*dp);                /* get address of procedure block */
+
+      /* print procedure name */
+      putstr(f, STRLOC(bp->pname), STRLEN(bp->pname));
+      fprintf(f, " local identifiers:\n");
+
+      /* print arguments */
+      np = bp->lnames;
+      for (n = bp->nparam; n > 0; n--) {
+        fprintf(f, "   ");
+        putstr(f, STRLOC(*np), STRLEN(*np));
+         fprintf(f, " = ");
+        outimage(f, --dp, 0);
+        putc('\n', f);
+        np++;
+        }
+
+      /* print local dynamics */
+      dp = r5 - 2;
+      for (n = bp->ndynam; n > 0; n--) {
+        fprintf(f, "   ");
+        putstr(f, STRLOC(*np), STRLEN(*np));
+         fprintf(f, " = ");
+        outimage(f, --dp, 0);
+        putc('\n', f);
+        np++;
+        }
+
+      /* print local statics */
+      dp = &statics[bp->fstatic];
+      for (n = bp->nstatic; n > 0; n--) {
+        fprintf(f, "   ");
+        putstr(f, STRLOC(*np), STRLEN(*np));
+         fprintf(f, " = ");
+        outimage(f, dp++, 0);
+        putc('\n', f);
+        np++;
+        }
+
+      }
+
+   fprintf(f, "global identifiers:\n");
+   dp = globals;
+   np = gnames;
+   while (dp < eglobals) {
+      fprintf(f, "   ");
+      putstr(f, STRLOC(*np), STRLEN(*np));
+      fprintf(f, " = ");
+      outimage(f, dp++, 0);
+      putc('\n', f);
+      np++;
+      }
+   fflush(f);
+   arg0 = nulldesc;            /* return &null */
+   }
+
+struct b_iproc Bdisplay = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xdisplay),
+   2,
+   -1,
+   0,
+   0,
+   {7, "display"}
+   };
+#endif VAX
+#ifdef PDP11
+/*
+ * display(i,f) - display local variables of i most recent
+ * procedure activations, plus global variables.
+ * Output to file f (default &errout).
+ */
+
+Xdisplay(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register struct descrip *dp;
+   register struct descrip *np;
+   register int n;
+   register int *r5;
+   long l;
+   int count;
+   static struct descrip errout = {D_FILE, &k_errout};
+   FILE *f;
+   struct b_proc *bp;
+   extern int *boundary;
+#ifdef INT
+   extern struct descrip *globals, *eglobals;
+   extern struct descrip *gnames;
+   extern struct descrip *statics;
+#endif INT
+#ifdef CMP
+   extern struct descrip globals[], eglobals[];
+   extern struct descrip gnames[];
+   extern struct descrip statics[];
+#endif CMP
+
+   defint(&arg1, &l, k_level);
+   deffile(&arg2, &errout);
+   f = BLKLOC(arg2)->file.fd;
+   if ((BLKLOC(arg2)->file.status & FS_WRITE) == 0)
+      runerr(213, &arg2);
+
+   if (l < 0)
+      runerr(205, &arg1);
+   else if (l > k_level)
+      count = k_level;
+   else
+      count = l;
+
+   r5 = *boundary;             /* start r5 at most recent procedure frame */
+   while (count--) {
+      n = r5[2];               /* get number of arguments */
+      dp = r5 + 3 + 2*n;       /* calculate address of procedure descriptor */
+      bp = BLKLOC(*dp);                /* get address of procedure block */
+
+      /* print procedure name */
+      putstr(f, STRLOC(bp->pname), STRLEN(bp->pname));
+      fprintf(f, " local identifiers:\n");
+
+      /* print arguments */
+      np = bp->lnames;
+      for (n = bp->nparam; n > 0; n--) {
+        fprintf(f, "   ");
+        putstr(f, STRLOC(*np), STRLEN(*np));
+         fprintf(f, " = ");
+        outimage(f, --dp, 0);
+        putc('\n', f);
+        np++;
+        }
+
+      /* print local dynamics */
+      dp = r5 - 5;
+      for (n = bp->ndynam; n > 0; n--) {
+        fprintf(f, "   ");
+        putstr(f, STRLOC(*np), STRLEN(*np));
+         fprintf(f, " = ");
+        outimage(f, --dp, 0);
+        putc('\n', f);
+        np++;
+        }
+
+      /* print local statics */
+      dp = &statics[bp->fstatic];
+      for (n = bp->nstatic; n > 0; n--) {
+        fprintf(f, "   ");
+        putstr(f, STRLOC(*np), STRLEN(*np));
+         fprintf(f, " = ");
+        outimage(f, dp++, 0);
+        putc('\n', f);
+        np++;
+        }
+
+      r5 = *r5;
+      }
+
+   fprintf(f, "global identifiers:\n");
+   dp = globals;
+   np = gnames;
+   while (dp < eglobals) {
+      fprintf(f, "   ");
+      putstr(f, STRLOC(*np), STRLEN(*np));
+      fprintf(f, " = ");
+      outimage(f, dp++, 0);
+      putc('\n', f);
+      np++;
+      }
+   fflush(f);
+   arg0 = nulldesc;            /* return &null */
+   }
+
+struct b_iproc Bdisplay = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xdisplay),
+   2,
+   -1,
+   0,
+   0,
+   {7, "display"}
+   };
+#endif PDP11
diff --git a/usr/src/new/new/icon/int/functions/exit.c b/usr/src/new/new/icon/int/functions/exit.c

new file mode 100644 (file)

index 0000000..d900573
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/exit.c
@@ -0,0 +1,24 @@
+#include "../h/rt.h"
+
+/*
+ * exit(status) - exit process with status.
+ */
+
+Xexit(nargs, arg1)
+int nargs;
+struct descrip arg1;
+   {
+   defshort(&arg1, 0);
+   c_exit(arg1.value.integer);
+   }
+
+struct b_iproc Bexit = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xexit),
+   1,
+   -1,
+   0,
+   0,
+   {4, "exit"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/find.c b/usr/src/new/new/icon/int/functions/find.c

new file mode 100644 (file)

index 0000000..afc7e03
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/find.c
@@ -0,0 +1,62 @@
+#include "../h/rt.h"
+
+/*
+ * find(s1,s2,i,j) - find string s1 in s2[i:j].
+ * Returns position in s2 of beginning of s1.
+ * Generator.
+ */
+
+Xfind(nargs, arg4, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg4, arg3, arg2, arg1, arg0;
+   {
+   register int l;
+   register char *s1, *s2;
+   int i, j, t;
+   long l1, l2;
+   char sbuf1[MAXSTRING], sbuf2[MAXSTRING];
+
+   if (cvstr(&arg1, sbuf1) == NULL)
+      runerr(103, &arg1);
+   if (defstr(&arg2, sbuf2, &k_subject))
+      defint(&arg3, &l1, k_pos);
+   else
+      defint(&arg3, &l1, 1);
+   defint(&arg4, &l2, 0);
+
+   i = cvpos(l1, STRLEN(arg2));
+   j = cvpos(l2, STRLEN(arg2));
+   if (i > j) {
+      t = i;
+      i = j;
+      j = t;
+      }
+
+   while (i <= j - STRLEN(arg1)) {
+      s1 = STRLOC(arg1);
+      s2 = STRLOC(arg2) + i - 1;
+      l = STRLEN(arg1);
+      do {
+        if (l-- <= 0) {
+           arg0.type = D_INTEGER;
+           INTVAL(arg0) = i;
+            suspend();
+           break;
+           }
+        } while (*s1++ == *s2++);
+      i++;
+      }
+
+   fail();
+   }
+
+struct b_iproc Bfind = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xfind),
+   4,
+   -1,
+   0,
+   0,
+   {4, "find"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/get.c b/usr/src/new/new/icon/int/functions/get.c

new file mode 100644 (file)

index 0000000..941696f
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/get.c
@@ -0,0 +1,19 @@
+#include "../h/rt.h"
+
+/*
+ * get(x) - get an element from end of list x.
+ * Synonym for pop(x).
+ */
+
+extern Xpop();
+
+struct b_iproc Bget = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xpop),
+   1,
+   -1,
+   0,
+   0,
+   {3, "get"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/image.c b/usr/src/new/new/icon/int/functions/image.c

new file mode 100644 (file)

index 0000000..80bc199
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/image.c
@@ -0,0 +1,276 @@
+#include "../h/rt.h"
+#include "../h/record.h"
+
+/*
+ * image(x) - return string giving image of object x.
+ */
+
+Ximage(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register int len, outlen, rnlen;
+   register char *s;
+   register union block *bp;
+   char *type;
+   extern char *alcstr();
+   extern struct descrip *cstos();
+   char sbuf[MAXSTRING];
+   FILE *fd;
+
+   deref(&arg1);
+
+   if (NULLDESC(arg1)) {
+      STRLOC(arg0) = "&null";
+      STRLEN(arg0) = 5;
+      return;
+      }
+
+   if (QUAL(arg1)) {
+      sneed(prescan(&arg1) + 2);
+      len = STRLEN(arg1);
+      s = STRLOC(arg1);
+      outlen = 2;
+      STRLOC(arg0) = alcstr("\"", 1);
+                     while (len-- > 0)
+                        outlen += doimage(*s++, '"');
+                     alcstr("\"", 1);
+      STRLEN(arg0) = outlen;
+      return;
+      }
+
+   switch (TYPE(arg1)) {
+      case T_INTEGER:
+#ifndef BIT32
+      case T_LONGINT:
+#endif
+      case T_REAL:
+         cvstr(&arg1, sbuf);
+        len = STRLEN(arg1);
+         sneed(len);
+        STRLOC(arg0) = alcstr(STRLOC(arg1), len);
+        STRLEN(arg0) = len;
+         return;
+
+      case T_CSET:
+         if (BLKLOC(arg1) == &k_ascii) {
+            STRLOC(arg0) = "&ascii";
+            STRLEN(arg0) = 6;
+            return;
+            }
+         else if (BLKLOC(arg1) == &k_cset) {
+            STRLOC(arg0) = "&cset";
+            STRLEN(arg0) = 5;
+            return;
+            }
+         else if (BLKLOC(arg1) == &k_lcase) {
+            STRLOC(arg0) = "&lcase";
+            STRLEN(arg0) = 6;
+            return;
+            }
+         else if (BLKLOC(arg1) == &k_ucase) {
+            STRLOC(arg0) = "&ucase";
+            STRLEN(arg0) = 6;
+            return;
+            }
+         cvstr(&arg1, sbuf);
+         sneed(prescan(&arg1) + 2);
+         len = STRLEN(arg1);
+         s = STRLOC(arg1);
+         outlen = 2;
+         STRLOC(arg0) = alcstr("'", 1);
+                        while (len-- > 0)
+                           outlen += doimage(*s++, '\'');
+                        alcstr("'", 1);
+         STRLEN(arg0) = outlen;
+         return;
+
+      case T_FILE:
+         if ((fd = BLKLOC(arg1)->file.fd) == stdin) {
+            STRLEN(arg0) = 6;
+            STRLOC(arg0) = "&input";
+            }
+         else if (fd == stdout) {
+            STRLEN(arg0) = 7;
+            STRLOC(arg0) = "&output";
+            }
+         else if (fd == stderr) {
+            STRLEN(arg0) = 7;
+            STRLOC(arg0) = "&errout";
+            }
+         else {
+            sneed(prescan(&BLKLOC(arg1)->file.fname)+6);
+            len = STRLEN(BLKLOC(arg1)->file.fname);
+            s = STRLOC(BLKLOC(arg1)->file.fname);
+            outlen = 6;
+            STRLOC(arg0) = alcstr("file(", 5);
+                           while (len-- > 0)
+                              outlen += doimage(*s++, '\0');
+                          alcstr(")", 1);
+            STRLEN(arg0) = outlen;
+            }
+         return;
+
+      case T_PROC:
+         len = STRLEN(BLKLOC(arg1)->proc.pname);
+         s = STRLOC(BLKLOC(arg1)->proc.pname);
+        switch (BLKLOC(arg1)->proc.ndynam) {
+           default:  type = "procedure "; break;
+           case -1:  type = "function "; break;
+           case -2:  type = "record constructor "; break;
+           }
+         outlen = strlen(type);
+         sneed(len + outlen);
+        STRLOC(arg0) = alcstr(type, outlen);
+                        alcstr(s, len);
+         STRLEN(arg0) = len + outlen;
+         return;
+
+      case T_LIST:
+         bp = BLKLOC(arg1);
+         sprintf(sbuf, "list(%d)", bp->list.cursize);
+         len = strlen(sbuf);
+         sneed(len);
+         STRLOC(arg0) = alcstr(sbuf, len);
+         STRLEN(arg0) = len;
+         return;
+
+      case T_TABLE:
+         bp = BLKLOC(arg1);
+         sprintf(sbuf, "table(%d)", bp->table.cursize);
+         len = strlen(sbuf);
+         sneed(len);
+         STRLOC(arg0) = alcstr(sbuf, len);
+         STRLEN(arg0) = len;
+         return;
+
+      case T_RECORD:
+         bp = BLKLOC(arg1);
+         rnlen = STRLEN(bp->record.recptr->proc.recname);
+         sneed(15 + rnlen);
+         bp = BLKLOC(arg1);
+         sprintf(sbuf, "(%d)", bp->record.recptr->proc.nfields);
+         len = strlen(sbuf);
+         STRLOC(arg0) = alcstr("record ", 7);
+                        alcstr(STRLOC(bp->record.recptr->proc.recname),
+                               rnlen);
+                        alcstr(sbuf, len);
+         STRLEN(arg0) = 7 + len + rnlen;
+         return;
+
+      case T_ESTACK:
+         sneed(22);
+         sprintf(sbuf, "(%d)", BLKLOC(arg1)->estack.nresults);
+         len = strlen(sbuf);
+         STRLOC(arg0) = alcstr("co-expression", 13);
+                        alcstr(sbuf, len);
+         STRLEN(arg0) = 13 + len;
+         return;
+
+      default:
+         syserr("image: unknown type.");
+      }
+   }
+
+struct b_iproc Bimage = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Ximage),
+   1,
+   -1,
+   0,
+   0,
+   {5, "image"}
+   };
+
+/*
+ * doimage(c,q) - allocate character c in string space, with escape
+ * conventions if c is unprintable, '\', or equal to q.
+ * Returns number of characters allocated.
+ */
+
+doimage(c, q)
+int c, q;
+   {
+   static char *cbuf = "\\\0\0\0";
+   extern char *alcstr();
+
+   if (c >= ' ' && c < '\177') {
+      switch (c) {
+         case '"':                         /*      d. quote     */
+            if (c != q) goto def;
+           alcstr("\\\"", 2);
+            return (2);
+         case '\'':                        /*      s. quote     */
+            if (c != q) goto def;
+            alcstr("\\'", 2);
+            return (2);
+         case '\\':                        /*      backslash    */
+            alcstr("\\\\", 2);
+            return (2);
+         default:                          /*      normal ch.   */
+        def:
+            cbuf[0] = c;
+            cbuf[1] = '\0'; /* Do we need this? --whm */
+            alcstr(cbuf,1);
+            return (1);
+         }
+      }
+
+   switch (c) {                         /* special character */
+      case '\b':                        /*      backspace    */
+         alcstr("\\b", 2);
+         return (2);
+      case '\177':                      /*      delete       */
+         alcstr("\\d", 2);
+         return (2);
+      case '\33':                       /*      escape       */
+         alcstr("\\e", 2);
+         return (2);
+      case '\f':                        /*      form feed    */
+         alcstr("\\f", 2);
+         return (2);
+      case '\n':                        /*      new line     */
+         alcstr("\\n", 2);
+         return (2);
+      case '\r':                        /*      return       */
+         alcstr("\\r", 2);
+         return (2);
+      case '\t':                        /*      hor. tab     */
+         alcstr("\\t", 2);
+         return (2);
+      case '\13':                       /*      ver. tab     */
+         alcstr("\\v", 2);
+         return (2);
+      default:                          /*      octal cons.  */
+        cbuf[0] = '\\';
+         cbuf[1] = ((c&0300) >> 6) + '0';
+         cbuf[2] = ((c&070) >> 3) + '0';
+         cbuf[3] = (c&07) + '0';
+         alcstr(cbuf, 4);
+         return (4);
+      }
+   }
+
+/*
+ * prescan(d) - return upper bound on length of expanded string.
+ */
+
+prescan(d)
+struct descrip *d;
+   {
+   register int slen, len;
+   register char *s, c;
+
+   s = STRLOC(*d);
+   len = 0;
+   for (slen = STRLEN(*d); slen > 0; slen--)
+      if ((c = (*s++)) < ' ' || c >= 0177)
+         len += 4;
+      else if (c == '"' || c == '\\' || c == '\'')
+         len += 2;
+      else
+         len++;
+
+   return (len);
+   }
diff --git a/usr/src/new/new/icon/int/functions/integer.c b/usr/src/new/new/icon/int/functions/integer.c

new file mode 100644 (file)

index 0000000..f068c2f
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/integer.c
@@ -0,0 +1,34 @@
+#include "../h/rt.h"
+
+/*
+ * integer(x) - convert x to integer.
+ */
+
+Xinteger(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   long l;
+
+   switch (cvint(&arg1, &l)) {
+      case T_INTEGER:
+#ifndef BIT32
+      case T_LONGINT:
+#endif
+        mkint(l, &arg0);
+        break;
+      default:
+        fail();
+      }
+   }
+
+struct b_iproc Binteger = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xinteger),
+   1,
+   -1,
+   0,
+   0,
+   {7, "integer"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/left.c b/usr/src/new/new/icon/int/functions/left.c

new file mode 100644 (file)

index 0000000..0c24d5f
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/left.c
@@ -0,0 +1,62 @@
+#include "../h/rt.h"
+
+/*
+ * left(s1,n,s2) - pad s1 on right with s2 to length n.
+ */
+
+Xleft(nargs, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg3, arg2, arg1, arg0;
+   {
+   register char *s, *st;
+   int cnt, slen, i;
+   char *sbuf, *s3, sbuf1[MAXSTRING], sbuf2[MAXSTRING];
+   extern char *alcstr();
+
+   if (cvstr(&arg1, sbuf1) == NULL)
+      runerr(103, &arg1);
+   defshort(&arg2, 1);
+   if ((cnt = arg2.value.integer) < 0)
+      runerr(205, &arg2);
+   defstr(&arg3, sbuf2, &blank);
+
+   sneed(cnt);
+   if (STRLEN(arg3) == 0) {
+      slen = 1;
+      s3 = " ";
+      }
+   else {
+      slen = STRLEN(arg3);
+      s3 = STRLOC(arg3);
+      }
+
+   sbuf = alcstr(NULL, cnt);
+   s = sbuf + cnt;
+   while (s > sbuf) {
+      st = s3 + slen;
+      while (st > s3 && s > sbuf)
+         *--s = *--st;
+      }
+
+   s = sbuf;
+   slen = STRLEN(arg1);
+   st = STRLOC(arg1);
+   if (slen > cnt)
+      slen = cnt;
+   while (slen-- > 0)
+      *s++ = *st++;
+
+   STRLEN(arg0) = cnt;
+   STRLOC(arg0) = sbuf;
+   }
+
+struct b_iproc Bleft = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xleft),
+   3,
+   -1,
+   0,
+   0,
+   {4, "left"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/list.c b/usr/src/new/new/icon/int/functions/list.c

new file mode 100644 (file)

index 0000000..0daa64e
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/list.c
@@ -0,0 +1,49 @@
+#include "../h/rt.h"
+
+/*
+ * list(n,x) - create a list of size n, with initial value x.
+ */
+
+Xlist(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register int i, size;
+   register struct b_listb *bp;
+   register struct b_list *hp;
+   int nelem;
+   extern struct b_list *alclist();
+   extern struct b_listb *alclstb();
+
+   defshort(&arg1, 0);
+   deref(&arg2);
+
+   nelem = size = arg1.value.integer;
+   if (size < 0)
+      runerr(205, &arg1);
+   if (nelem < LISTBLKSIZE)
+      nelem = LISTBLKSIZE;
+
+   hneed(sizeof(struct b_list) + sizeof(struct b_listb) +
+         nelem * sizeof(struct descrip));
+
+   hp = alclist(size);
+   bp = alclstb(nelem, 0, size);
+   hp->listhead.type = hp->listtail.type = D_LISTB;
+   BLKLOC(hp->listhead) = BLKLOC(hp->listtail) = bp;
+   for (i = 0; i < size; i++)
+      bp->lelem[i] = arg2;
+   arg0.type = D_LIST;
+   BLKLOC(arg0) = hp;
+   }
+
+struct b_iproc Blist = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xlist),
+   2,
+   -1,
+   0,
+   0,
+   {4, "list"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/many.c b/usr/src/new/new/icon/int/functions/many.c

new file mode 100644 (file)

index 0000000..d18f873
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/many.c
@@ -0,0 +1,54 @@
+#include "../h/rt.h"
+
+/*
+ * many(c,s,i,j) - find longest prefix of s[i:j] of characters in c.
+ */
+
+Xmany(nargs, arg4, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg4, arg3, arg2, arg1, arg0;
+   {
+   register int i, j;
+   int t, *cs, csbuf[CSETSIZE];
+   long l1, l2;
+   char sbuf[MAXSTRING];
+
+   if (cvcset(&arg1, &cs, csbuf) == NULL)
+      runerr(104, &arg1);
+   if (defstr(&arg2, sbuf, &k_subject))
+      defint(&arg3, &l1, k_pos);
+   else
+      defint(&arg3, &l1, 1);
+   defint(&arg4, &l2, 0);
+
+   i = cvpos(l1, STRLEN(arg2));
+   j = cvpos(l2, STRLEN(arg2));
+   if (i == j)
+      fail();
+   if (i > j) {
+      t = i;
+      i = j;
+      j = t;
+      }
+
+   if (!tstb(STRLOC(arg2)[i-1], cs))
+      fail();
+
+   i++;
+   while (i < j && tstb(STRLOC(arg2)[i-1], cs))
+      i++;
+
+   arg0.type = D_INTEGER;
+   INTVAL(arg0) = i;
+   }
+
+struct b_iproc Bmany = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xmany),
+   4,
+   -1,
+   0,
+   0,
+   {4, "many"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/map.c b/usr/src/new/new/icon/int/functions/map.c

new file mode 100644 (file)

index 0000000..3f3e331
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/map.c
@@ -0,0 +1,65 @@
+#include "../h/rt.h"
+
+/*
+ * map(s1,s2,s3) - map s1, using s2 and s3.
+ */
+
+Xmap(nargs, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg3, arg2, arg1, arg0;
+   {
+   register int i;
+   register char *s1, *s2, *s3;
+   char sbuf1[MAXSTRING], sbuf2[MAXSTRING], sbuf3[MAXSTRING];
+   static char maptab[MAXSTRING];
+   extern char *alcstr();
+
+   if (cvstr(&arg1, sbuf1) == NULL)
+      runerr(103, &arg1);
+   defany(&arg2, &ucase);
+   defany(&arg3, &lcase);
+
+   if (maps2.type != arg2.type || maps3.type != arg3.type ||
+       BLKLOC(maps2) != BLKLOC(arg2) || BLKLOC(maps3) != BLKLOC(arg3)) {
+      maps2 = arg2;
+      maps3 = arg3;
+      if (cvstr(&arg2, sbuf2) == NULL)
+         runerr(103, &arg2);
+      if (cvstr(&arg3, sbuf3) == NULL)
+         runerr(103, &arg3);
+      if (STRLEN(arg2) != STRLEN(arg3))
+         runerr(208, NULL);
+      s2 = STRLOC(arg2);
+      s3 = STRLOC(arg3);
+      for (i = MAXSTRING - 1; i >= 0; i--)
+         maptab[i] = i;
+      for (i = 0; i < STRLEN(arg2); i++)
+         maptab[s2[i]&0377] = s3[i];
+      }
+
+   if (STRLEN(arg1) == 0) {
+      arg0.type = D_NULL;
+      INTVAL(arg0) = 1;
+      return;
+      }
+
+   i = STRLEN(arg1);
+   sneed(i);
+   s1 = STRLOC(arg1);
+
+   STRLEN(arg0) = i;
+   STRLOC(arg0) = s2 = alcstr(NULL, i);
+   while (i-- > 0)
+      *s2++ = maptab[(*s1++)&0377];
+   }
+
+struct b_iproc Bmap = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xmap),
+   3,
+   -1,
+   0,
+   0,
+   {3, "map"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/match.c b/usr/src/new/new/icon/int/functions/match.c

new file mode 100644 (file)

index 0000000..d9bc6b0
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/match.c
@@ -0,0 +1,58 @@
+#include "../h/rt.h"
+
+/*
+ * match(s1,s2,i,j) - test if s1 is prefix of s2[i:j].
+ */
+
+Xmatch(nargs, arg4, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg4, arg3, arg2, arg1, arg0;
+   {
+   register int i;
+   register char *s1, *s2;
+   int j, t;
+   long l1, l2;
+   char sbuf1[MAXSTRING], sbuf2[MAXSTRING];
+
+   if (cvstr(&arg1, sbuf1) == NULL)
+      runerr(103, &arg1);
+   if (defstr(&arg2, sbuf2, &k_subject))
+      defint(&arg3, &l1, k_pos);
+   else
+      defint(&arg3, &l1, 1);
+   defint(&arg4, &l2, 0);
+
+   i = cvpos(l1, STRLEN(arg2));
+   j = cvpos(l2, STRLEN(arg2));
+
+   if (i > j) {                 /* convert to substring */
+      t = i;
+      i = j;
+      j = t - j;
+      }
+   else
+      j = j - i;
+
+   if (j < STRLEN(arg1))
+      fail();
+
+   s1 = STRLOC(arg1);
+   s2 = STRLOC(arg2) + i - 1;
+   for (j = STRLEN(arg1); j > 0; j--)
+      if (*s1++ != *s2++)
+         fail();
+
+   arg0.type = D_INTEGER;
+   INTVAL(arg0) = i + STRLEN(arg1);
+   }
+
+struct b_iproc Bmatch = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xmatch),
+   4,
+   -1,
+   0,
+   0,
+   {5, "match"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/move.c b/usr/src/new/new/icon/int/functions/move.c

new file mode 100644 (file)

index 0000000..93b4132
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/move.c
@@ -0,0 +1,55 @@
+#include "../h/rt.h"
+
+/*
+ * move(i) - move &pos by i, return substring of &subject spanned.
+ * Generator (reversible).
+ */
+
+Xmove(nargs, oldsubj, arg1, arg0)
+int nargs;
+struct descrip oldsubj, arg1, arg0;
+   {
+   register int i, j;
+   long l;
+   int oldpos;
+
+   switch (cvint(&arg1, &l)) {
+      case T_INTEGER:  j = (int)l; break;
+#ifndef BIT32
+      case T_LONGINT:  fail();
+#endif
+      default:         runerr(101, &arg1);
+      }
+
+   oldsubj = k_subject;                /* save old &subject and &pos */
+   oldpos = i = k_pos;
+
+   if (i + j <= 0 || i + j > STRLEN(k_subject) + 1)
+      fail();
+
+   k_pos += j;                 /* set new &pos */
+
+   if (j < 0) {                        /* make sure j >= 0 */
+      i += j;
+      j = -j;
+      }
+
+   STRLEN(arg0) = j;
+   STRLOC(arg0) = STRLOC(k_subject) + i - 1;
+   suspend();
+
+   k_subject = oldsubj;
+   k_pos = oldpos;
+   fail();
+   }
+
+struct b_iproc Bmove = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xmove),
+   2,
+   -1,
+   0,
+   0,
+   {4, "move"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/numeric.c b/usr/src/new/new/icon/int/functions/numeric.c

new file mode 100644 (file)

index 0000000..8b60ed2
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/numeric.c
@@ -0,0 +1,40 @@
+#include "../h/rt.h"
+
+/*
+ * numeric(x) - convert x to numeric type.
+ */
+
+Xnumeric(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   union numeric n1;
+
+   switch (cvnum(&arg1, &n1)) {
+#ifdef  BIT32
+      case T_INTEGER:
+#else
+      case T_LONGINT:
+#endif
+        mkint(n1.i, &arg0);
+        break;
+
+      case T_REAL:
+         mkreal(n1.r, &arg0);
+         break;
+
+      default:
+        fail();
+      }
+   }
+
+struct b_iproc Bnumeric = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xnumeric),
+   1,
+   -1,
+   0,
+   0,
+   {7, "numeric"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/open.c b/usr/src/new/new/icon/int/functions/open.c

new file mode 100644 (file)

index 0000000..594c1f1
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/open.c
@@ -0,0 +1,113 @@
+#include "../h/rt.h"
+
+/*
+ * open(s1,s2) - open file s1 with specification s2.
+ */
+int globals;
+Xopen(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register int slen, i;
+   register char *s;
+   int status;
+   char sbuf1[MAXSTRING], sbuf2[MAXSTRING], mode[3];
+   FILE *f;
+   extern struct b_file *alcfile();
+   extern FILE *fopen(), *popen();
+
+   switch (cvstr(&arg1, sbuf1)) {
+      case 1:
+         sneed(STRLEN(arg1));
+         STRLOC(arg1) = alcstr(STRLOC(arg1), STRLEN(arg1));
+        break;
+      case 2:
+         qtos(&arg1, sbuf1);
+        break;
+      default:
+         runerr(103, &arg1);
+      }
+   defstr(&arg2, sbuf2, &letr);
+
+   hneed(sizeof(struct b_file));
+   status = 0;
+
+   s = STRLOC(arg2);
+   slen = STRLEN(arg2);
+   for (i = 0; i < slen; i++) {
+      switch (*s++) {
+         case 'a': case 'A':
+            status |= FS_WRITE|FS_APPEND;
+            continue;
+         case 'b': case 'B':
+            status |= FS_READ|FS_WRITE;
+            continue;
+         case 'c': case 'C':
+            status |= FS_CREATE|FS_WRITE;
+            continue;
+         case 'p': case 'P':
+            status |= FS_PIPE;
+            continue;
+         case 'r': case 'R':
+            status |= FS_READ;
+            continue;
+         case 'w': case 'W':
+            status |= FS_WRITE;
+            continue;
+         default:
+            runerr(209, &arg2);
+         }
+      }
+
+   mode[0] = '\0';
+   mode[1] = '\0';
+   mode[2] = '\0';
+   if ((status & (FS_READ|FS_WRITE)) == 0)   /* default: read only */
+      status |= FS_READ;
+   if (status & FS_CREATE)
+      mode[0] = 'w';
+   else if (status & FS_APPEND)
+      mode[0] = 'a';
+   else if (status & FS_READ)
+      mode[0] = 'r';
+   else
+      mode[0] = 'w';
+   if ((status & (FS_READ|FS_WRITE)) == (FS_READ|FS_WRITE))
+      mode[1] = '+';
+
+   if (status & FS_PIPE) {
+      if (status != (FS_READ|FS_PIPE) && status != (FS_WRITE|FS_PIPE))
+         runerr(209, &arg2);
+      f = popen(sbuf1, mode);
+      }
+   else
+      f = fopen(sbuf1, mode);
+   if (f == NULL)
+      fail();
+   if (!isatty(fileno(f))) {
+      for (i = 0; i < numbufs; i++)
+         if (bufused[i] == NULL)
+            break;
+      if (i < numbufs) {              /* use buffer if any free */
+         setbuf(f, bufs[i]);
+         bufused[i] = f;
+         }
+      else
+         setbuf(f, NULL);
+      }
+   else
+      setbuf(f, NULL);
+   arg0.type = D_FILE;
+   BLKLOC(arg0) = alcfile(f, status, &arg1);
+   }
+
+struct b_iproc Bopen = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xopen),
+   2,
+   -1,
+   0,
+   0,
+   {4, "open"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/pop.c b/usr/src/new/new/icon/int/functions/pop.c

new file mode 100644 (file)

index 0000000..6bb4a98
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/pop.c
@@ -0,0 +1,47 @@
+#include "../h/rt.h"
+
+/*
+ * pop(x) - pop an element from beginning of list x.
+ */
+
+Xpop(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register int i;
+   register struct b_list *hp;
+   register struct b_listb *bp;
+   extern struct b_listb *alclstb();
+
+   deref(&arg1);
+   if (TYPE(arg1) != T_LIST)
+      runerr(108, &arg1);
+
+   hp = BLKLOC(arg1);
+   if (hp->cursize <= 0)
+      fail();
+   bp = BLKLOC(hp->listhead);
+   if (bp->nused <= 0) {
+      bp = BLKLOC(bp->listnext);
+      BLKLOC(hp->listhead) = bp;
+      bp->listprev = nulldesc;
+      }
+   i = bp->first;
+   arg0 = bp->lelem[i];
+   if (++i >= bp->nelem)
+      i = 0;
+   bp->first = i;
+   bp->nused--;
+   hp->cursize--;
+   }
+
+struct b_iproc Bpop = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xpop),
+   1,
+   -1,
+   0,
+   0,
+   {3, "pop"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/pos.c b/usr/src/new/new/icon/int/functions/pos.c

new file mode 100644 (file)

index 0000000..74377ef
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/pos.c
@@ -0,0 +1,32 @@
+#include "../h/rt.h"
+
+/*
+ * pos(i) - test if &pos is at position i in &subject.
+ */
+
+Xpos(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register int i;
+   long l;
+
+   if (cvint(&arg1, &l) == NULL)
+      runerr(101, &arg1);
+
+   if ((i = cvpos(l, STRLEN(k_subject))) != k_pos)
+      fail();
+   arg0.type = D_INTEGER;
+   BLKLOC(arg0) = i;
+   }
+
+struct b_iproc Bpos = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xpos),
+   1,
+   -1,
+   0,
+   0,
+   {3, "pos"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/pull.c b/usr/src/new/new/icon/int/functions/pull.c

new file mode 100644 (file)

index 0000000..b2a6645
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/pull.c
@@ -0,0 +1,46 @@
+#include "../h/rt.h"
+
+/*
+ * pull(x) - pull an element from end of list x.
+ */
+
+Xpull(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register int i;
+   register struct b_list *hp;
+   register struct b_listb *bp;
+   extern struct b_listb *alclstb();
+
+   deref(&arg1);
+   if (TYPE(arg1) != T_LIST)
+      runerr(108, &arg1);
+
+   hp = BLKLOC(arg1);
+   if (hp->cursize <= 0)
+      fail();
+   bp = BLKLOC(hp->listtail);
+   if (bp->nused <= 0) {
+      bp = BLKLOC(bp->listprev);
+      BLKLOC(hp->listtail) = bp;
+      bp->listnext = nulldesc;
+      }
+   i = bp->first + bp->nused - 1;
+   if (i >= bp->nelem)
+      i -= bp->nelem;
+   arg0 = bp->lelem[i];
+   bp->nused--;
+   hp->cursize--;
+   }
+
+struct b_iproc Bpull = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xpull),
+   1,
+   -1,
+   0,
+   0,
+   {4, "pull"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/push.c b/usr/src/new/new/icon/int/functions/push.c

new file mode 100644 (file)

index 0000000..815014e
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/push.c
@@ -0,0 +1,51 @@
+#include "../h/rt.h"
+
+/*
+ * push(x,val) - push val onto beginning of list x.
+ */
+
+Xpush(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register int i;
+   register struct b_list *hp;
+   register struct b_listb *bp;
+   extern struct b_listb *alclstb();
+
+   deref(&arg1);
+   deref(&arg2);
+   if (TYPE(arg1) != T_LIST)
+      runerr(108, &arg1);
+
+   hneed(sizeof(struct b_listb)+LISTBLKSIZE*sizeof(struct descrip));
+
+   hp = BLKLOC(arg1);
+   bp = BLKLOC(hp->listhead);
+   if (bp->nused >= bp->nelem) {
+      bp = alclstb(LISTBLKSIZE, 0, 0);
+      BLKLOC(hp->listhead)->listprev.type = D_LISTB;
+      BLKLOC(BLKLOC(hp->listhead)->listprev) = bp;
+      bp->listnext = hp->listhead;
+      BLKLOC(hp->listhead) = bp;
+      }
+   i = bp->first - 1;
+   if (i < 0)
+      i = bp->nelem - 1;
+   bp->lelem[i] = arg2;
+   bp->first = i;
+   bp->nused++;
+   hp->cursize++;
+   arg0 = arg1;
+   }
+
+struct b_iproc Bpush = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xpush),
+   2,
+   -1,
+   0,
+   0,
+   {4, "push"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/put.c b/usr/src/new/new/icon/int/functions/put.c

new file mode 100644 (file)

index 0000000..a687596
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/put.c
@@ -0,0 +1,50 @@
+#include "../h/rt.h"
+
+/*
+ * put(x,val) - put val onto end of list x.
+ */
+
+Xput(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register int i;
+   register struct b_list *hp;
+   register struct b_listb *bp;
+   extern struct b_listb *alclstb();
+
+   deref(&arg1);
+   deref(&arg2);
+   if (TYPE(arg1) != T_LIST)
+      runerr(108, &arg1);
+
+   hneed(sizeof(struct b_listb)+LISTBLKSIZE*sizeof(struct descrip));
+
+   hp = BLKLOC(arg1);
+   bp = BLKLOC(hp->listtail);
+   if (bp->nused >= bp->nelem) {
+      bp = alclstb(LISTBLKSIZE, 0, 0);
+      BLKLOC(hp->listtail)->listnext.type = D_LISTB;
+      BLKLOC(BLKLOC(hp->listtail)->listnext) = bp;
+      bp->listprev = hp->listtail;
+      BLKLOC(hp->listtail) = bp;
+      }
+   i = bp->first + bp->nused;
+   if (i >= bp->nelem)
+      i -= bp->nelem;
+   bp->lelem[i] = arg2;
+   bp->nused++;
+   hp->cursize++;
+   arg0 = arg1;
+   }
+
+struct b_iproc Bput = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xput),
+   2,
+   -1,
+   0,
+   0,
+   {3, "put"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/read.c b/usr/src/new/new/icon/int/functions/read.c

new file mode 100644 (file)

index 0000000..c38c1ef
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/read.c
@@ -0,0 +1,39 @@
+#include "../h/rt.h"
+
+/*
+ * read(f) - read line on file f.
+ */
+
+Xread(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register int slen;
+   int status;
+   char sbuf[MAXREADSTRING];
+   FILE *f;
+   extern char *alcstr();
+
+   deffile(&arg1, &input);
+   f = BLKLOC(arg1)->file.fd;
+   status = BLKLOC(arg1)->file.status;
+   if ((status & FS_READ) == 0)
+      runerr(212, &arg1);
+
+   if ((slen = getstr(sbuf,MAXREADSTRING,f)) < 0)
+      fail();
+   sneed(slen);
+   STRLEN(arg0) = slen;
+   STRLOC(arg0) = alcstr(sbuf,slen);
+   }
+
+struct b_iproc Bread = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xread),
+   1,
+   -1,
+   0,
+   0,
+   {4, "read"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/reads.c b/usr/src/new/new/icon/int/functions/reads.c

new file mode 100644 (file)

index 0000000..32bfefb
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/reads.c
@@ -0,0 +1,46 @@
+#include "../h/rt.h"
+
+/*
+ * reads(f,i) - read i chars on file f.
+ */
+
+Xreads(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register int i, cnt;
+   int status;
+   long l1;
+   FILE *f;
+
+   deffile(&arg1, &input);
+   defshort(&arg2, 1);
+
+   f = BLKLOC(arg1)->file.fd;
+   status = BLKLOC(arg1)->file.status;
+   if ((status & FS_READ) == 0)
+      runerr(212, &arg1);
+
+   if ((cnt = arg2.value.integer) <= 0)
+      runerr(205, &arg2);
+
+   sneed(cnt);
+   if (sfree + cnt > estrings)
+      runerr(302, NULL);
+   STRLOC(arg0) = sfree;
+   if ((cnt = fread(STRLOC(arg0), sizeof(char), cnt, f)) <= 0)
+      fail();
+   STRLEN(arg0) = cnt;
+   sfree += cnt;
+   }
+
+struct b_iproc Breads = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xreads),
+   2,
+   -1,
+   0,
+   0,
+   {5, "reads"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/real.c b/usr/src/new/new/icon/int/functions/real.c

new file mode 100644 (file)

index 0000000..dddbfe6
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/real.c
@@ -0,0 +1,31 @@
+#include "../h/rt.h"
+
+/*
+ * real(x) - convert x to real.
+ */
+
+Xreal(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   double r;
+
+   deref(&arg1);
+   if (!QUAL(arg1) && TYPE(arg1) == T_REAL)
+      arg0 = arg1;
+   else if (cvreal(&arg1, &r) == T_REAL)
+      mkreal(r, &arg0);
+   else
+      fail();
+   }
+
+struct b_iproc Breal = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xreal),
+   1,
+   -1,
+   0,
+   0,
+   {4, "real"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/repl.c b/usr/src/new/new/icon/int/functions/repl.c

new file mode 100644 (file)

index 0000000..9579fd1
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/repl.c
@@ -0,0 +1,53 @@
+#include "../h/rt.h"
+
+/*
+ * repl(s,n) - concatenate n copies of string s.
+ */
+
+Xrepl(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register int cnt, i;
+   register char *sloc;
+   long l1;
+   char sbuf[MAXSTRING];
+   extern char *alcstr();
+
+   if (cvstr(&arg1, sbuf) == NULL)
+      runerr(103, &arg1);
+   switch (cvint(&arg2, &l1)) {
+      case T_INTEGER:   if ((cnt = (int)l1) >= 0) break;
+#ifndef BIT32
+      case T_LONGINT:   runerr(205, &arg2);
+#endif
+      default:          runerr(101, &arg2);
+      }
+
+   if ((l1 * STRLEN(arg1)) > MAXSHORT)
+      runerr(302, NULL);
+   if (cnt == 0) {
+      arg0.type = D_NULL;
+      INTVAL(arg0) = 1;
+      }
+   else {
+      sneed(cnt * STRLEN(arg1));
+      sloc = alcstr(STRLOC(arg1), STRLEN(arg1));
+      cnt--;
+      while (cnt--)
+         alcstr(STRLOC(arg1), STRLEN(arg1));
+      STRLEN(arg0) = (int)l1 * STRLEN(arg1);
+      STRLOC(arg0) = sloc;
+      }
+   }
+
+struct b_iproc Brepl = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xrepl),
+   2,
+   -1,
+   0,
+   0,
+   {4, "repl"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/reverse.c b/usr/src/new/new/icon/int/functions/reverse.c

new file mode 100644 (file)

index 0000000..adabbf6
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/reverse.c
@@ -0,0 +1,42 @@
+#include "../h/rt.h"
+
+/*
+ * reverse(s) - reverse string s.
+ */
+
+Xreverse(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   register char c, *floc, *lloc;
+   register int slen;
+   char sbuf[MAXSTRING];
+   extern char *alcstr();
+
+   if (cvstr(&arg1, sbuf) == NULL)
+      runerr(103, &arg1);
+
+   slen = STRLEN(arg1);
+   sneed(slen);
+   STRLEN(arg0) = slen;
+   STRLOC(arg0) = alcstr(STRLOC(arg1), slen);
+
+   floc = STRLOC(arg0);
+   lloc = floc + --slen;
+   while (floc < lloc) {
+      c = *floc;
+      *floc++ = *lloc;
+      *lloc-- = c;
+      }
+   }
+
+struct b_iproc Breverse = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xreverse),
+   1,
+   -1,
+   0,
+   0,
+   {7, "reverse"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/right.c b/usr/src/new/new/icon/int/functions/right.c

new file mode 100644 (file)

index 0000000..f91f332
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/right.c
@@ -0,0 +1,64 @@
+#include "../h/rt.h"
+
+/*
+ * right(s1,n,s2) - pad s1 on left with s2 to length n.
+ */
+
+Xright(nargs, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg3, arg2, arg1, arg0;
+   {
+   register char *s, *st;
+   int cnt, slen, i;
+   char *sbuf, *s3, sbuf1[MAXSTRING], sbuf2[MAXSTRING];
+   extern char *alcstr();
+
+   if (cvstr(&arg1, sbuf1) == NULL)
+      runerr(103, &arg1);
+   defshort(&arg2, 1);
+   if ((cnt = arg2.value.integer) < 0)
+      runerr(205, &arg2);
+   defstr(&arg3, sbuf2, &blank);
+
+   sneed(cnt);
+
+   if (STRLEN(arg3) == 0) {
+      slen = 1;
+      s3 = " ";
+      }
+   else {
+      slen = STRLEN(arg3);
+      s3 = STRLOC(arg3);
+      }
+
+   sbuf = alcstr(NULL, cnt);            /* use string space as buffer */
+
+   s = sbuf;
+   while (s < sbuf + cnt) {
+      st = s3;
+      while (st < s3 + slen && s < sbuf + cnt)
+         *s++ = *st++;
+      }
+
+   s = sbuf + cnt;
+   slen = STRLEN(arg1);
+   st = STRLOC(arg1) + slen;
+   if (slen > cnt)
+      slen = cnt;
+   while (slen-- > 0)
+      *--s = *--st;
+
+   STRLEN(arg0) = cnt;
+   STRLOC(arg0) = sbuf;
+   }
+
+struct b_iproc Bright = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xright),
+   3,
+   -1,
+   0,
+   0,
+   {5, "right"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/seq.c b/usr/src/new/new/icon/int/functions/seq.c

new file mode 100644 (file)

index 0000000..5510097
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/seq.c
@@ -0,0 +1,38 @@
+#include "../h/rt.h"
+#ifdef EXT
+/*
+ * seq(e1,e2) generate {e1, e1+e2, e1+e2+e2, ...}
+ * Generator.
+ */
+
+seq(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   DclSave
+   long from, by;
+
+   defint(&arg1, &from, 1);
+   defint(&arg2, &by, 1);
+   
+   if (by == 0)
+      runerr(211, &arg2);
+
+   while ((from <= MAXLONG && by > 0) || (from >= MINLONG && by < 0)) {
+      mkint(from, &arg0);
+      suspend();
+      from += by;
+      }
+   fail();
+   }
+struct b_iproc Bseq = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(seq),
+   2,
+   -1,
+   0,
+   0,
+   {3, "seq"}
+   };
+#endif EXT
diff --git a/usr/src/new/new/icon/int/functions/sort.c b/usr/src/new/new/icon/int/functions/sort.c

new file mode 100644 (file)

index 0000000..e224089
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/sort.c
@@ -0,0 +1,111 @@
+#include "../h/rt.h"
+
+/*
+ * sort(l) - sort list l.
+ * sort(t,i) - sort table on reference (i = 1) or value (i = 2) field.
+ */
+
+Xsort(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register struct descrip *d1, *dp;
+   register int size, i, j;
+   int nelem;
+   struct b_list *lp, *tp;
+   union block *bp, *ep;
+   long l;
+   extern struct b_list *alclist();
+   extern struct b_listb *alclstb();
+   extern anycmp(), trefcmp(), tvalcmp();
+
+   deref(&arg1);
+   if (arg1.type == D_LIST) {
+      size = BLKLOC(arg1)->list.cursize;
+      cplist(&arg1, &arg0, 1, size + 1);
+      qsort(BLKLOC(BLKLOC(arg0)->list.listhead)->listb.lelem, size,
+            sizeof(struct descrip), anycmp);
+      }
+   else if (arg1.type == D_TABLE) {
+      defshort(&arg2, 1);
+      if (arg2.value.integer != 1 && arg2.value.integer != 2)
+         runerr(205, &arg2);
+      nelem = size = BLKLOC(arg1)->table.cursize;
+      if (nelem < LISTBLKSIZE)
+        nelem = LISTBLKSIZE;
+      hneed(sizeof(struct b_list) + sizeof(struct b_listb) +
+           nelem * (sizeof(struct b_list) + sizeof(struct b_listb) +
+                    3 * sizeof(struct descrip)));
+      bp = BLKLOC(arg1);
+      lp = alclist(size);
+      lp->listhead.type = lp->listtail.type = D_LISTB;
+      BLKLOC(lp->listhead) = BLKLOC(lp->listtail) = alclstb(nelem, 0, size);
+      if (size > 0) {
+         d1 = BLKLOC(lp->listhead)->listb.lelem;
+         for (i = 0; i < NBUCKETS; i++) {
+            ep = BLKLOC(bp->table.buckets[i]);
+            while (ep != NULL) {
+               d1->type = D_LIST;
+               BLKLOC(*d1) = tp = alclist(2);
+               tp->listhead.type = tp->listtail.type = D_LISTB;
+               BLKLOC(tp->listhead) = BLKLOC(tp->listtail) = alclstb(2, 0, 2);
+               BLKLOC(tp->listhead)->listb.lelem[0] = ep->telem.tref;
+               BLKLOC(tp->listhead)->listb.lelem[1] = ep->telem.tval;
+               d1++;
+               ep = BLKLOC(ep->telem.blink);
+               }
+            }
+         if (arg2.value.integer == 1)
+            qsort(BLKLOC(lp->listhead)->listb.lelem, size,
+                  sizeof(struct descrip), trefcmp);
+         else
+            qsort(BLKLOC(lp->listhead)->listb.lelem, size,
+                  sizeof(struct descrip), tvalcmp);
+         }
+      arg0.type = D_LIST;
+      BLKLOC(arg0) = lp;
+      }
+   else
+      runerr(115, &arg1);
+   }
+
+/*
+ * trefcmp(d1,d2) - compare two element lists on first field.
+ */
+
+trefcmp(d1,d2)
+struct descrip *d1, *d2;
+   {
+   extern anycmp();
+
+   if (d1->type != D_LIST || d2->type != D_LIST)
+      syserr("trefcmp: internal consistency check fails.");
+   return (anycmp(&(BLKLOC(BLKLOC(*d1)->list.listhead)->listb.lelem[0]),
+                  &(BLKLOC(BLKLOC(*d2)->list.listhead)->listb.lelem[0])));
+   }
+
+/*
+ * tvalcmp(d1,d2) - compare two element lists on second field.
+ */
+
+tvalcmp(d1,d2)
+struct descrip *d1, *d2;
+   {
+   extern anycmp();
+
+   if (d1->type != D_LIST || d2->type != D_LIST)
+      syserr("tvalcmp: internal consistency check fails.");
+   return (anycmp(&(BLKLOC(BLKLOC(*d1)->list.listhead)->listb.lelem[1]),
+                  &(BLKLOC(BLKLOC(*d2)->list.listhead)->listb.lelem[1])));
+   }
+
+struct b_iproc Bsort = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xsort),
+   2,
+   -1,
+   0,
+   0,
+   {4, "sort"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/stop.c b/usr/src/new/new/icon/int/functions/stop.c

new file mode 100644 (file)

index 0000000..0c72cab
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/stop.c
@@ -0,0 +1,51 @@
+#include "../h/rt.h"
+
+/*
+ * stop(a,b,...) - stop and write arguments (starting on error output).
+ */
+
+Xstop(nargs)
+int nargs;
+   {
+   register int n;
+   char sbuf[MAXSTRING];
+   struct descrip arg;
+   FILE *f;
+
+   f = stderr;
+
+   for (n = 1; n <= nargs; n++) {
+      arg = ARG(n);
+      deref(&arg);
+
+      if (!QUAL(arg) && TYPE(arg) == T_FILE) {
+         if (n > 1)
+            putc('\n', f);
+         if ((BLKLOC(arg)->file.status & FS_WRITE) == 0)
+           runerr(213, &arg);
+         f = BLKLOC(arg)->file.fd;
+         }
+      else {
+        if (n == 1 && (k_output.status & FS_WRITE) == 0)
+           runerr(213, NULL);
+        defany(&arg, &nullstr);
+        if (cvstr(&arg, sbuf) == NULL)
+           runerr(109, &arg);
+         putstr(f, STRLOC(arg), STRLEN(arg));
+         }
+      }
+
+   putc('\n', f);
+   c_exit(1);
+   }
+
+struct b_iproc Bstop = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xstop),
+   -1,
+   -1,
+   0,
+   0,
+   {4, "stop"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/string.c b/usr/src/new/new/icon/int/functions/string.c

new file mode 100644 (file)

index 0000000..cc533e6
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/string.c
@@ -0,0 +1,35 @@
+#include "../h/rt.h"
+
+/*
+ * string(x) - convert x to string.
+ */
+
+Xstring(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   char sbuf[MAXSTRING];
+   extern char *alcstr();
+
+   arg0 = arg1;
+   switch (cvstr(&arg0, sbuf)) {
+      case 1:
+        sneed(STRLEN(arg0));
+         STRLOC(arg0) = alcstr(STRLOC(arg0), STRLEN(arg0));
+      case 2:
+        return;
+      default:
+        fail();
+      }
+   }
+
+struct b_iproc Bstring = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xstring),
+   1,
+   -1,
+   0,
+   0,
+   {6, "string"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/system.c b/usr/src/new/new/icon/int/functions/system.c

new file mode 100644 (file)

index 0000000..cb3108d
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/system.c
@@ -0,0 +1,33 @@
+#include "../h/rt.h"
+
+/*
+ * system(s) - execute string s as a system command.
+ */
+
+Xsystem(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   char sbuf[MAXSTRING];
+
+   deref(&arg1);
+
+   if (!QUAL(arg1) || STRLEN(arg1) < 0)
+      runerr(103, &arg1);
+   if (STRLEN(arg1) >= MAXSTRING)
+      runerr(210, &arg1);
+   qtos(&arg1, sbuf);
+
+   mkint((long)((system(sbuf) >> 8) & 0377), &arg0);
+   }
+
+struct b_iproc Bsystem = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xsystem),
+   1,
+   -1,
+   0,
+   0,
+   {6, "system"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/tab.c b/usr/src/new/new/icon/int/functions/tab.c

new file mode 100644 (file)

index 0000000..7666517
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/tab.c
@@ -0,0 +1,52 @@
+#include "../h/rt.h"
+
+/*
+ * tab(i) - set &pos to i, return substring of &subject spanned.
+ * Reversible.
+ */
+
+Xtab(nargs, oldsubj, arg1, arg0)
+int nargs;
+struct descrip oldsubj, arg1, arg0;
+   {
+   register int i, j;
+   int t, oldpos;
+   long l1;
+
+   if (cvint(&arg1,&l1) == NULL)
+      runerr(101, &arg1);
+
+   j = cvpos(l1, STRLEN(k_subject));
+
+   oldsubj = k_subject;                /* save old &subject and &pos */
+   oldpos = i = k_pos;
+
+   k_pos = j;                  /* set new &pos */
+
+   if (i > j) {                        /* convert section to substring */
+      t = i;
+      i = j;
+      j = t - j;
+      }
+   else
+      j = j - i;
+
+   STRLOC(arg0) = STRLOC(k_subject) + i - 1;
+   STRLEN(arg0) = j;
+   suspend();
+
+   k_subject = oldsubj;
+   k_pos = oldpos;
+   fail();
+   }
+
+struct b_iproc Btab = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xtab),
+   2,
+   -1,
+   0,
+   0,
+   {3, "tab"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/table.c b/usr/src/new/new/icon/int/functions/table.c

new file mode 100644 (file)

index 0000000..7b17142
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/table.c
@@ -0,0 +1,29 @@
+#include "../h/rt.h"
+
+/*
+ * table(def) - create a table of default value def.
+ */
+
+Xtable(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   extern struct b_table *alctable();
+
+   hneed(sizeof(struct b_table));
+
+   deref(&arg1);
+   arg0.type = D_TABLE;
+   BLKLOC(arg0) = alctable(&arg1);
+   }
+
+struct b_iproc Btable = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xtable),
+   1,
+   -1,
+   0,
+   0,
+   {5, "table"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/trim.c b/usr/src/new/new/icon/int/functions/trim.c

new file mode 100644 (file)

index 0000000..2c16d80
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/trim.c
@@ -0,0 +1,39 @@
+#include "../h/rt.h"
+
+/*
+ * trim(s1,c) - trim trailing characters in c from s1.
+ */
+
+Xtrim(nargs, arg2, arg1, arg0)
+int nargs;
+struct descrip arg2, arg1, arg0;
+   {
+   register i;
+   char *sloc;
+   char sbuf[MAXSTRING];
+   int *cs, csbuf[CSETSIZE];
+   static int spcset[CSETSIZE] = 
+      cset_display(0, 0, 01, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
+
+   if (cvstr(&arg1, sbuf) == NULL)
+      runerr(103, &arg1);
+   defcset(&arg2, &cs, csbuf, spcset);
+
+   arg0 = arg1;
+   sloc = STRLOC(arg1) + STRLEN(arg1) - 1;
+   while (sloc >= STRLOC(arg1) && tstb(*sloc, cs)) {
+      sloc--;
+      STRLEN(arg0)--;
+      }
+   }
+
+struct b_iproc Btrim = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xtrim),
+   2,
+   -1,
+   0,
+   0,
+   {4, "trim"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/type.c b/usr/src/new/new/icon/int/functions/type.c

new file mode 100644 (file)

index 0000000..aeb5f21
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/type.c
@@ -0,0 +1,77 @@
+#include "../h/rt.h"
+#include "../h/record.h"
+
+/*
+ * type(x) - return type of x as a string.
+ */
+
+Xtype(nargs, arg1, arg0)
+int nargs;
+struct descrip arg1, arg0;
+   {
+   deref(&arg1);
+
+   if (NULLDESC(arg1)) {
+      STRLEN(arg0) = 4;
+      STRLOC(arg0) = "null";
+      }
+   else if (QUAL(arg1)) {
+      STRLEN(arg0) = 6;
+      STRLOC(arg0) = "string";
+      }
+   else {
+      switch (TYPE(arg1)) {
+         case T_INTEGER:
+#ifndef BIT32
+         case T_LONGINT:
+#endif
+            STRLEN(arg0) = 7;
+            STRLOC(arg0) = "integer";
+            break;
+         case T_REAL:
+            STRLEN(arg0) = 4;
+            STRLOC(arg0) = "real";
+            break;
+         case T_CSET:
+            STRLEN(arg0) = 4;
+            STRLOC(arg0) = "cset";
+            break;
+         case T_FILE:
+            STRLEN(arg0) = 4;
+            STRLOC(arg0) = "file";
+            break;
+         case T_PROC:
+            STRLEN(arg0) = 9;
+            STRLOC(arg0) = "procedure";
+            break;
+         case T_LIST:
+            STRLEN(arg0) = 4;
+            STRLOC(arg0) = "list";
+            break;
+         case T_TABLE:
+            STRLEN(arg0) = 5;
+            STRLOC(arg0) = "table";
+            break;
+         case T_RECORD:
+            arg0 = BLKLOC(arg1)->record.recptr->proc.recname;
+            break;
+         case T_ESTACK:
+            STRLEN(arg0) = 13;
+            STRLOC(arg0) = "co-expression";
+            break;
+         default:
+            syserr("type: unknown type.");
+         }
+      }
+   }
+
+struct b_iproc Btype = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xtype),
+   1,
+   -1,
+   0,
+   0,
+   {4, "type"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/upto.c b/usr/src/new/new/icon/int/functions/upto.c

new file mode 100644 (file)

index 0000000..4a2d280
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/upto.c
@@ -0,0 +1,55 @@
+#include "../h/rt.h"
+
+/*
+ * upto(c,s,i,j) - find each occurrence in s[i:j] of a character in c.
+ * Generator.
+ */
+
+Xupto(nargs, arg4, arg3, arg2, arg1, arg0)
+int nargs;
+struct descrip arg4, arg3, arg2, arg1, arg0;
+   {
+   register int i, j;
+   int t;
+   long l1, l2;
+   int *cs, csbuf[CSETSIZE];
+   char sbuf[MAXSTRING];
+
+   if (cvcset(&arg1, &cs, csbuf) == NULL)
+      runerr(104, &arg1);
+   if (defstr(&arg2, sbuf, &k_subject))
+      defint(&arg3, &l1, k_pos);
+   else
+      defint(&arg3, &l1, 1);
+   defint(&arg4, &l2, 0);
+
+   i = cvpos(l1, STRLEN(arg2));
+   j = cvpos(l2, STRLEN(arg2));
+
+   if (i > j) {
+      t = i;
+      i = j;
+      j = t;
+      }
+
+   while (i < j) {
+      if (tstb(STRLOC(arg2)[i-1], cs)) {
+         arg0.type = D_INTEGER;
+         INTVAL(arg0) = i;
+        suspend();
+        }
+      i++;
+      }
+   fail();
+   }
+
+struct b_iproc Bupto = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xupto),
+   4,
+   -1,
+   0,
+   0,
+   {4, "upto"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/write.c b/usr/src/new/new/icon/int/functions/write.c

new file mode 100644 (file)

index 0000000..708596f
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/write.c
@@ -0,0 +1,61 @@
+#include "../h/rt.h"
+
+/*
+ * write(a,b,...) - write arguments.
+ */
+
+Xwrite(nargs)
+int nargs;
+   {
+   register int n;
+   char sbuf[MAXSTRING];
+   struct descrip arg;
+   FILE *f;
+
+   f = stdout;
+   arg = nullstr;
+
+   for (n = 1; n <= nargs; n++) {
+      arg = ARG(n);
+      deref(&arg);
+
+      if (!QUAL(arg) && TYPE(arg) == T_FILE) {
+         if (n > 1) {
+            putc('\n', f);
+           /* Added fflush for buffering--whm Fri Feb 25 01:59:20 1983 */
+           fflush(f);
+           }
+         if ((BLKLOC(arg)->file.status & FS_WRITE) == 0)
+           runerr(213, &arg);
+         f = BLKLOC(arg)->file.fd;
+         arg = nullstr;
+        }
+      else {
+        if (n == 1 && (k_output.status & FS_WRITE) == 0)
+           runerr(213, NULL);
+        defany(&arg, &nullstr);
+        if (cvstr(&arg, sbuf) == NULL)
+           runerr(109, &arg);
+         putstr(f, STRLOC(arg), STRLEN(arg));
+        }
+      }
+   putc('\n', f);
+   /* Added fflush for buffering--whm */
+   fflush(f);
+   if (STRLOC(arg) >= sbuf && STRLOC(arg) < sbuf + MAXSTRING) {
+      sneed(STRLEN(arg));
+      STRLOC(arg) = alcstr(STRLOC(arg), STRLEN(arg));
+      }
+   ARG(0) = arg;
+   }
+
+struct b_iproc Bwrite = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xwrite),
+   -1,
+   -1,
+   0,
+   0,
+   {5, "write"}
+   };
diff --git a/usr/src/new/new/icon/int/functions/writes.c b/usr/src/new/new/icon/int/functions/writes.c

new file mode 100644 (file)

index 0000000..53d1078
--- /dev/null
+++ b/usr/src/new/new/icon/int/functions/writes.c
@@ -0,0 +1,58 @@
+#include "../h/rt.h"
+
+/*
+ * writes(a,b,...) - write arguments without newline terminator.
+ */
+
+Xwrites(nargs)
+int nargs;
+   {
+   register int n;
+   char sbuf[MAXSTRING];
+   struct descrip arg;
+   FILE *f;
+
+   f = stdout;
+   arg = nullstr;
+
+   for (n = 1; n <= nargs; n++) {
+      arg = ARG(n);
+      deref(&arg);
+
+      if (!QUAL(arg) && TYPE(arg) == T_FILE) {
+         if ((BLKLOC(arg)->file.status & FS_WRITE) == 0)
+           runerr(213, &arg);
+         f = BLKLOC(arg)->file.fd;
+         arg = nullstr;
+        }
+      else {
+        if (n == 1 && (k_output.status & FS_WRITE) == 0)
+           runerr(213, NULL);
+        defany(&arg, &nullstr);
+        if (cvstr(&arg, sbuf) == NULL)
+           runerr(109, &arg);
+         putstr(f, STRLOC(arg), STRLEN(arg));
+        /*
+         * Added following fflush(f) for buffering,
+         *  Fri Feb 25 01:58:23 1983--whm
+         */
+        fflush(f);
+         }
+      }
+   if (STRLOC(arg) >= sbuf && STRLOC(arg) < sbuf + MAXSTRING) {
+      sneed(STRLEN(arg));
+      STRLOC(arg) = alcstr(STRLOC(arg), STRLEN(arg));
+      }
+   ARG(0) = arg;
+   }
+
+struct b_iproc Bwrites = {
+   T_PROC,
+   sizeof(struct b_proc),
+   EntryPoint(Xwrites),
+   -1,
+   -1,
+   0,
+   0,
+   {6, "writes"}
+   };
author	CSRG <csrg@ucbvax.Berkeley.EDU>
	Wed, 11 May 1983 14:21:48 +0000 (06:21 -0800)
committer	CSRG <csrg@ucbvax.Berkeley.EDU>
	Wed, 11 May 1983 14:21:48 +0000 (06:21 -0800)
usr/src/new/new/icon/cmp/functions/abs.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/any.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/bal.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/center.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/close.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/copy.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/cset.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/display.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/exit.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/find.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/get.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/image.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/integer.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/left.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/list.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/many.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/map.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/match.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/move.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/numeric.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/open.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/pop.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/pos.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/pull.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/push.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/put.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/read.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/reads.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/real.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/repl.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/reverse.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/right.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/seq.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/sort.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/stop.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/string.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/system.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/tab.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/table.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/trim.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/type.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/upto.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/write.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/cmp/functions/writes.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/Makefile	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/abs.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/any.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/bal.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/center.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/close.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/copy.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/cset.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/display.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/exit.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/find.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/get.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/image.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/integer.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/left.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/list.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/many.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/map.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/match.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/move.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/numeric.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/open.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/pop.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/pos.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/pull.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/push.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/put.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/read.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/reads.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/real.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/repl.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/reverse.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/right.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/seq.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/sort.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/stop.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/string.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/system.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/tab.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/table.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/trim.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/type.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/upto.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/write.c	[new file with mode: 0644]	patch \| blob
usr/src/new/new/icon/int/functions/writes.c	[new file with mode: 0644]	patch \| blob