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