1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)func.c 1.3 10/19/80"; 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 p1 = stkrval((int *) argv[1], NLNIL , RREQ ); 111 if (p1 == NIL) 112 return (NIL); 113 switch (op) { 114 case O_EXP: 115 case O_SIN: 116 case O_COS: 117 case O_ATAN: 118 case O_LN: 119 case O_SQRT: 120 case O_RANDOM: 121 case O_EXPO: 122 case O_UNDEF: 123 if (isa(p1, "i")) 124 convert(p1, nl+TDOUBLE); 125 else if (isnta(p1, "d")) { 126 error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1)); 127 return (NIL); 128 } 129 put1(op); 130 if (op == O_UNDEF) 131 return (nl+TBOOL); 132 else if (op == O_EXPO) 133 return (nl+T4INT); 134 else 135 return (nl+TDOUBLE); 136 case O_SEED: 137 if (isnta(p1, "i")) { 138 error("seed's argument must be an integer, not %s", nameof(p1)); 139 return (NIL); 140 } 141 put1(op); 142 return (nl+T4INT); 143 case O_ROUND: 144 case O_TRUNC: 145 if (isnta(p1, "d")) { 146 error("%s's argument must be a real, not %s", p->symbol, nameof(p1)); 147 return (NIL); 148 } 149 put1(op); 150 return (nl+T4INT); 151 case O_ABS2: 152 case O_SQR2: 153 if (isa(p1, "d")) { 154 put1(op + O_ABS8-O_ABS2); 155 return (nl+TDOUBLE); 156 } 157 if (isa(p1, "i")) { 158 put1(op + (width(p1) >> 2)); 159 return (nl+T4INT); 160 } 161 error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1)); 162 return (NIL); 163 case O_ORD2: 164 if (isa(p1, "bcis") || classify(p1) == TPTR) { 165 return (nl+T4INT); 166 } 167 error("ord's argument must be of scalar type or a pointer, not %s", nameof(p1)); 168 return (NIL); 169 case O_SUCC2: 170 case O_PRED2: 171 if (isa(p1, "bcs")) { 172 put1(op); 173 return (p1); 174 } 175 if (isa(p1, "i")) { 176 if (width(p1) <= 2) 177 op += O_PRED24-O_PRED2; 178 else 179 op++; 180 put1(op); 181 return (nl+T4INT); 182 } 183 if (isa(p1, "id")) { 184 error("%s is forbidden for reals", p->symbol); 185 return (NIL); 186 } 187 error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1)); 188 return (NIL); 189 case O_ODD2: 190 if (isnta(p1, "i")) { 191 error("odd's argument must be an integer, not %s", nameof(p1)); 192 return (NIL); 193 } 194 put1(op + (width(p1) >> 2)); 195 return (nl+TBOOL); 196 case O_CHR2: 197 if (isnta(p1, "i")) { 198 error("chr's argument must be an integer, not %s", nameof(p1)); 199 return (NIL); 200 } 201 put1(op + (width(p1) >> 2)); 202 return (nl+TCHAR); 203 case O_CARD: 204 if (isnta(p1, "t")) { 205 error("Argument to card must be a set, not %s", nameof(p1)); 206 return (NIL); 207 } 208 put2(O_CARD, width(p1)); 209 return (nl+T2INT); 210 case O_EOLN: 211 if (!text(p1)) { 212 error("Argument to eoln must be a text file, not %s", nameof(p1)); 213 return (NIL); 214 } 215 put1(op); 216 return (nl+TBOOL); 217 case O_EOF: 218 if (p1->class != FILET) { 219 error("Argument to eof must be file, not %s", nameof(p1)); 220 return (NIL); 221 } 222 put1(op); 223 return (nl+TBOOL); 224 case 0: 225 error("%s is an unimplemented 6000-3.4 extension", p->symbol); 226 default: 227 panic("func1"); 228 } 229 } 230 #endif OBJ 231