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