Repatch (from linux) of OSX IRAF

1 files changed, 537 insertions, 0 deletions

diff --git a/pkg/dataio/export/bltins/exeps.x b/pkg/dataio/export/bltins/exeps.x
new file mode 100644
index 00000000..b7189896
--- /dev/null
+++ b/pkg/dataio/export/bltins/exeps.x
@@ -0,0 +1,537 @@
+include <evvexpr.h>
+include <imhdr.h>
+include <mach.h>
+include <fset.h>
+include "../export.h"
+include "../exbltins.h"
+
+
+define	SZ_EPSSTRUCT	    5
+define	EPS_ITEMSPERLINE    Memi[$1]		# no. of items per line
+define	EPS_HPTR	    Memi[$1+1]		# ptr to hex digit string
+define	EPS_BPTR	    Memi[$1+2]		# ptr to output buffer
+define	EPS_BCNT	    Memi[$1+3]		# index into output buffer
+define	HEXSTR		    Memc[EPS_HPTR($1)+$2]
+define	BUF		    Memc[EPS_BPTR($1)+$2-1]
+
+define	LINEWID		    36			# hexstr pixels per line
+define	HEXITS         	    "0123456789abcdef"  # hex digits
+define	MARGIN		    0.95		# defaults for 300 dpi
+define	PAGEWID	    	    612
+define	PAGEHGT	    	    762
+define	SZ_EPSBUF	    8192
+define	SZ_TRAILER	    31
+
+
+# EX_EPS - Write the output image to an Encasulated PostScript file.
+
+procedure ex_eps (ex)
+
+pointer	ex				#i task struct pointer
+
+pointer	eps
+pointer	bptr
+int	fd, len, flags
+
+int	strlen()
+bool	streq()
+
+begin
+        # Check to see that we have the correct number of expressions to
+        # write this format.
+        flags = EX_OUTFLAGS(ex)
+        if ((EX_NEXPR(ex) != 1 && !bitset(flags, OF_BAND)) && EX_NEXPR(ex) != 3)
+            call error (7, "Invalid number of expressions for EPS file.")
+
+	# Set some of the output parameters.
+	call ex_do_outtype (ex, "b1")
+        EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY)
+
+	# Allocate the EPS structure.
+	iferr (call calloc (eps, SZ_EPSSTRUCT, TY_STRUCT))
+	    call error (0, "Error allocating eps structure.")
+	call calloc (EPS_HPTR(eps), 17, TY_CHAR)
+	call calloc (EPS_BPTR(eps), SZ_EPSBUF+SZ_TRAILER, TY_CHAR)
+	call strcpy (HEXITS, Memc[EPS_HPTR(eps)], 17)
+	EPS_BCNT(eps) = 1
+
+	# Now write out the header and image data.
+	fd = EX_FD(ex)
+	call fseti (fd, F_ADVICE, SEQUENTIAL)
+	if (bitset (flags, OF_CMAP)) {
+	    if (streq (CMAPFILE(ex),"grayscale") || 
+		streq (CMAPFILE(ex),"greyscale")) {
+	    	    call eps_header (ex, eps, NO)
+	    	    call eps_gray (ex, eps, fd, false, true)
+	    } else {
+	        call eps_header (ex, eps, YES)
+	        call eps_gray (ex, eps, fd, true, false)
+	    }
+
+	} else if (EX_NEXPR(ex) == 1 || bitset (flags, OF_BAND)) {
+	    call eps_header (ex, eps, NO)
+	    call eps_gray (ex, eps, fd, false, false)
+
+	} else if (EX_NEXPR(ex) == 3) {
+	    call eps_header (ex, eps, YES)
+	    call eps_rgb (ex, eps, fd)
+	}
+
+	# Flush the remaining pixels in the buffer.
+	call calloc (bptr, SZ_EPSBUF, TY_CHAR)
+
+	if (mod (EPS_BCNT(eps),2) == 0) {
+	    call amovc ("\ngrestore showpage\n%%Trailer\n\0", 
+		BUF(eps,EPS_BCNT(eps)), SZ_TRAILER)
+	} else {
+	    call amovc ("\ngrestore  showpage\n%%Trailer\n", 
+		BUF(eps,EPS_BCNT(eps)), SZ_TRAILER)
+	}
+	len = strlen (BUF(eps,1))
+	call strpak (BUF(eps,1), Memc[bptr], len)
+	call write (fd, Memc[bptr], len / SZB_CHAR)
+	call flush (fd)
+
+	# Write the EPS trailer and clean up the pointers.
+	call mfree (EPS_HPTR(eps), TY_CHAR)
+	call mfree (EPS_BPTR(eps), TY_CHAR)
+	call mfree (eps, TY_STRUCT)
+	call mfree (bptr, TY_CHAR)
+end
+
+
+# EPS_GRAY - Write a grayscale EPS file.
+
+procedure eps_gray (ex, eps, fd, use_cmap, is_gray)
+
+pointer	ex				#i task struct pointer
+pointer	eps				#i postscript struct pointer
+int	fd				#i output file descriptor
+bool	use_cmap			#i write a false color image?
+bool	is_gray				#i is this a grayscale cmap?
+
+pointer	op, bop, out, cm
+int	i, j, k, line, percent
+int	len, orow, type
+
+pointer	ex_evaluate(), ex_chtype()
+
+begin
+	# Now process the expressions and write the image.
+        type = EX_OUTTYPE(ex)
+        percent = 0
+        orow = 0
+	cm = EX_CMAP(ex)
+	call malloc (out, EX_OCOLS(ex)+2, TY_SHORT)
+        do i = 1, EX_NEXPR(ex) {
+
+            # Process each line in the image.
+            do j = 1, O_HEIGHT(ex,i) {
+
+                # See if we're flipping the image.
+                if (bitset (EX_OUTFLAGS(ex), OF_FLIPY))
+                    line = EX_NLINES(ex) - j + 1
+                else
+                    line = j
+
+                # Get pixels from image(s).
+                call ex_getpix (ex, line)
+
+                # Evaluate expression.
+                op = ex_evaluate (ex, O_EXPR(ex,i))
+
+                # Convert to the output pixel type.
+                bop = ex_chtype (ex, op, type)
+
+                # Write evaluated pixels.
+		call achtbs (Memc[bop], Mems[out], O_LEN(op))
+		len = O_LEN(op) - 1
+		if (is_gray) {
+            	    # Write a single color index as the grayscale value.
+            	    do k = 0, len
+                	call eps_putval (eps, fd, CMAP(cm,EX_RED,Mems[out+k]+1))
+		} else if (use_cmap) {
+            	    # Write index values as RGB triplets.
+            	    do k = 0, len {
+                	call eps_putval (eps, fd, 
+			    CMAP(cm,EX_RED,  Mems[out+k]+1))
+               		call eps_putval (eps, fd, 
+			    CMAP(cm,EX_GREEN,Mems[out+k]+1))
+                	call eps_putval (eps, fd, 
+			    CMAP(cm,EX_BLUE, Mems[out+k]+1))
+            	    }
+		} else {
+		    do k = 0, len
+		        call eps_putval (eps, fd, Mems[out+k])
+		}
+
+                # Clean up the pointers.
+                call mfree (bop, TY_CHAR)
+                call evvfree (op)
+
+                # Print percent done if being verbose
+                orow = orow + 1
+                #if (EX_VERBOSE(ex) == YES)
+		    call ex_pstat (ex, orow, percent)
+            }
+        }
+        call mfree (out, TY_SHORT)
+end
+
+
+# EPS_RGB - Write a RGB true color EPS file.
+
+procedure eps_rgb (ex, eps, fd)
+
+pointer	ex				#i task struct pointer
+pointer	eps				#i postscript struct pointer
+int	fd				#i output file descriptor
+
+pointer	op, bop, out
+int	i, j, k, line, percent, orow, type
+
+pointer	ex_evaluate(), ex_chtype()
+
+begin
+	# Now process the expressions and write the image.
+        type = EX_OUTTYPE(ex)
+        percent = 0
+        orow = 0
+	call malloc (out, EX_OCOLS(ex)+2, TY_SHORT)
+        do j = 1, EX_NLINES(ex) {
+
+            # See if we're flipping the image.
+            if (bitset (EX_OUTFLAGS(ex), OF_FLIPY))
+                line = EX_NLINES(ex) - j + 1
+            else
+                line = j
+
+            # Get pixels from image(s).
+            call ex_getpix (ex, line)
+
+            # Process each line in the image.
+            do i = 1, EX_NEXPR(ex) {
+
+                # Evaluate expression.
+                op = ex_evaluate (ex, O_EXPR(ex,i))
+
+                # Convert to the output pixel type.
+                bop = ex_chtype (ex, op, type)
+
+                # Write evaluated pixels.
+		call achtbs (Memc[bop], Mems[out], O_LEN(op))
+		do k = 1, O_LEN(op)
+		    call eps_putval (eps, fd, Mems[out+k-1])
+
+                # Clean up the pointers.
+                call mfree (bop, TY_CHAR)
+                call evvfree (op)
+            }
+
+            # Print percent done if being verbose
+            orow = orow + 1
+            #if (EX_VERBOSE(ex) == YES)
+	        call ex_pstat (ex, orow, percent)
+        }
+        call mfree (out, TY_SHORT)
+end
+
+
+# EPS_HEADER - Write the EPS header block.
+
+procedure eps_header (ex, eps, color)
+
+pointer	ex				#i task struct pointer
+pointer	eps				#i EPS struct pointer
+int	color				#i is this a color image?
+
+int	bp, fd, cols, rows, dpi, len
+int	icols, irows, devpix, turnflag
+real    scale, pixfac, scols, srows, llx, lly
+
+int	strlen(), stropen()
+
+begin
+	fd = EX_FD(ex)
+	turnflag = NO
+	dpi = EX_PSDPI(ex)
+	scale = EX_PSSCALE(ex)
+	cols = EX_OCOLS(ex)
+	rows = EX_OROWS(ex)
+
+	# Open the buffer as a string file and print to it.
+	bp = stropen (BUF(eps,1), SZ_EPSBUF, TEXT_FILE)
+
+	# See if we need to rotate the image to fit on the page.
+	icols = cols
+	irows = rows
+	if (cols > rows && (scale * cols) > int (PAGEWID * MARGIN)) {
+	    turnflag = YES
+	    cols = irows
+	    rows = icols
+	}
+
+	# Figure out size.
+	devpix = dpi / 72.0 + 0.5        	# device pixels per unit, approx
+	pixfac = 72.0 / dpi * devpix    	# 1, approx.
+	scols = scale * cols * pixfac
+	srows = scale * rows * pixfac
+
+	if ( scols > PAGEWID * MARGIN || srows > PAGEHGT * MARGIN ) {
+	    if ( scols > PAGEWID * MARGIN ) {
+	        scale = scale * PAGEWID / scols * MARGIN
+	        scols = scale * cols * pixfac
+	        srows = scale * rows * pixfac
+	    }
+	    if ( srows > PAGEHGT * MARGIN ) {
+	        scale = scale * PAGEHGT / srows * MARGIN
+	        scols = scale * cols * pixfac
+	        srows = scale * rows * pixfac
+	    }
+	    if (EX_VERBOSE(ex) == YES) {
+	        call printf ("\tImage too large for page, rescaled to %g\n")
+		    call pargr (scale)
+		call flush (STDOUT)
+	    }
+	}
+
+	# Center it on the page.
+	llx = (PAGEWID - scols) / 2
+	lly = (PAGEHGT - srows) / 2
+
+	call fprintf  (bp, "%%!PS-Adobe-2.0 EPSF-2.0\n")
+	call fprintf  (bp, "%%%%Creator: IRAF EXPORT task\n")
+	call fprintf  (bp, "%%%%Title: %s\n")
+	    call pargstr (BFNAME(ex))
+	call fprintf  (bp, "%%%%Pages: 1\n")
+	call fprintf  (bp, "%%%%BoundingBox: %d %d %d %d\n")
+	    call pargi (int (llx + 0.5))
+	    call pargi (int (lly + 0.5))
+	    call pargi (int (llx + scols))
+	    call pargi (int (lly + srows))
+	call fprintf  (bp, "%%%%EndComments\n")
+
+	call fprintf (bp, "/readstring {\n")                # s -- s
+	call fprintf (bp, "  currentfile exch readhexstring pop\n")
+	call fprintf (bp, "} bind def\n")
+
+	if (color == YES && !bitset (EX_OUTFLAGS(ex),OF_CMAP)) {
+	    call eps_defcol (bp, icols)
+
+	    call fprintf (bp, "/rpicstr %d string def\n")
+	        call pargi (icols)
+	    call fprintf (bp, "/gpicstr %d string def\n")
+	        call pargi (icols)
+	    call fprintf (bp, "/bpicstr %d string def\n")
+	        call pargi (icols)
+
+	} else if (color == YES && bitset (EX_OUTFLAGS(ex),OF_CMAP)) {
+	    call eps_defcol (bp, icols)
+
+	} else {
+	    call fprintf (bp, "/picstr %d string def\n")
+	        call pargi (icols)
+	}
+
+	call fprintf (bp, "%%%%EndProlog\n")
+	call fprintf (bp, "%%%%Page: 1 1\n")
+	call fprintf (bp, "gsave\n")
+	call fprintf (bp, "%g %g translate\n")
+	    call pargr (llx)
+	    call pargr (lly)
+	call fprintf (bp, "%g %g scale\n")
+	    call pargr (scols)
+	    call pargr (srows)
+
+	if (turnflag == YES) {
+	    call fprintf (bp, 
+		"0.5 0.5 translate  90 rotate  -0.5 -0.5 translate\n")
+	}
+
+	call fprintf (bp, "%d %d 8\n")
+	    call pargi (icols)
+	    call pargi (irows)
+	call fprintf (bp, "[ %d 0 0 -%d 0 %d ]\n")
+	    call pargi (icols)
+	    call pargi (irows)
+	    call pargi (irows)
+	if (color == YES) {
+	    if (bitset (EX_OUTFLAGS(ex), OF_CMAP)) {
+	        call fprintf (bp, "{currentfile pix readhexstring pop}\n")
+	        call fprintf (bp, "false 3 colorimage")
+	    } else {
+	        call fprintf (bp, "{ rpicstr readstring }\n")
+	        call fprintf (bp, "{ gpicstr readstring }\n")
+	        call fprintf (bp, "{ bpicstr readstring }\n")
+	        call fprintf (bp, "true 3  colorimage")
+	    }
+	} else {
+	    call fprintf (bp, "{ picstr readstring }\n")
+	    call fprintf (bp, "image")
+	}
+	call flush (bp)
+	call strclose (bp)
+
+	# See if we need to pad the string to write it out correctly.
+	len = strlen(BUF(eps,1))
+	if (mod(len,2) == 1) {
+	    BUF(eps,len+1) = '\n'
+	} else {
+	    BUF(eps,len+1) = ' '
+	    BUF(eps,len+2) = '\n'
+	}
+
+	# Now write the contents of the string buffer to the output file.
+	len = strlen(BUF(eps,1))
+	call strpak (BUF(eps,1), BUF(eps,1), len)
+	call write (fd, BUF(eps,1), len / SZB_CHAR)
+	call aclrc (BUF(eps,1), SZ_EPSBUF)
+	EPS_ITEMSPERLINE(eps) = 0
+end
+
+
+# EPS_DEFCOL - Write out code that checks if the PostScript device in question
+# knows about the 'colorimage' operator.  If it doesn't, it defines
+# 'colorimage' in terms of image (ie, generates a greyscale image from
+# RGB data).
+
+procedure eps_defcol (fd, len)
+
+int	fd				#i output file descriptor
+int	len				#i length of a scanline
+
+begin
+  	call fprintf (fd, "%% build a temporary dictionary\n")
+  	call fprintf (fd, "20 dict begin\n\n")
+    	call fprintf (fd, 
+	    "%% define string to hold a scanline's worth of data\n")
+    	call fprintf (fd, "/pix %d string def\n\n")
+	    call pargi (len)
+
+	call fprintf (fd, "\n")
+	call fprintf (fd, "%% define 'colorimage' if it isn't defined\n")
+	call fprintf (fd, 
+	    "/colorimage where   %% do we know about 'colorimage'?\n")
+	call fprintf (fd, 
+	    "  { pop }           %% yes: pop off the 'dict' returned\n")
+	call fprintf (fd, "  {                 %% no:  define one\n")
+	call fprintf (fd, "    /colortogray {  %% define an RGB->I function\n")
+	call fprintf (fd, 
+	    "      /rgbdata exch store    %% call input 'rgbdata'\n")
+	call fprintf (fd, "      rgbdata length 3 idiv\n")
+	call fprintf (fd, "      /npixls exch store\n")
+	call fprintf (fd, "      /rgbindx 0 store\n")
+	call fprintf (fd, 
+	    "      /grays npixls string store  %% str to hold the result\n")
+	call fprintf (fd, "      0 1 npixls 1 sub {\n")
+	call fprintf (fd, "        grays exch\n")
+	call fprintf (fd, 
+	    "        rgbdata rgbindx       get 20 mul    %% Red\n")
+	call fprintf (fd, 
+	    "        rgbdata rgbindx 1 add get 32 mul    %% Green\n")
+	call fprintf (fd, 
+	    "        rgbdata rgbindx 2 add get 12 mul    %% Blue\n")
+	call fprintf (fd, 
+	    "        add add 64 idiv      %% I = .5G + .31R + .18B\n")
+	call fprintf (fd, "        put\n")
+	call fprintf (fd, "        /rgbindx rgbindx 3 add store\n")
+	call fprintf (fd, "      } for\n")
+	call fprintf (fd, "      grays\n")
+	call fprintf (fd, "    } bind def\n\n")
+
+	call fprintf (fd, "    %% Utility procedure for colorimage operator.\n")
+	call fprintf (fd, 
+	    "    %% This procedure takes two procedures off the\n")
+	call fprintf (fd, 
+	    "    %% stack and merges them into a single procedure.\n\n")
+	
+	call fprintf (fd, "    /mergeprocs { %% def\n")
+	call fprintf (fd, "      dup length\n")
+	call fprintf (fd, "      3 -1 roll\n")
+	call fprintf (fd, "      dup\n")
+	call fprintf (fd, "      length\n")
+	call fprintf (fd, "      dup\n")
+	call fprintf (fd, "      5 1 roll\n")
+	call fprintf (fd, "      3 -1 roll\n")
+	call fprintf (fd, "      add\n")
+	call fprintf (fd, "      array cvx\n")
+	call fprintf (fd, "      dup\n")
+	call fprintf (fd, "      3 -1 roll\n")
+	call fprintf (fd, "      0 exch\n")
+	call fprintf (fd, "      putinterval\n")
+	call fprintf (fd, "      dup\n")
+	call fprintf (fd, "      4 2 roll\n")
+	call fprintf (fd, "      putinterval\n")
+	call fprintf (fd, "    } bind def\n\n")
+
+	call fprintf (fd, "    /colorimage { %% def\n")
+	call fprintf (fd, "      pop pop     %% remove 'false 3' operands\n")
+	call fprintf (fd, "      {colortogray} mergeprocs\n")
+	call fprintf (fd, "      image\n")
+	call fprintf (fd, "    } bind def\n")
+	call fprintf (fd, "  } ifelse          %% end of 'false' case\n")
+	call fprintf (fd, "\n\n")
+	call flush (fd)
+end
+
+
+# EPS_PUTVAL - Put a pixel value to the output file.
+
+procedure eps_putval (eps, fd, sval)
+
+pointer	eps				#i EPS struct pointer
+int	fd				#i output file descriptor
+short	sval				#i value to write
+
+int	val, index
+char	ch, nl, sp
+int	shifti()
+
+begin
+	# Force value to 8-bit range.
+        #val = max (0, min (255, sval))
+        val = sval
+
+	if (EPS_ITEMSPERLINE(eps) >= LINEWID) {
+	    sp = ' '
+	    call eps_putc (eps, fd, sp)
+	    nl = '\n'
+	    call eps_putc (eps, fd, nl)
+	    EPS_ITEMSPERLINE(eps) = 0
+	}
+
+	# Get the hex string equivalent of the byte.
+	index = shifti (val, -4)    			# get left 4 bits
+	ch = HEXSTR(eps,index)
+	call eps_putc (eps, fd, ch)
+
+	index = and (val, 0FX)    			# get right 4 bits
+	ch = HEXSTR(eps,index)
+	call eps_putc (eps, fd, ch)
+
+	EPS_ITEMSPERLINE(eps) = EPS_ITEMSPERLINE(eps) + 1
+end
+
+
+# EPS_PUTC - Put a character to the buffer.  This routine also flushes the
+# accumulated buffer to disk once it fills.
+
+procedure eps_putc (eps, fd, ch)
+
+pointer	eps				#i EPS struct pointer
+int	fd				#i file descriptor
+char	ch				#i character to 'write'
+
+begin
+	BUF(eps,EPS_BCNT(eps)) = ch
+	EPS_BCNT(eps) = EPS_BCNT(eps) + 1
+
+	# If we're getting close to a full buffer, write it out.
+	# Leave some space at the end for the epilogue.
+	if (EPS_BCNT(eps) > SZ_EPSBUF-64) {
+	    call strpak (BUF(eps,1), BUF(eps,1), EPS_BCNT(eps))
+	    call write (fd, BUF(eps,1), EPS_BCNT(eps) / SZB_CHAR)
+	    #call aclrc (BUF(eps,1), SZ_EPSBUF)
+	    EPS_BCNT(eps) = 1
+	}
+end