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