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