1 files changed, 304 insertions, 0 deletions
diff --git a/noao/digiphot/photcal/parser/pralloc.x b/noao/digiphot/photcal/parser/pralloc.x
new file mode 100644
index 00000000..2147298e
--- /dev/null
+++ b/noao/digiphot/photcal/parser/pralloc.x
@@ -0,0 +1,304 @@
+.help pralloc
+Parser Memory Allocation.
+
+Entry points:
+
+	pr_alloc ()			Allocate parser tables.
+
+	pr_inalloc (ptr)		Allocate input variable substructure.
+	pr_ftalloc (ptr)		Allocate fitting parameter substructure.
+	pr_stalloc (ptr)		Allocate set equation substructure.
+	pr_tralloc (ptr, npars)		Allocate transf. equation substructure.
+
+	pr_free ()			Free parser tables.
+.endhelp
+
+include	"../lib/parser.h"
+include	"../lib/prstruct.h"
+
+# Number of expected symbols in the symbol table. The table is reallocated
+# automatically by the SYMTAB procedures if this value is not enough.
+
+define	LEN_SYMTABLE		100
+
+
+# PR_ALLOC -- Allocate space for symbol table and sequential tables
+
+procedure pr_alloc ()
+
+pointer stopen()
+
+include	"parser.com"
+
+begin
+	# Open symbol table
+	symtable = stopen ("parser", 2 * LEN_SYMTABLE, LEN_SYMTABLE, 
+			   LEN_SYMTABLE * SZ_LINE)
+
+	# Allocate space for other tables
+	call mct_alloc (obstable,   10, 1, TY_INT)
+	call mct_alloc (cattable,   10, 1, TY_INT)
+	call mct_alloc (partable,   30, 1, TY_INT)
+	call mct_alloc (exttable,   10, 1, TY_INT)
+	call mct_alloc (trntable,   10, 1, TY_INT)
+	call mct_alloc (settable,   10, 1, TY_INT)
+	call mct_alloc (trcattable, 20, 2, TY_INT)
+	call mct_alloc (trobstable, 20, 2, TY_INT)
+	call mct_alloc (tfcattable, 20, 2, TY_INT)
+	call mct_alloc (tfobstable, 20, 2, TY_INT)
+	call mct_alloc (tpartable,  20, 1, TY_INT)
+end
+
+
+# PR_INALLOC -- Allocate space for input variable substructure.
+
+procedure pr_inalloc (ptr)
+
+pointer	ptr		# substructure pointer (output)
+
+begin
+	# Allocate space
+	call malloc (ptr, LEN_PINP, TY_STRUCT)
+
+	# Initialize substructure
+	PINP_COL    (ptr) = INDEFI
+	PINP_ERRCOL (ptr) = INDEFI
+	PINP_WTSCOL (ptr) = INDEFI
+	PINP_SPARE  (ptr) = NO
+end
+
+
+# PR_FTALLOC -- Allocate space for fitting parameter substructure.
+
+procedure pr_ftalloc (ptr)
+
+pointer	ptr		# substructure pointer (output)
+
+begin
+	# Allocate space
+	call malloc (ptr, LEN_PFIT, TY_STRUCT)
+
+	# Initialize substructure
+	PFIT_VALUE (ptr) = INDEFR
+	PFIT_DELTA (ptr) = INDEFR
+end
+
+
+# PR_STALLOC -- Allocate and initialize a set equation substructure.
+# Initialization may not be necessary for all fields in the substructure,
+# but it's safer to do it anyway.
+
+procedure pr_stalloc (ptr)
+
+pointer	ptr		# substructure pointer (output)
+
+begin
+	# Allocate space
+	call malloc (ptr, LEN_PSEQ, TY_STRUCT)
+
+	# Initialize string offsets
+	PSEQ_EQ     (ptr) = INDEFI
+	PSEQ_ERROR  (ptr) = INDEFI
+	PSEQ_ERRMIN (ptr) = INDEFI
+	PSEQ_ERRMAX (ptr) = INDEFI
+	PSEQ_WEIGHT (ptr) = INDEFI
+	PSEQ_WTSMIN (ptr) = INDEFI
+	PSEQ_WTSMAX (ptr) = INDEFI
+
+	# Initialize code pointers
+	PSEQ_RPNEQ     (ptr) = NULL
+	PSEQ_RPNERROR  (ptr) = NULL
+	PSEQ_RPNERRMIN (ptr) = NULL
+	PSEQ_RPNERRMAX (ptr) = NULL
+	PSEQ_RPNWEIGHT (ptr) = NULL
+	PSEQ_RPNWTSMIN (ptr) = NULL
+	PSEQ_RPNWTSMAX (ptr) = NULL
+end
+
+
+# PR_TRALLOC -- Allocate space and initialize a transformation equation
+# substructure. Initialization may not be necessary for all fields in the
+# substructure, but it's safer to do it anyway.
+
+procedure pr_tralloc (ptr, nrcat, nrobs, nfcat, nfobs, npars)
+
+pointer	ptr		# substructure pointer (output)
+int	nrcat		# number of catalog variables in reference eq.
+int	nrobs		# number of observation variables in reference eq.
+int	nfcat		# number of catalog variables in fit eq.
+int	nfobs		# number of observation variables in fit eq.
+int	npars		# number of parameters
+
+int	nvars, nrvars, nfvars
+
+begin
+	# Total number of variables
+	nrvars = nrcat  + nrobs
+	nfvars = nfcat  + nfobs
+	nvars  = nrvars + nfvars
+
+	# Allocate space
+	call malloc (ptr, LEN_PTEQ (nvars, npars), TY_STRUCT)
+
+	# Initialize counters
+	PTEQ_NRCAT (ptr) = nrcat
+	PTEQ_NROBS (ptr) = nrobs
+	PTEQ_NRVAR (ptr) = nrvars
+	PTEQ_NFCAT (ptr) = nfcat
+	PTEQ_NFOBS (ptr) = nfobs
+	PTEQ_NFVAR (ptr) = nfvars
+	PTEQ_NVAR  (ptr) = nvars
+	PTEQ_NPAR  (ptr) = npars
+	PTEQ_NFPAR (ptr) = INDEFI
+
+	# Initialize variable offsets and counters
+	call amovki (INDEFI, PTEQ_AREFVAR (ptr), nrvars)
+	call amovki (INDEFI, PTEQ_AFITVAR (ptr), nfvars)
+	call aclri  (PTEQ_AREFCNT (ptr), nrvars)
+	call aclri  (PTEQ_AFITCNT (ptr), nfvars)
+
+	# Initialize parameter offsets, values, and list
+	call amovki (INDEFI, PTEQ_APAR (ptr), npars)
+	call amovkr (INDEFR, PTEQ_APARVAL (ptr), npars)
+	call aclri  (PTEQ_APLIST (ptr), npars)
+
+	# Initialize string offsets
+	PTEQ_FIT    (ptr) = INDEFI
+	PTEQ_REF    (ptr) = INDEFI
+	PTEQ_ERROR  (ptr) = INDEFI
+	PTEQ_ERRMIN (ptr) = INDEFI
+	PTEQ_ERRMAX (ptr) = INDEFI
+	PTEQ_WEIGHT (ptr) = INDEFI
+	PTEQ_WTSMIN (ptr) = INDEFI
+	PTEQ_WTSMAX (ptr) = INDEFI
+	PTEQ_XPLOT  (ptr) = INDEFI
+	PTEQ_YPLOT  (ptr) = INDEFI
+	call amovki (INDEFI, PTEQ_ADER (ptr), npars)
+
+	# Initialize code pointers
+	PTEQ_RPNFIT    (ptr) = NULL
+	PTEQ_RPNREF    (ptr) = NULL
+	PTEQ_RPNERROR  (ptr) = NULL
+	PTEQ_RPNERRMIN (ptr) = NULL
+	PTEQ_RPNERRMAX (ptr) = NULL
+	PTEQ_RPNWEIGHT (ptr) = NULL
+	PTEQ_RPNWTSMIN (ptr) = NULL
+	PTEQ_RPNWTSMAX (ptr) = NULL
+	PTEQ_RPNXPLOT  (ptr) = NULL
+	PTEQ_RPNYPLOT  (ptr) = NULL
+	call amovki (NULL, PTEQ_ARPNDER (ptr), npars)
+end
+
+
+# PR_FREE - Free parser symbol table and sequential tables.
+
+procedure pr_free ()
+
+int	n
+pointer	sym, ptr
+
+include	"parser.com"
+
+pointer	sthead(), stnext()
+
+begin
+	# Traverse the symbol table looking for symbol
+	# substructures before closing it.
+	sym = sthead (symtable)
+	while (sym != NULL) {
+
+	    # Get pointer to the equation substructure,
+	    # and free it only if not NULL
+	    ptr = PSYM_SUB (sym)
+	    if (ptr != NULL) {
+
+		# Free additonal buffers associated with the substructure
+		switch (PSYM_TYPE (sym)) {
+		case PTY_CATVAR, PTY_OBSVAR:
+		    # do nothing
+
+		case PTY_FITPAR, PTY_CONST:
+		    # do nothing
+
+		case PTY_TRNEQ:
+
+		    # Free transformation equation codes
+		    if (PTEQ_RPNFIT (ptr) != NULL)
+			call mfree (PTEQ_RPNFIT (ptr), TY_STRUCT)
+		    if (PTEQ_RPNREF (ptr) != NULL)
+			call mfree (PTEQ_RPNREF (ptr), TY_STRUCT)
+
+		    # Free error equation codes
+		    if (PTEQ_RPNERROR (ptr) != NULL)
+			call mfree (PTEQ_RPNERROR (ptr), TY_STRUCT)
+		    if (PTEQ_RPNERRMIN (ptr) != NULL)
+			call mfree (PTEQ_RPNERRMIN (ptr), TY_STRUCT)
+		    if (PTEQ_RPNERRMAX (ptr) != NULL)
+			call mfree (PTEQ_RPNERRMAX (ptr), TY_STRUCT)
+
+		    # Free weight equation codes
+		    if (PTEQ_RPNWEIGHT (ptr) != NULL)
+			call mfree (PTEQ_RPNWEIGHT (ptr), TY_STRUCT)
+		    if (PTEQ_RPNWTSMIN (ptr) != NULL)
+			call mfree (PTEQ_RPNWTSMIN (ptr), TY_STRUCT)
+		    if (PTEQ_RPNWTSMAX (ptr) != NULL)
+			call mfree (PTEQ_RPNWTSMAX (ptr), TY_STRUCT)
+
+		    # Free plot equation codes
+		    if (PTEQ_RPNXPLOT (ptr) != NULL)
+			call mfree (PTEQ_RPNXPLOT (ptr), TY_STRUCT)
+		    if (PTEQ_RPNYPLOT (ptr) != NULL)
+			call mfree (PTEQ_RPNYPLOT (ptr), TY_STRUCT)
+		    do n = 1, PTEQ_NPAR (ptr)
+			call mfree (PTEQ_RPNDER (ptr, n), TY_STRUCT)
+
+		case PTY_SETEQ:
+
+		    # Free set equation code
+		    if (PSEQ_RPNEQ (ptr) != NULL)
+			call mfree (PSEQ_RPNEQ (ptr), TY_STRUCT)
+
+		    # Free error equation codes
+		    if (PSEQ_RPNERROR (ptr) != NULL)
+			call mfree (PSEQ_RPNERROR (ptr), TY_STRUCT)
+		    if (PSEQ_RPNERRMIN (ptr) != NULL)
+			call mfree (PSEQ_RPNERRMIN (ptr), TY_STRUCT)
+		    if (PSEQ_RPNERRMAX (ptr) != NULL)
+			call mfree (PSEQ_RPNERRMAX (ptr), TY_STRUCT)
+
+		    # Free weight equation codes
+		    if (PSEQ_RPNWEIGHT (ptr) != NULL)
+			call mfree (PSEQ_RPNWEIGHT (ptr), TY_STRUCT)
+		    if (PSEQ_RPNWTSMIN (ptr) != NULL)
+			call mfree (PSEQ_RPNWTSMIN (ptr), TY_STRUCT)
+		    if (PSEQ_RPNWTSMAX (ptr) != NULL)
+			call mfree (PSEQ_RPNWTSMAX (ptr), TY_STRUCT)
+
+		default:
+		    call error (0, "pr_free: unknown equation symbol type")
+		}
+
+		# Free equation substructure
+		call mfree (ptr, TY_STRUCT)
+	    }
+
+	    # Advance to next symbol
+	    sym = stnext (symtable, sym)
+	}
+
+	# Close symbol table
+	call stclose (symtable)
+
+	# Close other tables
+	call mct_free (obstable)
+	call mct_free (cattable)
+	call mct_free (partable)
+	call mct_free (exttable)
+	call mct_free (trntable)
+	call mct_free (settable)
+	call mct_free (trcattable)
+	call mct_free (trobstable)
+	call mct_free (tfcattable)
+	call mct_free (tfobstable)
+	call mct_free (tpartable)
+end