Repatch (from linux) of OSX IRAF

1 files changed, 687 insertions, 0 deletions

diff --git a/sys/qpoe/qpgettok.x b/sys/qpoe/qpgettok.x
new file mode 100644
index 00000000..feb8d780
--- /dev/null
+++ b/sys/qpoe/qpgettok.x
@@ -0,0 +1,687 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<syserr.h>
+include	<error.h>
+include	<ctype.h>
+include	<fset.h>
+include	"qpoe.h"
+
+.help gettok
+.nf --------------------------------------------------------------------------
+GETTOK -- Lexical input routines for QPOE.  Used to return tokens from input
+text; this is where all macro expansion and file expansion takes place.
+
+	       gt = qp_opentext (qp, text)
+	      token = qp_gettok (gt, tokbuf, maxch)
+		    qp_ungettok (gt, tokbuf)
+	      token = qp_rawtok (gt, tokbuf, maxch)
+	     token = qp_nexttok (gt)
+		   qp_closetext (gt)
+
+Access to the package is gained by opening a text string with QP_OPENTEXT.
+This returns a descriptor which is passed to QP_GETTOK to read successive
+tokens, which may come from the input text string or from any macros,
+include files, etc., referenced in the text or in any substituted text.
+QP_UNGETTOK pushes a token back into the QP_GETTOK input stream, to be
+returned in the next QP_GETTOK call (following macro expansion).
+
+QP_RAWTOK returns the next physical token from an input stream (without
+macro expansion), and QP_NEXTTOK returns the type of the next *physical*
+token (no macro expansion) without actually fetching it (for look ahead
+decision making).
+
+The tokens that can be returned are as follows:
+
+	TOK_IDENTIFIER		[a-zA-Z][a-zA-Z0-9_]*
+	TOK_NUMBER		[0-9][0-9a-zA-Z.]*(e|E)?(+|-)?[0-9]*
+	TOK_STRING		if "abc" or 'abc', the abc
+	'c'			other characters, e.g., =+-*/,;:()[] etc
+	EOF			at end of input
+
+Macro replacement syntax:
+
+	macro			push macro with null arglist
+	macro(arg,arg,...)	push macro with argument substitution
+	@file			push contents of file
+	@file(arg,arg,...)	push file with argument substitution
+	`cmd`			substitute output of CL command "cmd"
+
+where
+	macro			is an identifier, the name of a global macro
+				or a datafile local macro (parameter)
+
+In all cases, occurences of $N in the replacement text are replaced by the
+macro arguments if any, and macros are recursively expanded.  Whitespace,
+including newline, equates to a single space, as does EOF (hence always
+delimits tokens).  Comments (# to end of line) are ignored.  All identifiers
+in scanned text are checked to see if they are references to predefined global
+or local (datafile) macros.
+
+A global macro is a symbol defined globally for QPOE, in effect for all poefile
+accesses (see qpmacro.x).  A local macro is a macro defined as a string
+parameter of type TY_MACRO in the poefile header (and hence affecting only
+that one datafile).
+.endhelp ---------------------------------------------------------------------
+
+# General definitions.
+define	MAX_LEVELS	20		# max include file nesting
+define	MAX_ARGS	9		# max arguments to a macro
+define	SZ_CMD		80		# `cmd`
+define	SZ_IBUF		8192		# buffer for macro replacement
+define	SZ_OBUF		8192		# buffer for macro replacement
+define	SZ_ARGBUF	256		# argument list to a macro
+
+# The gettok descriptor.
+define	LEN_GTDES	45
+define	GT_QP		Memi[$1]	# backpointer to QPOE descriptor
+define	GT_FD		Memi[$1+1]	# current input stream
+define	GT_NEXTCH	Memi[$1+2]	# lookahead character
+define	GT_FTEMP	Memi[$1+3]	# file on stream is a temp file
+define	GT_LEVEL	Memi[$1+4]	# current nesting level
+define	GT_SVFD		Memi[$1+5+$2-1]	# stacked file descriptors
+define	GT_SVFTEMP	Memi[$1+25+$2-1]# stacked ftemp flags
+
+
+# QP_OPENTEXT -- Open the QP_GETTOK descriptor.  The descriptor is initially
+# opened on the user supplied string buffer (which is opened as a file and
+# which must remain intact while token input is in progress), but include file
+# processing etc. may cause arbitrary nesting of file descriptors.
+
+pointer procedure qp_opentext (qp, text)
+
+pointer	qp			#I QPOE descriptor
+char	text[ARB]		#I input text to be scanned
+
+pointer	gt
+int	sz_pbbuf
+int	stropen(), strlen()
+errchk	stropen, calloc
+
+begin
+	call calloc (gt, LEN_GTDES, TY_STRUCT)
+
+	GT_QP(gt) = qp
+	GT_FD(gt) = stropen (text, strlen(text), READ_ONLY)
+
+	if (qp == NULL)
+	    sz_pbbuf = DEF_MAXPUSHBACK
+	else
+	    sz_pbbuf = QP_SZPBBUF(qp)
+	call fseti (GT_FD(gt), F_PBBSIZE, sz_pbbuf)
+
+	return (gt)
+end
+
+
+# QP_GETTOK -- Return the next token from the input stream.  The token ID
+# (a predefined integer code or the character value) is returned as the
+# function value.  The text of the token is returned as an output argument.
+# Any macro references, file includes, etc., are performed in the process
+# of scanning the input stream, hence only fully resolved tokens are output.
+
+int procedure qp_gettok (gt, tokbuf, maxch)
+
+pointer	gt			#I gettok descriptor
+char	tokbuf[maxch]		#O receives the text of the token
+int	maxch			#I max chars out
+
+pointer	sp, bp, qp, cmd, ibuf, obuf, argbuf, fname, sym, textp
+int	fd, token, level, nargs, nchars, i_fd, o_fd, ftemp
+
+bool	streq()
+pointer	qp_gmsym()
+int	strmac(), open(), stropen()
+int	qp_rawtok(), qp_nexttok(), qp_arglist()
+errchk	qp_rawtok,close,ungetci,ungetline,qp_arglist,clcmdw,stropen,syserr
+define	pushfile_ 91
+
+
+begin
+	call smark (sp)
+
+	# Allocate some buffer space.
+	nchars = SZ_CMD + SZ_IBUF + SZ_OBUF + SZ_ARGBUF + SZ_FNAME + 5
+	call salloc (bp, nchars, TY_CHAR)
+
+	cmd = bp
+	ibuf = cmd + SZ_CMD + 1
+	obuf = ibuf + SZ_IBUF + 1
+	argbuf = obuf + SZ_OBUF + 1
+	fname = argbuf + SZ_ARGBUF + 1
+
+	qp = GT_QP(gt)
+
+	# Read raw tokens and push back macro or include file text until we
+	# get a fully resolved token.
+
+	repeat {
+	    fd = GT_FD(gt)
+
+	    # Get a raw token.
+	    token = qp_rawtok (gt, tokbuf, maxch)
+
+	    # Process special tokens.
+	    switch (token) {
+	    case EOF:
+		# EOF has been reached on the current stream.
+		level = GT_LEVEL(gt)
+		if (GT_FTEMP(gt) == YES) {
+		    call fstats (fd, F_FILENAME, Memc[fname], SZ_FNAME)
+		    if (level > 0)
+			call close (fd)
+		    iferr (call delete (Memc[fname]))
+			call erract (EA_WARN)
+		} else if (level > 0)
+		    call close (fd)
+
+		if (level > 0) {
+		    # Restore previous stream.
+		    GT_FD(gt)     = GT_SVFD(gt,level)
+		    GT_FTEMP(gt)  = GT_SVFTEMP(gt,level)
+		    GT_LEVEL(gt)  = level - 1
+		    GT_NEXTCH(gt) = NULL
+		} else {
+		    # Return EOF token to caller.
+		    call strcpy ("EOF", tokbuf, maxch)
+		    break
+		}
+
+	    case TOK_IDENTIFIER:
+		# Lookup the identifier in the symbol table.
+		sym = NULL
+		if (qp != NULL)
+		    sym = qp_gmsym (qp, tokbuf, textp)
+
+		# Process a defined macro.
+		if (sym != NULL) {
+		    # If macro does not have any arguments, merely push back
+		    # the replacement text.
+
+		    if (and (S_FLAGS(sym), SF_MACARGS) == 0) {
+			if (GT_NEXTCH(gt) > 0) {
+			    call ungetci (fd, GT_NEXTCH(gt))
+			    GT_NEXTCH(gt) = 0
+			}
+			call ungetline (fd, Memc[textp])
+			next
+		    }
+
+		    # Extract argument list, if any, perform argument
+		    # substitution on the macro, and push back the edited
+		    # text to be rescanned.
+
+		    if (qp_nexttok(gt) == '(') {
+			nargs = qp_arglist (gt, Memc[argbuf], SZ_ARGBUF)
+
+			# Pushback the text of a macro with arg substitution.
+			nchars = strmac (Memc[textp], Memc[argbuf],
+			    Memc[obuf], SZ_OBUF)
+			if (GT_NEXTCH(gt) > 0) {
+			    call ungetci (fd, GT_NEXTCH(gt))
+			    GT_NEXTCH(gt) = 0
+			}
+			call ungetline (fd, Memc[obuf])
+			next
+
+		    } else {
+			call eprintf ("macro `%s' called with no arguments\n")
+			    call pargstr (tokbuf)
+		    }
+		}
+
+		# Check for the builtin symbol $DFN, the datafile name.
+		if (tokbuf[1] == '$') {
+		    if (streq (tokbuf, "$DFN")) {
+			call strcpy (QP_DFNAME(qp), tokbuf, maxch)
+			token = TOK_STRING
+			break
+		    }
+		}
+
+		# Return a regular identifier.
+		break
+
+	    case TOK_COMMAND:
+		# Send a command to the CL and push back the output.
+
+		# Execute the command, spooling the output in a temp file.
+		call mktemp ("tmp$co", Memc[fname], SZ_FNAME)
+		call sprintf (Memc[cmd], SZ_LINE, "%s > %s")
+		    call pargstr (tokbuf)
+		    call pargstr (Memc[fname])
+		call clcmdw (Memc[cmd])
+
+		# Open the output file as input text.
+		call strcpy (Memc[fname], tokbuf, maxch)
+		nargs = 0
+		ftemp = YES
+		goto pushfile_
+
+	    case '@':
+		token = qp_rawtok (gt, tokbuf, maxch)
+		if (token != TOK_IDENTIFIER && token != TOK_STRING) {
+		    call eprintf ("expected a filename after the `@'\n")
+		    next
+		} else {
+		    nargs = 0
+		    if (qp_nexttok(gt) == '(')		# )
+			nargs = qp_arglist (gt, Memc[argbuf], SZ_ARGBUF)
+		    ftemp = NO
+		}
+pushfile_
+		# Attempt to open the file; first try the given name, then
+		# if that doesn't work, try adding the macro file extension.
+
+		iferr (i_fd = open (tokbuf, READ_ONLY, TEXT_FILE)) {
+		    call qp_mkfname (tokbuf,
+			QPOE_MACROEXTN, Memc[fname], SZ_FNAME)
+		    iferr (i_fd = open (Memc[fname],READ_ONLY,TEXT_FILE)) {
+			call eprintf ("cannot open `%s'\n")
+			    call pargstr (tokbuf)
+			next
+		    }
+		}
+
+		if (qp != NULL)
+		    call fseti (i_fd, F_PBBSIZE, QP_SZPBBUF(qp))
+		else
+		    call fseti (i_fd, F_PBBSIZE, DEF_MAXPUSHBACK)
+
+		# Cancel lookahead.
+		if (GT_NEXTCH(gt) > 0) {
+		    call ungetci (fd, GT_NEXTCH(gt))
+		    GT_NEXTCH(gt) = 0
+		}
+
+		# If the macro was called with a nonnull argument list,
+		# attempt to perform argument substitution on the file
+		# contents.  Otherwise merely push the fd.
+
+		if (nargs > 0) {
+		    # Pushback file contents with argument substitution.
+		    o_fd = stropen (Memc[ibuf], SZ_IBUF, NEW_FILE)
+
+		    call fcopyo (i_fd, o_fd)
+		    nchars = strmac (Memc[ibuf],Memc[argbuf],Memc[obuf],SZ_OBUF)
+		    call ungetline (fd, Memc[obuf])
+
+		    call close (o_fd)
+		    call close (i_fd)
+
+		} else {
+		    # Push a new input stream.
+		    level = GT_LEVEL(gt) + 1
+		    if (level > MAX_LEVELS)
+			call syserr (SYS_QPMRECUR)
+
+		    GT_SVFD(gt,level) = GT_FD(gt)
+		    GT_SVFTEMP(gt,level) = GT_FTEMP(gt)
+		    GT_LEVEL(gt) = level
+
+		    fd = i_fd
+		    GT_FD(gt) = fd
+		    GT_FTEMP(gt) = ftemp
+		}
+
+	    default:
+		break
+	    }
+	}
+
+	if (qp != NULL)
+	    if (QP_DEBUG(qp) > 4) {
+		call eprintf ("token=%d(%o), `%s'\n")
+		    call pargi (token)
+		    call pargi (max(0,token))
+		    if (IS_PRINT(tokbuf[1]))
+			call pargstr (tokbuf)
+		    else
+			call pargstr ("")
+	    }
+
+	call sfree (sp)
+	return (token)
+end
+
+
+# QP_UNGETTOK -- Push a token back into the QP_GETTOK input stream, to be
+# returned as the next token by QP_GETTOK.
+
+procedure qp_ungettok (gt, tokbuf)
+
+pointer	gt			#I gettok descriptor
+char	tokbuf[ARB]		#I text of token
+
+int	fd
+pointer	qp
+errchk	ungetci
+
+begin
+	fd = GT_FD(gt)
+	qp = GT_QP(gt)
+
+	if (qp != NULL)
+	    if (QP_DEBUG(qp) > 4) {
+		call eprintf ("unget token `%s'\n")
+		    call pargstr (tokbuf)
+	    }
+
+	# Cancel lookahead.
+	if (GT_NEXTCH(gt) > 0) {
+	    call ungetci (fd, GT_NEXTCH(gt))
+	    GT_NEXTCH(gt) = 0
+	}
+
+	# First push back a space to ensure that the token is recognized
+	# when the input is rescanned.
+
+	call ungetci (fd, ' ')
+
+	# Now push the token text.
+	call ungetline (fd, tokbuf)
+end
+ 
+
+# QP_RAWTOK -- Get a raw token from the input stream, without performing any
+# macro expansion or file inclusion.  The text of the token in returned in
+# tokbuf, and the token type is returened as the function value.
+
+int procedure qp_rawtok (gt, outstr, maxch)
+
+pointer	gt			#I gettok descriptor
+char	outstr[maxch]		#O receives text of token.
+int	maxch			#I max chars out
+
+int	token, delim, fd, ch, op
+define	again_ 91
+int	getci()
+
+begin
+	fd = GT_FD(gt)
+again_
+	# Get lookahead char if we don't already have one.
+	ch = GT_NEXTCH(gt)
+	GT_NEXTCH(gt) = NULL
+	if (ch <= 0 || IS_WHITE(ch) || ch == '\n') {
+	    while (getci (fd, ch) != EOF)
+		if (!(IS_WHITE(ch) || ch == '\n'))
+		    break
+	}
+
+	# Output the first character.
+	op = 1
+	if (ch != EOF && ch != '"' && ch != '\'' && ch != '`') {
+	    outstr[op] = ch
+	    op = op + 1
+	}
+
+	# Accumulate token.  Some of the token recognition logic used here
+	# (especially for numbers) is crude, but it is not clear that rigour
+	# is justified for this application.
+
+	if (ch == EOF) {
+	    call strcpy ("EOF", outstr, maxch)
+	    token = EOF
+
+	} else if (ch == '#') {
+	    # Ignore a comment.
+	    while (getci (fd, ch) != '\n')
+		if (ch == EOF)
+		    break
+	    goto again_
+
+	} else if (IS_ALPHA(ch) || ch == '_' || ch == '$' || ch == '.') {
+	    # Identifier.
+	    token = TOK_IDENTIFIER
+	    while (getci (fd, ch) != EOF)
+		if (IS_ALNUM(ch) || ch == '_' || ch == '$' || ch == '.') {
+		    outstr[op] = ch
+		    op = min (maxch, op+1)
+		} else
+		    break
+
+	} else if (IS_DIGIT(ch)) {
+	    # Number.
+	    token = TOK_NUMBER
+
+	    # Get number.
+	    while (getci (fd, ch) != EOF)
+		if (IS_ALNUM(ch) || ch == '.') {
+		    outstr[op] = ch
+		    op = min (maxch, op+1)
+		} else
+		    break
+
+	    # Get exponent if any.
+	    if (ch == 'E' || ch == 'e') {
+		outstr[op] = ch
+		op = min (maxch, op+1)
+		while (getci (fd, ch) != EOF)
+		    if (IS_DIGIT(ch) || ch == '+' || ch == '-') {
+			outstr[op] = ch
+			op = min (maxch, op+1)
+		    } else
+			break
+	    }
+
+	} else if (ch == '"' || ch == '\'' || ch == '`') {
+	    # Quoted string or command.
+
+	    if (ch == '`')
+		token = TOK_COMMAND
+	    else
+		token = TOK_STRING
+
+	    delim = ch
+	    while (getci (fd, ch) != EOF)
+		if (ch==delim && (op>1 && outstr[op-1] != '\\') || ch == '\n')
+		    break
+		else {
+		    outstr[op] = ch
+		    op = min (maxch, op+1)
+		}
+	    ch = getci (fd, ch)
+
+	} else if (ch == '+') {
+	    # May be the += operator.
+	    if (getci (fd, ch) != EOF)
+		if (ch == '=') {
+		    token = TOK_PLUSEQUALS
+		    outstr[op] = ch
+		    op = op + 1
+		    ch = getci (fd, ch)
+		} else
+		    token = '+'
+
+	} else if (ch == ':') {
+	    # May be the := operator.
+	    if (getci (fd, ch) != EOF)
+		if (ch == '=') {
+		    token = TOK_COLONEQUALS
+		    outstr[op] = ch
+		    op = op + 1
+		    ch = getci (fd, ch)
+		} else
+		    token = ':'
+
+	} else {
+	    # Other characters.
+	    token = ch
+	    ch = getci (fd, ch)
+	}
+
+	# Process the lookahead character.
+	if (IS_WHITE(ch) || ch == '\n') {
+	    repeat {
+		ch = getci (fd, ch)
+	    } until (!(IS_WHITE(ch) || ch == '\n'))
+	}
+
+	if (ch != EOF)
+	    GT_NEXTCH(gt) = ch
+
+	outstr[op] = EOS
+	return (token)
+end
+
+
+# QP_NEXTTOK -- Determine the type of the next raw token in the input stream,
+# without actually fetching the token.  TOK_PLUSEQUALS is not recognized at
+# this level.  Note that this is at the same level as QP_RAWTOK, i.e., no
+# macro expansion is performed, and the lookahead token is that which would
+# be returned by the next qp_rawtok, which is not necessarily what qp_gettok
+# would return after macro replacement.
+
+int procedure qp_nexttok (gt)
+
+pointer	gt			#I gettok descriptor
+
+pointer	qp
+int	token, fd, ch
+int	getci()
+
+begin
+	fd = GT_FD(gt)
+	qp = GT_QP(gt)
+
+	# Get lookahead char if we don't already have one.
+	ch = GT_NEXTCH(gt)
+	if (ch <= 0 || IS_WHITE(ch) || ch == '\n')
+	    while (getci (fd, ch) != EOF)
+		if (!(IS_WHITE(ch) || ch == '\n'))
+		    break
+
+	if (ch == EOF)
+	    token = EOF
+	else if (IS_ALPHA(ch))
+	    token = TOK_IDENTIFIER
+	else if (IS_DIGIT(ch))
+	    token = TOK_NUMBER
+	else if (ch == '"' || ch == '\'') 
+	    token = TOK_STRING
+	else if (ch == '`')
+	    token = TOK_COMMAND
+	else
+	    token = ch
+
+	if (qp != NULL)
+	    if (QP_DEBUG(qp) > 4) {
+		call eprintf ("nexttok=%d(%o) `%c'\n")
+		    call pargi (token)
+		    call pargi (max(0,token))
+		    if (IS_PRINT(ch))
+			call pargi (ch)
+		    else
+			call pargi (0)
+	    }
+
+	return (token)
+end
+
+
+# QP_CLOSETEXT -- Close the gettok descriptor and any files opened thereon.
+
+procedure qp_closetext (gt)
+
+pointer	gt			#I gettok descriptor
+
+int	level, fd
+pointer	sp, fname
+
+begin
+	call smark (sp)
+	call salloc (fname, SZ_FNAME, TY_CHAR)
+
+	for (level=GT_LEVEL(gt);  level >= 0;  level=level-1) {
+	    fd = GT_FD(gt)
+	    if (GT_FTEMP(gt) == YES) {
+		call fstats (fd, F_FILENAME, Memc[fname], SZ_FNAME)
+		call close (fd)
+		iferr (call delete (Memc[fname]))
+		    call erract (EA_WARN)
+	    } else
+		call close (fd)
+
+	    if (level > 0) {
+		GT_FD(gt)    = GT_SVFD(gt,level)
+		GT_FTEMP(gt) = GT_SVFTEMP(gt,level)
+	    }
+	}
+
+	call mfree (gt, TY_STRUCT)
+	call sfree (sp)
+end
+
+
+# QP_ARGLIST -- Extract a paren and comma delimited argument list to be used
+# for substitution into a macro replacement string.  Since the result will be
+# pushed back and rescanned, we do not have to perform macro substitution on
+# the argument list at this level.
+
+int procedure qp_arglist (gt, argbuf, maxch)
+
+pointer	gt			#I gettok descriptor
+char	argbuf[maxch]		#O receives parsed arguments
+int	maxch			#I max chars out
+
+int	level, quote, nargs, op, ch, fd
+int	getci()
+
+begin
+	fd = GT_FD(gt)
+
+	# Get lookahead char if we don't already have one.
+	ch = GT_NEXTCH(gt)
+	if (ch <= 0 || IS_WHITE(ch) || ch == '\n')
+	    while (getci (fd, ch) != EOF)
+		if (!(IS_WHITE(ch) || ch == '\n'))
+		    break
+
+	quote = 0
+	level = 1
+	nargs = 0
+	op = 1
+
+	if (ch == '(') {
+	    while (getci (fd, ch) != EOF) {
+		if (ch == '"' || ch == '\'') {
+		    if (quote == 0)
+			quote = ch
+		    else if (quote == ch)
+			quote = 0
+
+		} else if (ch == '(' && quote == 0) {
+		    level = level + 1
+		} else if (ch == ')' && quote == 0) {
+		    level = level - 1
+		    if (level <= 0) {
+			if (op > 1 && argbuf[op-1] != EOS)
+			    nargs = nargs + 1
+			break
+		    }
+
+		} else if (ch == ',' && level == 1 && quote == 0) {
+		    ch = EOS
+		    nargs = nargs + 1
+		} else if (ch == '\n') {
+		    ch = ' '
+		} else if (ch == '\\' && quote == 0) {
+		    ch = getci (fd, ch)
+		    next
+		} else if (ch == '#' && quote == 0) {
+		    while (getci (fd, ch) != EOF)
+			if (ch == '\n')
+			    break
+		    next
+		}
+
+		argbuf[op] = ch
+		op = min (maxch, op + 1)
+	    }
+
+	    GT_NEXTCH(gt) = NULL
+	}
+
+	argbuf[op] = EOS
+	return (nargs)
+end