![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to pcfunc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / pascal / src|
Return to pcfunc.c CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / 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[] = "@(#)pcfunc.c 5.1 (Berkeley) 6/5/85";
9: #endif not lint
10:
11: #include "whoami.h"
12: #ifdef PC
13: /*
14: * and to the end of the file
15: */
16: #include "0.h"
17: #include "tree.h"
18: #include "objfmt.h"
19: #include "opcode.h"
20: #include "pc.h"
21: #include <pcc.h>
22: #include "tmps.h"
23: #include "tree_ty.h"
24:
25: /*
26: * Funccod generates code for
27: * built in function calls and calls
28: * call to generate calls to user
29: * defined functions and procedures.
30: */
31: struct nl *
32: pcfunccod( r )
33: struct tnode *r; /* T_FCALL */
34: {
35: struct nl *p;
36: register struct nl *p1;
37: register struct tnode *al;
38: register op;
39: int argc;
40: struct tnode *argv;
41: struct tnode tr, tr2;
42: char *funcname;
43: struct nl *tempnlp;
44: long temptype;
45: struct nl *rettype;
46:
47: /*
48: * Verify that the given name
49: * is defined and the name of
50: * a function.
51: */
52: p = lookup(r->pcall_node.proc_id);
53: if (p == NLNIL) {
54: rvlist(r->pcall_node.arg);
55: return (NLNIL);
56: }
57: if (p->class != FUNC && p->class != FFUNC) {
58: error("%s is not a function", p->symbol);
59: rvlist(r->pcall_node.arg);
60: return (NLNIL);
61: }
62: argv = r->pcall_node.arg;
63: /*
64: * Call handles user defined
65: * procedures and functions
66: */
67: if (bn != 0)
68: return (call(p, argv, FUNC, bn));
69: /*
70: * Count the arguments
71: */
72: argc = 0;
73: for (al = argv; al != TR_NIL; al = al->list_node.next)
74: argc++;
75: /*
76: * Built-in functions have
77: * their interpreter opcode
78: * associated with them.
79: */
80: op = p->value[0] &~ NSTAND;
81: if (opt('s') && (p->value[0] & NSTAND)) {
82: standard();
83: error("%s is a nonstandard function", p->symbol);
84: }
85: if ( op == O_ARGC ) {
86: putleaf( PCC_NAME , 0 , 0 , PCCT_INT , "__argc" );
87: return nl + T4INT;
88: }
89: switch (op) {
90: /*
91: * Parameterless functions
92: */
93: case O_CLCK:
94: funcname = "_CLCK";
95: goto noargs;
96: case O_SCLCK:
97: funcname = "_SCLCK";
98: goto noargs;
99: noargs:
100: if (argc != 0) {
101: error("%s takes no arguments", p->symbol);
102: rvlist(argv);
103: return (NLNIL);
104: }
105: putleaf( PCC_ICON , 0 , 0
106: , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
107: , funcname );
108: putop( PCCOM_UNARY PCC_CALL , PCCT_INT );
109: return (nl+T4INT);
110: case O_WCLCK:
111: if (argc != 0) {
112: error("%s takes no arguments", p->symbol);
113: rvlist(argv);
114: return (NLNIL);
115: }
116: putleaf( PCC_ICON , 0 , 0
117: , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
118: , "_time" );
119: putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 );
120: putop( PCC_CALL , PCCT_INT );
121: return (nl+T4INT);
122: case O_EOF:
123: case O_EOLN:
124: if (argc == 0) {
125: argv = &(tr);
126: tr.list_node.list = &(tr2);
127: tr2.tag = T_VAR;
128: tr2.var_node.cptr = input->symbol;
129: tr2.var_node.line_no = NIL;
130: tr2.var_node.qual = TR_NIL;
131: argc = 1;
132: } else if (argc != 1) {
133: error("%s takes either zero or one argument", p->symbol);
134: rvlist(argv);
135: return (NLNIL);
136: }
137: }
138: /*
139: * All other functions take
140: * exactly one argument.
141: */
142: if (argc != 1) {
143: error("%s takes exactly one argument", p->symbol);
144: rvlist(argv);
145: return (NLNIL);
146: }
147: /*
148: * find out the type of the argument
149: */
150: codeoff();
151: p1 = stkrval( argv->list_node.list, NLNIL , (long) RREQ );
152: codeon();
153: if (p1 == NLNIL)
154: return (NLNIL);
155: /*
156: * figure out the return type and the funtion name
157: */
158: switch (op) {
159: case 0:
160: error("%s is an unimplemented 6000-3.4 extension", p->symbol);
161: default:
162: panic("func1");
163: case O_EXP:
164: funcname = opt('t') ? "_EXP" : "_exp";
165: goto mathfunc;
166: case O_SIN:
167: funcname = opt('t') ? "_SIN" : "_sin";
168: goto mathfunc;
169: case O_COS:
170: funcname = opt('t') ? "_COS" : "_cos";
171: goto mathfunc;
172: case O_ATAN:
173: funcname = opt('t') ? "_ATAN" : "_atan";
174: goto mathfunc;
175: case O_LN:
176: funcname = opt('t') ? "_LN" : "_log";
177: goto mathfunc;
178: case O_SQRT:
179: funcname = opt('t') ? "_SQRT" : "_sqrt";
180: goto mathfunc;
181: case O_RANDOM:
182: funcname = "_RANDOM";
183: goto mathfunc;
184: mathfunc:
185: if (isnta(p1, "id")) {
186: error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
187: return (NLNIL);
188: }
189: putleaf( PCC_ICON , 0 , 0
190: , PCCM_ADDTYPE( PCCTM_FTN | PCCT_DOUBLE , PCCTM_PTR ) , funcname );
191: p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
192: sconv(p2type(p1), PCCT_DOUBLE);
193: putop( PCC_CALL , PCCT_DOUBLE );
194: return nl + TDOUBLE;
195: case O_EXPO:
196: if (isnta( p1 , "id" ) ) {
197: error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
198: return NIL;
199: }
200: putleaf( PCC_ICON , 0 , 0
201: , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_EXPO" );
202: p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
203: sconv(p2type(p1), PCCT_DOUBLE);
204: putop( PCC_CALL , PCCT_INT );
205: return ( nl + T4INT );
206: case O_UNDEF:
207: if ( isnta( p1 , "id" ) ) {
208: error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
209: return NLNIL;
210: }
211: p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
212: putleaf( PCC_ICON , 0 , 0 , PCCT_CHAR , (char *) 0 );
213: putop( PCC_COMOP , PCCT_CHAR );
214: return ( nl + TBOOL );
215: case O_SEED:
216: if (isnta(p1, "i")) {
217: error("seed's argument must be an integer, not %s", nameof(p1));
218: return (NLNIL);
219: }
220: putleaf( PCC_ICON , 0 , 0
221: , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_SEED" );
222: p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
223: putop( PCC_CALL , PCCT_INT );
224: return nl + T4INT;
225: case O_ROUND:
226: case O_TRUNC:
227: if ( isnta( p1 , "d" ) ) {
228: error("%s's argument must be a real, not %s", p->symbol, nameof(p1));
229: return (NLNIL);
230: }
231: putleaf( PCC_ICON , 0 , 0
232: , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
233: , op == O_ROUND ? "_ROUND" : "_TRUNC" );
234: p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
235: putop( PCC_CALL , PCCT_INT );
236: return nl + T4INT;
237: case O_ABS2:
238: if ( isa( p1 , "d" ) ) {
239: putleaf( PCC_ICON , 0 , 0
240: , PCCM_ADDTYPE( PCCTM_FTN | PCCT_DOUBLE , PCCTM_PTR )
241: , "_fabs" );
242: p1 = stkrval( argv->list_node.list , NLNIL ,(long) RREQ );
243: putop( PCC_CALL , PCCT_DOUBLE );
244: return nl + TDOUBLE;
245: }
246: if ( isa( p1 , "i" ) ) {
247: putleaf( PCC_ICON , 0 , 0
248: , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_abs" );
249: p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
250: putop( PCC_CALL , PCCT_INT );
251: return nl + T4INT;
252: }
253: error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1));
254: return NLNIL;
255: case O_SQR2:
256: if ( isa( p1 , "d" ) ) {
257: temptype = PCCT_DOUBLE;
258: rettype = nl + TDOUBLE;
259: tempnlp = tmpalloc((long) (sizeof(double)), rettype, REGOK);
260: } else if ( isa( p1 , "i" ) ) {
261: temptype = PCCT_INT;
262: rettype = nl + T4INT;
263: tempnlp = tmpalloc((long) (sizeof(long)), rettype, REGOK);
264: } else {
265: error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1));
266: return NLNIL;
267: }
268: putRV( (char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
269: tempnlp -> extra_flags , (char) temptype );
270: p1 = rvalue( argv->list_node.list , NLNIL , RREQ );
271: sconv(p2type(p1), (int) temptype);
272: putop( PCC_ASSIGN , (int) temptype );
273: putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
274: tempnlp -> extra_flags , (char) temptype );
275: putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
276: tempnlp -> extra_flags , (char) temptype );
277: putop( PCC_MUL , (int) temptype );
278: putop( PCC_COMOP , (int) temptype );
279: return rettype;
280: case O_ORD2:
281: p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
282: if (isa(p1, "bcis")) {
283: return (nl+T4INT);
284: }
285: if (classify(p1) == TPTR) {
286: if (!opt('s')) {
287: return (nl+T4INT);
288: }
289: standard();
290: }
291: error("ord's argument must be of scalar type, not %s",
292: nameof(p1));
293: return (NLNIL);
294: case O_SUCC2:
295: case O_PRED2:
296: if (isa(p1, "d")) {
297: error("%s is forbidden for reals", p->symbol);
298: return (NLNIL);
299: }
300: if ( isnta( p1 , "bcsi" ) ) {
301: error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1));
302: return NLNIL;
303: }
304: if ( opt( 't' ) ) {
305: putleaf( PCC_ICON , 0 , 0
306: , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
307: , op == O_SUCC2 ? "_SUCC" : "_PRED" );
308: p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
309: tempnlp = p1 -> class == TYPE ? p1 -> type : p1;
310: putleaf( PCC_ICON, (int) tempnlp -> range[0], 0, PCCT_INT, (char *) 0 );
311: putop( PCC_CM , PCCT_INT );
312: putleaf( PCC_ICON, (int) tempnlp -> range[1], 0, PCCT_INT, (char *) 0 );
313: putop( PCC_CM , PCCT_INT );
314: putop( PCC_CALL , PCCT_INT );
315: sconv(PCCT_INT, p2type(p1));
316: } else {
317: p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
318: putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 );
319: putop( op == O_SUCC2 ? PCC_PLUS : PCC_MINUS , PCCT_INT );
320: sconv(PCCT_INT, p2type(p1));
321: }
322: if ( isa( p1 , "bcs" ) ) {
323: return p1;
324: } else {
325: return nl + T4INT;
326: }
327: case O_ODD2:
328: if (isnta(p1, "i")) {
329: error("odd's argument must be an integer, not %s", nameof(p1));
330: return (NLNIL);
331: }
332: p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
333: /*
334: * THIS IS MACHINE-DEPENDENT!!!
335: */
336: putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 );
337: putop( PCC_AND , PCCT_INT );
338: sconv(PCCT_INT, PCCT_CHAR);
339: return nl + TBOOL;
340: case O_CHR2:
341: if (isnta(p1, "i")) {
342: error("chr's argument must be an integer, not %s", nameof(p1));
343: return (NLNIL);
344: }
345: if (opt('t')) {
346: putleaf( PCC_ICON , 0 , 0
347: , PCCM_ADDTYPE( PCCTM_FTN | PCCT_CHAR , PCCTM_PTR ) , "_CHR" );
348: p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
349: putop( PCC_CALL , PCCT_CHAR );
350: } else {
351: p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
352: sconv(PCCT_INT, PCCT_CHAR);
353: }
354: return nl + TCHAR;
355: case O_CARD:
356: if (isnta(p1, "t")) {
357: error("Argument to card must be a set, not %s", nameof(p1));
358: return (NLNIL);
359: }
360: putleaf( PCC_ICON , 0 , 0
361: , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_CARD" );
362: p1 = stkrval( argv->list_node.list , NLNIL , (long) LREQ );
363: putleaf( PCC_ICON , (int) lwidth( p1 ) , 0 , PCCT_INT , (char *) 0 );
364: putop( PCC_CM , PCCT_INT );
365: putop( PCC_CALL , PCCT_INT );
366: return nl + T4INT;
367: case O_EOLN:
368: if (!text(p1)) {
369: error("Argument to eoln must be a text file, not %s", nameof(p1));
370: return (NLNIL);
371: }
372: putleaf( PCC_ICON , 0 , 0
373: , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_TEOLN" );
374: p1 = stklval( argv->list_node.list , NOFLAGS );
375: putop( PCC_CALL , PCCT_INT );
376: sconv(PCCT_INT, PCCT_CHAR);
377: return nl + TBOOL;
378: case O_EOF:
379: if (p1->class != FILET) {
380: error("Argument to eof must be file, not %s", nameof(p1));
381: return (NLNIL);
382: }
383: putleaf( PCC_ICON , 0 , 0
384: , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_TEOF" );
385: p1 = stklval( argv->list_node.list , NOFLAGS );
386: putop( PCC_CALL , PCCT_INT );
387: sconv(PCCT_INT, PCCT_CHAR);
388: return nl + TBOOL;
389: }
390: }
391: #endif PC
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.