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

   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

Defined variables