aboutsummaryrefslogtreecommitdiff
path: root/pkg/ecl/operand.c
diff options
context:
space:
mode:
Diffstat (limited to 'pkg/ecl/operand.c')
-rw-r--r--pkg/ecl/operand.c411
1 files changed, 411 insertions, 0 deletions
diff --git a/pkg/ecl/operand.c b/pkg/ecl/operand.c
new file mode 100644
index 00000000..6c3a73af
--- /dev/null
+++ b/pkg/ecl/operand.c
@@ -0,0 +1,411 @@
+/* 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 "errs.h"
+#include "operand.h"
+#include "param.h"
+#include "grammar.h"
+#include "mem.h"
+#include "task.h" /* to get currentask for prop */
+#include "construct.h"
+#include "eparam.h"
+#include "proto.h"
+
+
+/*
+ * OPERAND -- Primitives for operations upon operands, as used on the
+ * operand stack (runtime arithmetic).
+ */
+
+extern int cldebug;
+extern char *truestr;
+extern char *falsestr;
+extern char *nullstr;
+extern char *indefstr;
+extern char *indeflc;
+extern char *eofstr;
+extern char *epsilonstr;
+
+
+/* SPROP -- Format the value of a parameter into the output string.
+ */
+void
+sprop (register char *outstr, register struct operand *op)
+{
+ register int type;
+ char *index();
+
+ if (opundef (op))
+ cl_error (E_IERR, "can not print an undefined operand");
+ if (opindef (op)) {
+ strcpy (outstr, indefstr);
+ return;
+ }
+
+ type = op->o_type & OT_BASIC;
+ switch (type) {
+ case OT_BOOL:
+ sprintf (outstr, op->o_val.v_i == NO ? falsestr : truestr);
+ break;
+ case OT_INT:
+ sprintf (outstr, "%d", op->o_val.v_i);
+ break;
+ case OT_REAL:
+ /* unix's %g suppresses '.' if no fractional part */
+ sprintf (outstr, "%g", op->o_val.v_r);
+ if (index (outstr, '.') == NULL)
+ strcat (outstr, ".");
+ break;
+ case OT_STRING:
+ strcpy (outstr, op->o_val.v_s);
+ break;
+ default:
+ /* cannot happen because there are only 2 bits for 4 types.
+ cl_error (E_IERR, e_badsw, type, "fprop()");
+ */
+ ;
+ }
+}
+
+
+/* SPPARVAL -- Print value field of a parameter into a string.
+ */
+void
+spparval (char *outstr, struct param *pp)
+{
+ struct operand o;
+
+ if (!(pp->p_valo.o_type & OT_UNDEF)) {
+ paramget (pp, FN_VALUE);
+ o = popop();
+ sprop (outstr, &o);
+ } else
+ outstr[0] = '\0';
+}
+
+
+/* Print an operand on stream fp.
+ * o_val is printed with proper format; no trailing nl.
+ * handle indefinite and abort on undefined.
+ */
+void
+fprop (FILE *fp, struct operand *op)
+{
+ /* Use MAXPROMPT to give greatest length we expect to print.
+ */
+ char outstr[MAXPROMPT+1], *out;
+ char newstr[SZ_LINE], *new;
+
+ sprop (outstr, op);
+
+ /* Convert embedded newlines to \n.
+ */
+ new = newstr;
+ out = outstr;
+ for (; *out != '\0' && ((new-newstr) < SZ_LINE-1 ); out++, new++) {
+ if (*out == '\n') {
+ *new++ = '\\';
+ *new = 'n';
+ } else {
+ *new = *out;
+ }
+ }
+ *new = '\0';
+
+ fputs (newstr, fp);
+ if (ferror (fp))
+ cl_error (E_IERR, "write error within fprop()");
+}
+
+
+/* print operand, using fprop, to our t_stdout.
+ */
+void
+oprop (struct operand *op)
+{
+ fprop (currentask->t_stdout, op);
+}
+
+
+/* print operand, using fprintf, to currentask.
+ */
+void
+prop (struct operand *op)
+{
+ fprop (currentask->t_out, op);
+}
+
+
+/* pop the top element, which must be of type string, and use it as the
+ * name of a parameter which is then found and pushed.
+ * call error() if popped op is not a string; DO NOT CAST into string.
+ */
+void
+opindir (void)
+{
+ struct operand nameop;
+ struct param *indirpp;
+ char *pk, *t, *p, *f;
+
+ nameop = popop();
+ if ((nameop.o_type & OT_BASIC) != OT_STRING)
+ cl_error (E_IERR, "non-string operand seen by opindir()");
+ breakout (nameop.o_val.v_s, &pk, &t, &p, &f);
+ indirpp = paramsrch (pk, t, p);
+ validparamget (indirpp, *f);
+}
+
+
+/* Pop top operand and replace it with one cast to type newtype.
+ * Newtype is assumed to not have OT_INDEF or OT_UNDEF set.
+ * Call error() if trying to convert strings to something else unless
+ * it is a length 1 string conversion to integer which we take to be
+ * conversion from char to int.
+ *
+ * Do nothing if already the correct type, regardless of whether it is indef
+ * or undef.
+ * N.B. we use intimate knowledge of the stack layout to do the simple cases.
+ */
+void
+opcast (int newtype)
+{
+ struct operand o, result;
+ struct operand *op;
+
+ /* Do nothing if already the correct type,
+ * regardless of whether it is indef or undef.
+ */
+ op = (struct operand *) &stack[stack[topos]+1];
+ if ((op->o_type & OT_BASIC) == newtype)
+ return;
+
+ o = popop();
+ result.o_type = newtype;
+
+ if (opindef (&o)) {
+ /* manufacture another indefinite but with the new type */
+ setopindef (&result);
+ goto pushresult;
+ }
+
+ switch (newtype) {
+ default:
+ /* Coerce all unknowns to type integer. Actually this cannot
+ * happen since the 4 types are encoded in 2 bits.
+ */
+ newtype = OT_INT;
+ /* continue... */
+
+ case OT_BOOL:
+ /* Coercion of booleans is not permitted */
+ if (o.o_type != OT_BOOL)
+ cl_error (E_UERR,
+ "Non-boolean operand used where boolean expected");
+ break;
+
+ case OT_INT:
+ switch (o.o_type) {
+ case OT_BOOL:
+ cl_error (E_UERR, "Attempt to coerce a boolean to an integer");
+ case OT_INT:
+ result.o_val.v_i = o.o_val.v_i;
+ break;
+ case OT_REAL:
+ result.o_val.v_i = o.o_val.v_r;
+ break;
+ case OT_STRING:
+ if (*o.o_val.v_s != '\0' && *(o.o_val.v_s+1) == '\0')
+ result.o_val.v_i = (int) *o.o_val.v_s;
+ else
+ cl_error (E_UERR, e_nostrcnv);
+ break;
+ default:
+ goto err;
+ }
+ break;
+
+ case OT_REAL:
+ switch (o.o_type) {
+ case OT_BOOL:
+ cl_error (E_UERR, "Attempt to coerce a boolean to a real");
+ case OT_INT:
+ result.o_val.v_r = o.o_val.v_i;
+ break;
+ case OT_REAL:
+ result.o_val.v_r = o.o_val.v_r;
+ break;
+ case OT_STRING:
+ cl_error (E_UERR, e_nostrcnv);
+ default:
+ goto err;
+ }
+ break;
+
+ case OT_STRING: {
+ char numstr[SZ_LINE];
+ switch (o.o_type) {
+ case OT_BOOL:
+ result.o_val.v_s =
+ o.o_val.v_i == NO ? falsestr : truestr;
+ break;
+ case OT_INT:
+ sprintf (numstr, "%d", o.o_val.v_i);
+ result.o_val.v_s = numstr;
+ break;
+ case OT_REAL:
+ sprintf (numstr, "%g", o.o_val.v_r);
+ result.o_val.v_s = numstr;
+ break;
+ case OT_STRING:
+ strcpy (numstr, o.o_val.v_s);
+ result.o_val.v_s = numstr;
+ break;
+ default: goto err;
+ }
+
+ /* Must do pushop here to use numstr */
+ pushop (&result);
+ return;
+
+ } /* end case OT_STRING */
+ }
+
+pushresult:
+ pushop (&result);
+ return;
+
+err:
+ cl_error (E_IERR, e_badsw, o.o_type, "opcast()");
+}
+
+
+/* MAKEOP -- Read through string s and create and return an operand of given
+ * type. Type must be strictly OT_BASIC. See the various cases for
+ * considerations unique to each. Set OT_UNDEF if string does not look like
+ * it is the correct type or it is null length; set OT_INDEF if s is the
+ * indefstr.. Null length strings of type OT_STRING are not considered
+ * undefined, however.
+ */
+struct operand
+makeop (char *str, int type)
+{
+ register char *s, *ip;
+ register char c;
+ char *index(), *format;
+ char hexnum[MAX_DIGITS];
+ char firstchar;
+ struct operand o;
+
+ maybeindex = 0;
+ s = str;
+ if (type & ~OT_BASIC)
+ cl_error (E_IERR, e_badsw, type, "makeop()");
+
+ /* Leading whitespace is ignored except in strings. */
+ o.o_type = type;
+ if (type != OT_STRING)
+ while (*s == ' ' || *s == '\t')
+ s++;
+
+ if (type != OT_STRING &&
+ (!strcmp (indefstr, s) || !strcmp (indeflc, s))) {
+ setopindef (&o);
+ return (o);
+ }
+ if (*s == '\0' && type != OT_STRING) {
+ setopundef (&o);
+ return (o);
+ }
+
+ switch (type) {
+ case OT_BOOL:
+ /* s is converted, IN PLACE, to lower case */
+ makelower (s);
+ /* Accept either "y" or "yes", "n" or "no" */
+ if (((s[0] == truestr[0]) && (s[1] == '\0')) ||
+ (strcmp (s, truestr) == 0))
+ o.o_val.v_i = YES;
+ else if (((s[0] == falsestr[0]) && (s[1] == '\0')) ||
+ (strcmp (s, falsestr) == 0))
+ o.o_val.v_i = NO;
+ else
+ setopundef (&o);
+ break;
+
+ case OT_INT:
+ /* trailing 'b' or 'B' means convert as octal.
+ * trailing 'x' or 'X' means convert as hex.
+ * Set format to appropriate scanf format. Note we must test
+ * for hex number first, since 'b' is legal in hex numbers.
+ */
+ firstchar = *s;
+ if (*s != '\'' && *s != '"')
+ makelower (s);
+
+ if (index (s, 'x') != NULL) {
+ strcpy (hexnum, "0x");
+ strcat (hexnum, s);
+ format = "%x";
+ } else if (index (s, 'b') != NULL) {
+ format = "%o";
+ } else
+ format = "%d";
+
+ if (sscanf (s, format, &o.o_val.v_i) != 1) {
+ /* Check if string has exactly one character.
+ * Use firstchar because it hasn't been forced to lower case.
+ */
+ if (*s && !(*(s+1)) )
+ o.o_val.v_i = firstchar;
+ /* Quoted character? */
+ else if ( (*s == '\'' || *s == '"') && (*s == *(s+2) ) &&
+ !(*(s+3)) )
+ o.o_val.v_i = *(s+2);
+ else
+ setopundef (&o);
+ }
+
+ break;
+
+ case OT_REAL: {
+ /* If there is only a single colon this might be
+ * an array index range. If so set flag.
+ * Check for decimal point after first colon also.
+ */
+ char *colon;
+
+ if ( (colon=index (s, ':') ) != NULL) {
+ if (index (colon+1, ':') == NULL &&
+ index (colon+1, '.') == NULL)
+ maybeindex++;
+
+ o = sexa (s);
+ } else if (sscanf (s, "%lf", &o.o_val.v_r) != 1)
+ setopundef (&o);
+ break;
+ }
+ case OT_STRING:
+ /* set v_s to s and strip off any surrounding quotes.
+ * trailing " or ' will be reset, IN-PLACE, to '\0'.
+ */
+ ip = s;
+ c = *ip++;
+ if (c == '\'' || c == '"') {
+ while (*ip)
+ ip++;
+ if (*--ip == c) {
+ s++; /* skip leading quote */
+ *ip = '\0'; /* remove trailing quote */
+ }
+ }
+ o.o_val.v_s = s;
+ }
+
+ return (o);
+}
generated by cgit (git 2.34.1) at 2025-09-20 07:03:04 -0400