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