aboutsummaryrefslogtreecommitdiff
path: root/pkg/ecl/debug.c
diff options
context:
space:
mode:
Diffstat (limited to 'pkg/ecl/debug.c')
-rw-r--r--pkg/ecl/debug.c486
1 files changed, 486 insertions, 0 deletions
diff --git a/pkg/ecl/debug.c b/pkg/ecl/debug.c
new file mode 100644
index 00000000..a8d0087c
--- /dev/null
+++ b/pkg/ecl/debug.c
@@ -0,0 +1,486 @@
+/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+ */
+
+#define import_spp
+#define import_libc
+#define import_stdio
+#include <iraf.h>
+
+#include "config.h"
+#include "operand.h"
+#include "mem.h"
+#include "grammar.h"
+#include "opcodes.h"
+#include "param.h"
+#include "task.h"
+#include "proto.h"
+
+
+/*
+ * DEBUG -- The various debugging functions.
+ *
+ * the D_XXX grammar rules use the d_xxx routines to dump various tables
+ * for debugging purposes.
+ * some of these (see setbuiltins()) are done as builtin ltasks, while others
+ * that show dictionary or stack info are not to avoid the complication of
+ * having to work around the fact that builtins are really separate tasks.
+ * all write to stderr.
+ */
+
+extern char *nullstr;
+extern int cldebug;
+extern int cltrace;
+static void dd_f();
+
+
+/* D_STACK -- Go through the instruction stack, starting at locpc, printing
+ * what is found until END opcode discovered. If ss > 0, just go through ss
+ * instructions. Done directly.
+ */
+static int pc_mark = 0;
+
+void
+d_asmark (void)
+{
+ /* Mark the PC to begin the instruction output. If not defined,
+ * do the whole script.
+ */
+ pc_mark = pc;
+}
+
+
+void
+d_assemble (void)
+{
+ d_stack ((pc_mark ? pc_mark : pc), 0, pc);
+ pc_mark = 0;
+}
+
+void
+d_stack (register XINT locpc, int ss, int endpc)
+{
+ register struct codeentry *cep;
+ int n, opcode, errs = 0;
+
+ do {
+ cep = coderef (locpc);
+ opcode = cep->c_opcode;
+
+ if ((n = d_instr (stderr, "", locpc)) <= 0) {
+ errs++;
+ locpc += (SZ_CE - 1);
+ } else
+ locpc += n;
+
+ if (ss > 0 && --ss == 0) /* ss > 0 done first! */
+ errs = 100; /* simulate end */
+
+ if (endpc > 0 && locpc > (endpc - SZ_CE))
+ break;
+
+ } while (opcode != END && errs < 10);
+}
+
+
+/* D_INSTR -- Decode a single instruction on the output file. The length of
+ * the instruction in memel is returned as the function value.
+ */
+int
+d_instr (FILE *fp, char *prefix, register XINT locpc)
+{
+ register struct codeentry *cep;
+ int opcode, extra=0;
+
+ cep = coderef (locpc);
+ opcode = cep->c_opcode;
+
+ if (prefix[0] == '\t') {
+ if (cltrace > 1) {
+ /* For verbose output, get the filename. */
+ fprintf (fp, " %4d:%s %6d+%d:\t", cep->c_scriptln,
+ currentask->t_ltp->lt_pname,
+ locpc, cep->c_length);
+ } else {
+ fprintf (fp, " %4d %6d+%d:\t", cep->c_scriptln,
+ locpc, cep->c_length);
+ }
+ } else
+ fprintf (fp, "%s %4d %6d+%d:\t", prefix, cep->c_scriptln,
+ locpc, cep->c_length);
+
+
+ switch (opcode) {
+ case ABSARGSET: fprintf (fp, "absargset"); goto string;
+ case ADDASSIGN: fprintf (fp, "addassign"); goto string;
+ case ASSIGN: fprintf (fp, "assign\t"); goto string;
+ case CALL: fprintf (fp, "call\t"); goto string;
+ case CATASSIGN: fprintf (fp, "catassign"); goto string;
+ case DIVASSIGN: fprintf (fp, "divassign"); goto string;
+ case GSREDIR: fprintf (fp, "gsredir"); goto string;
+ case INDIRABSSET: fprintf (fp, "indirabsset"); goto string;
+ case INSPECT: fprintf (fp, "inspect\t"); goto string;
+ case INTRINSIC: fprintf (fp, "intrinsic"); goto string;
+ case MULASSIGN: fprintf (fp, "mulassign"); goto string;
+ case OSESC: fprintf (fp, "os_escape"); goto string;
+ case PUSHPARAM: fprintf (fp, "pushparam"); goto string;
+ case SUBASSIGN: fprintf (fp, "subassign"); goto string;
+ case SWOFF: fprintf (fp, "swoff\t"); goto string;
+ case SWON: fprintf (fp, "swon"); goto string;
+string:
+ fprintf (fp, "\t%s\n", (char *)&cep->c_args);
+ break;
+
+ case PUSHCONST: fprintf (fp, "pushconst"); goto op;
+op:
+ { struct operand *op;
+
+ op = (struct operand *) &cep->c_args;
+ fprintf (fp, "\t");
+ if ((op->o_type & OT_BASIC) == OT_STRING)
+ fprintf (fp, "`");
+ fprop (stderr, op);
+ if ((op->o_type & OT_BASIC) == OT_STRING)
+ fprintf (fp, "'");
+ fprintf (fp, "\n");
+ }
+ break;
+
+ case ADD: fprintf (fp, "add\n"); break;
+ case ADDPIPE: fprintf (fp, "addpipe\n"); break;
+ case ALLAPPEND: fprintf (fp, "allappend\n"); break;
+ case ALLREDIR: fprintf (fp, "allredir\n"); break;
+ case AND: fprintf (fp, "and\n"); break;
+ case APPENDOUT: fprintf (fp, "append\n"); break;
+ case CHSIGN: fprintf (fp, "chsign\n"); break;
+ case CONCAT: fprintf (fp, "concat\n"); break;
+ case DEFAULT: fprintf (fp, "default\n"); break;
+ case DIV: fprintf (fp, "div\n"); break;
+ case END: fprintf (fp, "end\n"); break;
+ case EQ: fprintf (fp, "eq\n"); break;
+ case EXEC: fprintf (fp, "exec\n"); break;
+ case FSCAN: fprintf (fp, "fscan\n"); break;
+ case FSCANF: fprintf (fp, "fscanf\n"); break;
+ case GE: fprintf (fp, "ge\n"); break;
+ case GETPIPE: fprintf (fp, "getpipe\n"); break;
+ case GT: fprintf (fp, "gt\n"); break;
+ case IMMED: fprintf (fp, "immed\n"); break;
+ case LE: fprintf (fp, "le\n"); break;
+ case LT: fprintf (fp, "lt\n"); break;
+ case MUL: fprintf (fp, "mul\n"); break;
+ case NE: fprintf (fp, "ne\n"); break;
+ case NOT: fprintf (fp, "not\n"); break;
+ case OR: fprintf (fp, "or\n"); break;
+ case POW: fprintf (fp, "pow\n"); break;
+ case PRINT: fprintf (fp, "print\n"); break;
+ case REDIR: fprintf (fp, "redir\n"); break;
+ case REDIRIN: fprintf (fp, "redirin\n"); break;
+ case RETURN: fprintf (fp, "return\n"); break;
+ case SCAN: fprintf (fp, "scan\n"); break;
+ case SCANF: fprintf (fp, "scanf\n"); break;
+ case SUB: fprintf (fp, "sub\n"); break;
+ case SWITCH: fprintf (fp, "switch\n"); break;
+
+ case BIFF: fprintf (fp, "biff\t"); goto offset;
+ case GOTO: fprintf (fp, "goto\t"); goto offset;
+offset:
+ /* Print offset with sign, - or +, in all cases. */
+ if ((int)cep->c_args <= 0)
+ goto oneint; /* pick up sign there */
+ else
+ fprintf (fp, "\t+%d\n", cep->c_args);
+ break;
+
+ case CASE: fprintf (fp, "case\t"); goto oneint;
+ case INDIRPOSSET: fprintf (fp, "indirposset"); goto oneint;
+ case POSARGSET: fprintf (fp, "posargset"); goto oneint;
+ case RMPIPES: fprintf (fp, "rmpipes\t"); goto oneint;
+oneint:
+ fprintf (fp, "\t%d\n", cep->c_args);
+ break;
+
+ /* Used for arrays. */
+ case PUSHINDEX: fprintf (fp, "pushindex"); goto oneint;
+ case INDXINCR: fprintf (fp, "indxincr");
+ /* Output two jump offsets. */
+ fprintf (fp, "\t%d, %d\t", cep->c_args, *(&cep->c_args+1));
+
+ /* Output array index ranges: {beg, end} * N. */
+ { memel *ip = (memel *) &cep->c_args;
+ int i, n = (int)ip[2];
+ for (ip += 2, i=0; i < n; i++, ip += 2)
+ fprintf (fp, "%d:%d ", (XINT)*ip, (XINT)(*ip+1));
+ fprintf (fp, "\n");
+ extra = 2*n + 1;
+ }
+ break;
+
+ default:
+ fprintf (fp, "bad opcode, %d, at pc %d\n", opcode, locpc);
+ return (-1);
+ }
+
+ return (cep->c_length + extra);
+}
+
+
+/* print neat things about the dictionary and stack.
+ * done directly.
+ */
+void
+d_d (void)
+{
+ char *stackaddr = (char *)stack; /* just so we may subtract */
+ char *otheraddr;
+
+
+ eprintf ("\ndictionary indices:\n");
+ eprintf ("\tmaxd-1\t%u (%u)\n", maxd-1, dictionary[maxd-1]);
+ eprintf ("\ttopd\t%u (%u)\n", topd, dictionary[topd]);
+ eprintf ("\tpachead\t%u (`%s')\n", pachead,
+ reference (package, pachead)->pk_name);
+ eprintf ("\tparhead\t%u (`%s')\n", parhead,
+ reference (pfile, parhead)->pf_ltp->lt_lname);
+
+ eprintf ("\ndictionary pointers (shown as indices)\n");
+ eprintf ("\tcurpack\t%u (`%s')\n", dereference (curpack),
+ curpack->pk_name);
+ eprintf ("\tdictionary\t%u\n", dictionary);
+
+ eprintf ("\nstack indices\n");
+ eprintf ("\ttopcs\t%d\n", topcs);
+ eprintf ("\ttopos\t%d\n", topos);
+ eprintf ("\tbasos\t%d\n", basos);
+ eprintf ("\tpc\t%d\n", pc);
+ otheraddr = (char *)currentask;
+ eprintf ("\tcurrentask\t%u (`%s')\n", btoi (otheraddr - stackaddr),
+ currentask->t_ltp->lt_lname);
+ otheraddr = (char *)firstask;
+ eprintf ("\tfirstask\t%u (`%s')\n", btoi (otheraddr - stackaddr),
+ firstask->t_ltp->lt_lname);
+}
+
+
+/* print all loaded pfiles and their params from parhead.
+ * done as a builtin task. depends on the fact that the fake param file
+ * has been unlinked from parhead before the builtin is run to avoid showing
+ * it. see execnewtask().
+ */
+void
+d_p (void)
+{
+ register struct pfile *pfp;
+ register struct param *pp;
+ register FILE *fp;
+ int flags;
+
+ fp = currentask->t_stderr;
+ eprintf ("loaded parameter files -\n");
+ for (pfp = reference (pfile, parhead); pfp; pfp = pfp->pf_npf) {
+ eprintf ("\n\t%s: ", pfp->pf_ltp->lt_lname);
+ flags = pfp->pf_flags;
+ if (flags & PF_UPDATE) eprintf ("updated, ");
+ if (flags & PF_FAKE) eprintf ("fake, ");
+ if (flags & PF_COPY) eprintf ("copy, ");
+ if (flags & PF_PSETREF) eprintf ("contains pset pars, ");
+ eprintf ("\n");
+ for (pp = pfp->pf_pp; pp != NULL; pp = pp->p_np)
+ printparam (pp, fp);
+ }
+}
+
+
+/* print info about the tasks currently on the control stack.
+ * done as a builtin. no attempt is made to hide the task running for this
+ * builtin.
+ */
+void
+d_t (void)
+{
+ struct task *tp;
+ int flags;
+
+ eprintf ("stacked tasks (most recent first)\n\n");
+ for (tp=currentask; (XINT)tp<(XINT)&stack[STACKSIZ]; tp=next_task(tp)) {
+ flags = tp->t_flags;
+ eprintf ("%s:\t", tp->t_ltp->lt_lname);
+ if (flags & T_SCRIPT) eprintf ("script, ");
+ if (flags & T_CL) eprintf ("cl, ");
+ if (flags & T_INTERACTIVE) eprintf ("interactive, ");
+ if (flags & T_MYOUT) eprintf ("new out, ");
+ if (flags & T_MYIN) eprintf ("new in, ");
+ if (flags & T_MYERR) eprintf ("new err, ");
+ if (flags & T_MYSTDGRAPH) eprintf ("new stdgraph, ");
+ if (flags & T_MYSTDIMAGE) eprintf ("new stdimage, ");
+ if (flags & T_MYSTDPLOT) eprintf ("new stdplot, ");
+ if (flags & T_BUILTIN)
+ eprintf ("builtin, ");
+ else
+ eprintf ("mode = `%s' ", tp->t_modep->p_val.v_s);
+ eprintf ("\n");
+ }
+}
+
+
+/* print all loaded packages and their ltasks from pachead.
+ * builtin.
+ */
+void
+d_l (void)
+{
+ register struct package *pkp;
+ register struct ltask *ltp;
+ int flags;
+
+ eprintf ("loaded packages -\n");
+ for (pkp = reference (package,pachead); pkp; pkp = pkp->pk_npk) {
+ eprintf ("(%u) package `%s':\n", pkp, pkp->pk_name);
+ for (ltp = pkp->pk_ltp; ltp != NULL; ltp = ltp->lt_nlt) {
+ flags = ltp->lt_flags;
+ eprintf ("\t(%u)\t%s: ", ltp, ltp->lt_lname);
+ if (flags & LT_BUILTIN)
+ eprintf ("builtin, ");
+ else
+ eprintf ("in %s (%d), ", ltp->lt_pname,
+ ltp->lt_pname);
+ if (flags & LT_SCRIPT) eprintf ("script, ");
+ if (!(flags & LT_PFILE)) eprintf ("no pfile, ");
+ if (flags & LT_STDINB) eprintf ("b_in, ");
+ if (flags & LT_STDOUTB) eprintf ("b_out, ");
+ if (flags & LT_INVIS) eprintf ("invisible, ");
+ eprintf ("\n");
+ }
+ }
+}
+
+
+/* D_F -- Determine the number of logical (e.g. dev$null, stropen) and physical
+ * (host system) file slots available.
+ */
+void
+d_f (void)
+{
+ dd_f ("logical: ", "dev$null");
+ dd_f ("physical: ", "hlib$iraf.h");
+}
+
+static void
+dd_f (char *msg, char *fname)
+{
+ FILE *fp[128];
+ int fn;
+
+ eprintf (msg);
+ fn = 0;
+ while ((fp[fn] = fopen (fname, "r")) != NULL) {
+ eprintf ("%d,", fileno(fp[fn]));
+ if (++fn >= 128)
+ break;
+ }
+ eprintf ("\n");
+ while (fn > 0)
+ fclose (fp[--fn]);
+}
+
+
+/* enable debugging messages.
+ * builtins.
+ */
+void
+d_on (void)
+{
+ cldebug = 1;
+}
+
+/* disable debugging.
+ */
+void
+d_off (void)
+{
+ cldebug = 0;
+}
+
+/* Enable/disable instruction tracing.
+ */
+void
+d_trace (int value)
+{
+ cltrace = value;
+}
+
+
+/* Dump operand stack until underflow occurs.
+ */
+void
+e_dumpop (void)
+{
+ struct operand o;
+
+ forever {
+ o = popop();
+ oprop (&o);
+ }
+}
+
+
+/* Format a multiline exec-task message string for debug output.
+ */
+void
+d_fmtmsg (FILE *fp, char *prefix, char *message, int width)
+{
+ register char *ip, *op, *cp;
+ char lbuf[SZ_COMMAND], obuf[SZ_COMMAND];
+ int len_prefix, nchars;
+
+ len_prefix = strlen (prefix);
+
+ for (ip=message, op=obuf; *ip; ) {
+ /* Get next message line. */
+ for (cp=lbuf, nchars=0; (*cp++ = *ip); ip++, nchars++) {
+ if (*ip == '\\' && *(ip+1) == '\n') {
+ *cp++ = 'n';
+ nchars += 2;
+ ip += 2;
+ break;
+ } else if (*ip == '\n') {
+ *(cp-1) = '\\';
+ *cp++ = 'n';
+ nchars += 2;
+ ip++;
+ break;
+ }
+ }
+ *cp++ = '\0';
+
+ /* Flush output line if it is full. */
+ if (len_prefix + op-obuf + nchars > width) {
+ if (op > obuf) {
+ *op++ = '\0';
+ fprintf (fp, "%s%s\n", prefix, obuf);
+ op = obuf;
+ } else {
+ fprintf (fp, "%s%s\n", prefix, lbuf);
+ op = obuf;
+ continue;
+ }
+ }
+
+ /* Copy line to output buffer. */
+ for (cp=lbuf; *cp; )
+ *op++ = *cp++;
+ }
+
+ /* Flush anything left in output buffer. */
+ if (op > obuf) {
+ *op++ = '\0';
+ fprintf (fp, "%s%s\n", prefix, obuf);
+ }
+}
+
+
+/* D_PROF -- Enable script execution profiling.
+ */
+void
+d_prof (void)
+{
+}
+
generated by cgit (git 2.34.1) at 2025-09-20 09:49:20 -0400