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

proc_functions defined in line 125; used 1 times

Defined variables

RCSid defined in line 2; never used

Defined macros

argname defined in line 29; used 7 times
argtype defined in line 30; used 9 times
Last modified: 1986-03-13
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 1430
Valid CSS Valid XHTML 1.0 Strict