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