Repatch (from linux) of OSX IRAF

1 files changed, 283 insertions, 0 deletions

diff --git a/pkg/utilities/nttools/texpand/parser.x b/pkg/utilities/nttools/texpand/parser.x
new file mode 100644
index 00000000..2dcba75e
--- /dev/null
+++ b/pkg/utilities/nttools/texpand/parser.x
@@ -0,0 +1,283 @@
+include <tbset.h>
+include	"lexoper.h"
+
+define	MAXSTACK	100
+define	SZ_VALSTACK	3*SZ_LINE
+
+# PARSER -- Parse a rule base file
+#
+# This procedure uses a simple operator precedence parser. Every token
+# retrieved from the file is either an identifier or an operator.
+# Identifiers are pushed onto an identifier stack. Operators are
+# pushed onto a separate operator stack. When an operator is read
+# whose priority is less than that of the operator on top of the
+# operator stack, the operator on the stack is popped and passed to
+# a procedure which performs the appropriate action, using the
+# identifiers on the identifier stack. This continues until all
+# operators of higher priority have been processed, or the stack is
+# empty. Syntax checking is done by checking that the identifier
+# stack contains the correct number and type of identifier and that
+# identifiers and operators alternate in the input. The priority of 
+# each operator is implicit in the integer which is used to represent 
+# it. For more information on operator precedence parsers, see "Writing 
+# Interactive Compilers and Interpreters" by P.J Brown, pp. 149-151.
+#
+# B.Simon	25-Apr-88	Original
+# B.Simon	15-Jan-99	Skip rules with columns not in table
+
+procedure parser (rbase, itp, dbg, target, action)
+
+char	rbase[ARB]	# i: Rule base name
+pointer	itp		# i: Input table descriptor
+int	dbg		# i: Debug file descriptor
+pointer	target		# o: Target table descriptor
+pointer	action		# o: Action table descriptor
+#--
+include "parser.com"
+
+bool	done, expect_id
+int	idtop, optop, oper, tabtop, missing
+int	opstack[MAXSTACK]
+pointer	sp, rb, work, value, valstack, nxtval, colname, colval
+pointer	idstack[MAXSTACK]
+
+string	find_error  "Column name or type mismatch"
+string	stack_error "Stack overflow"
+string	oper_error  "Operator expected"
+string	ident_error "Identifier expected"
+
+string	wrkname     "The parser changed the work table to the following:"
+
+int	gstrcpy(), putstackt(), numstack()
+pointer	initstack()
+
+errchk	initstack, lexinit, lexer, lexclose, syntax, typecheck, mkrules
+
+begin
+	# Allocate dynamic memory for strings
+
+	call smark (sp)
+	call salloc (value, SZ_LINE, TY_CHAR)
+	call salloc (valstack, SZ_VALSTACK, TY_CHAR)
+
+	# Initialize the lexical analyzer
+
+	call lexinit (rbase, rb)
+
+	# Create tables used by parser
+
+	target = initstack (itp, "_FIRST,_LAST,_USED")
+	action = initstack (itp, "")
+	work =  initstack (itp, "")
+
+	# Save copy of table pointers in common block
+
+	ptgt = target
+	pact = action
+	pwrk = work
+
+	# Initialize stack pointers
+
+	idtop = 0
+	optop = 0
+	nxtval = valstack
+
+	missing = NO
+	done = false
+	expect_id = true
+
+	repeat {
+
+	    # Get next operator from rule base
+
+	    call lexer (rb, oper, Memc[value], SZ_LINE)
+
+	    # First case: operator is identifier, push on id stack
+
+	    if (oper == IDOPR) {
+		if (expect_id) {
+		    idtop = idtop + 1
+		    if (idtop > MAXSTACK)
+			call syntax (rb, stack_error)
+
+		    idstack[idtop] = nxtval
+		    nxtval = gstrcpy (Memc[value], Memc[nxtval], SZ_LINE) +
+			     nxtval + 1
+		} else {
+		    call syntax (rb, oper_error)
+		}
+
+	    # Second case: operator is not identifier
+
+	    } else {
+		if (oper != ENDOPR && expect_id)
+		    call syntax (rb, ident_error)
+
+		# Process all operators whose priorities are >=
+		# the operator just read from the rule base
+
+		repeat {
+		    if (optop == 0)
+			break
+		    if (oper > opstack[optop])
+			break
+
+		    # Perform semantic actions associated with operators
+
+		    switch (opstack[optop]) {
+		    case ENDOPR:
+			call typecheck (rb, idstack, idtop, NO_IDENT, NO_IDENT)
+			done = true
+		    case SEPOPR:
+			call typecheck (rb, idstack, idtop, NO_IDENT, NO_IDENT)
+		    case IMPOPR:
+			call typecheck (rb, idstack, idtop, PHRASE, CLAUSE)
+			if (missing == NO) {
+			    call mkrules (work, target, action)
+			} else {
+			    missing = NO
+			    tabtop = numstack (work)
+			    call tbrdel (work, 1, tabtop)
+			}
+			idtop = idtop - 2
+		    case OROPR:
+			call typecheck (rb, idstack, idtop, CLAUSE, CLAUSE)
+			idtop = idtop - 1
+			idstack[idtop] = CLAUSE
+		    case ANDOPR:
+			call typecheck (rb, idstack, idtop, PHRASE, PHRASE)
+			if (missing == NO)
+			    call andstack (work)
+
+			idtop = idtop - 1
+			idstack[idtop] = PHRASE
+		    case EQOPR:
+			call typecheck (rb, idstack, idtop, NAME, NAME)
+			colval = idstack[idtop]
+			colname = idstack[idtop-1]
+			nxtval = colname
+			call pushstack (work)
+			if (putstackt (work, Memc[colname], Memc[colval])== NO)
+			    missing = YES
+
+			idtop = idtop - 1
+			idstack[idtop] = PHRASE			
+		    }
+
+		    optop = optop - 1
+
+		    # Debug prints
+
+		    tabtop = numstack (work)
+		    call dbg_rules (work, wrkname, 1, tabtop, dbg)
+
+		} until (done)
+
+		# Push the operator just read on the operator stack
+
+		optop = optop + 1
+		if (optop > MAXSTACK)
+		    call syntax (rb, stack_error)
+		opstack[optop] = oper
+	    }
+
+	    # Operators and identifiers should alternate in the input
+
+	    expect_id = ! expect_id
+
+	} until (done)
+
+	call freestack (work)
+	call lexclose (rb)
+	call sfree (sp)
+end
+
+# TYPECHECK -- Check the number and type of identifiers on the stack
+
+procedure typecheck (rb, idstack, idtop, type1, type2)
+
+pointer	rb		# i: Rule base descriptor
+pointer	idstack[ARB]	# i: Identifier stack
+int	idtop		# i: Top of identifier stack
+pointer	type1		# i: Type expected for one below stack top
+pointer	type2		# i: Type expected for stack top
+#--
+int	itype
+pointer	id, type[2]
+
+string	bad_type "Operator out of order"
+string	too_few  "Missing identifier"
+string	too_many "Unexpected end of rule"
+
+begin
+	type[1] = type1
+	type[2] = type2
+
+	do itype = 1, 2 {
+	    switch (type[itype]) {
+	    case CLAUSE:
+
+		if (idtop < itype)
+		    call syntax (rb, too_few)
+		id = idstack[idtop+itype-2]
+
+		# a phrase is also a clause
+
+		if (!(id == PHRASE || id == CLAUSE))
+		    call syntax (rb, bad_type)
+
+	    case PHRASE:
+
+		if (idtop < itype)
+		    call syntax (rb, too_few)
+		id = idstack[idtop+itype-2]
+		if (id != PHRASE)
+		    call syntax (rb, bad_type)
+
+	    case NO_IDENT:
+
+		if (idtop >= itype)
+		    call syntax (rb, too_many)
+
+	    case NAME:
+
+		if (idtop < itype)
+		    call syntax (rb, too_few)
+		id = idstack[idtop+itype-2]
+		if (id <= 0)
+		    call syntax (rb, bad_type)
+
+	    }
+	}
+
+end
+
+# SYNTAX -- Print a syntax error message
+
+procedure syntax (rb, errmsg)
+
+pointer	rb		# i: Rule base descriptor
+char	errmsg[ARB]	# i: Error message
+#--
+include "parser.com"
+
+begin
+	# Remove temporary tables
+
+	call freestack (ptgt)
+	call freestack (pact)
+	call freestack (pwrk)
+
+	# Print the line where the error was detected
+
+	call eprintf ("Syntax error on line %d\n%s%*t^\n")
+	    call pargi (RB_NLINE(rb))
+	    call pargstr (RB_LINE(rb))
+	    call pargi (RB_INDEX(rb))
+
+	# Close the rules file and send the error message
+
+	call lexclose (rb)
+	call error (ERR, errmsg)
+
+end