![[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] / 3BSD / cmd / pi|
Return to func.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / pi |
1.1 root 1: /* Copyright (c) 1979 Regents of the University of California */
2: #
3: /*
4: * pi - Pascal interpreter code translator
5: *
6: * Charles Haley, Bill Joy UCB
7: * Version 1.2 November 1978
8: */
9:
10: #include "whoami"
11: #include "0.h"
12: #include "tree.h"
13: #include "opcode.h"
14:
15: /*
16: * Funccod generates code for
17: * built in function calls and calls
18: * call to generate calls to user
19: * defined functions and procedures.
20: */
21: funccod(r)
22: int *r;
23: {
24: struct nl *p;
25: register struct nl *p1;
26: register int *al;
27: register op;
28: int argc, *argv;
29: int tr[2], tr2[4];
30:
31: /*
32: * Verify that the given name
33: * is defined and the name of
34: * a function.
35: */
36: p = lookup(r[2]);
37: if (p == NIL) {
38: rvlist(r[3]);
39: return (NIL);
40: }
41: if (p->class != FUNC) {
42: error("%s is not a function", p->symbol);
43: rvlist(r[3]);
44: return (NIL);
45: }
46: argv = r[3];
47: /*
48: * Call handles user defined
49: * procedures and functions
50: */
51: if (bn != 0)
52: return (call(p, argv, FUNC, bn));
53: /*
54: * Count the arguments
55: */
56: argc = 0;
57: for (al = argv; al != NIL; al = al[2])
58: argc++;
59: /*
60: * Built-in functions have
61: * their interpreter opcode
62: * associated with them.
63: */
64: op = p->value[0] &~ NSTAND;
65: if (opt('s') && (p->value[0] & NSTAND)) {
66: standard();
67: error("%s is a nonstandard function", p->symbol);
68: }
69: switch (op) {
70: /*
71: * Parameterless functions
72: */
73: case O_CLCK:
74: case O_SCLCK:
75: case O_WCLCK:
76: case O_ARGC:
77: if (argc != 0) {
78: error("%s takes no arguments", p->symbol);
79: rvlist(argv);
80: return (NIL);
81: }
82: put1(op);
83: return (nl+T4INT);
84: case O_EOF:
85: case O_EOLN:
86: if (argc == 0) {
87: argv = tr;
88: tr[1] = tr2;
89: tr2[0] = T_VAR;
90: tr2[2] = input->symbol;
91: tr2[1] = tr2[3] = NIL;
92: argc = 1;
93: } else if (argc != 1) {
94: error("%s takes either zero or one argument", p->symbol);
95: rvlist(argv);
96: return (NIL);
97: }
98: }
99: /*
100: * All other functions take
101: * exactly one argument.
102: */
103: if (argc != 1) {
104: error("%s takes exactly one argument", p->symbol);
105: rvlist(argv);
106: return (NIL);
107: }
108: /*
109: * Evaluate the argmument
110: */
111: p1 = rvalue((int *) argv[1], NLNIL);
112: if (p1 == NIL)
113: return (NIL);
114: switch (op) {
115: case O_EXP:
116: case O_SIN:
117: case O_COS:
118: case O_ATAN:
119: case O_LN:
120: case O_SQRT:
121: case O_RANDOM:
122: case O_EXPO:
123: case O_UNDEF:
124: if (isa(p1, "i"))
125: convert(p1, nl+TDOUBLE);
126: else if (isnta(p1, "d")) {
127: error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
128: return (NIL);
129: }
130: put1(op);
131: if (op == O_UNDEF)
132: return (nl+TBOOL);
133: else if (op == O_EXPO)
134: return (nl+T4INT);
135: else
136: return (nl+TDOUBLE);
137: case O_SEED:
138: if (isnta(p1, "i")) {
139: error("seed's argument must be an integer, not %s", nameof(p1));
140: return (NIL);
141: }
142: convert(p1, nl+T4INT);
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: switch (width(p1)) {
168: case 1:
169: return (nl+T1INT);
170: case 2:
171: return (nl+T2INT);
172: case 4:
173: return (nl+T4INT);
174: }
175: error("ord's argument must be of scalar type or a pointer, not %s", nameof(p1));
176: return (NIL);
177: case O_SUCC2:
178: case O_PRED2:
179: if (isa(p1, "bcs")) {
180: put1(op);
181: return (p1);
182: }
183: if (isa(p1, "i")) {
184: if (width(p1) <= 2)
185: op += O_PRED24-O_PRED2;
186: else
187: op++;
188: put1(op);
189: return (nl+T4INT);
190: }
191: if (isa(p1, "id")) {
192: error("%s is forbidden for reals", p->symbol);
193: return (NIL);
194: }
195: error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1));
196: return (NIL);
197: case O_ODD2:
198: if (isnta(p1, "i")) {
199: error("odd's argument must be an integer, not %s", nameof(p1));
200: return (NIL);
201: }
202: put1(op + (width(p1) >> 2));
203: return (nl+TBOOL);
204: case O_CHR2:
205: if (isnta(p1, "i")) {
206: error("chr's argument must be an integer, not %s", nameof(p1));
207: return (NIL);
208: }
209: put1(op + (width(p1) >> 2));
210: return (nl+TCHAR);
211: case O_CARD:
212: if (isnta(p1, "t")) {
213: error("Argument to card must be a set, not %s", nameof(p1));
214: return (NIL);
215: }
216: put2(O_CARD, width(p1));
217: return (nl+T2INT);
218: case O_EOLN:
219: if (!text(p1)) {
220: error("Argument to eoln must be a text file, not %s", nameof(p1));
221: return (NIL);
222: }
223: put1(op);
224: return (nl+TBOOL);
225: case O_EOF:
226: if (p1->class != FILET) {
227: error("Argument to eof must be file, not %s", nameof(p1));
228: return (NIL);
229: }
230: put1(op);
231: return (nl+TBOOL);
232: case 0:
233: error("%s is an unimplemented 6000-3.4 extension", p->symbol);
234: default:
235: panic("func1");
236: }
237: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.