# 2.11BSD#431 - /usr/src/ucb/PORT/pascal/src/pcfunc.c

##### Functions

    pcfunccod         X

       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

pcfunccod defined in line 31; used 4 times

- in /usr/src/ucb/PORT/pascal/src/0.h line 731
- in /usr/src/ucb/PORT/pascal/src/rval.c line 122, 339
- in /usr/src/ucb/PORT/pascal/src/stkrval.c line 272

#### 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: 1587 |