Return to procedures.c CVS log

Up to [CSRG BSD Unix] / 43BSD / contrib / xns / compiler

Annotation of 43BSD/contrib/xns/compiler/procedures.c, revision 1.1

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.