![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to pcfunc.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 pcfunc.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[] = "@(#)pcfunc.c 1.3 10/19/80"; ! 4: ! 5: #include "whoami.h" ! 6: #ifdef PC ! 7: /* ! 8: * and to the end of the file ! 9: */ ! 10: #include "0.h" ! 11: #include "tree.h" ! 12: #include "opcode.h" ! 13: #include "pc.h" ! 14: #include "pcops.h" ! 15: ! 16: /* ! 17: * Funccod generates code for ! 18: * built in function calls and calls ! 19: * call to generate calls to user ! 20: * defined functions and procedures. ! 21: */ ! 22: pcfunccod( r ) ! 23: int *r; ! 24: { ! 25: struct nl *p; ! 26: register struct nl *p1; ! 27: register int *al; ! 28: register op; ! 29: int argc, *argv; ! 30: int tr[2], tr2[4]; ! 31: char *funcname; ! 32: long tempoff; ! 33: long temptype; ! 34: struct nl *rettype; ! 35: ! 36: /* ! 37: * Verify that the given name ! 38: * is defined and the name of ! 39: * a function. ! 40: */ ! 41: p = lookup(r[2]); ! 42: if (p == NIL) { ! 43: rvlist(r[3]); ! 44: return (NIL); ! 45: } ! 46: if (p->class != FUNC && p->class != FFUNC) { ! 47: error("%s is not a function", p->symbol); ! 48: rvlist(r[3]); ! 49: return (NIL); ! 50: } ! 51: argv = r[3]; ! 52: /* ! 53: * Call handles user defined ! 54: * procedures and functions ! 55: */ ! 56: if (bn != 0) ! 57: return (call(p, argv, FUNC, bn)); ! 58: /* ! 59: * Count the arguments ! 60: */ ! 61: argc = 0; ! 62: for (al = argv; al != NIL; al = al[2]) ! 63: argc++; ! 64: /* ! 65: * Built-in functions have ! 66: * their interpreter opcode ! 67: * associated with them. ! 68: */ ! 69: op = p->value[0] &~ NSTAND; ! 70: if (opt('s') && (p->value[0] & NSTAND)) { ! 71: standard(); ! 72: error("%s is a nonstandard function", p->symbol); ! 73: } ! 74: if ( op == O_ARGC ) { ! 75: putleaf( P2NAME , 0 , 0 , P2INT , "__argc" ); ! 76: return nl + T4INT; ! 77: } ! 78: switch (op) { ! 79: /* ! 80: * Parameterless functions ! 81: */ ! 82: case O_CLCK: ! 83: funcname = "_CLCK"; ! 84: goto noargs; ! 85: case O_SCLCK: ! 86: funcname = "_SCLCK"; ! 87: goto noargs; ! 88: noargs: ! 89: if (argc != 0) { ! 90: error("%s takes no arguments", p->symbol); ! 91: rvlist(argv); ! 92: return (NIL); ! 93: } ! 94: putleaf( P2ICON , 0 , 0 ! 95: , ADDTYPE( P2FTN | P2INT , P2PTR ) ! 96: , funcname ); ! 97: putop( P2UNARY P2CALL , P2INT ); ! 98: return (nl+T4INT); ! 99: case O_WCLCK: ! 100: if (argc != 0) { ! 101: error("%s takes no arguments", p->symbol); ! 102: rvlist(argv); ! 103: return (NIL); ! 104: } ! 105: putleaf( P2ICON , 0 , 0 ! 106: , ADDTYPE( P2FTN | P2INT , P2PTR ) ! 107: , "_time" ); ! 108: putleaf( P2ICON , 0 , 0 , P2INT , 0 ); ! 109: putop( P2CALL , P2INT ); ! 110: return (nl+T4INT); ! 111: case O_EOF: ! 112: case O_EOLN: ! 113: if (argc == 0) { ! 114: argv = tr; ! 115: tr[1] = tr2; ! 116: tr2[0] = T_VAR; ! 117: tr2[2] = input->symbol; ! 118: tr2[1] = tr2[3] = NIL; ! 119: argc = 1; ! 120: } else if (argc != 1) { ! 121: error("%s takes either zero or one argument", p->symbol); ! 122: rvlist(argv); ! 123: return (NIL); ! 124: } ! 125: } ! 126: /* ! 127: * All other functions take ! 128: * exactly one argument. ! 129: */ ! 130: if (argc != 1) { ! 131: error("%s takes exactly one argument", p->symbol); ! 132: rvlist(argv); ! 133: return (NIL); ! 134: } ! 135: /* ! 136: * find out the type of the argument ! 137: */ ! 138: codeoff(); ! 139: p1 = stkrval((int *) argv[1], NLNIL , RREQ ); ! 140: codeon(); ! 141: if (p1 == NIL) ! 142: return (NIL); ! 143: /* ! 144: * figure out the return type and the funtion name ! 145: */ ! 146: switch (op) { ! 147: case O_EXP: ! 148: funcname = "_exp"; ! 149: goto mathfunc; ! 150: case O_SIN: ! 151: funcname = "_sin"; ! 152: goto mathfunc; ! 153: case O_COS: ! 154: funcname = "_cos"; ! 155: goto mathfunc; ! 156: case O_ATAN: ! 157: funcname = "_atan"; ! 158: goto mathfunc; ! 159: case O_LN: ! 160: funcname = opt('t') ? "_LN" : "_log"; ! 161: goto mathfunc; ! 162: case O_SQRT: ! 163: funcname = opt('t') ? "_SQRT" : "_sqrt"; ! 164: goto mathfunc; ! 165: case O_RANDOM: ! 166: funcname = "_RANDOM"; ! 167: goto mathfunc; ! 168: mathfunc: ! 169: if (isnta(p1, "id")) { ! 170: error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1)); ! 171: return (NIL); ! 172: } ! 173: putleaf( P2ICON , 0 , 0 ! 174: , ADDTYPE( P2FTN | P2DOUBLE , P2PTR ) , funcname ); ! 175: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); ! 176: if ( isa( p1 , "i" ) ) { ! 177: putop( P2SCONV , P2DOUBLE ); ! 178: } ! 179: putop( P2CALL , P2DOUBLE ); ! 180: return nl + TDOUBLE; ! 181: case O_EXPO: ! 182: if (isnta( p1 , "id" ) ) { ! 183: error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1)); ! 184: return NIL; ! 185: } ! 186: putleaf( P2ICON , 0 , 0 ! 187: , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_EXPO" ); ! 188: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); ! 189: if ( isa( p1 , "i" ) ) { ! 190: putop( P2SCONV , P2DOUBLE ); ! 191: } ! 192: putop( P2CALL , P2INT ); ! 193: return ( nl + T4INT ); ! 194: case O_UNDEF: ! 195: if ( isnta( p1 , "id" ) ) { ! 196: error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1)); ! 197: return NIL; ! 198: } ! 199: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); ! 200: putleaf( P2ICON , 0 , 0 , P2INT , 0 ); ! 201: putop( P2COMOP , P2INT ); ! 202: return ( nl + TBOOL ); ! 203: case O_SEED: ! 204: if (isnta(p1, "i")) { ! 205: error("seed's argument must be an integer, not %s", nameof(p1)); ! 206: return (NIL); ! 207: } ! 208: putleaf( P2ICON , 0 , 0 ! 209: , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_SEED" ); ! 210: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); ! 211: putop( P2CALL , P2INT ); ! 212: return nl + T4INT; ! 213: case O_ROUND: ! 214: case O_TRUNC: ! 215: if ( isnta( p1 , "d" ) ) { ! 216: error("%s's argument must be a real, not %s", p->symbol, nameof(p1)); ! 217: return (NIL); ! 218: } ! 219: putleaf( P2ICON , 0 , 0 ! 220: , ADDTYPE( P2FTN | P2INT , P2PTR ) ! 221: , op == O_ROUND ? "_ROUND" : "_TRUNC" ); ! 222: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); ! 223: putop( P2CALL , P2INT ); ! 224: return nl + T4INT; ! 225: case O_ABS2: ! 226: if ( isa( p1 , "d" ) ) { ! 227: putleaf( P2ICON , 0 , 0 ! 228: , ADDTYPE( P2FTN | P2DOUBLE , P2PTR ) ! 229: , "_fabs" ); ! 230: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); ! 231: putop( P2CALL , P2DOUBLE ); ! 232: return nl + TDOUBLE; ! 233: } ! 234: if ( isa( p1 , "i" ) ) { ! 235: putleaf( P2ICON , 0 , 0 ! 236: , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_abs" ); ! 237: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); ! 238: putop( P2CALL , P2INT ); ! 239: return nl + T4INT; ! 240: } ! 241: error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1)); ! 242: return NIL; ! 243: case O_SQR2: ! 244: if ( isa( p1 , "d" ) ) { ! 245: temptype = P2DOUBLE; ! 246: rettype = nl + TDOUBLE; ! 247: sizes[ cbn ].om_off -= sizeof( double ); ! 248: } else if ( isa( p1 , "i" ) ) { ! 249: temptype = P2INT; ! 250: rettype = nl + T4INT; ! 251: sizes[ cbn ].om_off -= sizeof( long ); ! 252: } else { ! 253: error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1)); ! 254: return NIL; ! 255: } ! 256: tempoff = sizes[ cbn ].om_off; ! 257: if ( tempoff < sizes[ cbn ].om_max ) { ! 258: sizes[ cbn ].om_max = tempoff; ! 259: } ! 260: putlbracket( ftnno , -tempoff ); ! 261: putRV( 0 , cbn , tempoff , temptype , 0 ); ! 262: p1 = rvalue( (int *) argv[1] , NLNIL , RREQ ); ! 263: putop( P2ASSIGN , temptype ); ! 264: putRV( 0 , cbn , tempoff , temptype , 0 ); ! 265: putRV( 0 , cbn , tempoff , temptype , 0 ); ! 266: putop( P2MUL , temptype ); ! 267: putop( P2COMOP , temptype ); ! 268: return rettype; ! 269: case O_ORD2: ! 270: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); ! 271: if (isa(p1, "bcis") || classify(p1) == TPTR) { ! 272: return (nl+T4INT); ! 273: } ! 274: error("ord's argument must be of scalar type or a pointer, not %s", nameof(p1)); ! 275: return (NIL); ! 276: case O_SUCC2: ! 277: case O_PRED2: ! 278: if (isa(p1, "d")) { ! 279: error("%s is forbidden for reals", p->symbol); ! 280: return (NIL); ! 281: } ! 282: if ( isnta( p1 , "bcsi" ) ) { ! 283: error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1)); ! 284: return NIL; ! 285: } ! 286: if ( opt( 't' ) ) { ! 287: putleaf( P2ICON , 0 , 0 ! 288: , ADDTYPE( P2FTN | P2INT , P2PTR ) ! 289: , op == O_SUCC2 ? "_SUCC" : "_PRED" ); ! 290: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); ! 291: putleaf( P2ICON , p1 -> range[0] , 0 , P2INT , 0 ); ! 292: putop( P2LISTOP , P2INT ); ! 293: putleaf( P2ICON , p1 -> range[1] , 0 , P2INT , 0 ); ! 294: putop( P2LISTOP , P2INT ); ! 295: putop( P2CALL , P2INT ); ! 296: } else { ! 297: p1 = rvalue( argv[1] , NIL , RREQ ); ! 298: putleaf( P2ICON , 1 , 0 , P2INT , 0 ); ! 299: putop( op == O_SUCC2 ? P2PLUS : P2MINUS , P2INT ); ! 300: } ! 301: if ( isa( p1 , "bcs" ) ) { ! 302: return p1; ! 303: } else { ! 304: return nl + T4INT; ! 305: } ! 306: case O_ODD2: ! 307: if (isnta(p1, "i")) { ! 308: error("odd's argument must be an integer, not %s", nameof(p1)); ! 309: return (NIL); ! 310: } ! 311: p1 = rvalue( (int *) argv[1] , NLNIL , RREQ ); ! 312: putleaf( P2ICON , 1 , 0 , P2INT , 0 ); ! 313: putop( P2AND , P2INT ); ! 314: return nl + TBOOL; ! 315: case O_CHR2: ! 316: if (isnta(p1, "i")) { ! 317: error("chr's argument must be an integer, not %s", nameof(p1)); ! 318: return (NIL); ! 319: } ! 320: if (opt('t')) { ! 321: putleaf( P2ICON , 0 , 0 ! 322: , ADDTYPE( P2FTN | P2CHAR , P2PTR ) , "_CHR" ); ! 323: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); ! 324: putop( P2CALL , P2CHAR ); ! 325: } else { ! 326: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); ! 327: } ! 328: return nl + TCHAR; ! 329: case O_CARD: ! 330: if (isnta(p1, "t")) { ! 331: error("Argument to card must be a set, not %s", nameof(p1)); ! 332: return (NIL); ! 333: } ! 334: putleaf( P2ICON , 0 , 0 ! 335: , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_CARD" ); ! 336: p1 = stkrval( (int *) argv[1] , NLNIL , LREQ ); ! 337: putleaf( P2ICON , lwidth( p1 ) , 0 , P2INT , 0 ); ! 338: putop( P2LISTOP , P2INT ); ! 339: putop( P2CALL , P2INT ); ! 340: return nl + T2INT; ! 341: case O_EOLN: ! 342: if (!text(p1)) { ! 343: error("Argument to eoln must be a text file, not %s", nameof(p1)); ! 344: return (NIL); ! 345: } ! 346: putleaf( P2ICON , 0 , 0 ! 347: , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_TEOLN" ); ! 348: p1 = stklval( (int *) argv[1] , NOFLAGS ); ! 349: putop( P2CALL , P2INT ); ! 350: return nl + TBOOL; ! 351: case O_EOF: ! 352: if (p1->class != FILET) { ! 353: error("Argument to eof must be file, not %s", nameof(p1)); ! 354: return (NIL); ! 355: } ! 356: putleaf( P2ICON , 0 , 0 ! 357: , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_TEOF" ); ! 358: p1 = stklval( (int *) argv[1] , NOFLAGS ); ! 359: putop( P2CALL , P2INT ); ! 360: return nl + TBOOL; ! 361: case 0: ! 362: error("%s is an unimplemented 6000-3.4 extension", p->symbol); ! 363: default: ! 364: panic("func1"); ! 365: } ! 366: } ! 367: #endif PC
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.