2.11BSD#431 - /usr/src/new/PORT/B/src/bsmall/b2fpr.c

   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: }

Defined functions

Defined variables

Defined struct's

Defined macros