![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to procedures.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / contrib / xns / compiler|
Return to procedures.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / xns / compiler |
1.1 root 1: #ifndef lint
2: static char RCSid[] = "$Header: procedures.c,v 2.0 85/11/21 07:21:43 jqj Exp $";
3: #endif
4:
5: /* $Log: procedures.c,v $
6: * Revision 2.0 85/11/21 07:21:43 jqj
7: * 4.3BSD standard release
8: *
9: * Revision 1.5 85/05/06 08:13:31 jqj
10: * *** empty log message ***
11: *
12: * Revision 1.5 85/05/06 08:13:31 jqj
13: * Almost Beta-test version.
14: *
15: * Revision 1.4 85/03/26 06:10:21 jqj
16: * Revised public alpha-test version, released 26 March 1985
17: *
18: * Revision 1.3 85/03/11 16:39:55 jqj
19: * Public alpha-test version, released 11 March 1985
20: *
21: * Revision 1.2 85/02/21 11:05:39 jqj
22: * alpha test version
23: *
24: * Revision 1.1 85/02/15 13:55:36 jqj
25: * Initial revision
26: *
27: */
28:
29: #define argname(p) ((char *) car(caar(p)))
30: #define argtype(p) ((struct type *) cdar(p))
31:
32: /*
33: * routines for generating procedures and errors
34: */
35:
36: #include "compiler.h"
37:
38: /*
39: * Generate client and server functions for procedure declarations.
40: */
41: define_procedure_constant(symbol,typtr,value)
42: struct object *symbol;
43: struct type *typtr;
44: struct constant *value;
45: {
46: struct type *resulttype;
47: char *procvalue;
48: char * resultname;
49: char buf[MAXSTR];
50: list p, q;
51:
52: if (recursive_flag) /* don't bother to do anything for procs */
53: return; /* in DEPENDS UPON modules */
54: if (typtr->type_constr != C_PROCEDURE)
55: error(FATAL, "internal error (define_procedure): not a procedure");
56: if (value->cn_constr != C_NUMERIC) {
57: error(ERROR,"Values of procedure constants must be numeric");
58: procvalue = "-1";
59: }
60: else
61: procvalue = value->cn_value;
62: /*
63: * RETURNS stuff: coerce the result to be a single record
64: */
65: if (length(typtr->type_results) > 0) {
66: struct object *resultobj;
67:
68: resulttype = record_type(typtr->type_results);
69: sprintf(buf,"%sResults",name_of(symbol));
70: resultname = copy(buf);
71: resultobj = make_symbol(resultname,CurrentProgram);
72: define_type(resultobj, resulttype);
73: /* replaces define_record_type(resulttype); */
74: typtr->type_results = cons( cons( cons((list)resultname, NIL),
75: (list)resulttype),
76: NIL);
77: }
78: /*
79: * REPORTS stuff: check here to make sure the errors are all defined
80: */
81: for (p = typtr->type_errors, q = NIL; p != NIL; q = p, p = cdr(p)) {
82: struct object *sym;
83: sym = check_def((char *)car(p),CurrentProgram);
84: if (sym == (struct object *)0) {
85: error(ERROR,"Error constant %s not defined",
86: (char*)car(p));
87: if (q == NIL) typtr->type_errors = cdr(p);
88: else cdr(q) = cdr(p);
89: }
90: else if (sym->o_class != O_CONSTANT
91: || sym->o_constant->cn_constr != C_ERROR) {
92: error(ERROR,"Symbol %s is not of appropriate type",
93: name_of(sym));
94: if (q == NIL) typtr->type_errors = cdr(p);
95: else cdr(q) = cdr(p);
96: }
97: }
98: /*
99: * Argument stuff: make sure all the argument types are defined
100: */
101: for (p = typtr->type_args; p != NIL; p = cdr(p)) {
102: if (typename(argtype(p)) == NULL) {
103: struct object *name;
104: name = make_symbol(gensym("T_p"),CurrentProgram);
105: define_type(name,argtype(p));
106: }
107: }
108: /*
109: * Actually generate code for this procedure
110: */
111: proc_functions(symbol->o_constant->cn_name, typtr, procvalue);
112: /*
113: * Save this procedure on the global procs for wrapup (server
114: * dispatch code)
115: */
116: Procedures = cons(cons( (list)symbol->o_constant->cn_name,
117: (list)procvalue ),
118: Procedures);
119: }
120:
121:
122: /*
123: * Generate funcions for client and server calls to a procedure.
124: */
125: proc_functions(proc_name, type, proc_number)
126: char *proc_name;
127: struct type *type;
128: char *proc_number;
129: {
130: list p;
131: int nresults, fixed_size, variable_size;
132: struct type *t, *bt, *result_type;
133: char *result_name, *ref, *rtname;
134:
135: /*
136: * Make sure there is at most one result returned.
137: */
138: nresults = length(type->type_results);
139: if (nresults > 1) {
140: error(ERROR, "procedures that return multiple results are not supported");
141: return;
142: }
143: if (nresults) {
144: result_name = "_Results";
145: result_type = argtype(type->type_results);
146: rtname = typename(result_type);
147: } else {
148: rtname = "void";
149: }
150:
151: /*
152: * Server routine.
153: */
154:
155: fprintf(server, "\nextern %s %s();\n", rtname, proc_name);
156: fprintf(server,
157: "\nserver_%s(_buf)\n\
158: \tregister Unspecified *_buf;\n\
159: {\n\
160: \tregister Unspecified *_bp = _buf;\n\
161: \tregister LongCardinal _n;\n",
162: proc_name);
163: for (p = type->type_args; p != NIL; p = cdr(p)) {
164: t = argtype(p);
165: fprintf(server, "\t%s %s;\n", typename(t), argname(p));
166: }
167: if (nresults)
168: fprintf(server, "\t%s %s;\n", rtname, result_name);
169: fprintf(server, "\n");
170: /*
171: * Generate code to internalize the arguments.
172: */
173: for (p = type->type_args; p != NIL; p = cdr(p)) {
174: t = argtype(p);
175: ref = refstr(t);
176: fprintf(server, "\t_bp += %s(%s%s, _bp);\n",
177: xfn(INTERNALIZE, t), ref, argname(p));
178: }
179: /*
180: * Generate code to call the procedure.
181: */
182: if (nresults)
183: fprintf(server, "\t%s = %s(_serverConnection, 0",
184: result_name, proc_name);
185: else
186: fprintf(server, "\t%s(_serverConnection, 0", proc_name);
187: for (p = type->type_args; p != NIL; p = cdr(p)) {
188: fprintf(server, ", %s", argname(p));
189: }
190: fprintf(server, ");\n");
191: /*
192: * Generate code to externalize the result.
193: */
194: if (nresults) {
195: ref = refstr(result_type);
196: fprintf(server,
197: "\t_n = sizeof_%s(%s%s);\n\
198: \t_bp = Allocate(_n);\n\
199: \t%s(%s%s, _bp);\n\
200: \tSendReturnMessage(_n, _bp);\n\
201: \tDeallocate(_bp);\n\
202: }\n",
203: rtname, ref, result_name,
204: xfn(EXTERNALIZE, result_type), ref, result_name);
205: } else
206: fprintf(server,"}\n" );
207:
208: /*
209: * Stub routine for client.
210: */
211:
212: fprintf(header, "\nextern %s %s();\n",
213: rtname, proc_name);
214: fprintf(client,
215: "\n\
216: %s\n\
217: %s(_Connection, _BDTprocptr",
218: rtname, proc_name);
219: for (p = type->type_args; p != NIL; p = cdr(p))
220: fprintf(client, ", %s", argname(p));
221: fprintf(client, ")\n\
222: \tCourierConnection *_Connection;\n\
223: \tint (*_BDTprocptr)();\n\
224: "
225: );
226: for (p = type->type_args; p != NIL; p = cdr(p)) {
227: t = argtype(p);
228: fprintf(client, "\t%s %s;\n", typename(t), argname(p));
229: }
230: fprintf(client, "{\n");
231: if (nresults)
232: fprintf(client, "\t%s %s;\n", rtname, result_name);
233: fprintf(client,
234: "\tregister Unspecified *_buf, *_bp;\n\
235: \tBoolean _errorflag;\n\
236: \tCardinal _errtype;\n"
237: );
238: /*
239: * Determine the size of the arguments.
240: * This is like the code in record_type().
241: */
242: fixed_size = 0;
243: variable_size = 0;
244: for (p = type->type_args; p != NIL; p = cdr(p)) {
245: bt = argtype(p);
246: if (bt->type_xsize == -1) {
247: variable_size = 1;
248: } else {
249: fixed_size += bt->type_xsize;
250: }
251: }
252: if (!variable_size) {
253: /*
254: * The argument list is fixed-size.
255: */
256: fprintf(client,
257: "\n\
258: \t_buf = Allocate(%d);\n",
259: fixed_size);
260: } else {
261: /*
262: * There are some variable-size arguments.
263: */
264: fprintf(client,
265: "\tregister LongCardinal _n = %d;\n\
266: \n",
267: fixed_size);
268: for (p = type->type_args; p != NIL; p = cdr(p)) {
269: t = argtype(p);
270: bt = t;
271: if (bt->type_xsize != -1)
272: continue;
273: ref = refstr(bt);
274: fprintf(client,
275: "\t_n += sizeof_%s(%s%s);\n",
276: typename(t), ref, argname(p));
277: }
278: fprintf(client,
279: "\t_buf = Allocate(_n);\n"
280: );
281: }
282: fprintf(client,
283: "\t_bp = _buf;\n"
284: );
285: /*
286: * Generate code to externalize the arguments.
287: */
288: for (p = type->type_args; p != NIL; p = cdr(p)) {
289: t = argtype(p);
290: ref = refstr(t);
291: fprintf(client, "\t_bp += %s(%s%s, _bp);\n",
292: xfn(EXTERNALIZE, t), ref, argname(p));
293: }
294: if (!variable_size) {
295: fprintf(client,
296: "\tSendCallMessage(_Connection, %d, %d, %s, %d, _buf);\n",
297: CurrentNumber, CurrentVersion,
298: proc_number, fixed_size);
299: } else {
300: fprintf(client,
301: "\tSendCallMessage(_Connection, %d, %d, %s, _n, _buf);\n",
302: CurrentNumber, CurrentVersion,
303: proc_number);
304: }
305: fprintf(client,
306: "\tDeallocate(_buf);\n\
307: \tMaybeCallBDTHandler(_Connection, _BDTprocptr);\n"
308: );
309: /*
310: * Generate code to receive the results and interpret them
311: * as errors
312: */
313: fprintf(client,
314: "\t_bp = ReceiveReturnMessage(_Connection, &_errorflag);\n\
315: \t_buf = _bp;\n\
316: \tif (_errorflag) {\n\
317: \t\t_bp += %s(&_errtype, _bp);\n\
318: \t\tswitch (ERROR_OFFSET+_errtype) {\n",
319: xfn(INTERNALIZE, Cardinal_type)
320: );
321: for (p = type->type_errors; p != NIL; p = cdr(p)) {
322: struct constant *errconst;
323: struct type *errtype;
324: errconst = (check_def((char *)car(p),CurrentProgram))->o_constant;
325: errtype = (struct type *) cdr(errconst->cn_list);
326: if (errtype == TNIL)
327: fprintf(client,
328: "\t\tcase %s:\n\
329: \t\t\traise(ERROR_OFFSET+_errtype, 0);\n\
330: \t\t\t/*NOTREACHED*/\n",
331: errconst->cn_name);
332: else
333: fprintf(client,
334: "\t\tcase %s: {\n\
335: \t\t\tstatic %s _result;\n\
336: \t\t\t_bp += %s(%s_result, _bp);\n\
337: \t\t\traise(ERROR_OFFSET+_errtype, (char *) &_result);\n\
338: \t\t\t/*NOTREACHED*/\n\
339: \t\t\t}\n",
340: errconst->cn_name,
341: typename(errtype),
342: xfn(INTERNALIZE, errtype), refstr(errtype)
343: );
344: }
345: fprintf(client,
346: "\t\tdefault:\n\
347: \t\t\t/* don't know how to unpack this */\n\
348: \t\t\traise(ERROR_OFFSET+_errtype, 0);\n\
349: \t\t\t/*NOTREACHED*/\n\
350: \t\t}\n"
351: );
352: /*
353: * Code to unpack results and return
354: */
355: if (nresults)
356: fprintf(client,
357: "\t} else\n\
358: \t\t_bp += %s(%s%s, _bp);\n\
359: \tDeallocate(_buf);\n\
360: \treturn (%s);\n\
361: }\n",
362: xfn(INTERNALIZE, result_type),
363: refstr(result_type), result_name, result_name);
364: else
365: fprintf(client,
366: "\t}\n\
367: \tDeallocate(_buf);\n\
368: }\n");
369: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.