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