1: /* @(#)func.c 2.4 SCCS id keyword */ 2: /* Copyright (c) 1979 Regents of the University of California */ 3: # 4: /* 5: * pi - Pascal interpreter code translator 6: * 7: * Charles Haley, Bill Joy UCB 8: * Version 1.2 November 1978 9: */ 10: 11: #include "whoami" 12: #include "0.h" 13: #include "tree.h" 14: #include "opcode.h" 15: 16: short cardemptyline = 0; 17: 18: /* 19: * Funccod generates code for 20: * built in function calls and calls 21: * call to generate calls to user 22: * defined functions and procedures. 23: */ 24: funccod(r) 25: int *r; 26: { 27: struct nl *p; 28: register struct nl *p1; 29: register int *al; 30: register op; 31: int argc, *argv; 32: int tr[2], tr2[4]; 33: 34: /* 35: * Verify that the given name 36: * is defined and the name of 37: * a function. 38: */ 39: p = lookup(r[2]); 40: if (p == NIL) { 41: rvlist(r[3]); 42: return (NIL); 43: } 44: if (p->class != FUNC) { 45: error("%s is not a function", p->symbol); 46: rvlist(r[3]); 47: return (NIL); 48: } 49: argv = r[3]; 50: /* 51: * Call handles user defined 52: * procedures and functions 53: */ 54: if (bn != 0) 55: return (call(p, argv, FUNC, bn)); 56: /* 57: * Count the arguments 58: */ 59: argc = 0; 60: for (al = argv; al != NIL; al = al[2]) 61: argc++; 62: /* 63: * Built-in functions have 64: * their interpreter opcode 65: * associated with them. 66: */ 67: op = p->value[0] &~ NSTAND; 68: if (opt('s') && (p->value[0] & NSTAND)) { 69: standard(); 70: error("%s is a nonstandard function", p->symbol); 71: } 72: switch (op) { 73: /* 74: * Parameterless functions 75: */ 76: case O_CLCK: 77: case O_SCLCK: 78: case O_WCLCK: 79: case O_ARGC: 80: if (argc != 0) { 81: error("%s takes no arguments", p->symbol); 82: rvlist(argv); 83: return (NIL); 84: } 85: put1(op); 86: return (nl+T4INT); 87: case O_EOF: 88: case O_EOLN: 89: if (argc == 0) { 90: argv = tr; 91: tr[1] = tr2; 92: tr2[0] = T_VAR; 93: tr2[2] = input->symbol; 94: tr2[1] = tr2[3] = NIL; 95: argc = 1; 96: } else if (argc != 1) { 97: error("%s takes either zero or one argument", p->symbol); 98: rvlist(argv); 99: return (NIL); 100: } 101: } 102: /* 103: * All other functions take 104: * exactly one argument. 105: */ 106: if (argc != 1) { 107: error("%s takes exactly one argument", p->symbol); 108: rvlist(argv); 109: return (NIL); 110: } 111: /* 112: * Evaluate the argmument 113: */ 114: p1 = rvalue((int *) argv[1], NLNIL); 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(p1, 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: put1(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: convert(p1, nl+T4INT); 146: put1(op); 147: return (nl+T4INT); 148: case O_ROUND: 149: case O_TRUNC: 150: if (isnta(p1, "d")) { 151: error("%s's argument must be a real, not %s", p->symbol, nameof(p1)); 152: return (NIL); 153: } 154: put1(op); 155: return (nl+T4INT); 156: case O_ABS2: 157: case O_SQR2: 158: if (isa(p1, "d")) { 159: put1(op + O_ABS8-O_ABS2); 160: return (nl+TDOUBLE); 161: } 162: if (isa(p1, "i")) { 163: put1(op + (width(p1) >> 2)); 164: return (nl+T4INT); 165: } 166: error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1)); 167: return (NIL); 168: case O_ORD2: 169: if (isa(p1, "bcis") || classify(p1) == TPTR) 170: switch (width(p1)) { 171: case 1: 172: return (nl+T1INT); 173: case 2: 174: return (nl+T2INT); 175: case 4: 176: return (nl+T4INT); 177: } 178: error("ord's argument must be of scalar type or a pointer, not %s", nameof(p1)); 179: return (NIL); 180: case O_SUCC2: 181: case O_PRED2: 182: if (isa(p1, "bcs")) { 183: put1(op); 184: return (p1); 185: } 186: if (isa(p1, "i")) { 187: if (width(p1) <= 2) 188: op += O_PRED24-O_PRED2; 189: else 190: op++; 191: put1(op); 192: return (nl+T4INT); 193: } 194: if (isa(p1, "id")) { 195: error("%s is forbidden for reals", p->symbol); 196: return (NIL); 197: } 198: error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1)); 199: return (NIL); 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: put1(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: put1(op + (width(p1) >> 2)); 213: return (nl+TCHAR); 214: case O_CARD: 215: if ( ( p1 != nl + TSET ) && isnta(p1, "t")) { 216: error("Argument to card must be a set, not %s", nameof(p1)); 217: return (NIL); 218: } 219: if ( p1 == nl + TSET ) { 220: if ( line != cardemptyline ) { 221: cardemptyline = line; 222: warning(); 223: error("Cardinality of the empty set is always 0"); 224: } 225: put2(O_CON1, 0); 226: } else { 227: put2(O_CARD, width(p1)); 228: } 229: return (nl+T2INT); 230: case O_EOLN: 231: if (!text(p1)) { 232: error("Argument to eoln must be a text file, not %s", nameof(p1)); 233: return (NIL); 234: } 235: put1(op); 236: return (nl+TBOOL); 237: case O_EOF: 238: if (p1->class != FILET) { 239: error("Argument to eof must be file, not %s", nameof(p1)); 240: return (NIL); 241: } 242: put1(op); 243: return (nl+TBOOL); 244: case 0: 245: error("%s is an unimplemented 6000-3.4 extension", p->symbol); 246: default: 247: panic("func1"); 248: } 249: }
Defined functions
Defined variables
|
Last modified: 1983-03-17
Generated: 2016-12-26 |
Generated by src2html V0.67
page hit count: 962 |
|