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

Defined functions

funccod defined in line 24; used 2 times

Defined variables

cardemptyline defined in line 16; used 2 times
Last modified: 1983-03-17
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 1305
Valid CSS Valid XHTML 1.0 Strict