1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)pcfunc.c 1.10 01/17/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 "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 = opt('t') ? "_EXP" : "_exp"; 149 goto mathfunc; 150 case O_SIN: 151 funcname = opt('t') ? "_SIN" : "_sin"; 152 goto mathfunc; 153 case O_COS: 154 funcname = opt('t') ? "_COS" : "_cos"; 155 goto mathfunc; 156 case O_ATAN: 157 funcname = opt('t') ? "_ATAN" : "_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 sconv(p2type(p1), P2DOUBLE); 177 putop( P2CALL , P2DOUBLE ); 178 return nl + TDOUBLE; 179 case O_EXPO: 180 if (isnta( p1 , "id" ) ) { 181 error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1)); 182 return NIL; 183 } 184 putleaf( P2ICON , 0 , 0 185 , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_EXPO" ); 186 p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); 187 sconv(p2type(p1), P2DOUBLE); 188 putop( P2CALL , P2INT ); 189 return ( nl + T4INT ); 190 case O_UNDEF: 191 if ( isnta( p1 , "id" ) ) { 192 error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1)); 193 return NIL; 194 } 195 p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); 196 putleaf( P2ICON , 0 , 0 , P2INT , 0 ); 197 putop( P2COMOP , P2INT ); 198 return ( nl + TBOOL ); 199 case O_SEED: 200 if (isnta(p1, "i")) { 201 error("seed's argument must be an integer, not %s", nameof(p1)); 202 return (NIL); 203 } 204 putleaf( P2ICON , 0 , 0 205 , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_SEED" ); 206 p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); 207 putop( P2CALL , P2INT ); 208 return nl + T4INT; 209 case O_ROUND: 210 case O_TRUNC: 211 if ( isnta( p1 , "d" ) ) { 212 error("%s's argument must be a real, not %s", p->symbol, nameof(p1)); 213 return (NIL); 214 } 215 putleaf( P2ICON , 0 , 0 216 , ADDTYPE( P2FTN | P2INT , P2PTR ) 217 , op == O_ROUND ? "_ROUND" : "_TRUNC" ); 218 p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); 219 putop( P2CALL , P2INT ); 220 return nl + T4INT; 221 case O_ABS2: 222 if ( isa( p1 , "d" ) ) { 223 putleaf( P2ICON , 0 , 0 224 , ADDTYPE( P2FTN | P2DOUBLE , P2PTR ) 225 , "_fabs" ); 226 p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); 227 putop( P2CALL , P2DOUBLE ); 228 return nl + TDOUBLE; 229 } 230 if ( isa( p1 , "i" ) ) { 231 putleaf( P2ICON , 0 , 0 232 , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_abs" ); 233 p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); 234 putop( P2CALL , P2INT ); 235 return nl + T4INT; 236 } 237 error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1)); 238 return NIL; 239 case O_SQR2: 240 if ( isa( p1 , "d" ) ) { 241 temptype = P2DOUBLE; 242 rettype = nl + TDOUBLE; 243 tempnlp = tmpalloc(sizeof(double), rettype, REGOK); 244 } else if ( isa( p1 , "i" ) ) { 245 temptype = P2INT; 246 rettype = nl + T4INT; 247 tempnlp = tmpalloc(sizeof(long), rettype, REGOK); 248 } else { 249 error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1)); 250 return NIL; 251 } 252 putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] , 253 tempnlp -> extra_flags , temptype , 0 ); 254 p1 = rvalue( (int *) argv[1] , NLNIL , RREQ ); 255 sconv(p2type(p1), temptype); 256 putop( P2ASSIGN , temptype ); 257 putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] , 258 tempnlp -> extra_flags , temptype , 0 ); 259 putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] , 260 tempnlp -> extra_flags , temptype , 0 ); 261 putop( P2MUL , temptype ); 262 putop( P2COMOP , temptype ); 263 return rettype; 264 case O_ORD2: 265 p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); 266 if (isa(p1, "bcis")) { 267 return (nl+T4INT); 268 } 269 if (classify(p1) == TPTR) { 270 if (!opt('s')) { 271 return (nl+T4INT); 272 } 273 standard(); 274 } 275 error("ord's argument must be of scalar type, not %s", 276 nameof(p1)); 277 return (NIL); 278 case O_SUCC2: 279 case O_PRED2: 280 if (isa(p1, "d")) { 281 error("%s is forbidden for reals", p->symbol); 282 return (NIL); 283 } 284 if ( isnta( p1 , "bcsi" ) ) { 285 error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1)); 286 return NIL; 287 } 288 if ( opt( 't' ) ) { 289 putleaf( P2ICON , 0 , 0 290 , ADDTYPE( P2FTN | P2INT , P2PTR ) 291 , op == O_SUCC2 ? "_SUCC" : "_PRED" ); 292 p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); 293 tempnlp = p1 -> class == TYPE ? p1 -> type : p1; 294 putleaf( P2ICON, tempnlp -> range[0], 0, P2INT, 0 ); 295 putop( P2LISTOP , P2INT ); 296 putleaf( P2ICON, tempnlp -> range[1], 0, P2INT, 0 ); 297 putop( P2LISTOP , P2INT ); 298 putop( P2CALL , P2INT ); 299 } else { 300 p1 = rvalue( argv[1] , NIL , RREQ ); 301 putleaf( P2ICON , 1 , 0 , P2INT , 0 ); 302 putop( op == O_SUCC2 ? P2PLUS : P2MINUS , P2INT ); 303 } 304 if ( isa( p1 , "bcs" ) ) { 305 return p1; 306 } else { 307 return nl + T4INT; 308 } 309 case O_ODD2: 310 if (isnta(p1, "i")) { 311 error("odd's argument must be an integer, not %s", nameof(p1)); 312 return (NIL); 313 } 314 p1 = rvalue( (int *) argv[1] , NLNIL , RREQ ); 315 putleaf( P2ICON , 1 , 0 , P2INT , 0 ); 316 putop( P2AND , P2INT ); 317 return nl + TBOOL; 318 case O_CHR2: 319 if (isnta(p1, "i")) { 320 error("chr's argument must be an integer, not %s", nameof(p1)); 321 return (NIL); 322 } 323 if (opt('t')) { 324 putleaf( P2ICON , 0 , 0 325 , ADDTYPE( P2FTN | P2CHAR , P2PTR ) , "_CHR" ); 326 p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); 327 putop( P2CALL , P2CHAR ); 328 } else { 329 p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); 330 } 331 return nl + TCHAR; 332 case O_CARD: 333 if (isnta(p1, "t")) { 334 error("Argument to card must be a set, not %s", nameof(p1)); 335 return (NIL); 336 } 337 putleaf( P2ICON , 0 , 0 338 , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_CARD" ); 339 p1 = stkrval( (int *) argv[1] , NLNIL , LREQ ); 340 putleaf( P2ICON , lwidth( p1 ) , 0 , P2INT , 0 ); 341 putop( P2LISTOP , P2INT ); 342 putop( P2CALL , P2INT ); 343 return nl + T2INT; 344 case O_EOLN: 345 if (!text(p1)) { 346 error("Argument to eoln must be a text file, not %s", nameof(p1)); 347 return (NIL); 348 } 349 putleaf( P2ICON , 0 , 0 350 , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_TEOLN" ); 351 p1 = stklval( (int *) argv[1] , NOFLAGS ); 352 putop( P2CALL , P2INT ); 353 return nl + TBOOL; 354 case O_EOF: 355 if (p1->class != FILET) { 356 error("Argument to eof must be file, not %s", nameof(p1)); 357 return (NIL); 358 } 359 putleaf( P2ICON , 0 , 0 360 , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_TEOF" ); 361 p1 = stklval( (int *) argv[1] , NOFLAGS ); 362 putop( P2CALL , P2INT ); 363 return nl + TBOOL; 364 case 0: 365 error("%s is an unimplemented 6000-3.4 extension", p->symbol); 366 default: 367 panic("func1"); 368 } 369 } 370 #endif PC 371