1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)pcfunc.c 1.13 02/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 382