1 /*- 2 * Copyright (c) 1980, 1993 3 * The Regents of the University of California. All rights reserved. 4 * 5 * %sccs.include.redist.c% 6 */ 7 8 #ifndef lint 9 static char sccsid[] = "@(#)pcfunc.c 8.1 (Berkeley) 06/06/93"; 10 #endif /* not lint */ 11 12 #include "whoami.h" 13 #ifdef PC 14 /* 15 * and to the end of the file 16 */ 17 #include "0.h" 18 #include "tree.h" 19 #include "objfmt.h" 20 #include "opcode.h" 21 #include "pc.h" 22 #include <pcc.h> 23 #include "tmps.h" 24 #include "tree_ty.h" 25 26 /* 27 * Funccod generates code for 28 * built in function calls and calls 29 * call to generate calls to user 30 * defined functions and procedures. 31 */ 32 struct nl * 33 pcfunccod( r ) 34 struct tnode *r; /* T_FCALL */ 35 { 36 struct nl *p; 37 register struct nl *p1; 38 register struct tnode *al; 39 register op; 40 int argc; 41 struct tnode *argv; 42 struct tnode tr, tr2; 43 char *funcname; 44 struct nl *tempnlp; 45 long temptype; 46 struct nl *rettype; 47 48 /* 49 * Verify that the given name 50 * is defined and the name of 51 * a function. 52 */ 53 p = lookup(r->pcall_node.proc_id); 54 if (p == NLNIL) { 55 rvlist(r->pcall_node.arg); 56 return (NLNIL); 57 } 58 if (p->class != FUNC && p->class != FFUNC) { 59 error("%s is not a function", p->symbol); 60 rvlist(r->pcall_node.arg); 61 return (NLNIL); 62 } 63 argv = r->pcall_node.arg; 64 /* 65 * Call handles user defined 66 * procedures and functions 67 */ 68 if (bn != 0) 69 return (call(p, argv, FUNC, bn)); 70 /* 71 * Count the arguments 72 */ 73 argc = 0; 74 for (al = argv; al != TR_NIL; al = al->list_node.next) 75 argc++; 76 /* 77 * Built-in functions have 78 * their interpreter opcode 79 * associated with them. 80 */ 81 op = p->value[0] &~ NSTAND; 82 if (opt('s') && (p->value[0] & NSTAND)) { 83 standard(); 84 error("%s is a nonstandard function", p->symbol); 85 } 86 if ( op == O_ARGC ) { 87 putleaf( PCC_NAME , 0 , 0 , PCCT_INT , "__argc" ); 88 return nl + T4INT; 89 } 90 switch (op) { 91 /* 92 * Parameterless functions 93 */ 94 case O_CLCK: 95 funcname = "_CLCK"; 96 goto noargs; 97 case O_SCLCK: 98 funcname = "_SCLCK"; 99 goto noargs; 100 noargs: 101 if (argc != 0) { 102 error("%s takes no arguments", p->symbol); 103 rvlist(argv); 104 return (NLNIL); 105 } 106 putleaf( PCC_ICON , 0 , 0 107 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 108 , funcname ); 109 putop( PCCOM_UNARY PCC_CALL , PCCT_INT ); 110 return (nl+T4INT); 111 case O_WCLCK: 112 if (argc != 0) { 113 error("%s takes no arguments", p->symbol); 114 rvlist(argv); 115 return (NLNIL); 116 } 117 putleaf( PCC_ICON , 0 , 0 118 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 119 , "_time" ); 120 putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 ); 121 putop( PCC_CALL , PCCT_INT ); 122 return (nl+T4INT); 123 case O_EOF: 124 case O_EOLN: 125 if (argc == 0) { 126 argv = &(tr); 127 tr.list_node.list = &(tr2); 128 tr2.tag = T_VAR; 129 tr2.var_node.cptr = input->symbol; 130 tr2.var_node.line_no = NIL; 131 tr2.var_node.qual = TR_NIL; 132 argc = 1; 133 } else if (argc != 1) { 134 error("%s takes either zero or one argument", p->symbol); 135 rvlist(argv); 136 return (NLNIL); 137 } 138 } 139 /* 140 * All other functions take 141 * exactly one argument. 142 */ 143 if (argc != 1) { 144 error("%s takes exactly one argument", p->symbol); 145 rvlist(argv); 146 return (NLNIL); 147 } 148 /* 149 * find out the type of the argument 150 */ 151 codeoff(); 152 p1 = stkrval( argv->list_node.list, NLNIL , (long) RREQ ); 153 codeon(); 154 if (p1 == NLNIL) 155 return (NLNIL); 156 /* 157 * figure out the return type and the funtion name 158 */ 159 switch (op) { 160 case 0: 161 error("%s is an unimplemented 6000-3.4 extension", p->symbol); 162 default: 163 panic("func1"); 164 case O_EXP: 165 funcname = opt('t') ? "_EXP" : "_exp"; 166 goto mathfunc; 167 case O_SIN: 168 funcname = opt('t') ? "_SIN" : "_sin"; 169 goto mathfunc; 170 case O_COS: 171 funcname = opt('t') ? "_COS" : "_cos"; 172 goto mathfunc; 173 case O_ATAN: 174 funcname = opt('t') ? "_ATAN" : "_atan"; 175 goto mathfunc; 176 case O_LN: 177 funcname = opt('t') ? "_LN" : "_log"; 178 goto mathfunc; 179 case O_SQRT: 180 funcname = opt('t') ? "_SQRT" : "_sqrt"; 181 goto mathfunc; 182 case O_RANDOM: 183 funcname = "_RANDOM"; 184 goto mathfunc; 185 mathfunc: 186 if (isnta(p1, "id")) { 187 error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1)); 188 return (NLNIL); 189 } 190 putleaf( PCC_ICON , 0 , 0 191 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_DOUBLE , PCCTM_PTR ) , funcname ); 192 p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 193 sconv(p2type(p1), PCCT_DOUBLE); 194 putop( PCC_CALL , PCCT_DOUBLE ); 195 return nl + TDOUBLE; 196 case O_EXPO: 197 if (isnta( p1 , "id" ) ) { 198 error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1)); 199 return NIL; 200 } 201 putleaf( PCC_ICON , 0 , 0 202 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_EXPO" ); 203 p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 204 sconv(p2type(p1), PCCT_DOUBLE); 205 putop( PCC_CALL , PCCT_INT ); 206 return ( nl + T4INT ); 207 case O_UNDEF: 208 if ( isnta( p1 , "id" ) ) { 209 error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1)); 210 return NLNIL; 211 } 212 p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 213 putleaf( PCC_ICON , 0 , 0 , PCCT_CHAR , (char *) 0 ); 214 putop( PCC_COMOP , PCCT_CHAR ); 215 return ( nl + TBOOL ); 216 case O_SEED: 217 if (isnta(p1, "i")) { 218 error("seed's argument must be an integer, not %s", nameof(p1)); 219 return (NLNIL); 220 } 221 putleaf( PCC_ICON , 0 , 0 222 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_SEED" ); 223 p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 224 putop( PCC_CALL , PCCT_INT ); 225 return nl + T4INT; 226 case O_ROUND: 227 case O_TRUNC: 228 if ( isnta( p1 , "d" ) ) { 229 error("%s's argument must be a real, not %s", p->symbol, nameof(p1)); 230 return (NLNIL); 231 } 232 putleaf( PCC_ICON , 0 , 0 233 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 234 , op == O_ROUND ? "_ROUND" : "_TRUNC" ); 235 p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 236 putop( PCC_CALL , PCCT_INT ); 237 return nl + T4INT; 238 case O_ABS2: 239 if ( isa( p1 , "d" ) ) { 240 putleaf( PCC_ICON , 0 , 0 241 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_DOUBLE , PCCTM_PTR ) 242 , "_fabs" ); 243 p1 = stkrval( argv->list_node.list , NLNIL ,(long) RREQ ); 244 putop( PCC_CALL , PCCT_DOUBLE ); 245 return nl + TDOUBLE; 246 } 247 if ( isa( p1 , "i" ) ) { 248 putleaf( PCC_ICON , 0 , 0 249 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_abs" ); 250 p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 251 putop( PCC_CALL , PCCT_INT ); 252 return nl + T4INT; 253 } 254 error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1)); 255 return NLNIL; 256 case O_SQR2: 257 if ( isa( p1 , "d" ) ) { 258 temptype = PCCT_DOUBLE; 259 rettype = nl + TDOUBLE; 260 tempnlp = tmpalloc((long) (sizeof(double)), rettype, REGOK); 261 } else if ( isa( p1 , "i" ) ) { 262 temptype = PCCT_INT; 263 rettype = nl + T4INT; 264 tempnlp = tmpalloc((long) (sizeof(long)), rettype, REGOK); 265 } else { 266 error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1)); 267 return NLNIL; 268 } 269 putRV( (char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] , 270 tempnlp -> extra_flags , (char) temptype ); 271 p1 = rvalue( argv->list_node.list , NLNIL , RREQ ); 272 sconv(p2type(p1), (int) temptype); 273 putop( PCC_ASSIGN , (int) temptype ); 274 putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] , 275 tempnlp -> extra_flags , (char) temptype ); 276 putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] , 277 tempnlp -> extra_flags , (char) temptype ); 278 putop( PCC_MUL , (int) temptype ); 279 putop( PCC_COMOP , (int) temptype ); 280 return rettype; 281 case O_ORD2: 282 p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 283 if (isa(p1, "bcis")) { 284 return (nl+T4INT); 285 } 286 if (classify(p1) == TPTR) { 287 if (!opt('s')) { 288 return (nl+T4INT); 289 } 290 standard(); 291 } 292 error("ord's argument must be of scalar type, not %s", 293 nameof(p1)); 294 return (NLNIL); 295 case O_SUCC2: 296 case O_PRED2: 297 if (isa(p1, "d")) { 298 error("%s is forbidden for reals", p->symbol); 299 return (NLNIL); 300 } 301 if ( isnta( p1 , "bcsi" ) ) { 302 error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1)); 303 return NLNIL; 304 } 305 if ( opt( 't' ) ) { 306 putleaf( PCC_ICON , 0 , 0 307 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 308 , op == O_SUCC2 ? "_SUCC" : "_PRED" ); 309 p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 310 tempnlp = p1 -> class == TYPE ? p1 -> type : p1; 311 putleaf( PCC_ICON, (int) tempnlp -> range[0], 0, PCCT_INT, (char *) 0 ); 312 putop( PCC_CM , PCCT_INT ); 313 putleaf( PCC_ICON, (int) tempnlp -> range[1], 0, PCCT_INT, (char *) 0 ); 314 putop( PCC_CM , PCCT_INT ); 315 putop( PCC_CALL , PCCT_INT ); 316 sconv(PCCT_INT, p2type(p1)); 317 } else { 318 p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 319 putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 ); 320 putop( op == O_SUCC2 ? PCC_PLUS : PCC_MINUS , PCCT_INT ); 321 sconv(PCCT_INT, p2type(p1)); 322 } 323 if ( isa( p1 , "bcs" ) ) { 324 return p1; 325 } else { 326 return nl + T4INT; 327 } 328 case O_ODD2: 329 if (isnta(p1, "i")) { 330 error("odd's argument must be an integer, not %s", nameof(p1)); 331 return (NLNIL); 332 } 333 p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 334 /* 335 * THIS IS MACHINE-DEPENDENT!!! 336 */ 337 putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 ); 338 putop( PCC_AND , PCCT_INT ); 339 sconv(PCCT_INT, PCCT_CHAR); 340 return nl + TBOOL; 341 case O_CHR2: 342 if (isnta(p1, "i")) { 343 error("chr's argument must be an integer, not %s", nameof(p1)); 344 return (NLNIL); 345 } 346 if (opt('t')) { 347 putleaf( PCC_ICON , 0 , 0 348 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_CHAR , PCCTM_PTR ) , "_CHR" ); 349 p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 350 putop( PCC_CALL , PCCT_CHAR ); 351 } else { 352 p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 353 sconv(PCCT_INT, PCCT_CHAR); 354 } 355 return nl + TCHAR; 356 case O_CARD: 357 if (isnta(p1, "t")) { 358 error("Argument to card must be a set, not %s", nameof(p1)); 359 return (NLNIL); 360 } 361 putleaf( PCC_ICON , 0 , 0 362 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_CARD" ); 363 p1 = stkrval( argv->list_node.list , NLNIL , (long) LREQ ); 364 putleaf( PCC_ICON , (int) lwidth( p1 ) , 0 , PCCT_INT , (char *) 0 ); 365 putop( PCC_CM , PCCT_INT ); 366 putop( PCC_CALL , PCCT_INT ); 367 return nl + T4INT; 368 case O_EOLN: 369 if (!text(p1)) { 370 error("Argument to eoln must be a text file, not %s", nameof(p1)); 371 return (NLNIL); 372 } 373 putleaf( PCC_ICON , 0 , 0 374 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_TEOLN" ); 375 p1 = stklval( argv->list_node.list , NOFLAGS ); 376 putop( PCC_CALL , PCCT_INT ); 377 sconv(PCCT_INT, PCCT_CHAR); 378 return nl + TBOOL; 379 case O_EOF: 380 if (p1->class != FILET) { 381 error("Argument to eof must be file, not %s", nameof(p1)); 382 return (NLNIL); 383 } 384 putleaf( PCC_ICON , 0 , 0 385 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_TEOF" ); 386 p1 = stklval( argv->list_node.list , NOFLAGS ); 387 putop( PCC_CALL , PCCT_INT ); 388 sconv(PCCT_INT, PCCT_CHAR); 389 return nl + TBOOL; 390 } 391 } 392 #endif PC 393