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