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
Defined functions
pcfunccod
defined in line 31; used 4 times
- in /usr/src/ucb/PORT/pascal/src/0.h line 731
- in /usr/src/ucb/PORT/pascal/src/rval.c line 122, 339
- in /usr/src/ucb/PORT/pascal/src/stkrval.c line 272
Defined variables
|
Last modified: 1985-06-05
Generated: 2016-12-26 |
Generated by src2html V0.67
page hit count: 3618 |
|