Repatch (from linux) of OSX IRAF

1 files changed, 585 insertions, 0 deletions

diff --git a/pkg/utilities/nttools/stxtools/vexstack.x b/pkg/utilities/nttools/stxtools/vexstack.x
new file mode 100644
index 00000000..8f51b2bb
--- /dev/null
+++ b/pkg/utilities/nttools/stxtools/vexstack.x
@@ -0,0 +1,585 @@
+include "vex.h"
+
+# VEX_STACK -- Procedures which manipulate the vex stack
+#
+# The expression evaluator, vex_eval, uses a stack to hold intermediate
+# results, constants, and variable names in the expression. There are
+# actually two stacks, a type stack wich contains the data types of the
+# elements on the stack, and a value stack, which contains pointers to
+# the stack elements. Constants and variable names are stored in two
+# buffers which are part of the stack structure and pointers to their
+# locations are placed on the stack. Intermediate results are stored in 
+# malloc'ed arrays and their pointers are also placed on the stack. The
+# stack structure contains three indices, bottom, an index one greater
+# than the last constant or variable name, top, an index that is one 
+# greater than the current top of stack, and high, an index that is one 
+# greater than the last valid pointer on the stack. Valid pointers exist
+# beyond the top of stack because the arrays which store intermediate 
+# results are not mfree'd when the stack is popped, instead, they are 
+# kept in case they may be needed for a future intermediate result. The 
+# only user callable procedure in this file is stk_alloc, which should 
+# be called by getvar, the user's function which fills an array when
+# passed the name of a variable.
+#
+# B.Simon	24-Apr-91	Original
+# B.Simon	15-Oct-98	Store strings in pseudocode, not on stack
+
+# STK_ALLOC -- Allocate an array of the specified length and type
+
+pointer procedure stk_alloc (stack, len, type)
+
+pointer	stack		# i: Stack structure
+int	len		# i: Length of array to allocate
+int	type		# i: Data type of array (spp type)
+#--
+int	index, stype, top
+pointer	var, svar
+
+string	badstack  "stk_alloc: illegal type on stack"
+string	badsize   "Requested array size does not match previous requests"
+
+errchk	stk_find
+
+begin
+	# Check to see if array length is being defined for the first time
+
+	if (STK_LENVAL(stack) == 0 && len != 0) {
+
+	    # Store length in stack structure
+
+	    STK_LENVAL(stack) = len
+
+	    # Free all stack arrays not currently being used
+
+	    index = STK_TOP(stack)
+	    while (index < STK_HIGH(stack)) {
+		svar = STK_VALUE(stack,index)
+		stype = STK_TYPE(stack,index)
+		call mfree (svar, stype)
+		index = index + 1
+	    }
+	    STK_HIGH(stack) = STK_TOP(stack)
+
+	    # Reallocate the null buffer
+
+	    if (STK_NULLARY(stack) != NULL) {
+		call stk_freenull (stack)
+		call stk_initnull (stack, true)
+	    }
+
+	    # Convert length one arrays to their full length
+
+	    index = 0
+	    while (index < STK_TOP(stack)) {
+	        svar = STK_VALUE(stack,index)
+		stype = STK_TYPE(stack,index)
+
+		call malloc (var, len, stype)
+		STK_VALUE(stack,index) = var
+		switch (stype) {
+		case TY_INT,TY_LONG:
+		    call amovki (Memi[svar], Memi[var], len)
+		    call mfree (svar, TY_INT)
+		case TY_REAL:
+		    call amovkr (Memr[svar], Memr[var], len)
+		    call mfree (svar, TY_REAL)
+		case TY_DOUBLE:
+		    call amovkd (Memd[svar], Memd[var], len)
+		    call mfree (svar, TY_DOUBLE)
+		default:
+		    call error (1, badstack)
+		}		
+		index = index + 1
+	    }
+	}
+
+	# Check requested size
+
+	if (len != 0 && len != STK_LENVAL(stack))
+	    call error (1, badsize)
+
+	# Look for an existing array of the same type
+
+	call stk_find (stack, type, index)
+
+	# Increment top of stack pointer
+
+	top = STK_TOP(stack)
+	STK_TOP(stack) = top + 1
+
+	# Swap array with one currently at top of stack
+
+	if (top != index) {
+	    stype = STK_TYPE(stack,top)
+	    STK_TYPE(stack,top) = STK_TYPE(stack,index)
+	    STK_TYPE(stack,index) = stype
+
+	    svar = STK_VALUE(stack,top)
+	    STK_VALUE(stack,top) = STK_VALUE(stack,index)
+	    STK_VALUE(stack,index) = svar
+	}
+
+	var = STK_VALUE(stack,top)
+	return (var)
+end
+
+# STK_CLEAR -- Clear all stack elements above the bottom
+
+procedure stk_clear (stack)
+
+pointer	stack		# u: Stack pointer
+#--
+int	index
+
+begin
+	# Free all value arrays above the bottom of stack
+
+	index = 0
+	while (index < STK_HIGH(stack)) {
+	    call mfree (STK_VALUE(stack,index), STK_TYPE(stack,index))
+	    index = index + 1
+	}
+
+	# Free null array
+
+	call stk_freenull (stack)
+
+	# Reset scalars
+
+	STK_TOP(stack) = 0
+	STK_HIGH(stack) = 0
+	STK_LENVAL(stack) = 0
+end
+
+# STK_COERCE -- Coerce an array in the stack to the specified type
+
+procedure stk_coerce (stack, pos, type, var)
+
+pointer	stack		# i: Stack descriptor
+int	pos		# i: Position of array in stack
+int	type		# i: New type for array
+pointer	var		# o: New pointer to array
+#--
+int	index, last, stype, len, i
+pointer	svar
+
+string	underflow  "stk_coerce: underflow in expression evaluator"
+
+errchk	stk_find
+
+begin
+	# Convert relative to absolute position
+
+	if (pos == TOP) {
+	    index = STK_TOP(stack) - 1
+	    if (index < 0)
+		call error (1, underflow)
+	} else {
+	    index = pos
+	}
+
+	# If type of array matches requested type, return pointer to array
+	# Otherwise, get new array and copy old array to it
+
+	if (type == STK_TYPE(stack,index)) {
+	    var = STK_VALUE(stack,index)
+
+	} else {
+	    # Find array of correct type
+
+	    last = index
+	    call stk_find (stack, type, index)
+
+	    # Copy array, converting to new type
+
+	    len = max (1, STK_LENVAL(stack))
+	    var = STK_VALUE(stack,index)
+
+	    stype = STK_TYPE(stack,last)
+	    svar = STK_VALUE(stack,last)
+
+	    switch (type) {
+	    case TY_INT,TY_LONG:
+		switch (stype) {
+		case TY_INT,TY_LONG:
+		    ; # can't happen
+		case TY_REAL:
+		    do i = 0, len-1 {
+			if (IS_INDEFR(Memr[svar+i])) {
+			    Memi[var+i] = INDEFI
+			} else {
+			    Memi[var+i] = Memr[svar+i]
+			}
+		    }
+		case TY_DOUBLE:
+		    do i = 0, len-1 {
+			if (IS_INDEFD(Memd[svar+i])) {
+			    Memi[var+i] = INDEFI
+			} else {
+			    Memi[var+i] = Memd[svar+i]
+			}
+		    }
+		}
+	    case TY_REAL:
+		switch (stype) {
+		case TY_INT,TY_LONG:
+		    do i = 0, len-1 {
+			if (IS_INDEFI(Memi[svar+i])) {
+			    Memr[var+i] = INDEFR
+			} else {
+			    Memr[var+i] = Memi[svar+i]
+			}
+		    }
+		case TY_REAL:
+		    ; # can't happen
+		case TY_DOUBLE:
+		    do i = 0, len-1 {
+			if (IS_INDEFD(Memd[svar+i])) {
+			    Memr[var+i] = INDEFR
+			} else {
+			    Memr[var+i] = Memd[svar+i]
+			}
+		    }
+		}
+	    case TY_DOUBLE:
+		switch (stype) {
+		case TY_INT,TY_LONG:
+		    do i = 0, len-1 {
+			if (IS_INDEFI(Memi[svar+i])) {
+			    Memd[var+i] = INDEFD
+			} else {
+			    Memd[var+i] = Memi[svar+i]
+			}
+		    }
+		case TY_REAL:
+		    do i = 0, len-1 {
+			if (IS_INDEFR(Memr[svar+i])) {
+			    Memd[var+i] = INDEFD
+			} else {
+			    Memd[var+i] = Memr[svar+i]
+			}
+		    }
+		case TY_DOUBLE:
+		    ; # can't happen
+		}
+	    }
+
+	    # Swap position of new and old arrays on stack
+
+	    STK_TYPE(stack,last) = STK_TYPE(stack,index)
+	    STK_TYPE(stack,index) = stype
+
+	    STK_VALUE(stack,last) = STK_VALUE(stack,index)
+	    STK_VALUE(stack,index) = svar
+	}
+	
+end
+
+# STK_FETCH -- Fetch the specified number of arrays from the stack
+
+procedure stk_fetch (stack, nvar, var, len, type)
+
+pointer	stack		# i: Stack descriptor
+int	nvar		# i: Number of pointers requested
+pointer	var[ARB]	# o: Array pointers
+int	len		# o: Length of arrays
+int	type		# o: Type of arrays
+#--
+int	one, two, index, ivar
+
+string	underflow  "stk_fetch: underflow in expression evaluator"
+
+errchk	stk_coerce
+
+begin
+	# If length is not yet defined, STK_LENVAL equals zero
+
+	len = STK_LENVAL(stack)
+
+	# Find the highest type in the pointers to be returned
+
+	one = STK_TOP(stack) - 1
+	two = STK_TOP(stack) - 2
+
+	type = STK_TYPE(stack,one)
+	if (nvar > 1) {
+	    switch (STK_TYPE(stack,two)) {
+	    case TY_INT, TY_LONG:
+		;
+	    case TY_REAL:
+		if (type == TY_INT)
+		    type = TY_REAL
+	    case TY_DOUBLE:
+		type = TY_DOUBLE
+	    }
+	}
+
+	# Retrieve pointers to arrays from stack. var[nvar] is top of stack
+	# Convert arrays to output type when the type differs
+
+	index = STK_TOP(stack) - nvar
+	do ivar = 1, nvar {
+	    if (index < 0)
+		call error (1, underflow)
+
+	    if (type == STK_TYPE(stack,index) || index < two) {
+		var[ivar] = STK_VALUE(stack,index)
+	    } else {
+	        call stk_coerce (stack, index, type, var[ivar])
+	    }
+	    index = index + 1
+	}
+
+end
+
+# STK_FIND -- Find a free array of the proper type on the stack
+
+procedure stk_find (stack, type, index)
+
+pointer	stack		# i: Stack descriptor
+int	type		# i: Required type
+int	index		# o: Position on the stack
+#--
+int	len
+pointer	var
+
+string	overflow  "Expression too complex to be evaluated"
+
+begin
+	# Try to find an array of the proper type already on the stack
+
+	index = STK_TOP(stack)
+	while (index < STK_HIGH(stack)) {
+	    if (type == STK_TYPE(stack,index))
+		break
+
+	    index = index + 1
+	}
+
+	# If not found, allocate a new array
+
+	if (index == MAX_STACK) {
+	    call error (1, overflow)
+
+	} else if (index == STK_HIGH(stack)) {
+	    len = max (1, STK_LENVAL(stack))
+	    call malloc (var, len, type)
+
+	    STK_TYPE(stack,index) = type
+	    STK_VALUE(stack,index) = var
+	    STK_HIGH(stack) = STK_HIGH(stack) + 1
+	}
+
+end
+
+# STK_FREE -- Free memory used by the stack
+
+procedure stk_free (stack)
+
+pointer	stack		# u: Stack pointer
+#--
+
+begin
+	# Free all values above the stack bottom
+
+	call stk_clear (stack)
+
+	# Free substructures in stack
+
+	if (STK_NULLARY(stack) != NULL)
+	    call mfree (STK_NULLARY(stack), TY_BOOL)
+
+	call mfree (STK_VALARY(stack), TY_INT)
+	call mfree (STK_TYPARY(stack), TY_INT)
+
+	# Free the stack structure
+	call mfree (stack, TY_INT)
+end
+
+# STK_FREENULL -- Free the null array in the stack
+
+procedure stk_freenull (stack)
+
+pointer	stack		# u: Stack structure
+#--
+
+begin
+	if (STK_NULLARY(stack) != NULL)
+	    call mfree (STK_NULLARY(stack), TY_BOOL)
+
+	STK_NULLARY(stack) = NULL
+end
+
+# STK_GET -- Get a single array from the stack
+
+procedure stk_get (stack, pos, var, len, type)
+
+pointer	stack		# i: Stack descriptor
+int	pos		# i: Position on the stack
+pointer	var		# o: Pointer to array
+int	len		# o: Length of array
+int	type		# o: Type of the array
+#--
+int	index
+
+string	underflow  "stk_get: underflow in expression evaluator"
+
+begin
+	# Convert relative to absolute position
+
+	if (pos == TOP) {
+	    index = STK_TOP(stack) - 1
+	    if (index < 0)
+		call error (1, underflow)
+	} else {
+	    index = pos
+	}
+
+	var = STK_VALUE(stack,index)
+	len = STK_LENVAL(stack)
+	type = STK_TYPE(stack,index)
+end
+
+# STK_GETNULL -- Get the null array from the stack
+
+procedure stk_getnull (stack, nullvec)
+
+pointer	stack		# i: Stack structure
+pointer nullvec		# o: Null array
+#--
+
+begin
+	nullvec = STK_NULLARY(stack)
+end
+
+# STK_INIT -- Initialize the stack
+
+procedure stk_init (stack)
+
+pointer	stack		# o: Stack pointer
+#--
+
+begin
+	# Allocate stack and initialize members to zero
+
+	call calloc (stack, SZ_STKSTRUCT, TY_INT)
+
+	# Allocate substructures in stack
+
+	call malloc (STK_VALARY(stack), MAX_STACK, TY_INT)
+	call malloc (STK_TYPARY(stack), MAX_STACK, TY_INT)
+
+end
+
+# STK_INITNULL -- Initialize the null array on the stack
+
+procedure stk_initnull (stack, value)
+
+pointer	stack		# u: Stack structure
+bool	value		# i: Value used in initialization
+#--
+int	len, i
+pointer	nullvec
+
+begin
+	# Only initialize if array doesn't exist
+
+	if (STK_NULLARY(stack) == NULL) {
+	    len = STK_LENVAL(stack)
+
+	    # Allocate array
+	    call malloc (nullvec, len, TY_BOOL)
+	    STK_NULLARY(stack) = nullvec
+
+	    # Initialize to value
+	    do i = 0, len-1
+		Memb[nullvec+i] = value
+	}
+
+end
+
+# STK_ORNULL -- Update null array by doing a logical or
+
+procedure stk_ornull (stack, newvec, newlen)
+
+pointer	stack		# u: Stack structure
+bool	newvec[ARB]	# i: Array of new values
+int	newlen		# i: Length of new array 
+#--
+int	len, i
+pointer	nullvec
+
+string	badlength  "stk_ornull: length of array does not match null array"
+
+begin
+	len = STK_LENVAL(stack)
+	if (len != newlen)
+	    call error (1, badlength)
+
+	call stk_initnull (stack, false)
+	nullvec = STK_NULLARY(stack)
+
+	do i = 1, len {
+	    Memb[nullvec] = Memb[nullvec] || newvec[i]
+	    nullvec = nullvec + 1
+	}
+
+end
+
+# STK_POP -- Remove the specified number of arrays from the stack
+
+procedure stk_pop (stack, npop)
+
+pointer	stack		# u: Stack structure
+int	npop		# i: Number of arrays to pop
+#--
+int	top, index, type
+pointer	var
+
+string	underflow  "stk_pop: underflow in expression evaluator"
+
+begin
+
+	top = STK_TOP(stack) - 1
+	index = top - npop
+
+	if (index < 0) {
+	    call error (1, underflow)
+	} else {
+	    STK_TOP(stack) = index + 1
+	}
+
+	var = STK_VALUE(stack,index)
+	STK_VALUE(stack,index) = STK_VALUE(stack,top)
+	STK_VALUE(stack,top) = var
+
+	type = STK_TYPE(stack,index)
+	STK_TYPE(stack,index) = STK_TYPE(stack,top)
+	STK_TYPE(stack,top) = type
+
+end
+
+# STK_POS -- Compute absolute position on stack
+
+int procedure stk_pos (stack, pos)
+
+pointer	stack		# i: Stack structure
+int	pos		# i: Position relative to top of stack
+#--
+
+begin
+	return (STK_TOP(stack) - pos)
+end
+
+# STK_SETNULL -- Set a single value in the null array to true
+
+procedure stk_setnull (stack, index)
+
+pointer	stack		# u: Stack structure
+int	index		# i: Index into null array
+#--
+
+begin
+	STK_NULL(stack,index) = true
+end
+