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

##### Functions

    funccod           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[] = "@(#)func.c	5.1 (Berkeley) 6/5/85";
       9: #endif not lint
      10:
      11:
      12: #include "whoami.h"
      13: #ifdef OBJ
      14:     /*
      15:      *	the rest of the file
      16:      */
      17: #include "0.h"
      18: #include "tree.h"
      19: #include "opcode.h"
      20: #include "tree_ty.h"
      21:
      22: /*
      23:  * Funccod generates code for
      24:  * built in function calls and calls
      25:  * call to generate calls to user
      26:  * defined functions and procedures.
      27:  */
      28: struct nl
      29: *funccod(r)
      30:     struct tnode *r;
      31: {
      32:     struct nl *p;
      33:     register struct nl *p1;
      34:     struct nl *tempnlp;
      35:     register struct tnode *al;
      36:     register op;
      37:     int argc;
      38:     struct tnode *argv, tr, tr2;
      39:
      40:     /*
      41: 	 * Verify that the given name
      42: 	 * is defined and the name of
      43: 	 * a function.
      44: 	 */
      45:     p = lookup(r->pcall_node.proc_id);
      46:     if (p == NLNIL) {
      47:         rvlist(r->pcall_node.arg);
      48:         return (NLNIL);
      49:     }
      50:     if (p->class != FUNC && p->class != FFUNC) {
      51:         error("%s is not a function", p->symbol);
      52:         rvlist(r->pcall_node.arg);
      53:         return (NLNIL);
      54:     }
      55:     argv = r->pcall_node.arg;
      56:     /*
      57: 	 * Call handles user defined
      58: 	 * procedures and functions
      59: 	 */
      60:     if (bn != 0)
      61:         return (call(p, argv, FUNC, bn));
      62:     /*
      63: 	 * Count the arguments
      64: 	 */
      65:     argc = 0;
      66:     for (al = argv; al != TR_NIL; al = al->list_node.next)
      67:         argc++;
      68:     /*
      69: 	 * Built-in functions have
      70: 	 * their interpreter opcode
      71: 	 * associated with them.
      72: 	 */
      73:     op = p->value[0] &~ NSTAND;
      74:     if (opt('s') && (p->value[0] & NSTAND)) {
      75:         standard();
      76:         error("%s is a nonstandard function", p->symbol);
      77:     }
      78:     switch (op) {
      79:         /*
      80: 		 * Parameterless functions
      81: 		 */
      82:         case O_CLCK:
      83:         case O_SCLCK:
      84:         case O_WCLCK:
      85:         case O_ARGC:
      86:             if (argc != 0) {
      87:                 error("%s takes no arguments", p->symbol);
      88:                 rvlist(argv);
      89:                 return (NLNIL);
      90:             }
      91:             (void) put(1, op);
      92:             return (nl+T4INT);
      93:         case O_EOF:
      94:         case O_EOLN:
      95:             if (argc == 0) {
      96:                 argv = (&tr);
      97:                 tr.list_node.list = (&tr2);
      98:                 tr2.tag = T_VAR;
      99:                 tr2.var_node.cptr = input->symbol;
     100:                 tr2.var_node.line_no = NIL;
     101:                 tr2.var_node.qual = TR_NIL;
     102:                 argc = 1;
     103:             } else if (argc != 1) {
     104:                 error("%s takes either zero or one argument", p->symbol);
     105:                 rvlist(argv);
     106:                 return (NLNIL);
     107:             }
     108:         }
     109:     /*
     110: 	 * All other functions take
     111: 	 * exactly one argument.
     112: 	 */
     113:     if (argc != 1) {
     114:         error("%s takes exactly one argument", p->symbol);
     115:         rvlist(argv);
     116:         return (NLNIL);
     117:     }
     118:     /*
     119: 	 * Evaluate the argmument
     120: 	 */
     121:     if (op == O_EOF || op == O_EOLN)
     122:         p1 = stklval(argv->list_node.list, NIL );
     123:     else
     124:         p1 = stkrval(argv->list_node.list, NLNIL , (long) RREQ );
     125:     if (p1 == NLNIL)
     126:         return (NLNIL);
     127:     switch (op) {
     128:         case 0:
     129:             error("%s is an unimplemented 6000-3.4 extension", p->symbol);
     130:         default:
     131:             panic("func1");
     132:         case O_EXP:
     133:         case O_SIN:
     134:         case O_COS:
     135:         case O_ATAN:
     136:         case O_LN:
     137:         case O_SQRT:
     138:         case O_RANDOM:
     139:         case O_EXPO:
     140:         case O_UNDEF:
     141:             if (isa(p1, "i"))
     142:                 convert( nl+T4INT , nl+TDOUBLE);
     143:             else if (isnta(p1, "d")) {
     144:                 error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
     145:                 return (NLNIL);
     146:             }
     147:             (void) put(1, op);
     148:             if (op == O_UNDEF)
     149:                 return (nl+TBOOL);
     150:             else if (op == O_EXPO)
     151:                 return (nl+T4INT);
     152:             else
     153:                 return (nl+TDOUBLE);
     154:         case O_SEED:
     155:             if (isnta(p1, "i")) {
     156:                 error("seed's argument must be an integer, not %s", nameof(p1));
     157:                 return (NLNIL);
     158:             }
     159:             (void) put(1, op);
     160:             return (nl+T4INT);
     161:         case O_ROUND:
     162:         case O_TRUNC:
     163:             if (isnta(p1, "d"))  {
     164:                 error("%s's argument must be a real, not %s", p->symbol, nameof(p1));
     165:                 return (NLNIL);
     166:             }
     167:             (void) put(1, op);
     168:             return (nl+T4INT);
     169:         case O_ABS2:
     170:         case O_SQR2:
     171:             if (isa(p1, "d")) {
     172:                 (void) put(1, op + O_ABS8-O_ABS2);
     173:                 return (nl+TDOUBLE);
     174:             }
     175:             if (isa(p1, "i")) {
     176:                 (void) put(1, op + (width(p1) >> 2));
     177:                 return (nl+T4INT);
     178:             }
     179:             error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1));
     180:             return (NLNIL);
     181:         case O_ORD2:
     182:             if (isa(p1, "bcis")) {
     183:                 return (nl+T4INT);
     184:             }
     185:             if (classify(p1) == TPTR) {
     186:                 if (!opt('s')) {
     187:                 return (nl+T4INT);
     188:                 }
     189:                 standard();
     190:             }
     191:             error("ord's argument must be of scalar type, not %s",
     192:                 nameof(p1));
     193:             return (NLNIL);
     194:         case O_SUCC2:
     195:         case O_PRED2:
     196:             if (isa(p1, "d")) {
     197:                 error("%s is forbidden for reals", p->symbol);
     198:                 return (NLNIL);
     199:             }
     200:             if ( isnta( p1 , "bcsi" ) ) {
     201:                 error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1));
     202:                 return NIL;
     203:             }
     204:             tempnlp = p1 -> class == TYPE ? p1 -> type : p1;
     205:             if (isa(p1, "i")) {
     206:                 if (width(p1) <= 2) {
     207:                     op += O_PRED24 - O_PRED2;
     208:                     (void) put(3, op, (int)tempnlp->range[0],
     209:                         (int)tempnlp->range[1]);
     210:                 } else {
     211:                     op++;
     212:                     (void) put(3, op, tempnlp->range[0],
     213:                         tempnlp->range[1]);
     214:                 }
     215:                 return nl + T4INT;
     216:             } else {
     217:                 (void) put(3, op, (int)tempnlp->range[0],
     218:                     (int)tempnlp->range[1]);
     219:                 return p1;
     220:             }
     221:         case O_ODD2:
     222:             if (isnta(p1, "i")) {
     223:                 error("odd's argument must be an integer, not %s", nameof(p1));
     224:                 return (NLNIL);
     225:             }
     226:             (void) put(1, op + (width(p1) >> 2));
     227:             return (nl+TBOOL);
     228:         case O_CHR2:
     229:             if (isnta(p1, "i")) {
     230:                 error("chr's argument must be an integer, not %s", nameof(p1));
     231:                 return (NLNIL);
     232:             }
     233:             (void) put(1, op + (width(p1) >> 2));
     234:             return (nl+TCHAR);
     235:         case O_CARD:
     236:             if (isnta(p1, "t")) {
     237:                 error("Argument to card must be a set, not %s", nameof(p1));
     238:                 return (NLNIL);
     239:             }
     240:             (void) put(2, O_CARD, width(p1));
     241:             return (nl+T2INT);
     242:         case O_EOLN:
     243:             if (!text(p1)) {
     244:                 error("Argument to eoln must be a text file, not %s", nameof(p1));
     245:                 return (NLNIL);
     246:             }
     247:             (void) put(1, op);
     248:             return (nl+TBOOL);
     249:         case O_EOF:
     250:             if (p1->class != FILET) {
     251:                 error("Argument to eof must be file, not %s", nameof(p1));
     252:                 return (NLNIL);
     253:             }
     254:             (void) put(1, op);
     255:             return (nl+TBOOL);
     256:     }
     257: }
     258: #endif OBJ

#### Defined functions

funccod defined in line 28; used 5 times

- in /usr/src/ucb/PORT/pascal/src/0.h line 730
- in /usr/src/ucb/PORT/pascal/src/rval.c line 119, 336
- in /usr/src/ucb/PORT/pascal/src/stkrval.c line 263-267(2)

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