summaryrefslogtreecommitdiff
path: root/src/iconc/codegen.c
diff options
context:
space:
mode:
Diffstat (limited to 'src/iconc/codegen.c')
-rw-r--r--src/iconc/codegen.c1918
1 files changed, 1918 insertions, 0 deletions
diff --git a/src/iconc/codegen.c b/src/iconc/codegen.c
new file mode 100644
index 0000000..8ca5bd1
--- /dev/null
+++ b/src/iconc/codegen.c
@@ -0,0 +1,1918 @@
+/*
+ * codegen.c - routines to write out C code.
+ */
+#include "../h/gsupport.h"
+#include "ctrans.h"
+#include "cglobals.h"
+#include "csym.h"
+#include "ccode.h"
+#include "ctree.h"
+#include "cproto.h"
+
+#ifndef LoopThreshold
+#define LoopThreshold 7
+#endif /* LoopThreshold */
+
+/*
+ * MinOne - arrays sizes must be at least 1.
+ */
+#define MinOne(n) ((n) > 0 ? (n) : 1)
+
+/*
+ * ChkSeqNum - make sure a label has been given a sequence number.
+ */
+#define ChkSeqNum(x) if ((x)->SeqNum == 0) (x)->SeqNum = ++lbl_seq_num
+
+/*
+ * ChkBound - for a given procedure, signals that transfer control to a
+ * bounding label all use the same signal number.
+ */
+#define ChkBound(x) (((x)->LabFlg & Bounding) ? bound_sig : (x))
+
+/*
+ * When a switch statement for signal handling is optimized, there
+ * are three possible forms of default clauses.
+ */
+#define DfltNone 0 /* no default clause */
+#define DfltBrk 1 /* default is just a break */
+#define DfltRetSig 2 /* default is to return the signal from the call */
+
+/*
+ * Prototypes for static functions.
+ */
+static int arg_nms (struct lentry *lptr, int prt);
+static void bi_proc (char *name, struct implement *ip);
+static void chkforgn (int outer);
+static int dyn_nms (struct lentry *lptr, int prt);
+static void fldnames (struct fldname *fields);
+static void fnc_blk (struct gentry *gptr);
+static void frame (int outer);
+static void good_clsg (struct code *call, int outer);
+static void initpblk (FILE *f, int c, char *prefix, char *name,
+ int nquals, int nparam, int ndynam, int nstatic,
+ int frststat);
+static char *is_builtin (struct gentry *gptr);
+static void proc_blk (struct gentry *gptr, int init_glbl);
+static void prt_ary (struct code *cd, int outer);
+static void prt_cond (struct code *cond);
+static void prt_cont (struct c_fnc *cont);
+static void prt_var (struct lentry *var, int outer);
+static void prtcall (struct code *call, int outer);
+static void prtcode (struct code *cd, int outer);
+static void prtpccall (int outer);
+static void rec_blk (struct gentry *gptr, int init_glbl);
+static void smpl_clsg (struct code *call, int outer);
+static void stat_nms (struct lentry *lptr, int prt);
+static void val_loc (struct val_loc *rslt, int outer);
+
+static int n_stat = -1; /* number of static variables */
+
+/*
+ * var_dcls - produce declarations necessary to implement variables
+ * and to initialize globals and statics: procedure blocks, procedure
+ * frames, record blocks, declarations for globals and statics, the
+ * C main program.
+ */
+void var_dcls()
+ {
+ register int i;
+ register struct gentry *gptr;
+ struct gentry *gbl_main;
+ struct pentry *prc_main;
+ int n_glob = 0;
+ int flag;
+ int init_glbl;
+ int first;
+ char *pfx;
+
+ /*
+ * Output initialized array of descriptors for globals.
+ */
+ fprintf(codefile, "\nstatic struct {word dword; union block *vword;}");
+ fprintf(codefile, " init_globals[NGlobals] = {\n");
+ prc_main = NULL;
+ for (i = 0; i < GHSize; i++)
+ for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) {
+ flag = gptr->flag & ~(F_Global | F_StrInv);
+ if (strcmp(gptr->name, "main") == 0 && (gptr->flag & F_Proc)) {
+ /*
+ * Remember main procedure.
+ */
+ gbl_main = gptr;
+ prc_main = gbl_main->val.proc;
+ }
+ if (flag == 0) {
+ /*
+ * Ordinary variable.
+ */
+ gptr->index = n_glob++;
+ fprintf(codefile, " {D_Null},\n");
+ }
+ else {
+ /*
+ * Procedure, function, or record constructor. If the variable
+ * has not been optimized away, initialize the it to reference
+ * the procedure block.
+ */
+ if (flag & F_SmplInv) {
+ init_glbl = 0;
+ flag &= ~(uword)F_SmplInv;
+ }
+ else {
+ init_glbl = 1;
+ gptr->index = n_glob++;
+ fprintf(codefile, " {D_Proc, ");
+ }
+ switch (flag) {
+ case F_Proc:
+ proc_blk(gptr, init_glbl);
+ break;
+ case F_Builtin:
+ if (init_glbl)
+ fnc_blk(gptr);
+ break;
+ case F_Record:
+ rec_blk(gptr, init_glbl);
+ }
+ }
+ }
+ if (n_glob == 0)
+ fprintf(codefile, " {D_Null} /* place holder */\n");
+ fprintf(codefile, " };\n");
+
+ if (prc_main == NULL) {
+ nfatal(NULL, "main procedure missing", NULL);
+ return;
+ }
+
+ /*
+ * Output array of descriptors initialized to the names of the
+ * global variables that have not been optimized away.
+ */
+ if (n_glob == 0)
+ fprintf(codefile, "\nstruct sdescrip init_gnames[1];\n");
+ else {
+ fprintf(codefile, "\nstruct sdescrip init_gnames[NGlobals] = {\n");
+ for (i = 0; i < GHSize; i++)
+ for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink)
+ if (!(gptr->flag & F_SmplInv))
+ fprintf(codefile, " {%d, \"%s\"},\n", strlen(gptr->name),
+ gptr->name);
+ fprintf(codefile, " };\n");
+ }
+
+ /*
+ * Output array of pointers to builtin functions that correspond to
+ * names of the global variables.
+ */
+ if (n_glob == 0)
+ fprintf(codefile, "\nstruct b_proc *builtins[1];\n");
+ else {
+ fprintf(codefile, "\nstruct b_proc *builtins[NGlobals] = {\n");
+ for (i = 0; i < GHSize; i++)
+ for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink)
+ if (!(gptr->flag & F_SmplInv)) {
+ /*
+ * Need to output *something* to stay in step with other arrays.
+ */
+ if (pfx = is_builtin(gptr)) {
+ fprintf(codefile, " (struct b_proc *)&BF%c%c_%s,\n",
+ pfx[0], pfx[1], gptr->name);
+ }
+ else
+ fprintf(codefile, " 0,\n");
+ }
+ fprintf(codefile, " };\n");
+ }
+
+ /*
+ * Output C main function that initializes the run-time system and
+ * calls the main procedure.
+ */
+ fprintf(codefile, "\n");
+ fprintf(codefile, "int main(argc, argv)\n");
+ fprintf(codefile, "int argc;\n");
+ fprintf(codefile, "char **argv;\n");
+ fprintf(codefile, " {\n");
+
+ /*
+ * If the main procedure requires a command-line argument list, we
+ * need a place to construct the Icon argument list.
+ */
+ if (prc_main->nargs != 0 || !(gbl_main->flag & F_SmplInv)) {
+ fprintf(codefile, " struct {\n");
+ fprintf(codefile, " struct tend_desc *previous;\n");
+ fprintf(codefile, " int num;\n");
+ fprintf(codefile, " struct descrip arg_lst;\n");
+ fprintf(codefile, " } t;\n");
+ fprintf(codefile, "\n");
+ }
+
+ /*
+ * Produce code to initialize run-time system variables. Some depend
+ * on compiler options.
+ */
+ fprintf(codefile, " op_tbl = (struct b_proc *)init_op_tbl;\n");
+ fprintf(codefile, " globals = (dptr)init_globals;\n");
+ fprintf(codefile, " eglobals = &globals[%d];\n", n_glob);
+ fprintf(codefile, " gnames = (dptr)init_gnames;\n");
+ fprintf(codefile, " egnames = &gnames[%d];\n", n_glob);
+ fprintf(codefile, " estatics = &statics[%d];\n", n_stat + 1);
+ if (debug_info)
+ fprintf(codefile, " debug_info = 1;\n");
+ else
+ fprintf(codefile, " debug_info = 0;\n");
+ if (line_info) {
+ fprintf(codefile, " line_info = 1;\n");
+ fprintf(codefile, " file_name = \"\";\n");
+ fprintf(codefile, " line_num = 0;\n");
+ }
+ else
+ fprintf(codefile, " line_info = 0;\n");
+ if (err_conv)
+ fprintf(codefile, " err_conv = 1;\n");
+ else
+ fprintf(codefile, " err_conv = 0;\n");
+ if (largeints)
+ fprintf(codefile, " largeints = 1;\n");
+ else
+ fprintf(codefile, " largeints = 0;\n");
+
+ /*
+ * Produce code to call the routine to initialize the runtime system.
+ */
+ if (trace)
+ fprintf(codefile, " init(*argv, &argc, argv, -1);\n");
+ else
+ fprintf(codefile, " init(*argv, &argc, argv, 0);\n");
+ fprintf(codefile, "\n");
+
+ /*
+ * If the main procedure requires an argument list (perhaps because
+ * it uses standard, rather than tailored calling conventions),
+ * set up the argument list.
+ */
+ if (prc_main->nargs != 0 || !(gbl_main->flag & F_SmplInv)) {
+ fprintf(codefile, " t.arg_lst = nulldesc;\n");
+ fprintf(codefile, " t.num = 1;\n");
+ fprintf(codefile, " t.previous = NULL;\n");
+ fprintf(codefile, " tend = (struct tend_desc *)&t;\n");
+ if (prc_main->nargs == 0)
+ fprintf(codefile,
+ " /* main() takes no arguments: construct no list */\n");
+ else
+ fprintf(codefile, " cmd_line(argc, argv, &t.arg_lst);\n");
+ fprintf(codefile, "\n");
+ }
+ else
+ fprintf(codefile, " tend = NULL;\n");
+
+ if (gbl_main->flag & F_SmplInv) {
+ /*
+ * procedure main only has a simplified implementation if it
+ * takes either 0 or 1 argument.
+ */
+ first = 1;
+ if (prc_main->nargs == 0)
+ fprintf(codefile, " P%s_main(", prc_main->prefix);
+ else {
+ fprintf(codefile, " P%s_main(&t.arg_lst", prc_main->prefix);
+ first = 0;
+ }
+ if (prc_main->ret_flag & (DoesRet | DoesSusp)) {
+ if (!first)
+ fprintf(codefile, ", ");
+ fprintf(codefile, "&trashcan");
+ first = 0;
+ }
+ if (prc_main->ret_flag & DoesSusp)
+ fprintf(codefile, ", (continuation)NULL");
+ fprintf(codefile, ");\n");
+ }
+ else /* the main procedure uses standard calling conventions */
+ fprintf(codefile,
+ " P%s_main(1, &t.arg_lst, &trashcan, (continuation)NULL);\n",
+ prc_main->prefix);
+ fprintf(codefile, " \n");
+ fprintf(codefile, " c_exit(EXIT_SUCCESS);\n");
+ fprintf(codefile, " }\n");
+
+ /*
+ * Output to header file definitions related to global and static
+ * variables.
+ */
+ fprintf(inclfile, "\n");
+ if (n_glob == 0) {
+ fprintf(inclfile, "#define NGlobals 1\n");
+ fprintf(inclfile, "int n_globals = 0;\n");
+ }
+ else {
+ fprintf(inclfile, "#define NGlobals %d\n", n_glob);
+ fprintf(inclfile, "int n_globals = NGlobals;\n");
+ }
+ ++n_stat;
+ fprintf(inclfile, "\n");
+ fprintf(inclfile, "int n_statics = %d;\n", n_stat);
+ fprintf(inclfile, "struct descrip statics[%d]", MinOne(n_stat));
+ if (n_stat > 0) {
+ fprintf(inclfile, " = {\n");
+ for (i = 0; i < n_stat; ++i)
+ fprintf(inclfile, " {D_Null},\n");
+ fprintf(inclfile, " };\n");
+ }
+ else
+ fprintf(inclfile, ";\n");
+ }
+
+/*
+ * proc_blk - create procedure block and initialize global variable, also
+ * compute offsets for local procedure variables.
+ */
+static void proc_blk(gptr, init_glbl)
+struct gentry *gptr;
+int init_glbl;
+ {
+ struct pentry *p;
+ register char *name;
+ int nquals;
+
+ name = gptr->name;
+ p = gptr->val.proc;
+
+ /*
+ * If we don't initialize a global variable for this procedure, we
+ * need only compute offsets for variables.
+ */
+ if (init_glbl) {
+ fprintf(codefile, "(union block *)&BP%s_%s},\n", p->prefix, name);
+ nquals = 1 + Abs(p->nargs) + p->ndynam + p->nstatic;
+ fprintf(inclfile, "\n");
+ fprintf(inclfile, "static int P%s_%s (int r_nargs, dptr r_args,",
+ p->prefix, name);
+ fprintf(inclfile, "dptr r_rslt, continuation r_s_cont);\n");
+ initpblk(inclfile, 'P', p->prefix, name, nquals, p->nargs, p->ndynam,
+ p->nstatic, n_stat + 1);
+ fprintf(inclfile, "\n {%d, \"%s\"},\n", strlen(name), name);
+ }
+ arg_nms(p->args, init_glbl);
+ p->tnd_loc = dyn_nms(p->dynams, init_glbl);
+ stat_nms(p->statics, init_glbl);
+ if (init_glbl)
+ fprintf(inclfile, " }};\n");
+ }
+
+/*
+ * arg_nms - compute offsets of arguments and, if needed, output the
+ * initializer for a descriptor for the argument name.
+ */
+static int arg_nms(lptr, prt)
+struct lentry *lptr;
+int prt;
+ {
+ register int n;
+
+ if (lptr == NULL)
+ return 0;
+ n = arg_nms(lptr->next, prt);
+ lptr->val.index = n;
+ if (prt)
+ fprintf(inclfile, " {%d, \"%s\"},\n", strlen(lptr->name), lptr->name);
+ return n + 1;
+ }
+
+/*
+ * dyn_nms - compute offsets of dynamic locals and, if needed, output the
+ * initializer for a descriptor for the variable name.
+ */
+static int dyn_nms(lptr, prt)
+struct lentry *lptr;
+int prt;
+ {
+ register int n;
+
+ if (lptr == NULL)
+ return 0;
+ n = dyn_nms(lptr->next, prt);
+ lptr->val.index = n;
+ if (prt)
+ fprintf(inclfile, " {%d, \"%s\"},\n", strlen(lptr->name), lptr->name);
+ return n + 1;
+ }
+
+/*
+ * stat_nams - compute offsets of static locals and, if needed, output the
+ * initializer for a descriptor for the variable name.
+ */
+static void stat_nms(lptr, prt)
+struct lentry *lptr;
+int prt;
+ {
+ if (lptr == NULL)
+ return;
+ stat_nms(lptr->next, prt);
+ lptr->val.index = ++n_stat;
+ if (prt)
+ fprintf(inclfile, " {%d, \"%s\"},\n", strlen(lptr->name), lptr->name);
+ }
+
+/*
+ * is_builtin - check if a global names or hides a builtin, returning prefix.
+ * If it hides one, we must also generate the prototype and block here.
+ */
+static char *is_builtin(gptr)
+struct gentry *gptr;
+ {
+ struct implement *iptr;
+
+ if (!(gptr->flag & F_StrInv)) /* if not eligible for string invoc */
+ return 0;
+ if (gptr->flag & F_Builtin) /* if global *is* a builtin */
+ return gptr->val.builtin->prefix;
+ iptr = db_ilkup(gptr->name, bhash);
+ if (iptr == NULL) /* if no builtin by this name */
+ return NULL;
+ bi_proc(gptr->name, iptr); /* output prototype and proc block */
+ return iptr->prefix;
+ }
+
+/*
+ * fnc_blk - output vword of descriptor for a built-in function and its
+ * procedure block.
+ */
+static void fnc_blk(gptr)
+struct gentry *gptr;
+ {
+ struct implement *iptr;
+ char *name, *pfx;
+
+ name = gptr->name;
+ iptr = gptr->val.builtin;
+ pfx = iptr->prefix;
+ /*
+ * output prototype and procedure block to inclfile.
+ */
+ bi_proc(name, iptr);
+ /*
+ * vword of descriptor references the procedure block.
+ */
+ fprintf(codefile, "(union block *)&BF%c%c_%s}, \n", pfx[0], pfx[1], name);
+ }
+
+/*
+ * bi_proc - output prototype and procedure block for builtin function.
+ */
+static void bi_proc(name, ip)
+char *name;
+ struct implement *ip;
+ {
+ int nargs;
+ char prefix[3];
+
+ prefix[0] = ip->prefix[0];
+ prefix[1] = ip->prefix[1];
+ prefix[2] = '\0';
+ nargs = ip->nargs;
+ if (nargs > 0 && ip->arg_flgs[nargs - 1] & VarPrm)
+ nargs = -nargs;
+ fprintf(inclfile, "\n");
+ implproto(ip);
+ initpblk(inclfile, 'F', prefix, name, 1, nargs, -1, 0, 0);
+ fprintf(inclfile, "{%d, \"%s\"}}};\n", strlen(name), name);
+ }
+
+/*
+ * rec_blk - if needed, output vword of descriptor for a record
+ * constructor and output its procedure block.
+ */
+static void rec_blk(gptr, init_glbl)
+struct gentry *gptr;
+int init_glbl;
+ {
+ struct rentry *r;
+ register char *name;
+ int nfields;
+
+ name = gptr->name;
+ r = gptr->val.rec;
+ nfields = r->nfields;
+
+ /*
+ * If the variable is not optimized away, output vword of descriptor.
+ */
+ if (init_glbl)
+ fprintf(codefile, "(union block *)&BR%s_%s},\n", r->prefix, name);
+
+ fprintf(inclfile, "\n");
+ /*
+ * Prototype for C function implementing constructor. If no optimizations
+ * have been performed on the variable, the standard calling conventions
+ * are used and we need a continuation parameter.
+ */
+ fprintf(inclfile,
+ "static int R%s_%s (int r_nargs, dptr r_args, dptr r_rslt",
+ r->prefix, name);
+ if (init_glbl)
+ fprintf(inclfile, ", continuation r_s_cont");
+ fprintf(inclfile, ");\n");
+
+ /*
+ * Procedure block, including record name and field names.
+ */
+ initpblk(inclfile, 'R', r->prefix, name, nfields + 1, nfields, -2,
+ r->rec_num, 1);
+ fprintf(inclfile, "\n {%d, \"%s\"},\n", strlen(name), name);
+ fldnames(r->fields);
+ fprintf(inclfile, " }};\n");
+ }
+
+
+/*
+ * fldnames - output the initializer for a descriptor for the field name.
+ */
+static void fldnames(fields)
+struct fldname *fields;
+ {
+ register char *name;
+
+ if (fields == NULL)
+ return;
+ fldnames(fields->next);
+ name = fields->name;
+ fprintf(inclfile, " {%d, \"%s\"},\n", strlen(name), name);
+ }
+
+/*
+ * implproto - print prototype for function implementing a run-time operation.
+ */
+void implproto(ip)
+struct implement *ip;
+ {
+ if (ip->iconc_flgs & ProtoPrint)
+ return; /* only print prototype once */
+ fprintf(inclfile, "int %c%c%c_%s ", ip->oper_typ, ip->prefix[0],
+ ip->prefix[1], ip->name);
+ fprintf(inclfile, "(int r_nargs, dptr r_args, dptr r_rslt, ");
+ fprintf(inclfile,"continuation r_s_cont);\n");
+ ip->iconc_flgs |= ProtoPrint;
+ }
+
+/*
+ * const_blks - output blocks for cset and real constants.
+ */
+void const_blks()
+ {
+ register int i;
+ register struct centry *cptr;
+
+ fprintf(inclfile, "\n");
+ for (i = 0; i < CHSize; i++)
+ for (cptr = chash[i]; cptr != NULL; cptr = cptr->blink) {
+ switch (cptr->flag) {
+ case F_CsetLit:
+ nxt_pre(cptr->prefix, pre, PrfxSz);
+ cptr->prefix[PrfxSz] = '\0';
+ fprintf(inclfile, "struct b_cset BDC%s = ", cptr->prefix);
+ cset_init(inclfile, cptr->u.cset);
+ break;
+ case F_RealLit:
+ nxt_pre(cptr->prefix, pre, PrfxSz);
+ cptr->prefix[PrfxSz] = '\0';
+ fprintf(inclfile, "struct b_real BDR%s = {T_Real, %s};\n",
+ cptr->prefix, cptr->image);
+ break;
+ }
+ }
+ }
+
+/*
+ * reccnstr - output record constructors.
+ */
+void recconstr(r)
+struct rentry *r;
+ {
+ register char *name;
+ int optim;
+ int nfields;
+
+ if (r == NULL)
+ return;
+ recconstr(r->next);
+
+ name = r->name;
+ nfields = r->nfields;
+
+ /*
+ * Does this record constructor use optimized calling conventions?
+ */
+ optim = glookup(name)->flag & F_SmplInv;
+
+ fprintf(codefile, "\n");
+ fprintf(codefile, "static int R%s_%s(r_nargs, r_args, r_rslt", r->prefix,
+ name);
+ if (!optim)
+ fprintf(codefile, ", r_s_cont"); /* continuation is passed */
+ fprintf(codefile, ")\n");
+ fprintf(codefile, "int r_nargs;\n");
+ fprintf(codefile, "dptr r_args;\n");
+ fprintf(codefile, "dptr r_rslt;\n");
+ if (!optim)
+ fprintf(codefile, "continuation r_s_cont;\n");
+ fprintf(codefile, " {\n");
+ fprintf(codefile, " register int i;\n");
+ fprintf(codefile, " register struct b_record *rp;\n");
+ fprintf(codefile, "\n");
+ fprintf(codefile, " rp = alcrecd(%d, (union block *)&BR%s_%s);\n",
+ nfields, r->prefix, name);
+ fprintf(codefile, " if (rp == NULL) {\n");
+ fprintf(codefile, " err_msg(307, NULL);\n");
+ if (err_conv)
+ fprintf(codefile, " return A_Resume;\n");
+ fprintf(codefile, " }\n");
+ fprintf(codefile, " for (i = %d; i >= 0; i--)\n", nfields - 1);
+ fprintf(codefile, " if (i < r_nargs)\n");
+ fprintf(codefile, " deref(&r_args[i], &rp->fields[i]);\n");
+ fprintf(codefile, " else\n");
+ fprintf(codefile, " rp->fields[i] = nulldesc;\n");
+ fprintf(codefile, " r_rslt->vword.bptr = (union block *)rp;\n");
+ fprintf(codefile, " r_rslt->dword = D_Record;\n");
+ fprintf(codefile, " return A_Continue;\n");
+ fprintf(codefile, " }\n");
+ }
+
+/*
+ * outerfnc - output code for the outer function implementing a procedure.
+ */
+void outerfnc(fnc)
+struct c_fnc *fnc;
+ {
+ char *prefix;
+ char *name;
+ char *cnt_var;
+ char *sep;
+ int ntend;
+ int first_arg;
+ int nparms;
+ int optim; /* optimized interface: no arg list adjustment */
+ int ret_flag;
+#ifdef OptimizeLoop
+ int i;
+#endif /* OptimizeLoop */
+
+ prefix = cur_proc->prefix;
+ name = cur_proc->name;
+ ntend = cur_proc->tnd_loc + num_tmp;
+ ChkPrefix(fnc->prefix);
+ optim = glookup(name)->flag & F_SmplInv;
+ nparms = Abs(cur_proc->nargs);
+ ret_flag = cur_proc->ret_flag;
+
+ fprintf(codefile, "\n");
+ if (optim) {
+ /*
+ * Arg list adjustment and dereferencing are done at call site.
+ * Use simplified interface. Output both function header and
+ * prototype.
+ */
+ sep = "";
+ fprintf(inclfile, "static int P%s_%s (", prefix, name);
+ fprintf(codefile, "static int P%s_%s(", prefix, name);
+ if (nparms != 0) {
+ fprintf(inclfile, "dptr r_args");
+ fprintf(codefile, "r_args");
+ sep = ", ";
+ }
+ if (ret_flag & (DoesRet | DoesSusp)) {
+ fprintf(inclfile, "%sdptr r_rslt", sep);
+ fprintf(codefile, "%sr_rslt", sep);
+ sep = ", ";
+ }
+ if (ret_flag & DoesSusp) {
+ fprintf(inclfile, "%scontinuation r_s_cont", sep);
+ fprintf(codefile, "%sr_s_cont", sep);
+ sep = ", ";
+ }
+ if (*sep == '\0')
+ fprintf(inclfile, "void");
+ fprintf(inclfile, ");\n");
+ fprintf(codefile, ")\n");
+ if (nparms != 0)
+ fprintf(codefile, "dptr r_args;\n");
+ if (ret_flag & (DoesRet | DoesSusp))
+ fprintf(codefile, "dptr r_rslt;\n");
+ if (ret_flag & DoesSusp)
+ fprintf(codefile, "continuation r_s_cont;\n");
+ }
+ else {
+ /*
+ * General invocation interface. Output function header; prototype has
+ * already been produced.
+ */
+ fprintf(codefile,
+ "static int P%s_%s(r_nargs, r_args, r_rslt, r_s_cont)\n", prefix,
+ name);
+ fprintf(codefile, "int r_nargs;\n");
+ fprintf(codefile, "dptr r_args;\n");
+ fprintf(codefile, "dptr r_rslt;\n");
+ fprintf(codefile, "continuation r_s_cont;\n");
+ }
+
+ fprintf(codefile, "{\n");
+ fprintf(codefile, " struct PF%s_%s r_frame;\n", prefix, name);
+ fprintf(codefile, " register int r_signal;\n");
+ fprintf(codefile, " int i;\n");
+ if (Type(Tree1(cur_proc->tree)) != N_Empty)
+ fprintf(codefile, " static int first_time = 1;");
+ fprintf(codefile, "\n");
+ fprintf(codefile, " r_frame.old_pfp = pfp;\n");
+ fprintf(codefile, " pfp = (struct p_frame *)&r_frame;\n");
+ fprintf(codefile, " r_frame.old_argp = glbl_argp;\n");
+ if (!optim || ret_flag & (DoesRet | DoesSusp))
+ fprintf(codefile, " r_frame.rslt = r_rslt;\n");
+ else
+ fprintf(codefile, " r_frame.rslt = NULL;\n");
+ if (!optim || ret_flag & DoesSusp)
+ fprintf(codefile, " r_frame.succ_cont = r_s_cont;\n");
+ else
+ fprintf(codefile, " r_frame.succ_cont = NULL;\n");
+ fprintf(codefile, "\n");
+#ifdef OptimizeLoop
+ if (ntend > 0) {
+ if (ntend < LoopThreshold)
+ for (i=0; i < ntend ;i++)
+ fprintf(codefile, " r_frame.tend.d[%d] = nulldesc;\n", i);
+ else {
+ fprintf(codefile, " for (i = 0; i < %d; ++i)\n", ntend);
+ fprintf(codefile, " r_frame.tend.d[i] = nulldesc;\n");
+ }
+ }
+#else /* OptimizeLoop */
+ fprintf(codefile, " for (i = 0; i < %d; ++i)\n", ntend);
+ fprintf(codefile, " r_frame.tend.d[i] = nulldesc;\n");
+#endif /* OptimizeLoop */
+ if (optim) {
+ /*
+ * Dereferencing and argument list adjustment is done at the call
+ * site. There is not much to do here.
+ */
+ if (nparms == 0)
+ fprintf(codefile, " glbl_argp = NULL;\n");
+ else
+ fprintf(codefile, " glbl_argp = r_args;\n");
+ }
+ else {
+ /*
+ * Dereferencing and argument list adjustment must be done by
+ * the procedure itself.
+ */
+ first_arg = ntend;
+ ntend += nparms;
+ if (cur_proc->nargs < 0) {
+ /*
+ * varargs - construct a list into the last argument.
+ */
+ nparms -= 1;
+ if (nparms == 0)
+ cnt_var = "r_nargs";
+ else {
+ fprintf(codefile, " i = r_nargs - %d;\n", nparms);
+ cnt_var = "i";
+ }
+ fprintf(codefile," if (%s <= 0)\n", cnt_var);
+ fprintf(codefile," varargs(NULL, 0, &r_frame.tend.d[%d]);\n",
+ first_arg + nparms);
+ fprintf(codefile," else\n");
+ fprintf(codefile,
+ " varargs(&r_args[%d], %s, &r_frame.tend.d[%d]);\n", nparms,
+ cnt_var, first_arg + nparms);
+ }
+ if (nparms > 0) {
+ /*
+ * Output code to dereference argument or supply default null
+ * value.
+ */
+#ifdef OptimizeLoop
+ fprintf(codefile, " for (i = 0; i < r_nargs ; ++i)\n");
+ fprintf(codefile, " deref(&r_args[i], &r_frame.tend.d[i + %d]);\n", first_arg);
+ fprintf(codefile, " for(i = r_nargs; i < %d ; ++i)\n", nparms);
+ fprintf(codefile, " r_frame.tend.d[i + %d] = nulldesc;\n",
+ first_arg);
+#else /* OptimizeLoop */
+ fprintf(codefile, " for (i = 0; i < %d; ++i)\n", nparms);
+ fprintf(codefile, " if (i < r_nargs)\n");
+ fprintf(codefile,
+ " deref(&r_args[i], &r_frame.tend.d[i + %d]);\n",
+ first_arg);
+ fprintf(codefile, " else\n");
+ fprintf(codefile, " r_frame.tend.d[i + %d] = nulldesc;\n",
+ first_arg);
+#endif /* OptimizeLoop */
+ }
+ fprintf(codefile, " glbl_argp = &r_frame.tend.d[%d];\n", first_arg);
+ }
+ fprintf(codefile, " r_frame.tend.num = %d;\n", ntend);
+ fprintf(codefile, " r_frame.tend.previous = tend;\n");
+ fprintf(codefile, " tend = (struct tend_desc *)&r_frame.tend;\n");
+ if (line_info) {
+ fprintf(codefile, " r_frame.debug.old_line = line_num;\n");
+ fprintf(codefile, " r_frame.debug.old_fname = file_name;\n");
+ }
+ if (debug_info) {
+ fprintf(codefile, " r_frame.debug.proc = (struct b_proc *)&BP%s_%s;\n",
+ prefix, name);
+ fprintf(codefile, " if (k_trace) ctrace();\n");
+ fprintf(codefile, " ++k_level;\n\n");
+ }
+ fprintf(codefile, "\n");
+
+ /*
+ * Output definition for procedure frame.
+ */
+ prt_frame(prefix, ntend, num_itmp, num_dtmp, num_sbuf, num_cbuf);
+
+ /*
+ * Output code to implement procedure body.
+ */
+ prtcode(&(fnc->cd), 1);
+ fprintf(codefile, " }\n");
+ }
+
+/*
+ * prt_fnc - output C function that implements a continuation.
+ */
+void prt_fnc(fnc)
+struct c_fnc *fnc;
+ {
+ struct code *sig;
+ char *name;
+ char *prefix;
+
+ if (fnc->flag & CF_SigOnly) {
+ /*
+ * This function only returns a signal. A shared function is used in
+ * its place. Make sure that function has been printed.
+ */
+ sig = fnc->cd.next->SigRef->sig;
+ if (sig->cd_id != C_Resume) {
+ sig = ChkBound(sig);
+ if (!(sig->LabFlg & FncPrtd)) {
+ ChkSeqNum(sig);
+ fprintf(inclfile, "static int sig_%d (void);\n",
+ sig->SeqNum);
+
+ fprintf(codefile, "\n");
+ fprintf(codefile, "static int sig_%d()\n", sig->SeqNum);
+ fprintf(codefile, " {\n");
+ fprintf(codefile, " return %d; /* %s */\n", sig->SeqNum,
+ sig->Desc);
+ fprintf(codefile, " }\n");
+ sig->LabFlg |= FncPrtd;
+ }
+ }
+ }
+ else {
+ ChkPrefix(fnc->prefix);
+ prefix = fnc->prefix;
+ name = cur_proc->name;
+
+ fprintf(inclfile, "static int P%s_%s (void);\n", prefix, name);
+
+ fprintf(codefile, "\n");
+ fprintf(codefile, "static int P%s_%s()\n", prefix, name);
+ fprintf(codefile, " {\n");
+ if (fnc->flag & CF_Coexpr)
+ fprintf(codefile, "#ifdef Coexpr\n");
+
+ prefix = fnc->frm_prfx;
+
+ fprintf(codefile, " register int r_signal;\n");
+ fprintf(codefile, " register struct PF%s_%s *r_pfp;\n", prefix, name);
+ fprintf(codefile, "\n");
+ fprintf(codefile, " r_pfp = (struct PF%s_%s *)pfp;\n", prefix, name);
+ prtcode(&(fnc->cd), 0);
+ if (fnc->flag & CF_Coexpr) {
+ fprintf(codefile, "#else\t\t\t\t\t/* Coexpr */\n");
+ fprintf(codefile, " fatalerr(401, NULL);\n");
+ fprintf(codefile, "#endif\t\t\t\t\t/* Coexpr */\n");
+ }
+ fprintf(codefile, " }\n");
+ }
+ }
+
+/*
+ * prt_frame - output the definition for a procedure frame.
+ */
+void prt_frame(prefix, ntend, n_itmp, n_dtmp, n_sbuf, n_cbuf)
+char *prefix;
+int ntend;
+int n_itmp;
+int n_dtmp;
+int n_sbuf;
+int n_cbuf;
+ {
+ int i;
+
+ /*
+ * Output standard part of procedure frame including tended
+ * descriptors.
+ */
+ fprintf(inclfile, "\n");
+ fprintf(inclfile, "struct PF%s_%s {\n", prefix, cur_proc->name);
+ fprintf(inclfile, " struct p_frame *old_pfp;\n");
+ fprintf(inclfile, " dptr old_argp;\n");
+ fprintf(inclfile, " dptr rslt;\n");
+ fprintf(inclfile, " continuation succ_cont;\n");
+ fprintf(inclfile, " struct {\n");
+ fprintf(inclfile, " struct tend_desc *previous;\n");
+ fprintf(inclfile, " int num;\n");
+ fprintf(inclfile, " struct descrip d[%d];\n", MinOne(ntend));
+ fprintf(inclfile, " } tend;\n");
+
+ if (line_info) { /* must be true if debug_info is true */
+ fprintf(inclfile, " struct debug debug;\n");
+ }
+
+ /*
+ * Output declarations for the integer, double, string buffer,
+ * and cset buffer work areas of the frame.
+ */
+ for (i = 0; i < n_itmp; ++i)
+ fprintf(inclfile, " word i%d;\n", i);
+ for (i = 0; i < n_dtmp; ++i)
+ fprintf(inclfile, " double d%d;\n", i);
+ if (n_sbuf > 0)
+ fprintf(inclfile, " char sbuf[%d][MaxCvtLen];", n_sbuf);
+ if (n_cbuf > 0)
+ fprintf(inclfile, " struct b_cset cbuf[%d];", n_cbuf);
+ fprintf(inclfile, " };\n");
+ }
+
+/*
+ * prtcode - print a list of C code.
+ */
+static void prtcode(cd, outer)
+struct code *cd;
+int outer;
+ {
+ struct lentry *var;
+ struct centry *lit;
+ struct code *sig;
+ int n;
+
+ for ( ; cd != NULL; cd = cd->next) {
+ switch (cd->cd_id) {
+ case C_Null:
+ break;
+
+ case C_NamedVar:
+ /*
+ * Construct a reference to a named variable in a result
+ * location.
+ */
+ var = cd->NamedVar;
+ fprintf(codefile, " ");
+ val_loc(cd->Rslt, outer);
+ fprintf(codefile, ".dword = D_Var;\n");
+ fprintf(codefile, " ");
+ val_loc(cd->Rslt, outer);
+ fprintf(codefile, ".vword.descptr = &");
+ prt_var(var, outer);
+ fprintf(codefile, ";\n");
+ break;
+
+ case C_CallSig:
+ /*
+ * Call to C function that returns a signal along with signal
+ * handling code.
+ */
+ if (opt_sgnl)
+ good_clsg(cd, outer);
+ else
+ smpl_clsg(cd, outer);
+ break;
+
+ case C_RetSig:
+ /*
+ * Return a signal.
+ */
+ sig = cd->SigRef->sig;
+ if (sig->cd_id == C_Resume)
+ fprintf(codefile, " return A_Resume;\n");
+ else {
+ sig = ChkBound(sig);
+ ChkSeqNum(sig);
+ fprintf(codefile, " return %d; /* %s */\n", sig->SeqNum,
+ sig->Desc);
+ }
+ break;
+
+ case C_Goto:
+ /*
+ * goto label.
+ */
+ ChkSeqNum(cd->Lbl);
+ fprintf(codefile, " goto L%d /* %s */;\n", cd->Lbl->SeqNum,
+ cd->Lbl->Desc);
+ break;
+
+ case C_Label:
+ /*
+ * numbered label.
+ */
+ if (cd->RefCnt > 0) {
+ ChkSeqNum(cd);
+ fprintf(codefile, "L%d: ; /* %s */\n", cd->SeqNum, cd->Desc);
+ }
+ break;
+
+ case C_Lit:
+ /*
+ * Assign literal value to a result location.
+ */
+ lit = cd->Literal;
+ fprintf(codefile, " ");
+ val_loc(cd->Rslt, outer);
+ switch (lit->flag) {
+ case F_CsetLit:
+ fprintf(codefile, ".dword = D_Cset;\n");
+ fprintf(codefile, " ");
+ val_loc(cd->Rslt, outer);
+ fprintf(codefile, ".vword.bptr = (union block *)&BDC%s;\n",
+ lit->prefix);
+ break;
+ case F_IntLit:
+ if (lit->u.intgr == -1) {
+ /*
+ * Large integer literal - output string and convert
+ * to integer.
+ */
+ fprintf(codefile, ".vword.sptr = \"%s\";\n", lit->image);
+ fprintf(codefile, " ");
+ val_loc(cd->Rslt, outer);
+ fprintf(codefile, ".dword = %d;\n", strlen(lit->image));
+ fprintf(codefile, " cnv_int(&");
+ val_loc(cd->Rslt, outer);
+ fprintf(codefile, ", &");
+ val_loc(cd->Rslt, outer);
+ fprintf(codefile, ");\n");
+ }
+ else {
+ /*
+ * Ordinary integer literal.
+ */
+ fprintf(codefile, ".dword = D_Integer;\n");
+ fprintf(codefile, " ");
+ val_loc(cd->Rslt, outer);
+ fprintf(codefile, ".vword.integr = %ld;\n", lit->u.intgr);
+ }
+ break;
+ case F_RealLit:
+ fprintf(codefile, ".dword = D_Real;\n");
+ fprintf(codefile, " ");
+ val_loc(cd->Rslt, outer);
+ fprintf(codefile, ".vword.bptr = (union block *)&BDR%s;\n",
+ lit->prefix);
+ break;
+ case F_StrLit:
+ fprintf(codefile, ".vword.sptr = ");
+ if (lit->length == 0) {
+ /*
+ * Placing an empty string at the end of the string region
+ * allows some concatenation optimizations at run time.
+ */
+ fprintf(codefile, "strfree;\n");
+ n = 0;
+ }
+ else {
+ fprintf(codefile, "\"");
+ n = prt_i_str(codefile, lit->image, lit->length);
+ fprintf(codefile, "\";\n");
+ }
+ fprintf(codefile, " ");
+ val_loc(cd->Rslt, outer);
+ fprintf(codefile, ".dword = %d;\n", n);
+ break;
+ }
+ break;
+
+ case C_PFail:
+ /*
+ * Procedure failure - this code occurs once near the end of
+ * the procedure.
+ */
+ if (debug_info) {
+ fprintf(codefile, " --k_level;\n");
+ fprintf(codefile, " if (k_trace) failtrace();\n");
+ }
+ fprintf(codefile, " tend = r_frame.tend.previous;\n");
+ fprintf(codefile, " pfp = r_frame.old_pfp;\n");
+ fprintf(codefile, " glbl_argp = r_frame.old_argp;\n");
+ if (line_info) {
+ fprintf(codefile, " line_num = r_frame.debug.old_line;\n");
+ fprintf(codefile, " file_name = r_frame.debug.old_fname;\n");
+ }
+ fprintf(codefile, " return A_Resume;\n");
+ break;
+
+ case C_PRet:
+ /*
+ * Procedure return - this code occurs once near the end of
+ * the procedure.
+ */
+ if (debug_info) {
+ fprintf(codefile, " --k_level;\n");
+ fprintf(codefile, " if (k_trace) rtrace();\n");
+ }
+ fprintf(codefile, " tend = r_frame.tend.previous;\n");
+ fprintf(codefile, " pfp = r_frame.old_pfp;\n");
+ fprintf(codefile, " glbl_argp = r_frame.old_argp;\n");
+ if (line_info) {
+ fprintf(codefile, " line_num = r_frame.debug.old_line;\n");
+ fprintf(codefile, " file_name = r_frame.debug.old_fname;\n");
+ }
+ fprintf(codefile, " return A_Continue;\n");
+ break;
+
+ case C_PSusp:
+ /*
+ * Procedure suspend - call success continuation.
+ */
+ prtpccall(outer);
+ break;
+
+ case C_Break:
+ fprintf(codefile, " break;\n");
+ break;
+
+ case C_If:
+ /*
+ * C if statement.
+ */
+ fprintf(codefile, " if (");
+ prt_ary(cd->Cond, outer);
+ fprintf(codefile, ")\n ");
+ prtcode(cd->ThenStmt, outer);
+ break;
+
+ case C_CdAry:
+ /*
+ * Array of code fragments.
+ */
+ fprintf(codefile, " ");
+ prt_ary(cd, outer);
+ fprintf(codefile, "\n");
+ break;
+
+ case C_LBrack:
+ fprintf(codefile, " {\n");
+ break;
+
+ case C_RBrack:
+ fprintf(codefile, " }\n");
+ break;
+
+ case C_Create:
+ /*
+ * Code to create a co-expression and assign it to a result
+ * location.
+ */
+ fprintf(codefile, " ");
+ val_loc(cd->Rslt, outer);
+ fprintf(codefile , ".vword.bptr = (union block *)create(");
+ prt_cont(cd->Cont);
+ fprintf(codefile,
+ ", (struct b_proc *)&BP%s_%s, %d, sizeof(word) * %d);\n",
+ cur_proc->prefix, cur_proc->name, cd->NTemps, cd->WrkSize);
+ fprintf(codefile, " ");
+ val_loc(cd->Rslt, outer);
+ fprintf(codefile, ".dword = D_Coexpr;\n");
+ break;
+
+ case C_SrcLoc:
+ /*
+ * Update file name and line number information.
+ */
+ if (cd->FileName != NULL) {
+ fprintf(codefile, " file_name = \"");
+ prt_i_str(codefile, cd->FileName, strlen(cd->FileName));
+ fprintf(codefile, "\";\n");
+ }
+ if (cd->LineNum != 0)
+ fprintf(codefile, " line_num = %d;\n", cd->LineNum);
+ break;
+ }
+ }
+ }
+
+/*
+ * prt_var - output C code to reference an Icon named variable.
+ */
+static void prt_var(var, outer)
+struct lentry *var;
+int outer;
+ {
+ switch (var->flag) {
+ case F_Global:
+ fprintf(codefile, "globals[%d]", var->val.global->index);
+ break;
+ case F_Static:
+ fprintf(codefile, "statics[%d]", var->val.index);
+ break;
+ case F_Dynamic:
+ frame(outer);
+ fprintf(codefile, ".tend.d[%d]", var->val.index);
+ break;
+ case F_Argument:
+ fprintf(codefile, "glbl_argp[%d]", var->val.index);
+ }
+
+ /*
+ * Include an identifying comment.
+ */
+ fprintf(codefile, " /* %s */", var->name);
+ }
+
+/*
+ * prt_ary - print an array of code fragments.
+ */
+static void prt_ary(cd, outer)
+struct code *cd;
+int outer;
+ {
+ int i;
+
+ for (i = 0; cd->ElemTyp(i) != A_End; ++i)
+ switch (cd->ElemTyp(i)) {
+ case A_Str:
+ /*
+ * Simple C code in a string.
+ */
+ fprintf(codefile, "%s", cd->Str(i));
+ break;
+ case A_ValLoc:
+ /*
+ * Value location (usually variable of some sort).
+ */
+ val_loc(cd->ValLoc(i), outer);
+ break;
+ case A_Intgr:
+ /*
+ * Integer.
+ */
+ fprintf(codefile, "%d", cd->Intgr(i));
+ break;
+ case A_ProcCont:
+ /*
+ * Current procedure call's success continuation.
+ */
+ if (outer)
+ fprintf(codefile, "r_s_cont");
+ else
+ fprintf(codefile, "r_pfp->succ_cont");
+ break;
+ case A_SBuf:
+ /*
+ * One of the string buffers.
+ */
+ frame(outer);
+ fprintf(codefile, ".sbuf[%d]", cd->Intgr(i));
+ break;
+ case A_CBuf:
+ /*
+ * One of the cset buffers.
+ */
+ fprintf(codefile, "&(");
+ frame(outer);
+ fprintf(codefile, ".cbuf[%d])", cd->Intgr(i));
+ break;
+ case A_Ary:
+ /*
+ * A subarray of code fragments.
+ */
+ prt_ary(cd->Array(i), outer);
+ break;
+ }
+ }
+
+/*
+ * frame - access to the procedure frame. Access directly from outer function,
+ * but access through r_pfp from a continuation.
+ */
+static void frame(outer)
+int outer;
+ {
+ if (outer)
+ fprintf(codefile, "r_frame");
+ else
+ fprintf(codefile, "(*r_pfp)");
+ }
+
+/*
+ * prtpccall - print procedure continuation call.
+ */
+static void prtpccall(outer)
+int outer;
+ {
+ int first_arg;
+ int optim; /* optimized interface: no arg list adjustment */
+
+ first_arg = cur_proc->tnd_loc + num_tmp;
+ optim = glookup(cur_proc->name)->flag & F_SmplInv;
+
+ /*
+ * The only signal to be handled in this procedure is
+ * resumption, the rest must be passed on.
+ */
+ if (cur_proc->nargs != 0 && optim && !outer) {
+ fprintf(codefile, " {\n");
+ fprintf(codefile, " dptr r_argp_sav;\n");
+ fprintf(codefile, "\n");
+ fprintf(codefile, " r_argp_sav = glbl_argp;\n");
+ }
+ if (debug_info) {
+ fprintf(codefile, " --k_level;\n");
+ fprintf(codefile, " if (k_trace) strace();\n");
+ }
+ fprintf(codefile, " pfp = ");
+ frame(outer);
+ fprintf(codefile, ".old_pfp;\n");
+ fprintf(codefile, " glbl_argp = ");
+ frame(outer);
+ fprintf(codefile, ".old_argp;\n");
+ if (line_info) {
+ fprintf(codefile, " line_num = ");
+ frame(outer);
+ fprintf(codefile, ".debug.old_line;\n");
+ fprintf(codefile, " file_name = ");
+ frame(outer);
+ fprintf(codefile , ".debug.old_fname;\n");
+ }
+ fprintf(codefile, " r_signal = (*");
+ if (outer)
+ fprintf(codefile, "r_s_cont)();\n");
+ else
+ fprintf(codefile, "r_pfp->succ_cont)();\n");
+ fprintf(codefile, " if (r_signal != A_Resume) {\n");
+ if (outer)
+ fprintf(codefile, " tend = r_frame.tend.previous;\n");
+ fprintf(codefile, " return r_signal;\n");
+ fprintf(codefile, " }\n");
+ fprintf(codefile, " pfp = (struct p_frame *)&");
+ frame(outer);
+ fprintf(codefile, ";\n");
+ if (cur_proc->nargs == 0)
+ fprintf(codefile, " glbl_argp = NULL;\n");
+ else {
+ if (optim) {
+ if (outer)
+ fprintf(codefile, " glbl_argp = r_args;\n");
+ else
+ fprintf(codefile, " glbl_argp = r_argp_sav;\n");
+ }
+ else {
+ fprintf(codefile, " glbl_argp = &");
+ if (outer)
+ fprintf(codefile, "r_frame.");
+ else
+ fprintf(codefile, "r_pfp->");
+ fprintf(codefile, "tend.d[%d];\n", first_arg);
+ }
+ }
+ if (debug_info) {
+ fprintf(codefile, " if (k_trace) atrace();\n");
+ fprintf(codefile, " ++k_level;\n");
+ }
+ if (cur_proc->nargs != 0 && optim && !outer)
+ fprintf(codefile, " }\n");
+ }
+
+/*
+ * smpl_clsg - print call and signal handling code, but nothing fancy.
+ */
+static void smpl_clsg(call, outer)
+struct code *call;
+int outer;
+ {
+ struct sig_act *sa;
+
+ fprintf(codefile, " r_signal = ");
+ prtcall(call, outer);
+ fprintf(codefile, ";\n");
+ if (call->Flags & ForeignSig)
+ chkforgn(outer);
+ fprintf(codefile, " switch (r_signal) {\n");
+ for (sa = call->SigActs; sa != NULL; sa = sa->next) {
+ fprintf(codefile, " case ");
+ prt_cond(sa->sig);
+ fprintf(codefile, ":\n ");
+ prtcode(sa->cd, outer);
+ }
+ fprintf(codefile, " }\n");
+ }
+
+/*
+ * chkforgn - produce code to see if the current signal belongs to a
+ * procedure higher up the call chain and pass it along if it does.
+ */
+static void chkforgn(outer)
+int outer;
+ {
+ fprintf(codefile, " if (pfp != (struct p_frame *)");
+ if (outer) {
+ fprintf(codefile, "&r_frame) {\n");
+ fprintf(codefile, " tend = r_frame.tend.previous;\n");
+ }
+ else
+ fprintf(codefile, "r_pfp) {\n");
+ fprintf(codefile, " return r_signal;\n");
+ fprintf(codefile, " }\n");
+ }
+
+/*
+ * good_clsg - print call and signal handling code and do a good job.
+ */
+static void good_clsg(call, outer)
+struct code *call;
+int outer;
+ {
+ struct sig_act *sa, *sa1, *nxt_sa;
+ int ncases; /* the number of cases - each may have multiple case labels */
+ int ncaselbl; /* the number of case labels */
+ int nbreak; /* the number of cases that just break out of the switch */
+ int nretsig; /* the number of cases that just pass along signal */
+ int sig_var;
+ int dflt;
+ struct code *cond;
+ struct code *then_cd;
+
+ /*
+ * Decide whether to use "break;", "return r_signal;", or nothing as
+ * the default case.
+ */
+ nretsig = 0;
+ nbreak = 0;
+ for (sa = call->SigActs; sa != NULL; sa = sa->next) {
+ if (sa->cd->cd_id == C_RetSig && sa->sig == sa->cd->SigRef->sig) {
+ /*
+ * The action returns the same signal detected by this case.
+ */
+ ++nretsig;
+ }
+ else if (sa->cd->cd_id == C_Break) {
+ cond = sa->sig; /* if there is only one break, we may want this */
+ ++nbreak;
+ }
+ }
+ dflt = DfltNone;
+ ncases = 0;
+ if (nbreak > 0 && nbreak >= nretsig) {
+ /*
+ * There are at least as many "break;"s as "return r_signal;"s, so
+ * use "break;" for default clause.
+ */
+ dflt = DfltBrk;
+ ncases = 1;
+ }
+ else if (nretsig > 1) {
+ /*
+ * There is more than one case that returns the same signal it
+ * detects and there are more of them than "break;"s, to make
+ * "return r_signal;" the default clause.
+ */
+ dflt = DfltRetSig;
+ ncases = 1;
+ }
+
+ /*
+ * Gather case labels together for each case, ignoring cases that
+ * fall under the default. This involves constructing a new
+ * improved call->SigActs list.
+ */
+ ncaselbl = ncases;
+ sa = call->SigActs;
+ call->SigActs = NULL;
+ for ( ; sa != NULL; sa = nxt_sa) {
+ nxt_sa = sa->next;
+ /*
+ * See if we have already found a case with the same action.
+ */
+ sa1 = call->SigActs;
+ switch (sa->cd->cd_id) {
+ case C_Break:
+ if (dflt == DfltBrk)
+ continue;
+ while (sa1 != NULL && sa1->cd->cd_id != C_Break)
+ sa1 = sa1->next;
+ break;
+ case C_RetSig:
+ if (dflt == DfltRetSig && sa->cd->SigRef->sig == sa->sig)
+ continue;
+ while (sa1 != NULL && (sa1->cd->cd_id != C_RetSig ||
+ sa1->cd->SigRef->sig != sa->cd->SigRef->sig))
+ sa1 = sa1->next;
+ break;
+ default: /* C_Goto */
+ while (sa1 != NULL && (sa1->cd->cd_id != C_Goto ||
+ sa1->cd->Lbl != sa->cd->Lbl))
+ sa1 = sa1->next;
+ break;
+ }
+ ++ncaselbl;
+ if (sa1 == NULL) {
+ /*
+ * First time we have seen this action, create a new case.
+ */
+ ++ncases;
+ sa->next = call->SigActs;
+ call->SigActs = sa;
+ }
+ else {
+ /*
+ * We can share the action of another case label.
+ */
+ sa->shar_act = sa1->shar_act;
+ sa1->shar_act = sa;
+ }
+ }
+
+ /*
+ * If we might receive a "foreign" signal that belongs to a procedure
+ * further down the call chain, put the signal in "r_signal" then
+ * check for this condition.
+ */
+ sig_var = 0;
+ if (call->Flags & ForeignSig) {
+ fprintf(codefile, " r_signal = ");
+ prtcall(call, outer);
+ fprintf(codefile, ";\n");
+ chkforgn(outer);
+ sig_var = 1;
+ }
+
+ /*
+ * Determine the best way to handle the signal returned from the call.
+ */
+ if (ncases == 0) {
+ /*
+ * Any further signal checking has been optimized away. Execution
+ * just falls through to subsequent code. If the call has not
+ * been done, do it.
+ */
+ if (!sig_var) {
+ fprintf(codefile, " ");
+ prtcall(call, outer);
+ fprintf(codefile, ";\n");
+ }
+ }
+ else if (ncases == 1) {
+ if (dflt == DfltRetSig || ncaselbl == nretsig) {
+ /*
+ * All this call does is pass the signal on. See if we have
+ * done the call yet.
+ */
+ if (sig_var)
+ fprintf(codefile, " return r_signal;");
+ else {
+ fprintf(codefile, " return ");
+ prtcall(call, outer);
+ fprintf(codefile, ";\n");
+ }
+ }
+ else {
+ /*
+ * We know what to do without looking at the signal. Make sure
+ * we have done the call. If the action is not simply "break"
+ * out signal checking, execute it.
+ */
+ if (!sig_var) {
+ fprintf(codefile, " ");
+ prtcall(call, outer);
+ fprintf(codefile, ";\n");
+ }
+ if (dflt != DfltBrk)
+ prtcode(call->SigActs->cd, outer);
+ }
+ }
+ else {
+ /*
+ * We have at least two cases. If we have a default action of returning
+ * the signal without looking at it, make sure it is in "r_signal".
+ */
+ if (!sig_var && dflt == DfltRetSig) {
+ fprintf(codefile, " r_signal = ");
+ prtcall(call, outer);
+ fprintf(codefile, ";\n");
+ sig_var = 1;
+ }
+
+ if (ncaselbl == 2) {
+ /*
+ * We can use an if statement. If we need the signal in "r_signal",
+ * it is already there.
+ */
+ fprintf(codefile, " if (");
+ if (sig_var)
+ fprintf(codefile, "r_signal");
+ else
+ prtcall(call, outer);
+
+ cond = call->SigActs->sig;
+ then_cd = call->SigActs->cd;
+
+ /*
+ * If the "then" clause is a no-op ("break;" from a switch),
+ * prepare to eliminate it by reversing the test in the
+ * condition.
+ */
+ if (then_cd->cd_id == C_Break)
+ fprintf(codefile, " != ");
+ else
+ fprintf(codefile, " == ");
+
+ prt_cond(cond);
+ fprintf(codefile, ")\n ");
+
+ if (then_cd->cd_id == C_Break) {
+ /*
+ * We have reversed the test, so we need to use the default
+ * code. However, because a "break;" exists and it is not
+ * default, "return r_signal;" must be the default.
+ */
+ fprintf(codefile, " return r_signal;\n");
+ }
+ else {
+ /*
+ * Print the "then" clause and determine what the "else" clause
+ * is.
+ */
+ prtcode(then_cd, outer);
+ if (call->SigActs->next != NULL) {
+ fprintf(codefile, " else\n ");
+ prtcode(call->SigActs->next->cd, outer);
+ }
+ else if (dflt == DfltRetSig) {
+ fprintf(codefile, " else\n");
+ fprintf(codefile, " return r_signal;\n");
+ }
+ }
+ }
+ else if (ncases == 2 && nbreak == 1) {
+ /*
+ * We can use an if-then statement with a negated test. Note,
+ * the non-break case is not "return r_signal" or we would have
+ * ncaselbl = 2, making the last test true. This also means that
+ * break is the default (the break condition was saved).
+ */
+ fprintf(codefile, " if (");
+ if (sig_var)
+ fprintf(codefile, "r_signal");
+ else
+ prtcall(call, outer);
+ fprintf(codefile, " != ");
+ prt_cond(cond);
+ fprintf(codefile, ") {\n ");
+ prtcode(call->SigActs->cd, outer);
+ fprintf(codefile, " }\n");
+ }
+ else {
+ /*
+ * We must use a full case statement. If we need the signal in
+ * "r_signal", it is already there.
+ */
+ fprintf(codefile, " switch (");
+ if (sig_var)
+ fprintf(codefile, "r_signal");
+ else
+ prtcall(call, outer);
+ fprintf(codefile, ") {\n");
+
+ /*
+ * Print the cases
+ */
+ for (sa = call->SigActs; sa != NULL; sa = sa->next) {
+ for (sa1 = sa; sa1 != NULL; sa1 = sa1->shar_act) {
+ fprintf(codefile, " case ");
+ prt_cond(sa1->sig);
+ fprintf(codefile, ":\n");
+ }
+ fprintf(codefile, " ");
+ prtcode(sa->cd, outer);
+ }
+
+ /*
+ * If we have a default action and it is not break, print it.
+ */
+ if (dflt == DfltRetSig) {
+ fprintf(codefile, " default:\n");
+ fprintf(codefile, " return r_signal;\n");
+ }
+
+ fprintf(codefile, " }\n");
+ }
+ }
+ }
+
+/*
+ * prtcall - print call.
+ */
+static void prtcall(call, outer)
+struct code *call;
+int outer;
+ {
+ /*
+ * Either the operation or the continuation may be missing, but not
+ * both.
+ */
+ if (call->OperName == NULL) {
+ prt_cont(call->Cont);
+ fprintf(codefile, "()");
+ }
+ else {
+ fprintf(codefile, "%s(", call->OperName);
+ if (call->ArgLst != NULL)
+ prt_ary(call->ArgLst, outer);
+ if (call->Cont == NULL) {
+ if (call->Flags & NeedCont) {
+ /*
+ * The operation requires a continuation argument even though
+ * this call does not include one, pass the NULL pointer.
+ */
+ if (call->ArgLst != NULL)
+ fprintf(codefile, ", ");
+ fprintf(codefile, "(continuation)NULL");
+ }
+ }
+ else {
+ /*
+ * Pass the success continuation.
+ */
+ if (call->ArgLst != NULL)
+ fprintf(codefile, ", ");
+ prt_cont(call->Cont);
+ }
+ fprintf(codefile, ")");
+ }
+ }
+
+/*
+ * prt_cont - print the name of a continuation.
+ */
+static void prt_cont(cont)
+struct c_fnc *cont;
+ {
+ struct code *sig;
+
+ if (cont->flag & CF_SigOnly) {
+ /*
+ * This continuation only returns a signal. All continuations
+ * returning the same signal are implemented by the same C function.
+ */
+ sig = cont->cd.next->SigRef->sig;
+ if (sig->cd_id == C_Resume)
+ fprintf(codefile, "sig_rsm");
+ else {
+ sig = ChkBound(sig);
+ ChkSeqNum(sig);
+ fprintf(codefile, "sig_%d", sig->SeqNum);
+ }
+ }
+ else {
+ /*
+ * Regular continuation.
+ */
+ ChkPrefix(cont->prefix);
+ fprintf(codefile, "P%s_%s", cont->prefix, cur_proc->name);
+ }
+ }
+
+/*
+ * val_loc - output code referencing a value location (usually variable of
+ * some sort).
+ */
+static void val_loc(loc, outer)
+struct val_loc *loc;
+int outer;
+ {
+ /*
+ * See if we need to cast a block pointer to a specific block type
+ * or if we need to take the address of a location.
+ */
+ if (loc->mod_access == M_BlkPtr && loc->blk_name != NULL)
+ fprintf(codefile, "(*(struct %s **)&", loc->blk_name);
+ if (loc->mod_access == M_Addr)
+ fprintf(codefile, "(&");
+
+ switch (loc->loc_type) {
+ case V_Ignore:
+ fprintf(codefile, "trashcan");
+ break;
+ case V_Temp:
+ /*
+ * Temporary descriptor variable.
+ */
+ frame(outer);
+ fprintf(codefile, ".tend.d[%d]", cur_proc->tnd_loc + loc->u.tmp);
+ break;
+ case V_ITemp:
+ /*
+ * Temporary C integer variable.
+ */
+ frame(outer);
+ fprintf(codefile, ".i%d", loc->u.tmp);
+ break;
+ case V_DTemp:
+ /*
+ * Temporary C double variable.
+ */
+ frame(outer);
+ fprintf(codefile, ".d%d", loc->u.tmp);
+ break;
+ case V_Const:
+ /*
+ * Integer constant (used for size of variable part of arg list).
+ */
+ fprintf(codefile, "%d", loc->u.int_const);
+ break;
+ case V_NamedVar:
+ /*
+ * Icon named variable.
+ */
+ prt_var(loc->u.nvar, outer);
+ break;
+ case V_CVar:
+ /*
+ * C variable from in-line code.
+ */
+ fprintf(codefile, "%s", loc->u.name);
+ break;
+ case V_PRslt:
+ /*
+ * Procedure result location.
+ */
+ if (!outer)
+ fprintf(codefile, "(*r_pfp->rslt)");
+ else
+ fprintf(codefile, "(*r_rslt)");
+ break;
+ }
+
+ /*
+ * See if we are accessing the vword of a descriptor.
+ */
+ switch (loc->mod_access) {
+ case M_CharPtr:
+ fprintf(codefile, ".vword.sptr");
+ break;
+ case M_BlkPtr:
+ fprintf(codefile, ".vword.bptr");
+ if (loc->blk_name != NULL)
+ fprintf(codefile, ")");
+ break;
+ case M_CInt:
+ fprintf(codefile, ".vword.integr");
+ break;
+ case M_Addr:
+ fprintf(codefile, ")");
+ break;
+ }
+ }
+
+/*
+ * prt_cond - print a condition (signal number).
+ */
+static void prt_cond(cond)
+struct code *cond;
+ {
+ if (cond == &resume)
+ fprintf(codefile, "A_Resume");
+ else if (cond == &contin)
+ fprintf(codefile, "A_Continue");
+ else if (cond == &fallthru)
+ fprintf(codefile, "A_FallThru");
+ else {
+ cond = ChkBound(cond);
+ ChkSeqNum(cond);
+ fprintf(codefile, "%d /* %s */", cond->SeqNum, cond->Desc);
+ }
+ }
+
+/*
+ * initpblk - write a procedure block along with initialization up to the
+ * the array of qualifiers.
+ */
+static void initpblk(f, c, prefix, name, nquals, nparam, ndynam, nstatic,
+ frststat)
+FILE *f; /* output file */
+int c; /* distinguishes procedures, functions, record constructors */
+char* prefix; /* prefix for name */
+char *name; /* name of routine */
+int nquals; /* number of qualifiers at end of block */
+int nparam; /* number of parameters */
+int ndynam; /* number of dynamic locals or function/record indicator */
+int nstatic; /* number of static locals or record number */
+int frststat; /* index into static array of first static local */
+ {
+ fprintf(f, "B_IProc(%d) B%c%s_%s = ", nquals, c, prefix, name);
+ fprintf(f, "{T_Proc, %d, %c%s_%s, %d, %d, %d, %d, {", 9 + 2 * nquals, c,
+ prefix, name, nparam, ndynam, nstatic, frststat);
+ }
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-03 04:02:03 +0000