2.11BSD#431 - /usr/src/new/PORT/B/src/bint/b3in2.c

   1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
   2: 
   3: /*
   4:   $Header: b3in2.c,v 1.4 85/08/22 16:58:21 timo Exp $
   5: */
   6: 
   7: /* B interpreter -- independent subroutines */
   8: 
   9: #include "b.h"
  10: #include "b1obj.h"
  11: #include "b3env.h"
  12: #include "b3in2.h"
  13: #include "b3sem.h"
  14: #include "b3sou.h"
  15: 
  16: /* Making ranges */
  17: 
  18: Hidden value c_range(lo, hi) value lo, hi; {
  19:     char a, z;
  20:     if (!character(lo))
  21:         error(MESS(3400, "in {p..q}, p is a text but not a character"));
  22:     else if (!Is_text(hi))
  23:         error(MESS(3401, "in {p..q}, p is a text, but q is not"));
  24:     else if (!character(hi))
  25:         error(MESS(3402, "in {p..q}, q is a text, but not a character"));
  26:     else {
  27:         a= charval(lo); z= charval(hi);
  28:         if (z < a-1) error(MESS(3403, "in {p..q}, character q < x < p"));
  29:         else return mk_charrange(lo, hi);
  30:     }
  31:     return Vnil;
  32: }
  33: 
  34: Hidden value i_range(lo, hi) value lo, hi; {
  35:     value entries, res= Vnil;
  36:     if (!integral(lo))
  37:         error(MESS(3404, "in {p..q}, p is a number but not an integer"));
  38:     else if (!Is_number(hi))
  39:         error(MESS(3405, "in {p..q}, p is a number but q is not"));
  40:     else if (!integral(hi))
  41:         error(MESS(3406, "in {p..q}, q is a number but not an integer"));
  42:     else {
  43:         entries= diff(lo, hi);
  44:         if (compare(entries, one)>0)
  45:             error(MESS(3407, "in {p..q}, integer q < x < p"));
  46:         else res= mk_numrange(lo, hi);
  47:         release(entries);
  48:     }
  49:     return res;
  50: }
  51: 
  52: Visible value mk_range(v1, v2) value v1, v2; {
  53:     value r= Vnil;
  54:     if (Is_text(v1)) r= c_range(v1, v2);
  55:     else if (Is_number(v1)) r= i_range(v1, v2);
  56:     else error(MESS(3408, "in {p..q}, p is neither a text nor a number"));
  57:     return r;
  58: }
  59: 
  60: 
  61: /* Newlines for WRITE /// */
  62: 
  63: Visible Procedure nl(n) value n; {
  64:     value l= size(n); int c= intval(l); release(l);
  65:     while (c--) newline();
  66: }
  67: 
  68: 
  69: /* Evaluating basic targets */
  70: 
  71: Visible value v_local(name, number) value name, number; {
  72:     value *aa= envassoc(curnv->tab, number);
  73:     if (aa != Pnil && *aa != Vnil) return copy(*aa);
  74:     error3(0, name, MESS(3409, " has not yet received a value"));
  75:     return Vnil;
  76: }
  77: 
  78: Visible value v_global(name) value name; {
  79:     value *aa= envassoc(prmnv->tab, name);
  80:     if (aa != Pnil && *aa != Vnil) return copy(tarvalue(name, *aa));
  81:     error3(0, name, MESS(3410, " has not yet received a value"));
  82:     return Vnil;
  83: }
  84: 
  85: 
  86: /* Locating mysteries */
  87: 
  88: Visible loc l_mystery(name, number) value name, number; {
  89:     if (Is_compound(curnv->tab)) return local_loc((basidf) number);
  90:     return global_loc(name);
  91: }
  92: 
  93: 
  94: /* Rangers */
  95: 
  96: /* An IN-ranger is represented on the stack as a compound of three fields:
  97:    the last index used, the value of the expression after IN, and its length.
  98:    (The latter is redundant, but saves save many calls of 'size()'.)
  99:    When first called, there is, of course, no compound on the stack, but only
 100:    the value of the expression.  As the expression should always be a text,
 101:    list or table, this is recognizable as a special case, and then the
 102:    compound is created.
 103:    Return value is Yes if a new element was available and assigned, No if not.
 104: */
 105: 
 106: Visible bool in_ranger(l, pv) loc l; value *pv; {
 107:     value v= *pv, ind, tlt, len, i1, val; bool res;
 108:     if (!Is_compound(v) || Nfields(v) != 3) { /* First time */
 109:         tlt= v;
 110:         if (!Is_tlt(tlt)) {
 111:             error(MESS(3411, "in ... i IN e, e is not a text, list or table"));
 112:             return No;
 113:         }
 114:         if (empty(tlt)) return No;
 115:         *pv= v= mk_compound(3);
 116:         *Field(v, 0)= ind= one;
 117:         *Field(v, 1)= tlt;
 118:         *Field(v, 2)= len= size(tlt);
 119:         bind(l);
 120:     }
 121:     else {
 122:         ind= *Field(v, 0); tlt= *Field(v, 1); len= *Field(v, 2);
 123:         res= numcomp(ind, len) < 0;
 124:         if (!res) { unbind(l); return No; }
 125:         *Field(v, 0)= ind= sum(i1= ind, one); release(i1);
 126:     }
 127:     put(val= th_of(ind, tlt), l); release(val);
 128:     return Yes;
 129: }
 130: 
 131: 
 132: /* PARSING-rangers are treated similarly to IN-rangers, but here the
 133:    compound contains the last parse (i.e., N texts). */
 134: 
 135: Visible bool pa_ranger(l, pv) loc l; value *pv; {
 136:     value v= *pv, e, f; int len, k;
 137:     if (!Is_compound(v)) {
 138:         if (!Is_text(v)) {
 139:             error(MESS(3412, "in  ... i PARSING e, e is not a text"));
 140:             return No;
 141:         }
 142:         if (!Is_compound(l)) {
 143:             error(
 144:         MESS(3413, "in ... i PARSING e, i is not a collateral identifier"));
 145:             return No;
 146:         }
 147:         v= mk_compound(len= Nfields(l));
 148:         *Field(v, len-1)= *pv;
 149:         *Field(v, 0)= e= mk_text("");
 150:         for (k= 1; k < len-1; ++k)
 151:             *Field(v, k)= copy(e);
 152:         *pv= v;
 153:         bind(l);
 154:         put(v, l);
 155:         return Yes;
 156:     }
 157:     uniql(pv); v= *pv;
 158:     len= Nfields(v);
 159:     for (k= len-1; k > 0; --k) {
 160:         if (!empty(f= *Field(v, k))) {
 161:             value head, tail, prev, newprev, two= sum(one, one);
 162:             head= curtail(f, one); tail= behead(f, two);
 163:             release(f);
 164:             newprev= concat(prev= *Field(v, k-1), head);
 165:             release(prev); release(head);
 166:             *Field(v, k-1)= newprev;
 167:             if (k < len-1)
 168:                 *Field(v, k)= *Field(v, len-1);
 169:             *Field(v, len-1)= tail;
 170:             put(v, l);
 171:             return Yes;
 172:         }
 173:     }
 174:     unbind(l);
 175:     return No;
 176: }

Defined functions