![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to func.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 40BSD / cmd / pi|
Return to func.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / pi |
1.1 root 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
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.