1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)func.c 1.4 01/06/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(p1, 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, "bcs")) { 175 put1(op); 176 return (p1); 177 } 178 if (isa(p1, "i")) { 179 if (width(p1) <= 2) 180 op += O_PRED24-O_PRED2; 181 else 182 op++; 183 put1(op); 184 return (nl+T4INT); 185 } 186 if (isa(p1, "id")) { 187 error("%s is forbidden for reals", p->symbol); 188 return (NIL); 189 } 190 error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1)); 191 return (NIL); 192 case O_ODD2: 193 if (isnta(p1, "i")) { 194 error("odd's argument must be an integer, not %s", nameof(p1)); 195 return (NIL); 196 } 197 put1(op + (width(p1) >> 2)); 198 return (nl+TBOOL); 199 case O_CHR2: 200 if (isnta(p1, "i")) { 201 error("chr's argument must be an integer, not %s", nameof(p1)); 202 return (NIL); 203 } 204 put1(op + (width(p1) >> 2)); 205 return (nl+TCHAR); 206 case O_CARD: 207 if (isnta(p1, "t")) { 208 error("Argument to card must be a set, not %s", nameof(p1)); 209 return (NIL); 210 } 211 put2(O_CARD, width(p1)); 212 return (nl+T2INT); 213 case O_EOLN: 214 if (!text(p1)) { 215 error("Argument to eoln must be a text file, not %s", nameof(p1)); 216 return (NIL); 217 } 218 put1(op); 219 return (nl+TBOOL); 220 case O_EOF: 221 if (p1->class != FILET) { 222 error("Argument to eof must be file, not %s", nameof(p1)); 223 return (NIL); 224 } 225 put1(op); 226 return (nl+TBOOL); 227 case 0: 228 error("%s is an unimplemented 6000-3.4 extension", p->symbol); 229 default: 230 panic("func1"); 231 } 232 } 233 #endif OBJ 234