Repatch (from linux) of OSX IRAF

1 files changed, 162 insertions, 0 deletions

diff --git a/pkg/xtools/ranges/rgxranges.gx b/pkg/xtools/ranges/rgxranges.gx
new file mode 100644
index 00000000..7a779925
--- /dev/null
+++ b/pkg/xtools/ranges/rgxranges.gx
@@ -0,0 +1,162 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<error.h>
+include	<ctype.h>
+include	<pkg/rg.h>
+
+define	NRGS	10		# Allocation size
+
+# RG_XRANGES -- Parse a range string corrsponding to a real set of values.
+# Return a pointer to the ranges.
+
+pointer procedure rg_xranges$t (rstr, rvals, npts)
+
+char	rstr[ARB]		# Range string
+PIXEL	rvals[npts]		# Range values (sorted)
+int	npts			# Number of range values
+pointer	rg			# Range pointer
+
+int	i, fd, strlen(), open(), getline()
+pointer	sp, str, ptr
+errchk	open, rg_xadd$t
+
+begin
+	# Check for valid arguments
+	if (npts < 1)
+	    call error (0, "No data points for range determination")
+
+	call smark (sp)
+	call salloc (str, max (strlen (rstr), SZ_LINE), TY_CHAR)
+	call calloc (rg, LEN_RG, TY_STRUCT)
+
+	i = 1
+	while (rstr[i] != EOS) {
+
+	    # Find beginning and end of a range and copy it to the work string
+	    while (IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n')
+	        i = i + 1
+	    if (rstr[i] == EOS)
+		break
+
+	    ptr = str
+	    while (!(IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n' ||
+		rstr[i]==EOS)) {
+		Memc[ptr] = rstr[i]
+	        i = i + 1
+		ptr = ptr + 1
+	    }
+	    Memc[ptr] = EOS
+
+	    # Add range(s)
+	    iferr {
+		if (Memc[str] == '@') {
+		    fd = open (Memc[str+1], READ_ONLY, TEXT_FILE)
+		    while (getline (fd, Memc[str]) != EOF) {
+			iferr (call rg_xadd$t (rg, Memc[str], rvals, npts))
+			    call erract (EA_WARN)
+		    }
+		    call close (fd)
+		} else
+		    call rg_xadd$t (rg, Memc[str], rvals, npts)
+	    } then
+		call erract (EA_WARN)
+	}
+
+	call sfree (sp)
+	return (rg)
+end
+
+
+# RG_XADD -- Add a range
+
+procedure rg_xadd$t (rg, rstr, rvals, npts)
+
+pointer	rg			# Range descriptor
+char	rstr[ARB]		# Range string
+PIXEL	rvals[npts]		# Range values (sorted)
+int	npts			# Number of range values
+
+int	i, j, k, nrgs, strlen(), cto$t()
+PIXEL	rval1, rval2, a1, b1, a2, b2
+pointer	sp, str, ptr
+
+begin
+	call smark (sp)
+	call salloc (str, strlen (rstr), TY_CHAR)
+
+	i = 1
+	while (rstr[i] != EOS) {
+
+	    # Find beginning and end of a range and copy it to the work string
+	    while (IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n')
+	        i = i + 1
+	    if (rstr[i] == EOS)
+		break
+
+	    ptr = str
+	    while (!(IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n' ||
+		rstr[i]==EOS)) {
+		if (rstr[i] == ':')
+		    Memc[ptr] = ' '
+		else
+		    Memc[ptr] = rstr[i]
+	        i = i + 1
+		ptr = ptr + 1
+	    }
+	    Memc[ptr] = EOS
+
+	    # Parse range
+	    if (Memc[str] == '@')
+		call error (1, "Cannot nest @files")
+	    else if (Memc[str] == '*') {
+		rval1 = rvals[1]
+		rval2 = rvals[npts]
+	    } else {
+		# Get range
+		j = 1
+		if (cto$t (Memc[str], j, rval1) == 0)
+		    call error (1, "Range syntax error")
+		rval2 = rval1
+		if (cto$t (Memc[str], j, rval2) == 0)
+		    ;
+	    }
+
+	    # Check limits and find indices into rval array
+	    a1 = min (rval1, rval2)
+	    b1 = max (rval1, rval2)
+	    a2 = min (rvals[1], rvals[npts])
+	    b2 = max (rvals[1], rvals[npts])
+	    if ((b1 >= a2) && (a1 <= b2)) {
+		a1 = max (a2, min (b2, a1))
+		b1 = max (a2, min (b2, b1))
+		if (rvals[1] <= rvals[npts]) {
+		    for (k = 1; (k <= npts) && (rvals[k] < a1); k = k + 1)
+			;
+		    for (j = k; (j <= npts) && (rvals[j] <= b1); j = j + 1)
+			;
+		    j = j - 1
+		} else {
+		    for (k = 1; (k <= npts) && (rvals[k] > b1); k = k + 1)
+			;
+		    for (j = k; (j <= npts) && (rvals[j] >= a1); j = j + 1)
+			;
+		    j = j - 1
+		}
+
+		# Add range
+		if (k <= j) {
+		    nrgs = RG_NRGS(rg)
+		    if (mod (nrgs, NRGS) == 0)
+			call realloc (rg, LEN_RG+2*(nrgs+NRGS), TY_STRUCT)
+		    nrgs = nrgs + 1
+		    RG_NRGS(rg) = nrgs
+		    RG_X1(rg, nrgs) = k
+		    RG_X2(rg, nrgs) = j
+		    RG_NPTS(rg) = RG_NPTS(rg) +
+			RG_X1(rg, nrgs) - RG_X2(rg, nrgs) + 1
+		}
+	    }
+	}
+
+	call sfree (sp)
+end