Return to procedures.c CVS log

Up to [CSRG BSD Unix] / 43BSDTahoe / new / xns / compiler

Annotation of 43BSDTahoe/new/xns/compiler/procedures.c, revision 1.1

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

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.