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: }
Defined functions
define_procedure_constant
defined in line 41; used 1 times
Defined variables
Defined macros
|
Last modified: 1986-03-13
Generated: 2016-12-26 |
Generated by src2html V0.67
page hit count: 1918 |
|