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