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