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