![[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 [Research Unix] / researchv10dc / cmd / pascal / pi|
Return to pcfunc.c CVS log | Up to [Research Unix] / researchv10dc / cmd / pascal / pi |
1.1 ! root 1: /* Copyright (c) 1979 Regents of the University of California */ ! 2: ! 3: static char sccsid[] = "@(#)pcfunc.c 1.6 6/1/81"; ! 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: struct nl *tempnlp; ! 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: tempnlp = tmpalloc(sizeof(double), rettype, REGOK); ! 248: } else if ( isa( p1 , "i" ) ) { ! 249: temptype = P2INT; ! 250: rettype = nl + T4INT; ! 251: tempnlp = tmpalloc(sizeof(long), rettype, REGOK); ! 252: } else { ! 253: error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1)); ! 254: return NIL; ! 255: } ! 256: putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] , ! 257: tempnlp -> extra_flags , temptype , 0 ); ! 258: p1 = rvalue( (int *) argv[1] , NLNIL , RREQ ); ! 259: putop( P2ASSIGN , temptype ); ! 260: putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] , ! 261: tempnlp -> extra_flags , temptype , 0 ); ! 262: putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] , ! 263: tempnlp -> extra_flags , temptype , 0 ); ! 264: putop( P2MUL , temptype ); ! 265: putop( P2COMOP , temptype ); ! 266: return rettype; ! 267: case O_ORD2: ! 268: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); ! 269: if (isa(p1, "bcis") || classify(p1) == TPTR) { ! 270: return (nl+T4INT); ! 271: } ! 272: error("ord's argument must be of scalar type or a pointer, not %s", nameof(p1)); ! 273: return (NIL); ! 274: case O_SUCC2: ! 275: case O_PRED2: ! 276: if (isa(p1, "d")) { ! 277: error("%s is forbidden for reals", p->symbol); ! 278: return (NIL); ! 279: } ! 280: if ( isnta( p1 , "bcsi" ) ) { ! 281: error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1)); ! 282: return NIL; ! 283: } ! 284: if ( opt( 't' ) ) { ! 285: putleaf( P2ICON , 0 , 0 ! 286: , ADDTYPE( P2FTN | P2INT , P2PTR ) ! 287: , op == O_SUCC2 ? "_SUCC" : "_PRED" ); ! 288: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); ! 289: putleaf( P2ICON , p1 -> range[0] , 0 , P2INT , 0 ); ! 290: putop( P2LISTOP , P2INT ); ! 291: putleaf( P2ICON , p1 -> range[1] , 0 , P2INT , 0 ); ! 292: putop( P2LISTOP , P2INT ); ! 293: putop( P2CALL , P2INT ); ! 294: } else { ! 295: p1 = rvalue( argv[1] , NIL , RREQ ); ! 296: putleaf( P2ICON , 1 , 0 , P2INT , 0 ); ! 297: putop( op == O_SUCC2 ? P2PLUS : P2MINUS , P2INT ); ! 298: } ! 299: if ( isa( p1 , "bcs" ) ) { ! 300: return p1; ! 301: } else { ! 302: return nl + T4INT; ! 303: } ! 304: case O_ODD2: ! 305: if (isnta(p1, "i")) { ! 306: error("odd's argument must be an integer, not %s", nameof(p1)); ! 307: return (NIL); ! 308: } ! 309: p1 = rvalue( (int *) argv[1] , NLNIL , RREQ ); ! 310: putleaf( P2ICON , 1 , 0 , P2INT , 0 ); ! 311: putop( P2AND , P2INT ); ! 312: return nl + TBOOL; ! 313: case O_CHR2: ! 314: if (isnta(p1, "i")) { ! 315: error("chr's argument must be an integer, not %s", nameof(p1)); ! 316: return (NIL); ! 317: } ! 318: if (opt('t')) { ! 319: putleaf( P2ICON , 0 , 0 ! 320: , ADDTYPE( P2FTN | P2CHAR , P2PTR ) , "_CHR" ); ! 321: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); ! 322: putop( P2CALL , P2CHAR ); ! 323: } else { ! 324: p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); ! 325: } ! 326: return nl + TCHAR; ! 327: case O_CARD: ! 328: if (isnta(p1, "t")) { ! 329: error("Argument to card must be a set, not %s", nameof(p1)); ! 330: return (NIL); ! 331: } ! 332: putleaf( P2ICON , 0 , 0 ! 333: , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_CARD" ); ! 334: p1 = stkrval( (int *) argv[1] , NLNIL , LREQ ); ! 335: putleaf( P2ICON , lwidth( p1 ) , 0 , P2INT , 0 ); ! 336: putop( P2LISTOP , P2INT ); ! 337: putop( P2CALL , P2INT ); ! 338: return nl + T2INT; ! 339: case O_EOLN: ! 340: if (!text(p1)) { ! 341: error("Argument to eoln must be a text file, not %s", nameof(p1)); ! 342: return (NIL); ! 343: } ! 344: putleaf( P2ICON , 0 , 0 ! 345: , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_TEOLN" ); ! 346: p1 = stklval( (int *) argv[1] , NOFLAGS ); ! 347: putop( P2CALL , P2INT ); ! 348: return nl + TBOOL; ! 349: case O_EOF: ! 350: if (p1->class != FILET) { ! 351: error("Argument to eof must be file, not %s", nameof(p1)); ! 352: return (NIL); ! 353: } ! 354: putleaf( P2ICON , 0 , 0 ! 355: , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_TEOF" ); ! 356: p1 = stklval( (int *) argv[1] , NOFLAGS ); ! 357: putop( P2CALL , P2INT ); ! 358: return nl + TBOOL; ! 359: case 0: ! 360: error("%s is an unimplemented 6000-3.4 extension", p->symbol); ! 361: default: ! 362: panic("func1"); ! 363: } ! 364: } ! 365: #endif PC
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.