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) 6/5/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

Defined functions

Defined variables

sccsid defined in line 8; never used
Last modified: 1985-06-05
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 1721
Valid CSS Valid XHTML 1.0 Strict