1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)pcfunc.c 1.9.1.2 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 "objfmt.h" 13 #include "opcode.h" 14 #include "pc.h" 15 #include "pcops.h" 16 17 /* 18 * Funccod generates code for 19 * built in function calls and calls 20 * call to generate calls to user 21 * defined functions and procedures. 22 */ 23 pcfunccod( r ) 24 int *r; 25 { 26 struct nl *p; 27 register struct nl *p1; 28 register int *al; 29 register op; 30 int argc, *argv; 31 int tr[2], tr2[4]; 32 char *funcname; 33 struct nl *tempnlp; 34 long temptype; 35 struct nl *rettype; 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 = opt('t') ? "_EXP" : "_exp"; 150 goto mathfunc; 151 case O_SIN: 152 funcname = opt('t') ? "_SIN" : "_sin"; 153 goto mathfunc; 154 case O_COS: 155 funcname = opt('t') ? "_COS" : "_cos"; 156 goto mathfunc; 157 case O_ATAN: 158 funcname = opt('t') ? "_ATAN" : "_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 if ( isa( p1 , "d" ) ) { 246 temptype = P2DOUBLE; 247 rettype = nl + TDOUBLE; 248 tempnlp = tmpalloc(sizeof(double), rettype, REGOK); 249 } else if ( isa( p1 , "i" ) ) { 250 temptype = P2INT; 251 rettype = nl + T4INT; 252 tempnlp = tmpalloc(sizeof(long), rettype, REGOK); 253 } else { 254 error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1)); 255 return NIL; 256 } 257 putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] , 258 tempnlp -> extra_flags , temptype , 0 ); 259 p1 = rvalue( (int *) argv[1] , NLNIL , RREQ ); 260 putop( P2ASSIGN , temptype ); 261 putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] , 262 tempnlp -> extra_flags , temptype , 0 ); 263 putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] , 264 tempnlp -> extra_flags , temptype , 0 ); 265 putop( P2MUL , temptype ); 266 putop( P2COMOP , temptype ); 267 return rettype; 268 case O_ORD2: 269 p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); 270 if (isa(p1, "bcis")) { 271 return (nl+T4INT); 272 } 273 if (classify(p1) == TPTR) { 274 if (!opt('s')) { 275 return (nl+T4INT); 276 } 277 standard(); 278 } 279 error("ord's argument must be of scalar type, not %s", 280 nameof(p1)); 281 return (NIL); 282 case O_SUCC2: 283 case O_PRED2: 284 if (isa(p1, "d")) { 285 error("%s is forbidden for reals", p->symbol); 286 return (NIL); 287 } 288 if ( isnta( p1 , "bcsi" ) ) { 289 error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1)); 290 return NIL; 291 } 292 if ( opt( 't' ) ) { 293 putleaf( P2ICON , 0 , 0 294 , ADDTYPE( P2FTN | P2INT , P2PTR ) 295 , op == O_SUCC2 ? "_SUCC" : "_PRED" ); 296 p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); 297 tempnlp = p1 -> class == TYPE ? p1 -> type : p1; 298 putleaf( P2ICON, tempnlp -> range[0], 0, P2INT, 0 ); 299 putop( P2LISTOP , P2INT ); 300 putleaf( P2ICON, tempnlp -> range[1], 0, P2INT, 0 ); 301 putop( P2LISTOP , P2INT ); 302 putop( P2CALL , P2INT ); 303 } else { 304 p1 = rvalue( argv[1] , NIL , RREQ ); 305 putleaf( P2ICON , 1 , 0 , P2INT , 0 ); 306 putop( op == O_SUCC2 ? P2PLUS : P2MINUS , P2INT ); 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 = rvalue( (int *) argv[1] , NLNIL , RREQ ); 319 putleaf( P2ICON , 1 , 0 , P2INT , 0 ); 320 putop( P2AND , P2INT ); 321 return nl + TBOOL; 322 case O_CHR2: 323 if (isnta(p1, "i")) { 324 error("chr's argument must be an integer, not %s", nameof(p1)); 325 return (NIL); 326 } 327 if (opt('t')) { 328 putleaf( P2ICON , 0 , 0 329 , ADDTYPE( P2FTN | P2CHAR , P2PTR ) , "_CHR" ); 330 p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); 331 putop( P2CALL , P2CHAR ); 332 } else { 333 p1 = stkrval( (int *) argv[1] , NLNIL , RREQ ); 334 } 335 return nl + TCHAR; 336 case O_CARD: 337 if (isnta(p1, "t")) { 338 error("Argument to card must be a set, not %s", nameof(p1)); 339 return (NIL); 340 } 341 putleaf( P2ICON , 0 , 0 342 , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_CARD" ); 343 p1 = stkrval( (int *) argv[1] , NLNIL , LREQ ); 344 putleaf( P2ICON , lwidth( p1 ) , 0 , P2INT , 0 ); 345 putop( P2LISTOP , P2INT ); 346 putop( P2CALL , P2INT ); 347 return nl + T2INT; 348 case O_EOLN: 349 if (!text(p1)) { 350 error("Argument to eoln must be a text file, not %s", nameof(p1)); 351 return (NIL); 352 } 353 putleaf( P2ICON , 0 , 0 354 , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_TEOLN" ); 355 p1 = stklval( (int *) argv[1] , NOFLAGS ); 356 putop( P2CALL , P2INT ); 357 return nl + TBOOL; 358 case O_EOF: 359 if (p1->class != FILET) { 360 error("Argument to eof must be file, not %s", nameof(p1)); 361 return (NIL); 362 } 363 putleaf( P2ICON , 0 , 0 364 , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_TEOF" ); 365 p1 = stklval( (int *) argv[1] , NOFLAGS ); 366 putop( P2CALL , P2INT ); 367 return nl + TBOOL; 368 case 0: 369 error("%s is an unimplemented 6000-3.4 extension", p->symbol); 370 default: 371 panic("func1"); 372 } 373 } 374 #endif PC 375