![[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] / 43BSDReno / pgrm / pascal / src|
Return to func.c CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / pascal / src |
1.1 root 1: /*
2: * Copyright (c) 1980 Regents of the University of California.
3: * All rights reserved. The Berkeley software License Agreement
4: * specifies the terms and conditions for redistribution.
5: */
6:
7: #ifndef lint
8: static char sccsid[] = "@(#)func.c 5.1 (Berkeley) 6/5/85";
9: #endif not lint
10:
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
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.