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