aboutsummaryrefslogtreecommitdiff
path: root/pkg/utilities/nttools/stxtools/vexfunc.x
diff options
context:
space:
mode:
Diffstat (limited to 'pkg/utilities/nttools/stxtools/vexfunc.x')
-rw-r--r--pkg/utilities/nttools/stxtools/vexfunc.x2011
1 files changed, 2011 insertions, 0 deletions
diff --git a/pkg/utilities/nttools/stxtools/vexfunc.x b/pkg/utilities/nttools/stxtools/vexfunc.x
new file mode 100644
index 00000000..b4e40ae6
--- /dev/null
+++ b/pkg/utilities/nttools/stxtools/vexfunc.x
@@ -0,0 +1,2011 @@
+include <mach.h>
+include "vex.h"
+
+define MAX_EXP (2.3 * MAX_EXPONENT)
+define MIN_REAL 1.0e-20
+define MIN_DOUBLE 1.0d-20
+
+# VEX_FUNC -- Miscelaneous procedures used by the vex expression evaluator.
+#
+# Mostly these functions implement single opcodes such as add, sin, and
+# push. However, it also includes vex_copy[dir], which copies the array
+# on the top of the stack into a user array and vex_errf, which returns
+# the substitute value used when an opcode would return an undefined
+# value. The only functions which should be called directly from a user's
+# program are vex_copy[dir].
+#
+# B.Simon 24-Apr-91 Original
+# B.Simon 15-Oct-98 Rewrite vex_push to use embedded strings
+
+# VEX_ABS -- Absolute value function
+
+procedure vex_abs (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ out = stk_alloc (stack, len, type)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memi[out+i] = abs (Memi[in+i])
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = abs (Memr[in+i])
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = abs (Memd[in+i])
+
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_ACOS -- Arc cosine function
+
+procedure vex_acos (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+double vex_errf()
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ if (type == TY_INT) {
+ out = stk_alloc (stack, len, TY_REAL)
+ } else {
+ out = stk_alloc (stack, len, type)
+ }
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in+i] < -1 || Memi[in+i] > 1) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = acos (real (Memi[in+i]))
+ }
+ }
+
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in+i] < -1.0 || Memr[in+i] > 1.0) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = acos (Memr[in+i])
+ }
+ }
+
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in+i] < -1.0 || Memd[in+i] > 1.0) {
+ Memd[out+i] = vex_errf (stack, i)
+ } else {
+ Memd[out+i] = acos (Memd[in+i])
+ }
+ }
+
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_ADD -- Addition function
+
+procedure vex_add (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, type)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memi[out+i] = Memi[in[1]+i] + Memi[in[2]+i]
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = Memr[in[1]+i] + Memr[in[2]+i]
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = Memd[in[1]+i] + Memd[in[2]+i]
+
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_AND -- Logical and
+
+procedure vex_and (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, TY_INT)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in[1]+i] != 0 && Memi[in[2]+i] != 0) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in[1]+i] != 0.0 && Memr[in[2]+i] != 0.0) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in[1]+i] != 0.0 && Memd[in[2]+i] != 0.0) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_ASIN -- Arc sine function
+
+procedure vex_asin (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+double vex_errf()
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ if (type == TY_INT) {
+ out = stk_alloc (stack, len, TY_REAL)
+ } else {
+ out = stk_alloc (stack, len, type)
+ }
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in+i] < -1 || Memi[in+i] > 1) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = asin (real (Memi[in+i]))
+ }
+ }
+
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in+i] < -1.0 || Memr[in+i] > 1.0) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = asin (Memr[in+i])
+ }
+ }
+
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in+i] < -1.0 || Memd[in+i] > 1.0) {
+ Memd[out+i] = vex_errf (stack, i)
+ } else {
+ Memd[out+i] = asin (Memd[in+i])
+ }
+ }
+
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_ATAN -- Arc tangent function with one argument
+
+procedure vex_atan (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ if (type == TY_INT) {
+ out = stk_alloc (stack, len, TY_REAL)
+ } else {
+ out = stk_alloc (stack, len, type)
+ }
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memr[out+i] = atan (real (Memi[in+i]))
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = atan (Memr[in+i])
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = atan (Memd[in+i])
+
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_ATAN2 -- Arc tangent function with two arguments
+
+procedure vex_atan2 (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+double vex_errf()
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ if (type == TY_INT) {
+ out = stk_alloc (stack, len, TY_REAL)
+ } else {
+ out = stk_alloc (stack, len, type)
+ }
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in[1]+i] == 0 && Memi[in[2]+i] == 0) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = atan2 (real (Memi[in[1]+i]),
+ real (Memi[in[2]+i]))
+ }
+ }
+
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in[1]+i] == 0.0 && Memr[in[2]+i] == 0.0) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = atan2 (Memr[in[1]+i], Memr[in[2]+i])
+ }
+ }
+
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in[1]+i] == 0.0 && Memd[in[2]+i] == 0.0) {
+ Memd[out+i] = vex_errf (stack, i)
+ } else {
+ Memd[out+i] = atan2 (Memd[in[1]+i], Memd[in[2]+i])
+ }
+ }
+
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_COPYD -- Copy the top element of the stack into a double array
+
+procedure vex_copyd (code, nullval, buffer, maxbuf)
+
+pointer code # i: Pseudocode structure pointer
+double nullval # i: Value to substitute for nulls
+double buffer[ARB] # o: Output array
+int maxbuf # i: Length of buffer
+#--
+int len, type, ibuf
+pointer stack, var, nullbuf
+
+string badsize "Cannot copy more elements than stack contains"
+
+begin
+ stack = VEX_STACK(code)
+ call stk_get (stack, TOP, var, len, type)
+
+ if (type != TY_DOUBLE)
+ call stk_coerce (stack, TOP, TY_DOUBLE, var)
+
+ if (maxbuf <= len) {
+ do ibuf = 1, maxbuf {
+ buffer[ibuf] = Memd[var]
+ var = var + 1
+ }
+
+ } else if (len != 0) {
+ call error (1, badsize)
+
+ } else {
+ do ibuf = 1, maxbuf
+ buffer[ibuf] = Memd[var]
+ }
+
+ # Set the null value in the output array
+
+ call stk_getnull (stack, nullbuf)
+ if (nullbuf != NULL) {
+ do ibuf = 1, maxbuf {
+ if (Memb[nullbuf])
+ buffer[ibuf] = nullval
+ if (len > 0)
+ nullbuf = nullbuf + 1
+ }
+ }
+
+ call stk_clear (stack)
+end
+
+# VEX_COPYI -- Copy the top element of the stack into an integer array
+
+procedure vex_copyi (code, nullval, buffer, maxbuf)
+
+pointer code # i: Pseudocode structure pointer
+int nullval # i: Value to substitute for nulls
+int buffer[ARB] # o: Output array
+int maxbuf # i: Length of buffer
+#--
+int len, type, ibuf
+pointer stack, var, nullbuf
+
+string badsize "Cannot copy more elements than stack contains"
+
+begin
+ stack = VEX_STACK(code)
+ call stk_get (stack, TOP, var, len, type)
+
+ if (type != TY_INT)
+ call stk_coerce (stack, TOP, TY_INT, var)
+
+ if (maxbuf <= len) {
+ do ibuf = 1, maxbuf {
+ buffer[ibuf] = Memi[var]
+ var = var + 1
+ }
+
+ } else if (len != 0) {
+ call error (1, badsize)
+
+ } else {
+ do ibuf = 1, maxbuf
+ buffer[ibuf] = Memi[var]
+ }
+
+ # Set the null value in the output array
+
+ call stk_getnull (stack, nullbuf)
+ if (nullbuf != NULL) {
+ do ibuf = 1, maxbuf {
+ if (Memb[nullbuf])
+ buffer[ibuf] = nullval
+ if (len > 0)
+ nullbuf = nullbuf + 1
+ }
+ }
+
+ call stk_clear (stack)
+end
+
+# VEX_COPYR -- Copy the top element of the stack into a real array
+
+procedure vex_copyr (code, nullval, buffer, maxbuf)
+
+pointer code # i: Pseudocode structure pointer
+real nullval # i: Value to substitute for nulls
+real buffer[ARB] # o: Output array
+int maxbuf # i: Length of buffer
+#--
+int len, type, ibuf
+pointer stack, var, nullbuf
+
+string badsize "Cannot copy more elements than stack contains"
+
+begin
+ stack = VEX_STACK(code)
+ call stk_get (stack, TOP, var, len, type)
+
+ if (type != TY_REAL)
+ call stk_coerce (stack, TOP, TY_REAL, var)
+
+ if (maxbuf <= len) {
+ do ibuf = 1, maxbuf {
+ buffer[ibuf] = Memr[var]
+ var = var + 1
+ }
+
+ } else if (len != 0) {
+ call error (1, badsize)
+
+ } else {
+ do ibuf = 1, maxbuf
+ buffer[ibuf] = Memr[var]
+ }
+
+ # Set the null value in the output array
+
+ call stk_getnull (stack, nullbuf)
+ if (nullbuf != NULL) {
+ do ibuf = 1, maxbuf {
+ if (Memb[nullbuf])
+ buffer[ibuf] = nullval
+ if (len > 0)
+ nullbuf = nullbuf + 1
+ }
+ }
+
+ call stk_clear (stack)
+end
+
+# VEX_COS -- Cosine function
+
+procedure vex_cos (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ if (type == TY_INT) {
+ out = stk_alloc (stack, len, TY_REAL)
+ } else {
+ out = stk_alloc (stack, len, type)
+ }
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memr[out+i] = cos (real (Memi[in+i]))
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = cos (Memr[in+i])
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = cos (Memd[in+i])
+
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_COSH -- Hyperbolic cosine function
+
+procedure vex_cosh (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+double vex_errf()
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ if (type == TY_INT) {
+ out = stk_alloc (stack, len, TY_REAL)
+ } else {
+ out = stk_alloc (stack, len, type)
+ }
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in+i] > MAX_EXP) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = cosh (real (Memi[in+i]))
+ }
+ }
+
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in+i] > MAX_EXP) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = cosh (Memr[in+i])
+ }
+ }
+
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in+i] > MAX_EXP) {
+ Memd[out+i] = vex_errf (stack, i)
+ } else {
+ Memd[out+i] = cosh (Memd[in+i])
+ }
+ }
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_CUBE -- Third power
+
+procedure vex_cube (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ out = stk_alloc (stack, len, type)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memi[out+i] = Memi[in+i] * Memi[in+i] * Memi[in+i]
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = Memr[in+i] * Memr[in+i] * Memr[in+i]
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = Memd[in+i] * Memd[in+i] * Memd[in+i]
+
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_DIM -- Positive difference
+
+procedure vex_dim (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, type)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memi[out+i] = dim (Memi[in[1]+i], Memi[in[2]+i])
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = dim (Memr[in[1]+i], Memr[in[2]+i])
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = dim (Memd[in[1]+i], Memd[in[2]+i])
+
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_DIV -- Division function
+
+procedure vex_div (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+double vex_errf()
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, type)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in[2]+i] == 0) {
+ Memi[out+i] = vex_errf (stack, i)
+ } else {
+ Memi[out+i] = Memi[in[1]+i] / Memi[in[2]+i]
+ }
+ }
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (abs(Memr[in[2]+i]) < MIN_REAL) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = Memr[in[1]+i] / Memr[in[2]+i]
+ }
+ }
+
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (abs(Memd[in[2]+i]) < MIN_DOUBLE) {
+ Memd[out+i] = vex_errf (stack, i)
+ } else {
+ Memd[out+i] = Memd[in[1]+i] / Memd[in[2]+i]
+ }
+ }
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_DOUBLE -- Convert to double
+
+procedure vex_double (stack)
+
+pointer stack # u: Stack descriptor
+#--
+pointer out
+
+begin
+ call stk_coerce (stack, TOP, TY_DOUBLE, out)
+
+end
+
+# VEX_EQ -- Logical equality
+
+procedure vex_eq (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, TY_INT)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in[1]+i] == Memi[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in[1]+i] == Memr[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in[1]+i] == Memd[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_ERRF -- Called when a function cannot be evaluated
+
+double procedure vex_errf (stack, index)
+
+pointer stack # u: Stack descriptor
+int index # i: Index to row with illegal operation
+double nil # i: Value substituted for illegal operation
+#--
+double substitute
+double temp
+
+data substitute / 0.0 /
+
+double vex_nilf()
+
+begin
+ call stk_initnull (stack, false)
+ call stk_setnull (stack, index)
+
+ return (substitute)
+
+ entry vex_nilf (nil)
+
+ temp = substitute
+ substitute = nil
+ return (temp)
+
+end
+
+# VEX_EXP -- Exponentiation function
+
+procedure vex_exp (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+double vex_errf()
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ if (type == TY_INT) {
+ out = stk_alloc (stack, len, TY_REAL)
+ } else {
+ out = stk_alloc (stack, len, type)
+ }
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in+i] > MAX_EXP) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = exp (real (Memi[in+i]))
+ }
+ }
+
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in+i] > MAX_EXP) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = exp (Memr[in+i])
+ }
+ }
+
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in+i] > MAX_EXP) {
+ Memd[out+i] = vex_errf (stack, i)
+ } else {
+ Memd[out+i] = exp (Memd[in+i])
+ }
+ }
+
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_GE -- Greater than or equal to function
+
+procedure vex_ge (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, TY_INT)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in[1]+i] >= Memi[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in[1]+i] >= Memr[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in[1]+i] >= Memd[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_GT -- Greater than function
+
+procedure vex_gt (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, TY_INT)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in[1]+i] > Memi[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in[1]+i] > Memr[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in[1]+i] > Memd[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_IF -- Conditional evaluation
+
+procedure vex_if (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, index, i
+pointer out, in[3]
+
+int stk_pos()
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 3, in, len, type)
+ index = stk_pos (stack, 3)
+ call stk_coerce (stack, index, TY_INT, in[1])
+
+ out = stk_alloc (stack, len, type)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in[1]+i] != 0) {
+ Memi[out+i] = Memi[in[2]+i]
+ } else {
+ Memi[out+i] = Memi[in[3]+i]
+ }
+ }
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memi[in[1]+i] != 0) {
+ Memr[out+i] = Memr[in[2]+i]
+ } else {
+ Memr[out+i] = Memr[in[3]+i]
+ }
+ }
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memi[in[1]+i] != 0) {
+ Memd[out+i] = Memd[in[2]+i]
+ } else {
+ Memd[out+i] = Memd[in[3]+i]
+ }
+ }
+ }
+
+ call stk_pop (stack, 3)
+end
+
+# VEX_INT -- Convert to integer
+
+procedure vex_int (stack)
+
+pointer stack # u: Stack descriptor
+#--
+pointer out
+
+begin
+ call stk_coerce (stack, TOP, TY_INT, out)
+
+end
+
+# VEX_LE -- Less than or equal to function
+
+procedure vex_le (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, TY_INT)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in[1]+i] <= Memi[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in[1]+i] <= Memr[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in[1]+i] <= Memd[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_LT -- Less than function
+
+procedure vex_lt (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, TY_INT)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in[1]+i] < Memi[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in[1]+i] < Memr[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in[1]+i] < Memd[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_LOG -- Natural log function
+
+procedure vex_log (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+double vex_errf()
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ if (type == TY_INT) {
+ out = stk_alloc (stack, len, TY_REAL)
+ } else {
+ out = stk_alloc (stack, len, type)
+ }
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in+i] <= 0) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = log (real (Memi[in+i]))
+ }
+ }
+
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in+i] <= 0.0) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = log (Memr[in+i])
+ }
+ }
+
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in+i] <= 0.0) {
+ Memd[out+i] = vex_errf (stack, i)
+ } else {
+ Memd[out+i] = log (Memd[in+i])
+ }
+ }
+
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_LOG10 -- Common log function
+
+procedure vex_log10 (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+double vex_errf()
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ if (type == TY_INT) {
+ out = stk_alloc (stack, len, TY_REAL)
+ } else {
+ out = stk_alloc (stack, len, type)
+ }
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in+i] <= 0) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = log10 (real (Memi[in+i]))
+ }
+ }
+
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in+i] <= 0.0) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = log10 (Memr[in+i])
+ }
+ }
+
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in+i] <= 0.0) {
+ Memd[out+i] = vex_errf (stack, i)
+ } else {
+ Memd[out+i] = log10 (Memd[in+i])
+ }
+ }
+
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_MAX -- Maximum of two numbers
+
+procedure vex_max (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, type)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memi[out+i] = max (Memi[in[1]+i], Memi[in[2]+i])
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = max (Memr[in[1]+i], Memr[in[2]+i])
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = max (Memd[in[1]+i], Memd[in[2]+i])
+
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_MIN -- Minimum of two numbers
+
+procedure vex_min (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, type)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memi[out+i] = min (Memi[in[1]+i], Memi[in[2]+i])
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = min (Memr[in[1]+i], Memr[in[2]+i])
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = min (Memd[in[1]+i], Memd[in[2]+i])
+
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_MOD -- Remainder function
+
+procedure vex_mod (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, type)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memi[out+i] = mod (Memi[in[1]+i], Memi[in[2]+i])
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = mod (Memr[in[1]+i], Memr[in[2]+i])
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = mod (Memd[in[1]+i], Memd[in[2]+i])
+
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_MUL -- Multiplication function
+
+procedure vex_mul (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, type)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memi[out+i] = Memi[in[1]+i] * Memi[in[2]+i]
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = Memr[in[1]+i] * Memr[in[2]+i]
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = Memd[in[1]+i] * Memd[in[2]+i]
+
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_NE -- Logical inequality
+
+procedure vex_ne (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, TY_INT)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in[1]+i] != Memi[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in[1]+i] != Memr[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in[1]+i] != Memd[in[2]+i]) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_NEG -- Negation function
+
+procedure vex_neg (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ out = stk_alloc (stack, len, type)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memi[out+i] = - Memi[in+i]
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = - Memr[in+i]
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = - Memd[in+i]
+
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_NINT -- Nearest integer
+
+procedure vex_nint (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer in, out
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ out = stk_alloc (stack, len, type)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memi[out+i] = Memi[in+i]
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = anint (Memr[in+i])
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = anint (Memd[in+i])
+
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_NOT -- Logical negation
+
+procedure vex_not (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ out = stk_alloc (stack, len, TY_INT)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in+i] != 0) {
+ Memi[out+i] = 0
+ } else {
+ Memi[out+i] = 1
+ }
+ }
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in+i] != 0.0) {
+ Memi[out+i] = 0
+ } else {
+ Memi[out+i] = 1
+ }
+ }
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in+i] != 0.0) {
+ Memi[out+i] = 0
+ } else {
+ Memi[out+i] = 1
+ }
+ }
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_OR -- Logical or
+
+procedure vex_or (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, TY_INT)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in[1]+i] != 0 || Memi[in[2]+i] != 0) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in[1]+i] != 0.0 || Memr[in[2]+i] != 0.0) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in[1]+i] != 0.0 || Memd[in[2]+i] != 0.0) {
+ Memi[out+i] = 1
+ } else {
+ Memi[out+i] = 0
+ }
+ }
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_POW -- Exponentiation function
+
+procedure vex_pow (stack)
+
+pointer stack # u: Stack descriptor
+#--
+double dtemp
+int index, len, type, i
+pointer out, in[2]
+real rtemp
+
+double vex_errf()
+int stk_pos()
+pointer stk_alloc()
+
+begin
+ # If the exponent is an integer, use the normal exponentiation
+ # otherwise, use the logarithmic formulation
+
+ call stk_get (stack, TOP, in[2], len, type)
+
+ if (type == TY_INT) {
+ index = stk_pos (stack, 2)
+ call stk_get (stack, index, in[1], len, type)
+
+ out = stk_alloc (stack, len, type)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memi[out+i] = Memi[in[1]+i] ** Memi[in[2]+i]
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = Memr[in[1]+i] ** Memi[in[2]+i]
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = Memd[in[1]+i] ** Memi[in[2]+i]
+ }
+
+ } else {
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, type)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in[1]+i] <= 0.0) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ rtemp = Memr[in[2]+i] * log(Memr[in[1]+i])
+ if (rtemp > MAX_EXP) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = exp (rtemp)
+ }
+ }
+ }
+
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in[1]+i] <= 0.0) {
+ Memd[out+i] = vex_errf (stack, i)
+ } else {
+ dtemp = Memd[in[2]+i] * log(Memd[in[1]+i])
+ if (dtemp > MAX_EXP) {
+ Memd[out+i] = vex_errf (stack, i)
+ } else {
+ Memd[out+i] = exp (dtemp)
+ }
+ }
+ }
+ }
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_PUSH -- Push a token onto the stack
+
+procedure vex_push (stack, getvar, type, token)
+
+pointer stack # i: Stack structure
+extern getvar # i: Function to return a variable
+int type # i: Token type
+char token[ARB] # i: Token string
+#--
+double dval
+int len, ic, nc, ival
+pointer sp, errmsg, var
+real rval
+
+string badtype "Unrecognized token type (%d)"
+
+int ctoi(), ctor(), ctod()
+pointer stk_alloc()
+errchk getvar
+
+begin
+ call smark (sp)
+ call salloc (errmsg, SZ_LINE, TY_CHAR)
+
+ len = STK_LENVAL(stack)
+
+ switch (type) {
+ case Y_VAR:
+ call getvar (stack, token)
+
+ case Y_INT:
+ var = stk_alloc (stack, len, TY_INT)
+
+ ic = 1
+ len = max (len, 1)
+ nc = ctoi (token, ic, ival)
+ call amovki (ival, Memi[var], len)
+
+ case Y_REAL:
+ var = stk_alloc (stack, len, TY_REAL)
+
+ ic = 1
+ len = max (len, 1)
+ nc = ctor (token, ic, rval)
+ call amovkr (rval, Memr[var], len)
+
+ case Y_DOUBLE:
+ var = stk_alloc (stack, len, TY_DOUBLE)
+
+ ic = 1
+ len = max (len, 1)
+ nc = ctod (token, ic, dval)
+ call amovkd (dval, Memd[var], len)
+
+ default:
+ call sprintf (Memc[errmsg], SZ_LINE, badtype)
+ call pargi (type)
+ call error (1, Memc[errmsg])
+ }
+
+ call sfree (sp)
+end
+
+# VEX_REAL -- Convert to real
+
+procedure vex_real (stack)
+
+pointer stack # u: Stack descriptor
+#--
+pointer out
+
+begin
+ call stk_coerce (stack, TOP, TY_REAL, out)
+
+end
+
+# VEX_SIG -- Sign transfer function
+
+procedure vex_sig (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, type)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memi[out+i] = sign (Memi[in[1]+i], Memi[in[2]+i])
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = sign (Memr[in[1]+i], Memr[in[2]+i])
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = sign (Memd[in[1]+i], Memd[in[2]+i])
+
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_SIN -- Sine function
+
+procedure vex_sin (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ if (type == TY_INT) {
+ out = stk_alloc (stack, len, TY_REAL)
+ } else {
+ out = stk_alloc (stack, len, type)
+ }
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memr[out+i] = sin (real (Memi[in+i]))
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = sin (Memr[in+i])
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = sin (Memd[in+i])
+
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_SINH -- Hyperbolic sine function
+
+procedure vex_sinh (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+double vex_errf()
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ if (type == TY_INT) {
+ out = stk_alloc (stack, len, TY_REAL)
+ } else {
+ out = stk_alloc (stack, len, type)
+ }
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in+i] > MAX_EXP) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = sinh (real (Memi[in+i]))
+ }
+ }
+
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in+i] > MAX_EXP) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = sinh (Memr[in+i])
+ }
+ }
+
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in+i] > MAX_EXP) {
+ Memd[out+i] = vex_errf (stack, i)
+ } else {
+ Memd[out+i] = sinh (Memd[in+i])
+ }
+ }
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_SQR -- Second power
+
+procedure vex_sqr (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ out = stk_alloc (stack, len, type)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memi[out+i] = Memi[in+i] * Memi[in+i]
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = Memr[in+i] * Memr[in+i]
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = Memd[in+i] * Memd[in+i]
+
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_SQRT -- Square root function
+
+procedure vex_sqrt (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+double vex_errf()
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ if (type == TY_INT) {
+ out = stk_alloc (stack, len, TY_REAL)
+ } else {
+ out = stk_alloc (stack, len, type)
+ }
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1 {
+ if (Memi[in+i] < 0) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = sqrt (real (Memi[in+i]))
+ }
+ }
+
+ case TY_REAL:
+ do i = 0, len-1 {
+ if (Memr[in+i] < 0.0) {
+ Memr[out+i] = vex_errf (stack, i)
+ } else {
+ Memr[out+i] = sqrt (Memr[in+i])
+ }
+ }
+
+ case TY_DOUBLE:
+ do i = 0, len-1 {
+ if (Memd[in+i] < 0.0) {
+ Memd[out+i] = vex_errf (stack, i)
+ } else {
+ Memd[out+i] = sqrt (Memd[in+i])
+ }
+ }
+
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_SUB -- Subtraction function
+
+procedure vex_sub (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in[2]
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 2, in, len, type)
+ out = stk_alloc (stack, len, type)
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memi[out+i] = Memi[in[1]+i] - Memi[in[2]+i]
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = Memr[in[1]+i] - Memr[in[2]+i]
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = Memd[in[1]+i] - Memd[in[2]+i]
+
+ }
+
+ call stk_pop (stack, 2)
+end
+
+# VEX_TAN -- Tangent function
+
+procedure vex_tan (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ if (type == TY_INT) {
+ out = stk_alloc (stack, len, TY_REAL)
+ } else {
+ out = stk_alloc (stack, len, type)
+ }
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memr[out+i] = tan (real (Memi[in+i]))
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = tan (Memr[in+i])
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = tan (Memd[in+i])
+
+ }
+
+ call stk_pop (stack, 1)
+end
+
+# VEX_TANH -- Hyperbolic tangent function
+
+procedure vex_tanh (stack)
+
+pointer stack # u: Stack descriptor
+#--
+int len, type, i
+pointer out, in
+
+pointer stk_alloc()
+
+begin
+ call stk_fetch (stack, 1, in, len, type)
+ if (type == TY_INT) {
+ out = stk_alloc (stack, len, TY_REAL)
+ } else {
+ out = stk_alloc (stack, len, type)
+ }
+ len = max (len, 1)
+
+ switch (type) {
+ case TY_INT, TY_LONG:
+ do i = 0, len-1
+ Memr[out+i] = tanh (real (Memi[in+i]))
+
+ case TY_REAL:
+ do i = 0, len-1
+ Memr[out+i] = tanh (Memr[in+i])
+
+ case TY_DOUBLE:
+ do i = 0, len-1
+ Memd[out+i] = tanh (Memd[in+i])
+
+ }
+
+ call stk_pop (stack, 1)
+end
+
+
+
+
generated by cgit (git 2.34.1) at 2025-09-20 05:04:52 -0400