![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to func.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 40BSD / cmd / pi|
Return to func.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / pi |
1.1 ! root 1: /* Copyright (c) 1979 Regents of the University of California */ ! 2: ! 3: static char sccsid[] = "@(#)func.c 1.3 10/19/80"; ! 4: ! 5: #include "whoami.h" ! 6: #ifdef OBJ ! 7: /* ! 8: * the rest of the file ! 9: */ ! 10: #include "0.h" ! 11: #include "tree.h" ! 12: #include "opcode.h" ! 13: ! 14: /* ! 15: * Funccod generates code for ! 16: * built in function calls and calls ! 17: * call to generate calls to user ! 18: * defined functions and procedures. ! 19: */ ! 20: funccod(r) ! 21: int *r; ! 22: { ! 23: struct nl *p; ! 24: register struct nl *p1; ! 25: register int *al; ! 26: register op; ! 27: int argc, *argv; ! 28: int tr[2], tr2[4]; ! 29: ! 30: /* ! 31: * Verify that the given name ! 32: * is defined and the name of ! 33: * a function. ! 34: */ ! 35: p = lookup(r[2]); ! 36: if (p == NIL) { ! 37: rvlist(r[3]); ! 38: return (NIL); ! 39: } ! 40: if (p->class != FUNC && p->class != FFUNC) { ! 41: error("%s is not a function", p->symbol); ! 42: rvlist(r[3]); ! 43: return (NIL); ! 44: } ! 45: argv = r[3]; ! 46: /* ! 47: * Call handles user defined ! 48: * procedures and functions ! 49: */ ! 50: if (bn != 0) ! 51: return (call(p, argv, FUNC, bn)); ! 52: /* ! 53: * Count the arguments ! 54: */ ! 55: argc = 0; ! 56: for (al = argv; al != NIL; al = al[2]) ! 57: argc++; ! 58: /* ! 59: * Built-in functions have ! 60: * their interpreter opcode ! 61: * associated with them. ! 62: */ ! 63: op = p->value[0] &~ NSTAND; ! 64: if (opt('s') && (p->value[0] & NSTAND)) { ! 65: standard(); ! 66: error("%s is a nonstandard function", p->symbol); ! 67: } ! 68: switch (op) { ! 69: /* ! 70: * Parameterless functions ! 71: */ ! 72: case O_CLCK: ! 73: case O_SCLCK: ! 74: case O_WCLCK: ! 75: case O_ARGC: ! 76: if (argc != 0) { ! 77: error("%s takes no arguments", p->symbol); ! 78: rvlist(argv); ! 79: return (NIL); ! 80: } ! 81: put1(op); ! 82: return (nl+T4INT); ! 83: case O_EOF: ! 84: case O_EOLN: ! 85: if (argc == 0) { ! 86: argv = tr; ! 87: tr[1] = tr2; ! 88: tr2[0] = T_VAR; ! 89: tr2[2] = input->symbol; ! 90: tr2[1] = tr2[3] = NIL; ! 91: argc = 1; ! 92: } else if (argc != 1) { ! 93: error("%s takes either zero or one argument", p->symbol); ! 94: rvlist(argv); ! 95: return (NIL); ! 96: } ! 97: } ! 98: /* ! 99: * All other functions take ! 100: * exactly one argument. ! 101: */ ! 102: if (argc != 1) { ! 103: error("%s takes exactly one argument", p->symbol); ! 104: rvlist(argv); ! 105: return (NIL); ! 106: } ! 107: /* ! 108: * Evaluate the argmument ! 109: */ ! 110: p1 = stkrval((int *) argv[1], NLNIL , RREQ ); ! 111: if (p1 == NIL) ! 112: return (NIL); ! 113: switch (op) { ! 114: case O_EXP: ! 115: case O_SIN: ! 116: case O_COS: ! 117: case O_ATAN: ! 118: case O_LN: ! 119: case O_SQRT: ! 120: case O_RANDOM: ! 121: case O_EXPO: ! 122: case O_UNDEF: ! 123: if (isa(p1, "i")) ! 124: convert(p1, nl+TDOUBLE); ! 125: else if (isnta(p1, "d")) { ! 126: error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1)); ! 127: return (NIL); ! 128: } ! 129: put1(op); ! 130: if (op == O_UNDEF) ! 131: return (nl+TBOOL); ! 132: else if (op == O_EXPO) ! 133: return (nl+T4INT); ! 134: else ! 135: return (nl+TDOUBLE); ! 136: case O_SEED: ! 137: if (isnta(p1, "i")) { ! 138: error("seed's argument must be an integer, not %s", nameof(p1)); ! 139: return (NIL); ! 140: } ! 141: put1(op); ! 142: return (nl+T4INT); ! 143: case O_ROUND: ! 144: case O_TRUNC: ! 145: if (isnta(p1, "d")) { ! 146: error("%s's argument must be a real, not %s", p->symbol, nameof(p1)); ! 147: return (NIL); ! 148: } ! 149: put1(op); ! 150: return (nl+T4INT); ! 151: case O_ABS2: ! 152: case O_SQR2: ! 153: if (isa(p1, "d")) { ! 154: put1(op + O_ABS8-O_ABS2); ! 155: return (nl+TDOUBLE); ! 156: } ! 157: if (isa(p1, "i")) { ! 158: put1(op + (width(p1) >> 2)); ! 159: return (nl+T4INT); ! 160: } ! 161: error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1)); ! 162: return (NIL); ! 163: case O_ORD2: ! 164: if (isa(p1, "bcis") || classify(p1) == TPTR) { ! 165: return (nl+T4INT); ! 166: } ! 167: error("ord's argument must be of scalar type or a pointer, not %s", nameof(p1)); ! 168: return (NIL); ! 169: case O_SUCC2: ! 170: case O_PRED2: ! 171: if (isa(p1, "bcs")) { ! 172: put1(op); ! 173: return (p1); ! 174: } ! 175: if (isa(p1, "i")) { ! 176: if (width(p1) <= 2) ! 177: op += O_PRED24-O_PRED2; ! 178: else ! 179: op++; ! 180: put1(op); ! 181: return (nl+T4INT); ! 182: } ! 183: if (isa(p1, "id")) { ! 184: error("%s is forbidden for reals", p->symbol); ! 185: return (NIL); ! 186: } ! 187: error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1)); ! 188: return (NIL); ! 189: case O_ODD2: ! 190: if (isnta(p1, "i")) { ! 191: error("odd's argument must be an integer, not %s", nameof(p1)); ! 192: return (NIL); ! 193: } ! 194: put1(op + (width(p1) >> 2)); ! 195: return (nl+TBOOL); ! 196: case O_CHR2: ! 197: if (isnta(p1, "i")) { ! 198: error("chr's argument must be an integer, not %s", nameof(p1)); ! 199: return (NIL); ! 200: } ! 201: put1(op + (width(p1) >> 2)); ! 202: return (nl+TCHAR); ! 203: case O_CARD: ! 204: if (isnta(p1, "t")) { ! 205: error("Argument to card must be a set, not %s", nameof(p1)); ! 206: return (NIL); ! 207: } ! 208: put2(O_CARD, width(p1)); ! 209: return (nl+T2INT); ! 210: case O_EOLN: ! 211: if (!text(p1)) { ! 212: error("Argument to eoln must be a text file, not %s", nameof(p1)); ! 213: return (NIL); ! 214: } ! 215: put1(op); ! 216: return (nl+TBOOL); ! 217: case O_EOF: ! 218: if (p1->class != FILET) { ! 219: error("Argument to eof must be file, not %s", nameof(p1)); ! 220: return (NIL); ! 221: } ! 222: put1(op); ! 223: return (nl+TBOOL); ! 224: case 0: ! 225: error("%s is an unimplemented 6000-3.4 extension", p->symbol); ! 226: default: ! 227: panic("func1"); ! 228: } ! 229: } ! 230: #endif OBJ
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.