1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)func.c 1.9 12/06/82"; 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 struct nl *tempnlp; 26 register int *al; 27 register op; 28 int argc, *argv; 29 int tr[2], tr2[4]; 30 31 /* 32 * Verify that the given name 33 * is defined and the name of 34 * a function. 35 */ 36 p = lookup(r[2]); 37 if (p == NIL) { 38 rvlist(r[3]); 39 return (NIL); 40 } 41 if (p->class != FUNC && p->class != FFUNC) { 42 error("%s is not a function", p->symbol); 43 rvlist(r[3]); 44 return (NIL); 45 } 46 argv = r[3]; 47 /* 48 * Call handles user defined 49 * procedures and functions 50 */ 51 if (bn != 0) 52 return (call(p, argv, FUNC, bn)); 53 /* 54 * Count the arguments 55 */ 56 argc = 0; 57 for (al = argv; al != NIL; al = al[2]) 58 argc++; 59 /* 60 * Built-in functions have 61 * their interpreter opcode 62 * associated with them. 63 */ 64 op = p->value[0] &~ NSTAND; 65 if (opt('s') && (p->value[0] & NSTAND)) { 66 standard(); 67 error("%s is a nonstandard function", p->symbol); 68 } 69 switch (op) { 70 /* 71 * Parameterless functions 72 */ 73 case O_CLCK: 74 case O_SCLCK: 75 case O_WCLCK: 76 case O_ARGC: 77 if (argc != 0) { 78 error("%s takes no arguments", p->symbol); 79 rvlist(argv); 80 return (NIL); 81 } 82 put(1, op); 83 return (nl+T4INT); 84 case O_EOF: 85 case O_EOLN: 86 if (argc == 0) { 87 argv = tr; 88 tr[1] = tr2; 89 tr2[0] = T_VAR; 90 tr2[2] = input->symbol; 91 tr2[1] = tr2[3] = NIL; 92 argc = 1; 93 } else if (argc != 1) { 94 error("%s takes either zero or one argument", p->symbol); 95 rvlist(argv); 96 return (NIL); 97 } 98 } 99 /* 100 * All other functions take 101 * exactly one argument. 102 */ 103 if (argc != 1) { 104 error("%s takes exactly one argument", p->symbol); 105 rvlist(argv); 106 return (NIL); 107 } 108 /* 109 * Evaluate the argmument 110 */ 111 if (op == O_EOF || op == O_EOLN) 112 p1 = stklval((int *) argv[1], NLNIL , LREQ ); 113 else 114 p1 = stkrval((int *) argv[1], NLNIL , RREQ ); 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( nl+T4INT , 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 put(1, 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 put(1, op); 146 return (nl+T4INT); 147 case O_ROUND: 148 case O_TRUNC: 149 if (isnta(p1, "d")) { 150 error("%s's argument must be a real, not %s", p->symbol, nameof(p1)); 151 return (NIL); 152 } 153 put(1, op); 154 return (nl+T4INT); 155 case O_ABS2: 156 case O_SQR2: 157 if (isa(p1, "d")) { 158 put(1, op + O_ABS8-O_ABS2); 159 return (nl+TDOUBLE); 160 } 161 if (isa(p1, "i")) { 162 put(1, op + (width(p1) >> 2)); 163 return (nl+T4INT); 164 } 165 error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1)); 166 return (NIL); 167 case O_ORD2: 168 if (isa(p1, "bcis")) { 169 return (nl+T4INT); 170 } 171 if (classify(p1) == TPTR) { 172 if (!opt('s')) { 173 return (nl+T4INT); 174 } 175 standard(); 176 } 177 error("ord's argument must be of scalar type, not %s", 178 nameof(p1)); 179 return (NIL); 180 case O_SUCC2: 181 case O_PRED2: 182 if (isa(p1, "d")) { 183 error("%s is forbidden for reals", p->symbol); 184 return (NIL); 185 } 186 if ( isnta( p1 , "bcsi" ) ) { 187 error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1)); 188 return NIL; 189 } 190 tempnlp = p1 -> class == TYPE ? p1 -> type : p1; 191 if (isa(p1, "i")) { 192 if (width(p1) <= 2) { 193 op += O_PRED24 - O_PRED2; 194 put(3, op, (int)tempnlp->range[0], 195 (int)tempnlp->range[1]); 196 } else { 197 op++; 198 put(3, op, tempnlp->range[0], 199 tempnlp->range[1]); 200 } 201 return nl + T4INT; 202 } else { 203 put(3, op, (int)tempnlp->range[0], 204 (int)tempnlp->range[1]); 205 return p1; 206 } 207 case O_ODD2: 208 if (isnta(p1, "i")) { 209 error("odd's argument must be an integer, not %s", nameof(p1)); 210 return (NIL); 211 } 212 put(1, op + (width(p1) >> 2)); 213 return (nl+TBOOL); 214 case O_CHR2: 215 if (isnta(p1, "i")) { 216 error("chr's argument must be an integer, not %s", nameof(p1)); 217 return (NIL); 218 } 219 put(1, op + (width(p1) >> 2)); 220 return (nl+TCHAR); 221 case O_CARD: 222 if (isnta(p1, "t")) { 223 error("Argument to card must be a set, not %s", nameof(p1)); 224 return (NIL); 225 } 226 put(2, O_CARD, width(p1)); 227 return (nl+T2INT); 228 case O_EOLN: 229 if (!text(p1)) { 230 error("Argument to eoln must be a text file, not %s", nameof(p1)); 231 return (NIL); 232 } 233 put(1, op); 234 return (nl+TBOOL); 235 case O_EOF: 236 if (p1->class != FILET) { 237 error("Argument to eof must be file, not %s", nameof(p1)); 238 return (NIL); 239 } 240 put(1, op); 241 return (nl+TBOOL); 242 case 0: 243 error("%s is an unimplemented 6000-3.4 extension", p->symbol); 244 default: 245 panic("func1"); 246 } 247 } 248 #endif OBJ 249