![[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] / 3BSD / cmd / pi|
Return to func.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / pi |
1.1 ! root 1: /* Copyright (c) 1979 Regents of the University of California */ ! 2: # ! 3: /* ! 4: * pi - Pascal interpreter code translator ! 5: * ! 6: * Charles Haley, Bill Joy UCB ! 7: * Version 1.2 November 1978 ! 8: */ ! 9: ! 10: #include "whoami" ! 11: #include "0.h" ! 12: #include "tree.h" ! 13: #include "opcode.h" ! 14: ! 15: /* ! 16: * Funccod generates code for ! 17: * built in function calls and calls ! 18: * call to generate calls to user ! 19: * defined functions and procedures. ! 20: */ ! 21: funccod(r) ! 22: int *r; ! 23: { ! 24: struct nl *p; ! 25: register struct nl *p1; ! 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) { ! 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: put1(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: p1 = rvalue((int *) argv[1], NLNIL); ! 112: if (p1 == NIL) ! 113: return (NIL); ! 114: switch (op) { ! 115: case O_EXP: ! 116: case O_SIN: ! 117: case O_COS: ! 118: case O_ATAN: ! 119: case O_LN: ! 120: case O_SQRT: ! 121: case O_RANDOM: ! 122: case O_EXPO: ! 123: case O_UNDEF: ! 124: if (isa(p1, "i")) ! 125: convert(p1, nl+TDOUBLE); ! 126: else if (isnta(p1, "d")) { ! 127: error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1)); ! 128: return (NIL); ! 129: } ! 130: put1(op); ! 131: if (op == O_UNDEF) ! 132: return (nl+TBOOL); ! 133: else if (op == O_EXPO) ! 134: return (nl+T4INT); ! 135: else ! 136: return (nl+TDOUBLE); ! 137: case O_SEED: ! 138: if (isnta(p1, "i")) { ! 139: error("seed's argument must be an integer, not %s", nameof(p1)); ! 140: return (NIL); ! 141: } ! 142: convert(p1, nl+T4INT); ! 143: put1(op); ! 144: return (nl+T4INT); ! 145: case O_ROUND: ! 146: case O_TRUNC: ! 147: if (isnta(p1, "d")) { ! 148: error("%s's argument must be a real, not %s", p->symbol, nameof(p1)); ! 149: return (NIL); ! 150: } ! 151: put1(op); ! 152: return (nl+T4INT); ! 153: case O_ABS2: ! 154: case O_SQR2: ! 155: if (isa(p1, "d")) { ! 156: put1(op + O_ABS8-O_ABS2); ! 157: return (nl+TDOUBLE); ! 158: } ! 159: if (isa(p1, "i")) { ! 160: put1(op + (width(p1) >> 2)); ! 161: return (nl+T4INT); ! 162: } ! 163: error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1)); ! 164: return (NIL); ! 165: case O_ORD2: ! 166: if (isa(p1, "bcis") || classify(p1) == TPTR) ! 167: switch (width(p1)) { ! 168: case 1: ! 169: return (nl+T1INT); ! 170: case 2: ! 171: return (nl+T2INT); ! 172: case 4: ! 173: return (nl+T4INT); ! 174: } ! 175: error("ord's argument must be of scalar type or a pointer, not %s", nameof(p1)); ! 176: return (NIL); ! 177: case O_SUCC2: ! 178: case O_PRED2: ! 179: if (isa(p1, "bcs")) { ! 180: put1(op); ! 181: return (p1); ! 182: } ! 183: if (isa(p1, "i")) { ! 184: if (width(p1) <= 2) ! 185: op += O_PRED24-O_PRED2; ! 186: else ! 187: op++; ! 188: put1(op); ! 189: return (nl+T4INT); ! 190: } ! 191: if (isa(p1, "id")) { ! 192: error("%s is forbidden for reals", p->symbol); ! 193: return (NIL); ! 194: } ! 195: error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1)); ! 196: return (NIL); ! 197: case O_ODD2: ! 198: if (isnta(p1, "i")) { ! 199: error("odd's argument must be an integer, not %s", nameof(p1)); ! 200: return (NIL); ! 201: } ! 202: put1(op + (width(p1) >> 2)); ! 203: return (nl+TBOOL); ! 204: case O_CHR2: ! 205: if (isnta(p1, "i")) { ! 206: error("chr's argument must be an integer, not %s", nameof(p1)); ! 207: return (NIL); ! 208: } ! 209: put1(op + (width(p1) >> 2)); ! 210: return (nl+TCHAR); ! 211: case O_CARD: ! 212: if (isnta(p1, "t")) { ! 213: error("Argument to card must be a set, not %s", nameof(p1)); ! 214: return (NIL); ! 215: } ! 216: put2(O_CARD, width(p1)); ! 217: return (nl+T2INT); ! 218: case O_EOLN: ! 219: if (!text(p1)) { ! 220: error("Argument to eoln must be a text file, not %s", nameof(p1)); ! 221: return (NIL); ! 222: } ! 223: put1(op); ! 224: return (nl+TBOOL); ! 225: case O_EOF: ! 226: if (p1->class != FILET) { ! 227: error("Argument to eof must be file, not %s", nameof(p1)); ! 228: return (NIL); ! 229: } ! 230: put1(op); ! 231: return (nl+TBOOL); ! 232: case 0: ! 233: error("%s is an unimplemented 6000-3.4 extension", p->symbol); ! 234: default: ! 235: panic("func1"); ! 236: } ! 237: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.