Initial commit

1 files changed, 475 insertions, 0 deletions

diff --git a/sys/imio/iki/fxf/fxfksection.x b/sys/imio/iki/fxf/fxfksection.x
new file mode 100644
index 00000000..cb37b4e5
--- /dev/null
+++ b/sys/imio/iki/fxf/fxfksection.x
@@ -0,0 +1,475 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+ 
+include	<syserr.h>
+include	<error.h>
+include <ctotok.h>
+include <lexnum.h>
+include <imhdr.h>
+include "fxf.h"
+
+# FXFKSECTION.X -- Routines to parse the FITS kernel section into 
+# parameter names and values.
+
+define	KS_EXTNAME	1
+define	KS_EXTVER	2
+define	KS_APPEND	3
+define	KS_NOAPPEND	4
+define	KS_OVERWRITE	5
+define	KS_DUPNAME	6
+define	KS_INHERIT	7
+define	KS_NOINHERIT    8 
+define	KS_NODUPNAME	9
+define	KS_NOOVERWRITE	10
+define	KS_EXPAND	11
+define	KS_PHULINES	12
+define	KS_EHULINES	13
+define	KS_PADLINES	14
+define	KS_NOEXPAND	15
+define	KS_CACHESIZE	16
+define	KS_TYPE		17
+define	ERROR           -2
+
+
+# FXF_KSECTION -- Procedure to parse and analyze a string of the form:
+#
+#     "keyword=value,keyword+,keyword-,..."
+# e.g.,
+#     "[extname=]name,[extver=]23,append,inherit+,overwrite+,dupname-"
+#
+# The 'extver' numeric field is position dependent if it does not have
+# the parameter name.  The 'group' output variable is not -1 when specified
+# as the 1st number in the section.
+
+procedure fxf_ksection (ksection, fit, group)
+
+char 	ksection[ARB]		#I String with kernel section
+pointer fit			#I Fits structure pointer
+int	group			#O Extension number
+
+bool    extn
+char    outstr[LEN_CARD]
+char 	identif[LEN_CARD]
+int     ip, jp, nident, nexpr, junk, nch, ty, token, ival
+int	lex_type, fxf_ks_lex(), ctoi(), ctotok(), lexnum()
+errchk	syserr, syserrs
+
+begin
+       # The default values should have been already initialized 
+       # with a call fxf_ksinit().
+
+       ip = 1
+       nexpr = 0
+       nident = 0
+       extn = false
+       group = -1
+       identif[1] = EOS
+
+       repeat {
+	   # Advance to the next keyword.
+	   token = ctotok (ksection, ip, outstr, LEN_CARD)
+
+	   switch (token) {
+	   case TOK_EOS:
+	       break
+	   case TOK_NEWLINE:
+	       break
+
+	   case TOK_NUMBER:
+	       if (nexpr != 1 && nexpr != 2 && extn) 
+		   call syserr (SYS_FXFKSNV)
+	       jp = 1
+	       ty = lexnum (outstr, jp, nch)
+	       if (ty != LEX_DECIMAL)
+		   call syserr (SYS_FXFKSNDEC)
+	       jp = 1
+	       junk = ctoi (outstr, jp, ival)
+	       if (nexpr == 0) {
+		   group = ival
+		   identif[1] = 1
+	       } else
+	           FKS_EXTVER(fit) = ival
+	       nexpr = nexpr + 1
+
+	   case TOK_PUNCTUATION:
+	       if (outstr[1] == ',' && identif[1] == EOS)
+		   call syserr (SYS_FXFKSSYN)
+
+	   case TOK_STRING:
+	       if (nexpr != 0 && nexpr != 1)
+		   call syserr (SYS_FXFKSSVAL)
+	       call strcpy (outstr, FKS_EXTNAME(fit), LEN_CARD)
+	       nexpr = nexpr + 1
+	       extn = true
+
+	   case TOK_IDENTIFIER:
+	       nident = nident + 1
+	       call strcpy (outstr, identif, LEN_CARD] 
+	       call strlwr (outstr)
+	       lex_type = fxf_ks_lex (outstr)
+
+	       # look for =<value>, + or -
+	       if (lex_type > 0) {
+	   	   call fxf_ks_gvalue (lex_type, ksection, ip, fit)
+	       } else {
+	           if (nexpr == 0 || nexpr == 1)
+		       call strcpy (identif, FKS_EXTNAME(fit), LEN_CARD)
+	           else
+		       call syserr (SYS_FXFKSSVAL)
+	       }
+	       nexpr = nexpr + 1
+	       extn = true
+
+	   default:
+		call syserr (SYS_FXFKSSYN)
+	   }
+	}	   
+end
+
+
+# FXF_KS_LEX -- Map an identifier into a FITS kernel parameter code.
+
+int procedure fxf_ks_lex (outstr)
+
+char    outstr[ARB]
+
+int	len, strlen(), strncmp()
+errchk	syserr, syserrs
+
+begin
+	len = strlen (outstr)
+
+	# Allow for small string to be taken as extname values and not
+	# kernel paramaters; like 'ap' instead of 'ap(ppend)'.
+	if (len < 3)
+	    return(0)
+
+	# See if it is extname or extver.
+	if (strncmp (outstr, "ext", 3) == 0 && len < 8 ) {
+	    if (len == 3)
+	        call syserr (SYS_FXFKSEXT)
+	    if (strncmp (outstr[4], "name", len-3) == 0)
+		return (KS_EXTNAME)
+	    else if (strncmp (outstr[4], "ver", len-3) == 0)
+		return (KS_EXTVER)
+
+	# Check for the "no" versions of selected keywords.
+	} else if (strncmp (outstr, "no", 2) == 0 && len < 12) {
+	    if (strncmp (outstr[3], "append", len-2) == 0)
+	        return (KS_NOAPPEND)
+	    if (strncmp (outstr[3], "inherit", len-2) == 0)
+	        return (KS_NOINHERIT)
+	    if (strncmp (outstr[3], "overwrite", len-2) == 0)
+	        return (KS_NOOVERWRITE)
+	    if (strncmp (outstr[3], "dupname", len-2) == 0)
+	        return (KS_NODUPNAME)
+	    if (strncmp (outstr[3], "expand", len-2) == 0)
+		return (KS_NOEXPAND)
+	}
+
+	# Other kernel keywords.
+	if (strncmp (outstr, "inherit", len) == 0)
+	    return (KS_INHERIT)
+	if (strncmp (outstr, "overwrite", len) == 0)
+	    return (KS_OVERWRITE)
+	if (strncmp (outstr, "dupname", len) == 0)
+	    return (KS_DUPNAME)
+	if (strncmp (outstr, "append", len) == 0)
+	    return (KS_APPEND)
+	if (strncmp (outstr, "noappend", len) == 0)
+	    return (KS_NOAPPEND)
+	if (strncmp (outstr, "type", len) == 0)
+	    return (KS_TYPE)
+	if (strncmp (outstr, "expand", len) == 0)
+	    return (KS_EXPAND)
+	if (strncmp (outstr, "phulines", len) == 0)
+	    return (KS_PHULINES)
+	if (strncmp (outstr, "ehulines", len) == 0)
+	    return (KS_EHULINES)
+	if (strncmp (outstr, "padlines", len) == 0)
+	    return (KS_PADLINES)
+	if (strncmp (outstr, "cachesize", len) == 0)
+	    return (KS_CACHESIZE)
+
+	return (0)	# not recognized; probably a value
+end
+
+
+# FXF_KS_GVALUE -- Given a parameter code get its value at the 'ip' character
+# position in the 'ksection' string.  Put the values in the FKS structure.
+
+procedure fxf_ks_gvalue (param, ksection, ip, fit)
+
+int	param			#I parameter code
+char	ksection[ARB]		#I Ksection
+int	ip			#I Current parsing pointer in ksection
+pointer	fit			#U Update the values in the FKS structure
+
+pointer sp, ln
+int     jp, token
+int	ctotok()
+errchk	syserr, syserrs
+
+begin
+	jp = ip
+
+	call smark (sp)
+	call salloc (ln, LEN_CARD, TY_CHAR)
+
+	# See if the parameter value is given as par=<value> or '+/-'
+	if (ctotok (ksection, jp, Memc[ln], LEN_CARD) == TOK_OPERATOR) {
+	    if (Memc[ln] == '=' ) {
+		token = ctotok (ksection, jp, Memc[ln], LEN_CARD)
+		if (token != TOK_IDENTIFIER &&
+			token != TOK_STRING && token != TOK_NUMBER) {
+		    call syserr (SYS_FXFKSSYN)
+		} else {
+		    call fxf_ks_val (Memc[ln], param, fit)
+		    ip = jp
+	        }
+	    } else if (Memc[ln] == '+' || Memc[ln] == '-') {
+		call fxf_ks_pm (Memc[ln], param, fit)
+		ip = jp
+	    }
+	} else {
+	    switch (param) {
+	    case  KS_APPEND:
+		FKS_APPEND(fit) = YES
+	    case  KS_NOAPPEND:
+		FKS_APPEND(fit) = NO
+	    case  KS_OVERWRITE:
+		FKS_OVERWRITE(fit) = YES
+	    case  KS_NOOVERWRITE:
+		FKS_OVERWRITE(fit) = NO
+	    case  KS_DUPNAME:
+		FKS_DUPNAME(fit) = YES
+	    case  KS_INHERIT:
+		FKS_INHERIT(fit) = YES
+	    case  KS_NOINHERIT:
+		FKS_INHERIT(fit) = NO
+	    case  KS_EXPAND:
+		FKS_EXPAND(fit) = YES
+	    case  KS_NOEXPAND:
+		FKS_EXPAND(fit) = NO
+	    default:
+		call syserr (SYS_FXFKSSYN)
+	    }
+	} 
+
+	call sfree (sp)
+end
+
+
+# FXF_KS_VALUE -- Returns the value of a parameter in the kernel section.
+
+procedure fxf_ks_val (outstr, param, fit)
+
+char	outstr[ARB] 		#I Input string with value		
+int	param			#I Parameter code
+pointer fit			#U Fits kernel descriptor
+
+int	ty, ip, ival, nchars
+int	lexnum(), ctoi(), strcmp()
+errchk	syserr, syserrs
+
+begin
+	call strlwr (outstr)
+	if (strcmp (outstr, "yes") == 0)
+	    ival = YES
+	else if (strcmp (outstr, "no") == 0)
+	    ival = NO
+	else
+	    ival = ERROR
+
+	switch (param) {
+	case  KS_EXTNAME:
+	    call strcpy (outstr, FKS_EXTNAME(fit), LEN_CARD)
+
+	case  KS_TYPE:
+	    call strlwr (outstr)
+	    if (strcmp ("mask", outstr) == 0)
+		FKS_SUBTYPE(fit) = FK_PLIO
+	    else
+		call syserrs (SYS_FXFKSINVAL, "type")
+	case KS_EXTVER:
+	    ip = 1
+	    ty = lexnum (outstr, ip, nchars)
+	    if (ty != LEX_DECIMAL)
+	        call syserr (SYS_FXFKSNDEC)
+	    ip = 1
+	    nchars = ctoi (outstr, ip, ival)
+	    if (nchars <= 0)
+	        call syserrs (SYS_FXFKSINVAL, "extver")
+	    FKS_EXTVER(fit) = ival
+
+	case KS_APPEND:
+	    if (ival != ERROR)
+	        FKS_APPEND(fit) = ival
+	    else
+	        call syserrs (SYS_FXFKSINVAL, "append")
+
+	case KS_OVERWRITE:
+	    if (ival != ERROR)
+	        FKS_OVERWRITE(fit) = ival
+	    else
+	        call syserrs (SYS_FXFKSINVAL, "overwrite")
+
+	case KS_DUPNAME:
+	    if (ival != ERROR)
+	        FKS_DUPNAME(fit) = ival
+	    else
+	        call syserrs (SYS_FXFKSINVAL, "dupname")
+
+	case KS_INHERIT:
+	    if (ival != ERROR)
+	        FKS_INHERIT(fit) = ival
+	    else
+	        call syserrs (SYS_FXFKSINVAL, "inherit")
+
+	case KS_EXPAND:
+	    if (ival != ERROR)
+	        FKS_EXPAND(fit) = ival
+	    else
+	        call syserrs (SYS_FXFKSINVAL, "expand")
+
+	case KS_PHULINES:
+	    ip = 1
+	    ty = lexnum (outstr, ip, nchars)
+	    if (ty != LEX_DECIMAL)
+	        call syserr (SYS_FXFKSNDEC)
+	    ip = 1
+	    nchars = ctoi (outstr, ip, ival)
+	    if (nchars <= 0 || ival < 0)
+	        call syserrs (SYS_FXFKSPVAL, "phulines")
+	    FKS_PHULINES(fit) = ival
+
+	case KS_EHULINES:
+	    ip = 1
+	    ty = lexnum (outstr, ip, nchars)
+	    if (ty != LEX_DECIMAL)
+	        call syserr (SYS_FXFKSNDEC)
+	    ip = 1
+	    nchars = ctoi (outstr, ip, ival)
+	    if (nchars <= 0 || ival < 0)
+	        call syserrs (SYS_FXFKSPVAL, "ehulines")
+	    FKS_EHULINES(fit) = ival
+
+	case KS_PADLINES:
+	    ip = 1
+	    ty = lexnum (outstr, ip, nchars)
+	    if (ty != LEX_DECIMAL)
+	        call syserr (SYS_FXFKSNDEC)
+	    ip = 1
+	    nchars = ctoi (outstr, ip, ival)
+	    if (nchars <= 0 || ival < 0)
+	        call syserrs (SYS_FXFKSPVAL, "padlines")
+	    FKS_PADLINES(fit) = ival
+
+	case KS_CACHESIZE:
+	    ip = 1
+	    ty = lexnum (outstr, ip, nchars)
+	    if (ty != LEX_DECIMAL)
+	        call syserr (SYS_FXFKSNDEC)
+	    ip = 1
+	    nchars = ctoi (outstr, ip, ival)
+	    if (nchars <= 0 || ival < 0)
+	        call syserrs (SYS_FXFKSPVAL, "cachesize")
+	    FKS_CACHESIZE(fit) = ival
+
+	default:
+            call syserr (SYS_FXFKSSYN)
+	}
+end
+
+
+# FXF_KS_PM -- Return the character YES or NO based on the value '+' or '-'
+ 
+procedure fxf_ks_pm (pm, param, fit)
+
+char	pm[1]		#I contains "+" or "-"
+int	param		#I Parameter code
+pointer fit		#U Fits kernel descriptor
+
+int	ival
+errchk	syserr, syserrs
+
+begin
+	if (pm[1] == '+') 
+	   ival = YES
+	else
+	   ival = NO
+
+	switch (param) {
+	case KS_APPEND:
+	    FKS_APPEND(fit) = ival
+	case KS_OVERWRITE:
+	    FKS_OVERWRITE(fit) = ival
+	case KS_DUPNAME:
+	    FKS_DUPNAME(fit) = ival
+	case KS_INHERIT:
+	    FKS_INHERIT(fit) = ival
+	case KS_EXPAND:
+	    FKS_EXPAND(fit) = ival
+	default:
+	    call syserr (SYS_FXFKSSYN)
+	}
+end
+
+
+# FXF_KS_ERRORS -- Handle an error condition in the kernel section.
+
+procedure fxf_ks_errors (fit, acmode)
+
+pointer fit 			#I fits kernel descriptor
+int	acmode			#I image access mode
+
+int	group
+errchk	syserr, syserrs
+
+begin
+	group = FIT_GROUP(fit)
+
+	if (FKS_OVERWRITE(fit) == YES) {
+	    if (FIT_NEWIMAGE(fit) == YES)
+		iferr (call syserrs (SYS_FOPNNEXFIL, IM_HDRFILE(FIT_IM(fit))))
+		    call erract (EA_WARN)
+	    if (acmode == APPEND)
+		call syserrs (SYS_FXFKSNOVR, "APPEND")
+	    if (group == -1 &&
+		    (FKS_EXTNAME(fit) == EOS && IS_INDEFL(FKS_EXTVER(fit))))
+		call syserr (SYS_FXFKSOVR)
+	} else {
+	    switch (acmode) {
+	    case NEW_COPY:
+		if (group != -1 && FKS_APPEND(fit) == NO)
+		    call syserr (SYS_FXFKSBOP)
+	    case NEW_IMAGE:
+		if (group != -1)
+		    call syserrs (SYS_FXFKSNEXT, "NEW_IMAGE" )
+	    case APPEND:
+	        if (group != -1)
+		    call syserrs (SYS_FXFKSNEXT, "APPEND" )
+	    }
+        }
+end			
+
+
+# FXF_KSINIT -- Initialize default values for ks parameters.
+
+procedure fxf_ksinit (fit)
+
+pointer	fit			#I fits kernel descriptor
+
+begin
+	FKS_EXTNAME(fit)   = EOS
+	FKS_SUBTYPE(fit)   = NO
+	FKS_EXTVER(fit)    = INDEFL
+	FKS_APPEND(fit)    = NO
+	FKS_OVERWRITE(fit) = NO
+	FKS_DUPNAME(fit)   = NO
+	FKS_EXPAND(fit)    = YES
+	FKS_PHULINES(fit)  = DEF_PHULINES
+	FKS_EHULINES(fit)  = DEF_EHULINES
+	FKS_PADLINES(fit)  = DEF_PADLINES
+	FKS_INHERIT(fit)   = YES
+	FKS_CACHESIZE(fit) = DEF_CACHE
+end