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, 0 insertions, 1918 deletions
diff --git a/src/iconc/codegen.c b/src/iconc/codegen.c
deleted file mode 100644
index 8ca5bd1..0000000
--- a/src/iconc/codegen.c
+++ /dev/null
@@ -1,1918 +0,0 @@
-/*
- * 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 2025-07-14 16:59:51 +0000