```   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);
163:             release(f);
164:             newprev= concat(prev= *Field(v, k-1), 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

c_range defined in line 18; used 1 times
• in line 54
i_range defined in line 34; used 1 times
• in line 55
nl defined in line 63; used 2 times
 Last modified: 1985-08-27 Generated: 2016-12-26 Generated by src2html V0.67 page hit count: 2366