![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to b2fpr.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / contrib / B / src / bsmall|
Return to b2fpr.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / B / src / bsmall |
1.1 root 1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1984. */
2: /* $Header: b2fpr.c,v 1.1 84/06/28 00:49:12 timo Exp $ */
3:
4: /* B formula/predicate invocation */
5: #include "b.h"
6: #include "b1obj.h"
7: #include "b2fil.h"
8: #include "b2env.h"
9: #include "b2sem.h"
10: #include "b2syn.h"
11: #include "b2sou.h"
12:
13: #define Other 0
14: #define Nume 1
15:
16: #define In ('[')
17: #define Not_in (']')
18:
19: /*
20: * Table defining all predefined functions (not propositions).
21: */
22:
23: struct funtab {
24: char *f_name;
25: char f_lopri, f_hipri;
26: char f_adic;
27: char f_flag;
28: value (*f_fun)();
29: } funtab[] = {
30: {"~", 8, 8, Mon, Nume, approximate},
31: {"+", 8, 8, Mon, Nume, copy},
32: {"+", 2, 2, Dya, Nume, sum},
33: {"-", 5, 5, Mon, Nume, negated},
34: {"-", 2, 2, Dya, Nume, diff},
35: {"*/", 1, 8, Mon, Nume, numerator},
36: {"/*", 1, 8, Mon, Nume, denominator},
37:
38: {"*", 4, 4, Dya, Nume, prod},
39: {"/", 3, 4, Dya, Nume, quot},
40: {"**", 6, 7, Dya, Nume, power},
41:
42: {"^", 2, 2, Dya, Other, concat},
43: {"^^", 1, 8, Dya, Other, repeat},
44: {"<<", 1, 8, Dya, Other, adjleft},
45: {"><", 1, 8, Dya, Other, centre},
46: {">>", 1, 8, Dya, Other, adjright},
47:
48: {"#", 7, 7, Mon, Other, size},
49: {"#", 7, 8, Dya, Other, size2},
50:
51: {"pi", 8, 8, Zer, Other, pi},
52: {"e", 8, 8, Zer, Other, e},
53:
54: {"abs", 1, 8, Mon, Nume, absval},
55: {"sign", 1, 8, Mon, Nume, signum},
56: {"floor", 1, 8, Mon, Nume, floorf},
57: {"ceiling",1, 8, Mon, Nume, ceilf},
58: {"round", 1, 8, Mon, Nume, round1},
59: {"round", 1, 8, Dya, Nume, round2},
60: {"mod", 1, 8, Dya, Nume, mod},
61: {"root", 1, 8, Mon, Nume, root1},
62: {"root", 1, 8, Dya, Nume, root2},
63:
64: {"sin", 1, 8, Mon, Nume, sin1},
65: {"cos", 1, 8, Mon, Nume, cos1},
66: {"tan", 1, 8, Mon, Nume, tan1},
67: {"atan",1, 8, Mon, Nume, atn1},
68: {"atan",1, 8, Dya, Other, atn2},
69: {"exp", 1, 8, Mon, Nume, exp1},
70: {"log", 1, 8, Mon, Nume, log1},
71: {"log", 1, 8, Dya, Other, log2},
72:
73: {"keys", 1, 8, Mon, Other, keys},
74: {"th'of",1, 8, Dya, Other, th_of},
75: {"min", 1, 8, Mon, Other, min1},
76: {"min", 1, 8, Dya, Other, min2},
77: {"max", 1, 8, Mon, Other, max1},
78: {"max", 1, 8, Dya, Other, max2},
79:
80: {"", 0, 0, Dya, Other, NULL} /*sentinel*/
81: };
82:
83: Visible Procedure initfprs() {
84: struct funtab *fp; value r, f;
85: for (fp = funtab; fp->f_lopri != 0; ++fp) {
86: /* Define function */
87: r= mk_text(fp->f_name);
88: f= mk_fun(fp->f_lopri, fp->f_hipri, fp->f_adic,
89: Pre, (txptr)(fp-funtab), /*NON-PORTABLE: remove the cast*/
90: (txptr)Dummy, (value)Dummy, (bool)Dummy);
91: def_unit(f, r, fp->f_adic == Zer ? FZR
92: :fp->f_adic == Mon ? FMN : FDY);
93: release(f); release(r);
94: }
95:
96: defprd("in", Dya, Pre, In);
97: defprd("not'in", Dya, Pre, Not_in);
98: }
99:
100: Hidden Procedure defprd(repr, adic, def, fux) string repr; literal adic, def, fux; {
101: literal ad= adic == Zer ? FZR : adic == Mon ? FMN : FDY;
102: value r= mk_text(repr), p= mk_prd(adic, def, (txptr) fux /*nasty*/, (txptr)Dummy, (value)Dummy, (bool)Dummy);
103: def_unit(p, r, ad);
104: release(p); release(r);
105: }
106:
107: Hidden bool is_funprd(t, f, adicity, func) value t, *f; literal adicity; bool func; {
108: value *aa, *sl= lookup(t);
109: if (sl != Pnil) return No;
110: if (!is_unit(t, adicity, &aa)) return No;
111: if (func) {
112: if (!Is_function(*aa)) return No;
113: } else {
114: if (!Is_predicate(*aa)) return No;
115: }
116: *f= *aa; return Yes;
117: }
118:
119: Visible bool is_zerfun(t, f) value t, *f; {
120: return is_funprd(t, f, FZR, Yes);
121: }
122:
123: Visible bool is_monfun(t, f) value t, *f; {
124: return is_funprd(t, f, FMN, Yes);
125: }
126:
127: Visible bool is_dyafun(t, f) value t, *f; {
128: return is_funprd(t, f, FDY, Yes);
129: }
130:
131: Visible bool is_zerprd(t, p) value t, *p; {
132: return is_funprd(t, p, FZR, No);
133: }
134:
135: Visible bool is_monprd(t, p) value t, *p; {
136: return is_funprd(t, p, FMN, No);
137: }
138:
139: Visible bool is_dyaprd(t, p) value t, *p; {
140: return is_funprd(t, p, FDY, No);
141: }
142:
143: char torbuf[3];
144: #define Tor *tb++= Char(tx++)
145: #define Rot *tb= '\0'
146:
147: Visible value montor() {
148: txptr tb= torbuf; value r, f;
149: switch (Char(tx)) {
150: case '~': Tor; break;
151: case '+': Tor; break;
152: case '-': Tor; break;
153: case '*': Tor;
154: if (Char(tx) != '/') pprerr("function * is not monadic", "");
155: Tor; break;
156: case '/': Tor;
157: if (Char(tx) != '*') pprerr("function / is not monadic", "");
158: Tor; break;
159: case '#': Tor; break;
160: default: syserr("unhandled Montormark");
161: }
162: Rot;
163: r= mk_text(torbuf);
164: f= unit_info(r, FMN);
165: release(r);
166: return f;
167: }
168:
169: Visible value dyator() {
170: txptr tb= torbuf; value r, f;
171: switch (Char(tx)) {
172: case '+': Tor; break;
173: case '-': Tor; break;
174: case '*': Tor;
175: {txptr tx0= tx;
176: loop: if (Char(tx++) != '*') {tx= tx0; break;}
177: if (Char(tx++) != '/') {tx= tx0; Tor; break;}
178: goto loop;
179: }
180: case '/': Tor; break;
181: case '^': Tor; if (Char(tx) == '^') Tor; break;
182: case '<': Tor;
183: if (Char(tx) != '<') pprerr("order-relator instead of function", "");
184: Tor; break;
185: case '>': Tor;
186: if (Char(tx) != '<' && Char(tx) != '>')
187: pprerr("order-relator instead of function", "");
188: Tor; break;
189: case '#': Tor; break;
190: default: syserr("unhandled Dyatormark");
191: }
192: Rot;
193: r= mk_text(torbuf);
194: f= unit_info(r, FDY);
195: release(r);
196: return f;
197: }
198:
199: Visible value formula(nd1, tor, nd2) value nd1, tor, nd2; {
200: funprd *t;
201: struct funtab *fp;
202: if (!Is_function(tor)) syserr("formula called with non-function");
203: if (!xeq) return (value) Dummy;
204: t= Funprd(tor);
205: if (!(t->adic==Zer ? nd2==Vnil : (t->adic==Mon) == (nd1==Vnil)))
206: syserr("invoked formula has other adicity than invoker");
207: if (t->def == Use) {
208: value r;
209: udfpr(nd1, t, nd2, Ret);
210: r= resval; resval= Vnil;
211: return r;
212: }
213: fp= &funtab[(int)(t->fux)];
214: if (fp->f_flag == Nume && t->adic != Zer) { /* check types */
215: if (t->adic == Dya && !Is_number(nd1)) {
216: error("left operand not a number");
217: return Vnil;
218: } else if (!Is_number(nd2)) {
219: error("right operand not a number");
220: return Vnil;
221: }
222: }
223: if (t->adic == Zer) return((*fp->f_fun)());
224: else if (fp->f_adic == Mon) return((*fp->f_fun)(nd2));
225: else return((*fp->f_fun)(nd1, nd2));
226: }
227:
228: Visible outcome proposition(nd1, pred, nd2) value nd1, pred, nd2; {
229: funprd *p;
230: if (!Is_predicate(pred)) syserr("proposition called with non-predicate");
231: if (!xeq) return (outcome) Dummy;
232: p= Funprd(pred);
233: if (!(p->adic==Zer ? nd2==Vnil : (p->adic==Mon) == (nd1==Vnil)))
234: syserr("invoked proposition has other adicity than invoker");
235: if (p->def == Use) {
236: outcome o;
237: udfpr(nd1, p, nd2, Rep);
238: o= resout; resout= Und;
239: return o;
240: }
241: switch (p->fux) {
242: case In:
243: return in(nd1, nd2);
244: case Not_in:
245: return !in(nd1, nd2);
246: default:
247: syserr("predicate not covered by proposition");
248: return (outcome) Dummy;
249: }
250: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.