


		    PNOTICE_mrpg.alm                02/14/84  0841.6r w 02/14/84  0841.5        3555


	dec	1			"version 1 structure
	dec	2			"no. of pnotices
	dec	3			"no. of STIs
	dec	156			"lgth of all pnotices + no. of pnotices
          acc       "Copyright, (C) Honeywell Information Systems Inc., 1981"
          acc       "Copyright (c) 1972 by Massachusetts Institute of
Technology and Honeywell Information Systems, Inc."

	aci	"W1RPGM0B0000"
	aci	"W2RPGM0B0000"
	aci	"W3RPGM0B0000"
	end
 



		    check_pointer_.pl1              05/20/80  1933.0r w 05/20/80  1924.4       12456


/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

check_pointer_: proc (pptr, msg);

dcl  pptr ptr,
     msg char (32);

dcl  uppt ptr based (pptr);
dcl  ch char (1);
dcl  upch char (1) unal based (uppt);
dcl  any_other condition;
dcl  code fixed bin (35);
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));

	msg = "";
	on condition (any_other) call handler;
	ch = upch;
quit:
	return;

packed:	entry (pptr, msg);

dcl  pch char (1) based (ppt);
dcl  ppt ptr unal based (pptr);

	msg = "";
	on condition (any_other) call handler;
	ch = pch;
	return;

handler:	proc;

dcl 1 cond_info,
%include cond_info;

	     call find_condition_info_ (null (), addr (cond_info), code);
	     if (condition_name = "quit")
	     | (condition_name = "alrm")
	     | (condition_name = "cput")
	     then do;
		call continue_to_signal_ (code);
		return;
	     end;
	     msg = condition_name;
	     goto quit;
	end;
     end;



		    macro_.pl1                      02/14/84  0905.4r w 02/14/84  0844.2      980109


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */

/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */
				/** FUTURE &fileout name ... &filend */

macro_: proc (sl_name, segname, macname, out_ptr, out_len, arglp, argct, msg,
      refseg, ecode);

      segtype = "MACRO";
      if (sl_name = "macro")
      then who_am_i = "MACRO";
      else who_am_i = "EXPANSION";
      mac_sw = "1"b;
      segptr = null ();
      refp = refseg;
      goto start;

expand: entry (sl_name, segname, macname, out_ptr, out_len, arglp, argct, msg,
      strptr, strlen, ecode);

      if (segname = "")
      then segtype = "STRING";
      else segtype = "SEGMENT";
      myname = "source ";
      myname = myname || segtype;
      mac_sw = "0"b;
      refp = null ();
      segptr = strptr;
      segi = 1;
      sege = strlen;
      goto start;

dcl sl_name	char (32) var,	/* search  list name	       */
    segname	char (32) var,	/* name of segment to find	       */
				/* "" -> not specified	       */
    macname	char (32) var,	/* name of macro to expand	       */
				/* "" -> expanding a string	       */
    out_ptr	ptr,		/* output string (not aligned)       */
    out_len	fixed bin (24),	/* length of output produced (Out)   */
    arglp		ptr,		/* pointer to argument list	       */
    argct		fixed bin,	/* number of arguments	       */
    msg		char (1000) var,	/* error message text	       */
    refseg	ptr,		/* pointer to referencing segment    */
    strptr	ptr,		/* pointer to string to expand       */
    strlen	fixed bin (24),	/* length of string to expand	       */

    ecode		fixed bin (35);

dcl 1 argl	(24) based (arglp),
      2 p		ptr,
      2 l		fixed bin (24);
dcl arg		char (argl.l (num)) based (argl.p (num));
dcl num		fixed bin (24);
dcl refp		ptr;

start:
      if free_area_p = null ()
      then call get_area;
      local_var_ptr, int_var_ptr = null ();
      msg_etc = "";

      do num = 1 to argct;
         if (argl.l (num) < 0)
         then signal condition (argleng_less_than_zero);
         if (argl.l (num) > 500)
         then do;
	  msg = "ARG ";
	  msg = msg || ltrim (char (num));
	  msg = msg || " >500 characters.";
	  ecode = -1;
	  return;
         end;
      end;
      msg = "";
      ecode = 0;
      macro_nest = macro_nest + 1;

      save_db = db_sw;
      if (segtype = "STRING") | (segptr ^= null ())
      then goto doit;

/* name = "macro" | "foo$foo" | "foo$bar"			       */
      if mac_sw
      then do;
         c32 = segname;
         if (c32 = "")
         then do;
	  if db_sw
	  then call ioa_ (""""" ^a", macname);
	  myname = macname;
	  do maclp = macro_list_p
	     repeat (macro_list.next)
	     while (maclp ^= null ());
	     if macro_list.int_mac
	     then do;
	        if db_sw
	        then call ioa_ ("   ^a/^a", substr (macro_list.dname, 1, 1),
		      macro_list.name);
	        if (macro_list.name = macname)
	        then do;
		 segptr = macro_list.ref;
		 segi = macro_list.from;
		 sege = macro_list.to;
		 goto doit;
	        end;
	     end;
	  end;
	  c32 = macname;		/* didn't find an imbedded macro by  */
         end;			/*  this name, try for macro$macro.  */
         if db_sw
         then call ioa_ ("^a$^a", c32, macname);
         myname = c32;
         myname = myname || "$";
         myname = myname || macname;
         do maclp = macro_list_p
	  repeat (macro_list.next)
	  while (maclp ^= null ());
	  if ^macro_list.int_mac
	  then do;
	     if db_sw
	     then call ioa_ ("   ^a/^a", macro_list.ename, macro_list.name);
	     if (macro_list.ename = c32) & (macro_list.name = macname)
	     then do;
	        segptr = macro_list.ref;
	        segi = macro_list.from;
	        sege = macro_list.to;
	        goto doit;
	     end;
	  end;
         end;
      end;

      call find_macro (refp, segname, sl_name, macname);

doit:
      tr_sw = "0"b;
      if (substr (segment, segi, 7) = "&trace
")
      then do;
         segi = segi + 7;
         tr_sw = "1"b;
      end;
      if (substr (segment, segi, 7) = "&debug
")
      then do;
         segi = segi + 7;
         db_sw = "1"b;
      end;
      if db_sw | pc_sw | tr_sw | al_sw
      then do;
         call ioa_ ("^[EXPAND^s^;^a^](^i)  ^a", (who_am_i = "EXPANSION"),
	  segtype, macro_nest, macname);
         do num = 1 to argct;
	  call ioa_ ("ARG^2i:  ""^va""", num, argl.l (num), arg);
         end;
         if (argct = 0)
         then call ioa_ ("ARGs: none");
      end;
      construct_nest = 1;
      call_err = "0"b;
      call expand (segptr, segi, sege, out_ptr, out_len, "11"b);
quit:
      if db_sw | pc_sw | tr_sw | al_sw
      then call ioa_ (" ^[MEND^;EXPEND^](^i)  ^a", (who_am_i = "MACRO"),
	    macro_nest, macname);

      if (segi < sege)
      then do;
misplaced:
         msg = "Misplaced """;
         msg = msg || c32;
         msg = msg || """. ";

add_identification:
         ecode = error_table_$badsyntax;
add_id:
         if call_err
         then msg = msg || "
	from";
         if segtype = "MACRO"
         then do;
	  msg = msg || " ";
	  msg = msg || who_am_i;
         end;
         msg = msg || " """;
         msg = msg || myname;
         msg = msg || """, line ";
         msg = msg || lineno (segi);
         if ^call_err
         then do;
	  msg = "
ERROR SEVERITY 4. " || msg;
	  if (msg_etc ^= "")
	  then do;
	     msg = msg || NL;
	     msg = msg || msg_etc;
	  end;
         end;
      end;
exit:
      macro_nest = macro_nest - 1;
      tptr = local_var_ptr;
      call free_um ("loc");
      if (err_ct (3) ^= 0) & (err_ct (4) = 0)
      then ecode = error_table_$translation_failed;
      db_sw = save_db;
      return;


syntax_err:
      msg = "Syntax error in " || msg;
      msg = msg || ". ";
      goto add_identification; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* add a macro to the list of known macros			       */

addmacro: proc (dname, segname, macname, int_mac, segp, segi, sege);

dcl dname		char (168),
    segname	char (32) var,
    macname	char (32) var,
    int_mac	bit (1),		/* 1- is &macro/&define	       */
    segp		ptr,
    segi		fixed bin (24),
    sege		fixed bin (24);

      if db_sw
      then call ioa_ ("addmacro ^a > ^a (^p) ^a^[ INTERNAL^]",
	    dname, segname, segp, macname, int_mac);
      do maclp = macro_list_p
         repeat (macro_list.next)
         while (maclp ^= null ());
         if (macro_list.ename = segname) & (macro_list.name = macname)
	  & (macro_list.int_mac = int_mac)
         then do;
	  if (segptr = macro_list.ref)
	     & (segi = macro_list.from)
	     & (sege = macro_list.to)
	  then do;
	     if db_sw
	     then call ioa_ ("   already there");
	     return;
	  end;
	  msg = who_am_i;
	  msg = msg || " already defined.";
	  goto add_identification;
         end;
      end;
      allocate macro_list in (free_area);
      if al_sw
      then call ioa_ ("A macro_list ^i ^p", size (macro_list), maclp);
      macro_list.name = macname;
      macro_list.ref = segp;
      macro_list.dname = dname;
      macro_list.ename = segname;
      macro_list.from = segi;
      macro_list.to = sege;
      macro_list.int_mac = int_mac;
      macro_list.next = macro_list_p;
      macro_list_p = maclp;
      if db_sw then call ioa_ ("addmac ^16a ^p ^i:^i^/^-^a > ^a",
	    macro_list.name, macro_list.ref, macro_list.from, macro_list.to,
	    macro_list.dname, macro_list.ename);

   end addmacro; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* An ampersand has been found, handle it.			       */

ampersand: proc (ifp, ifi, ife, ofp, ofe, TF, err_sw) recursive;

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2),
    err_sw	bit (1);		/* 0- misplaced are error	       */
				/* 1- misplaced no sweat	       */
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);


      begl = ifi;
      if db_sw then call dumper ("ampr", ifp, ifi, ife, ofp, ofe, TF);
      if (ifi >= ife)
      then do;
         msg = "Orphan &.";
         goto add_identification;
      end;
      i = index ("0123456789", inputa (ifi + 1));
      if (i ^= 0)
      then do;
         num = i - 1;
         i = index ("0123456789", inputa (ifi + 2));
         if (i ^= 0)
         then do;
	  num = num * 10 + i - 1;
	  ifi = ifi + 1;
         end;
         ifi = ifi + 2;
         if (num <= argct)
         then call putout(ofp, ofe, arg);
      end;
      else do;
         ch_2nd = inputa (ifi + 1);
         if (ch_2nd = "{")
         then call arg_range (ifp, ifi, ife, ofp, ofe, TF);

         else if (ch_2nd = "*")
         then do;
	  ifi = ifi + 2;
	  call putout (ofp, ofe, ltrim (char (argct)));
         end;

         else if (ch_2nd = ".")	/* &. null separator	       */
         then ifi = ifi + 2;

         else if (ch_2nd = "+")	/* &+ null separator,	       */
         then call strip2 (ifp, ifi, ife); /*  grabs trailing space	       */

         else if (ch_2nd = "[")
         then call macro_af (ifp, ifi, ife, ofp, ofe, TF);

         else if (ch_2nd = "(")
         then call arithmetic (ifp, ifi, ife, ofp, ofe, TF);

         else if (ch_2nd = """")
         then call protected (ifp, ifi, ife, ofp, ofe);

         else if (ch_2nd = ";")
         then do;
	  c32 = "&;";
	  return;
         end;

         else if (ch_2nd = "&")
         then do;
	  ifi = ifi + 2;
	  call putout (ofp, out_len, "&");
         end;
         else do;
variable:
	  i = verify (substr (input, ifi + 1), token_chars);

	  if (i = 0)
	  then i = ife - ifi + 1;
	  if (i > 1)
	  then do;
	     if (i > 26)
	     then do;
	        msg = who_am_i;
	        msg = msg || " name > 26 chars.";
	        goto add_identification;
	     end;
	     c32 = substr (input, ifi + 1, i - 1);
	     c32x = "";

	     if (inputa (ifi + i) = "$")
	     then do;
	        ifi = ifi + i;
	        ii = verify (substr (input, ifi + 1), token_chars);
	        if (ii = 0)
	        then i = 0;		/* error			       */
	        else if (inputa (ifi + ii) = "(")
	        then do;
		 i = ii;
		 c32x = c32;
		 c32 = substr (input, ifi + 1, i - 1);
	        end;
	     end;

	     if (inputa (ifi + i) = "(") & (ife > ifi + i)
	     then do;
	        ifi = ifi + i + 1;
	        call macro_call (ifp, ifi, ife, ofp, ofe, TF);
	     end;

	     else if (inputa (ifi + i) = "{") & (ife > ifi + i)
	     then do;
	        ifi = ifi + i + 1;
	        call var_range (ifp, ifi, ife, ofp, ofe, TF);
	     end;

/* arg */
	     else if (c32 = "lbound")
	     then call var_bound (ifp, ifi, ife, ofp, ofe, TF);
	     else if (c32 = "hbound")
	     then call var_bound (ifp, ifi, ife, ofp, ofe, TF);

	     else if (c32 = "empty")
	     then call macro_empty (ifp, ifi, ife, ofp, ofe, TF);

	     else if (c32 = "error")
	     then call macro_error (ifp, ifi, ife, ofp, ofe, TF);

	     else if (c32 = "comment")
	     then do;
	        i = index (substr (input, ifi), "&;");
	        if (i = 0)
	        then do;
		 msg = "&;";
		 call error_missing ("comment", begl, ife);
	        end;
	        ifi = ifi + i + 1;
	        return;
	     end;

	     else if (c32 = "usage")
	     then call macro_usage (ifp, ifi, ife, ofp, ofe, TF);

	     else if (c32 = "quote")
	     then call macro_quote (ifp, ifi, ife, ofp, ofe, TF);

	     else if (c32 = "unquote")
	     then call macro_unquote (ifp, ifi, ife, ofp, ofe, TF);

	     else if (c32 = "return")
	     then do;
	        segi = sege + 1;
	        goto quit;
	     end;

	     else if (c32 = "scan")
	     then call macro_scan (ifp, ifi, ife, ofp, ofe, TF);

	     else if (c32 = "define")
	     then call macro_define (ifp, ifi, ife, ofp, ofe, TF);

	     else if (c32 = "substr")
	     then call macro_substr (ifp, ifi, ife, ofp, ofe, TF);

	     else if (c32 = "length")
	     then call macro_length (ifp, ifi, ife, ofp, ofe, TF);

	     else if (c32 = "let")
	     then call macro_let (ifp, ifi, ife, ofp, ofe, TF, 0);

	     else if (c32 = "ext")
	     then call macro_let (ifp, ifi, ife, ofp, ofe, TF, 1);

	     else if (c32 = "int")
	     then call macro_let (ifp, ifi, ife, ofp, ofe, TF, 2);

	     else if (c32 = "loc")
	     then call macro_let (ifp, ifi, ife, ofp, ofe, TF, 3);

	     else if (c32 = "do")
	     then call macro_do (ifp, ifi, ife, ofp, ofe, TF);

	     else if (c32 = "if")
	     then call macro_if (ifp, ifi, ife, ofp, ofe, TF);

	     else if (c32 = "od")
		   | (c32 = "fi")
		   | (c32 = "then")
		   | (c32 = "else")
		   | (c32 = "elseif")
		   | (c32 = "while")
	     then do;
	        c32 = "&" || c32;
	        if ^err_sw
	        then goto misplaced;
	        return;
	     end;

	     else if (c32 = "expand")
	     then do;
	        start_sym = "expand";
	        end_sym = "expend";
	        goto macdef;
	     end;
	     else if (c32 = "macro")
	     then do;
	        start_sym = "macro";
	        end_sym = "mend";
macdef:
	        if construct_nest > 1
	        then do;
macnest_err:
		 msg = "&";
		 msg = msg || start_sym;
		 msg = msg || " may not be nested in any other construct.";
		 goto add_id;
	        end;
	        ifi = ifi + i;
	        if (substr (input, ifi, 1) ^= " ")
	        then do;
macdef_err:
		 call error_syntax ((start_sym), begl, ifi);
	        end;
	        ifi = ifi + 1;
	        i = verify (substr (input, ifi),
		 "abcdefghijklmnopqrstuvwxyz" ||
		 "ABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789");
	        if (i = 0)
	        then goto macdef_err;
	        if (i < 2)
	        then do;
		 msg = "name";
		 call error_missing ((start_sym), begl, ifi);
	        end;
	        i = i - 1;
	        c32 = substr (input, ifi, i);
	        ifi = ifi + i;
	        if (inputa (ifi) ^= NL)
	        then goto macdef_err;
	        ifi = ifi + 1;
	        i = index (substr (input, ifi), "&" || end_sym || NL);
	        if (i = 0)
	        then do;
no_mend:
		 msg = "&";
		 msg = msg || end_sym;
		 msg = msg || "<NL>";
		 call error_missing ((start_sym), begl, ife);
	        end;
	        if (index (substr (input, ifi, i - 1), "&macro ") ^= 0)
		 | (index (substr (input, ifi, i - 1), "&expand ") ^= 0)
	        then goto no_mend;
	        call hcs_$fs_get_path_name (ifp, dname, 0, ename, 0);
	        call addmacro ("  &" || start_sym || " in " || myname, "",
		 c32, "1"b, ifp, ifi, ifi + i - 2);
	        ifi = ifi + i + length (end_sym) + 1;
	     end;
	     else do;
	        call var_ref (ifp, ifi, ife, ofp, ofe, TF);
	        ifi = ifi + i;
	     end;
	  end;
	  else do;
	     msg = "Unrecognized &control """;
	     msg = msg || c32;
	     msg = msg || """. ";
	     goto add_identification;
	  end;
         end;
      end;
   end ampersand; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* parse an argument range specification.			       */

arg_range: proc (ifp, ifi, ife, ofp, ofe, TF);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl separator	char (150) var;

/* &{ ARITH }			yields argument ARITH	       */
/* &{ ARITH : ARITH } 		yields arguments ARITH thru ARITH    */
/*                                          separated by a SP	       */
/* &{ ARITH : ARITH , STRING }	yields arguments ARITH thru ARITH    */
/*                                          separated by STRING	       */

      begl = ifi;
      ii = ofe;
      i = 1;
      j = argct;
      call get_range (ifp, ifi, ife, ofp, ofe, TF, i, j);
      separator = " ";
      if (inputa (ifi) = ",")
      then do;
         ifi = ifi + 1;
         do while ("1"b);
	  jj = search (substr (input, ifi), "&}");
	  if (jj = 0)
	  then do;
	     msg = "}";
	     call error_missing ("{", begl, ife);
	  end;
	  if (jj > 1)
	  then do;
	     jj = jj - 1;
	     call putout (ofp, ofe, substr (input, ifi, jj));
	     ifi = ifi + jj;
	  end;
	  if (inputa (ifi) = "}")
	  then do;
	     separator = substr (output, ii + 1, ofe - ii);
	     ofe = ii;
	     goto end_range;
	  end;
	  call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
         end;
      end;
      if (inputa (ifi) = "}")
      then do;
end_range:
         ifi = ifi + 1;
         if (TF = "00"b)
         then return;
         j = min (j, argct);
         do num = i to j;
	  call putout (ofp, ofe, arg);
	  if (num ^= j)
	  then call putout (ofp, ofe, (separator));
         end;
      end;
      else do;
         call error_syntax ("{", begl, ifi);
      end;
   end arg_range; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* process an arithmetic expression.				       */

arithmetic: proc (ifp, ifi, ife, ofp, ofe, TF);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl level		fixed bin (24);
dcl (vl, sl)	fixed bin (24);
dcl val		(20) fixed dec (59, 9);
dcl stk		(20) fixed bin (24);
dcl pic60		pic "(49)-9v.(9)9";
dcl v		fixed dec (59, 9);

      ifi, begl = ifi + 2;
      if db_sw then call dumper ("arth", ifp, ifi, ife, ofp, ofe, TF);
      ii = ofe;
      call putout (ofp, ofe, "(");
      level = 1;
      construct_nest = construct_nest + 1;
loop:
      i = search (substr (input, ifi), "&(),:}");
      if (i = 0)
      then do;
         msg = "Missing arithmetic terminator. ";
         goto add_identification;
      end;
      if (i > 1)
      then do;
         i = i - 1;
         call putout (ofp, ofe, substr (input, ifi, i));
         ifi = ifi + i;
      end;
      goto type (index ("&(),:}", inputa (ifi)));

type (1):				/* & */ /* */
      if (substr (input, ifi, 2) = "&;")
      then goto type (4);		/* It stops scan, but is not used up */
      call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
      goto loop;

type (2):				/* ( */ /* */
      call putout (ofp, ofe, "(");
      level = level + 1;
      ifi = ifi + 1;
      goto loop;

type (4):				/* , */ /* */
type (5):				/* : */ /* */
type (6):				/* } */ /* */
      if (level > 1)
      then goto arith_err;
      ifi = ifi - 1;		/* don't want to use up this char    */
type (3):				/* ) */ /* */
      call putout (ofp, ofe, ")");
      ifi = ifi + 1;
      level = level - 1;
      if (level > 0)
      then goto loop;
      construct_nest = construct_nest - 1;

      if (TF = "00"b)
      then do;
         ofe = ii;
         return;
      end;

      sl = 1;
      vl = 0;
      stk (1) = 16;

      if db_sw | tr_sw
      then do;
         call ioa_$nnl ("#^a:^a^-arith ", lineno (begl), lineno (ifi - 1));
         call show_string (substr (output, ii + 1), NL);
      end;
      do i = ii + 1 to ofe;
				/* format: off */
/*                                       "---------1111111111222222	22 2   */
/*                                       "---------0123456789012345	67 8   */
dcl arithchar char (28) int static init ("0123456789(=^=<=>=+-*/) 	.""
"); /* format: on */
         j = index (arithchar, substr (output, i, 1));
         if (j = 0)
         then do;
	  jj = verify (substr (output, i),
	     "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789");
	  if (jj = 0)
	  then jj = ife - ifi + 1;
	  if (jj = 1)
	  then goto arith_err;
	  goto arith_err;
         end;
retry:
         if lg_sw
         then if db_sw
	    then do;
	       call ioa_ ("^3i :^1a:", i, substr (output, i, 1));
	       do jj = 1 to sl;
		call ioa_$nnl (" ^1a",
		   substr (arithchar, stk (jj), 1));
	       end;
	       call ioa_ (".");
	       do jj = 1 to vl;
		call ioa_$nnl (" ^f", val (jj));
	       end;
	       call ioa_ ("#");
	    end;
         if (j > 10)
         then goto type (j);

type (26):			/* decimal point */
         jj = verify (substr (output, i), ".0123456789") - 1;
         if (jj < 0)
         then jj = ofe - i + 1;
         vl = vl + 1;
         val (vl) = convert (val (1), substr (output, i, jj));
         sl = sl + 1;
         stk (sl) = 10;
         i = i + jj - 1;
         goto endloop;

type (23):			/* ) */ /* */
         if (stk (sl) ^= 10)
         then goto arith_err;
         goto calc (stk (sl - 1));

type (13):			/* ^ */ /* */
type (15):			/* < */ /* */
type (17):			/* > */ /* */
         if (substr (output, i + 1, 1) = "=")
         then do;
	  i = i + 1;
	  j = j + 1;
         end;
         if (j = 13)
         then goto type (11);
type (14):			/* ^= */ /* */
type (16):			/* <= */ /* */
type (18):			/* >= */ /* */
type (12):			/* = */ /* */
type (21):			/* * */ /* */
type (22):			/* / */ /* */
         if (stk (sl) ^= 10)
         then do;
type (27):			/* quoted string not handled yet     */
arith_err:
	  msg = "Arithmetic syntax error. ";
	  msg = msg || substr (arithchar, stk (sl), 1);
	  msg = msg || substr (arithchar, j, 1);
	  msg = msg || " """;
	  msg = msg || substr (output, ii + 1, i - ii);
	  msg = msg || """ ";
	  goto add_identification;
         end;

type (19):			/* + */ /* */
type (20):			/* - */ /* */
         if (stk (sl) = 21)
         then goto arith_err;
         if (stk (sl) = 22)
         then goto arith_err;
         if (stk (sl) > 10)
         then do;
	  vl = vl + 1;
	  val (vl) = 0;
	  sl = sl + 1;
	  stk (sl) = 10;
         end;
         if (stk (sl - 1) >= j)
         then goto calc (stk (sl - 1));
         sl = sl + 1;
         stk (sl) = j;
         goto endloop;

type (11):			/* ( */ /* */
         if (stk (sl) = 10)
         then goto arith_err;
         sl = sl + 1;
         stk (sl) = j;
         goto endloop;

calc (12):			/* =  */ /* */
         if (val (vl - 1) = val (vl))
         then v = 1;
         else v = 0;
         goto calc_common;


calc (13):			/* ^  */ /* */
         if (val (vl) = 0)
         then val (vl) = 1;
         else val (vl) = 0;
         sl = sl - 1;
         stk (sl) = 10;
         goto retry;


calc (14):			/* ^= */ /* */
         if (val (vl - 1) ^= val (vl))
         then v = 1;
         else v = 0;
         goto calc_common;


calc (15):			/* <  */ /* */
         if (val (vl - 1) < val (vl))
         then v = 1;
         else v = 0;
         goto calc_common;


calc (16):			/* <= */ /* */
         if (val (vl - 1) <= val (vl))
         then v = 1;
         else v = 0;
         goto calc_common;


calc (17):			/* >  */ /* */
         if (val (vl - 1) > val (vl))
         then v = 1;
         else v = 0;
         goto calc_common;


calc (18):			/* >= */ /* */
         if (val (vl - 1) >= val (vl))
         then v = 1;
         else v = 0;
         goto calc_common;


calc (19):			/* + */ /* */
         v = val (vl - 1) + val (vl);
         goto calc_common;

calc (20):			/* - */ /* */
         v = val (vl - 1) - val (vl);
         goto calc_common;

calc (21):			/* * */ /* */
         v = val (vl - 1) * val (vl);
         goto calc_common;

calc (22):			/* / */ /* */
         v = val (vl - 1) / val (vl);
calc_common:
         vl = vl - 1;
         val (vl) = v;
         sl = sl - 2;
         stk (sl) = 10;
         goto retry;


calc (11):			/* ( */ /* */
         if (j = 23)
         then do;
	  sl = sl - 1;
	  stk (sl) = 10;
	  goto endloop;
         end;
         goto arith_err;

type (24):			/* SP */ /* */
type (25):			/* HT */ /* */
type (28):			/* NL */ /* */
endloop:
      end;
      ofe = ii;
      call putout (ofp, ofe,
         ltrim (rtrim (rtrim (convert (pic60, val (1)), "0"), ".")));
   end arithmetic; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* convert a text string for debug display.			       */

cvt: proc (ifp, ifi, ife) returns (char (32) var);

dcl res		char (32) var;
dcl ifp		ptr;
dcl (ifi, ife)	fixed bin (24);
dcl i		fixed bin (24);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl ch		char (1);

      res = """";
      do i = ifi to min (ifi + 15, ife);
         ch = inputa (i);
         if (ch < " ")
         then ch = "~";
         res = res || ch;
      end;
      res = res || """";
      return (res);

   end cvt; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* show a bunch of debugging information.			       */

dumper: proc (text, ifp, ifi, ife, ofp, ofe, TF);

dcl text		char (4),
    ifp		ptr,
    (ifi, ife)	fixed bin (24),
    ofp		ptr,
    ofe		fixed bin (24),
    TF		bit (2);

      call ioa_ ("^2i.^2i ^4a TF^.1b ^i:^i ^i^-^a - ^a", macro_nest,
         construct_nest, text, TF, ifi, ife, ofe,
         cvt (ifp, ifi, ife), cvt (ofp, max (1, ofe - 15), ofe));

   end dumper; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* ERROR MESSAGE procs					       */

error_missing: proc (who, begl, endl);

dcl who		char (*),
    begl		fixed bin (24),
    endl		fixed bin (24);

dcl hold		char (1000) var;
dcl (cline, eline)	char (6) var;

      hold = "Missing ";
      hold = hold || msg;
      goto common;

error_syntax: entry (who, begl, endl);

      hold = "Syntax error";
      goto common;

error_misplaced: entry (who, begl, endl);

      hold = "Misplaced ";
      hold = hold || msg;
      goto common;

error_gen: entry (who, begl, endl);

      hold = msg;
      goto common;

error_attempt: entry (who, begl, endl);

      hold = "Attempt to ";
      hold = hold || msg;
      goto common;

common:
      hold = hold || " in """;
      cline = lineno (begl);
      eline = lineno (endl);

      msg = "
ERROR SEVERITY 4. ";
      msg = msg || who_am_i;
      msg = msg || " """;
      msg = msg || myname;
      msg = msg || """, line ";
      msg = msg || eline;
      msg = msg || ".
      ";
      msg = msg || hold;
      msg = msg || "&";
      msg = msg || who;
      msg = msg || """";
      if (eline ^= cline)
      then do;
         msg = msg || " (on line ";
         msg = msg || cline;
         msg = msg || ")";
      end;
      msg = msg || ".";
      ecode = error_table_$badsyntax;
      goto exit;

   end error_missing; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* expand a specified string					       */

expand: proc (ifp, ifi, ife, ofp, ofe, tf);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    tf		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);


      if db_sw then call dumper ("expn", ifp, ifi, ife, ofp, ofe, tf);
      do while (ifi <= ife);
         i = index (substr (input, ifi), "&");
         if (i = 0)
         then i = ife - ifi + 1;
         else i = i - 1;
         if (i > 0)
         then do;
	  call putout (ofp, out_len, substr (input, ifi, i));
	  ifi = ifi + i;
         end;
         if (ifi > ife)
         then return;
         ii = ifi;
         call ampersand (ifp, ifi, ife, ofp, ofe, tf, "1"b);
         if (ii = ifi)
         then return;
      end;
   end expand; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* search for the macro specified				       */

find_macro: proc (refp, segname, suffix, macname);
dcl refp		ptr,
    segname	char (32) var,
    suffix	char (32) var,
    macname	char (32) var;

dcl initiate_file_	entry (char(*), char(*), bit(*), ptr, fixed bin(24),
		fixed bin(35));
dcl search_paths_$find_dir entry (char (*), ptr, char (*), char (*), char (*),
		fixed bin (35));
dcl search_for	char (35) var;

      if (segname = "")
      then search_for = macname;
      else search_for = segname;
      search_for = search_for || "." || suffix;

      if (refp = null ())
      then ref_path = "";
      else call hcs_$fs_get_path_name (refp, ref_path, 0, "", 0);
      if db_sw
      then call ioa_ ("find_macro ^a ^a (^a)", search_for, macname, ref_path);
      call search_paths_$find_dir ((suffix), null (), (search_for), ref_path,
         dname, ecode);
      if (ecode = error_table_$no_search_list)
      then do;
dcl hcs_$make_ptr	entry (ptr, char (*), char (*), ptr, fixed bin (35));
here:    call hcs_$make_ptr (codeptr (here), suffix || ".search",
	  suffix || ".search", segptr, ecode); /* fudge a little */
         if (segptr = null ())
         then call com_err_ (0, (suffix),
	       "Default search segment not in same directory as object segment.");
         else call search_paths_$find_dir ((suffix), null (), (search_for),
	       ref_path, dname, ecode);
      end;
      if (ecode = 0)
      then call initiate_file_ (dname, (search_for), "100"b, segptr, bc,
         ecode);
      if (ecode ^= 0)
      then do;
         msg = "No definition segment found. ";
         msg = msg || search_for;
         msg = msg || "$";
         msg = msg || macname;
         ecode = -1;
         goto exit;
      end;
      segi = 1;
      sege = divide (bc, 9, 24, 0);
      if mac_sw
      then do;
         if (suffix = "macro")
         then i = index (seg, "&macro " || macname || NL);
         else i = index (seg, "&expand " || macname || NL);
         if (i = 0)
         then do;
	  msg = "No definition found for """;
bad_mac:
	  msg = msg || macname;
	  msg = msg || """ ";
	  msg = msg || "in ";
	  msg = msg || rtrim (dname);
	  msg = msg || ">";
	  msg = msg || search_for;
	  ecode = -1;
	  goto exit;
         end;
         segi = i + length (macname) + 8;
         if (suffix = "macro")
         then i = index (substr (seg, segi), "&mend
");
         else do;
	  segi = segi + 1;		/* &expand 1 char>than &macro	       */
	  i = index (substr (seg, segi), "&expend
");
         end;
         if (i = 0)
         then do;
	  if (suffix = "macro")
	  then msg = "&mend";
	  else msg = "&expand";
	  msg = msg || " missing on """;
	  goto bad_mac;
         end;

         sege = segi + i - 2;
         call addmacro (dname, before (search_for, "."), (macname), "0"b,
	  segptr, segi, sege);
         if (segname = "")
         then do;

/* now all that is fine and dandy, but we don't want to let &b() find an     */
/* external b$b because nothing has been internally defined and then later   */
/* have the same thing find a different macro because there now has been an  */
/* internal macro/define encountered. So we dummy up a pseudo-internal entry */
/* to nip such a thing in the bud.				       */

	  call addmacro ("", before (search_for, "."), (macname), "1"b,
	     segptr, segi, sege);
         end;
      end;

   end find_macro; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* free all the storage used					       */

free_um: proc (which);

dcl which		char (3);

      do while (tptr ^= null ());
         var_ptr = tptr;
         tptr = var.next;
         if (var.type = 0)
         then do;
	  if db_sw
	  then do;
	     call ioa_ ("^p	^a ^a", var_ptr, which, var.name);
	     if var.ref ^= null ()
	     then call ioa_ ("  ^p	""^a""", var.ref,
		   vartext);
	  end;
	  if (var.ref ^= null ())
	  then do;
	     if al_sw then call ioa_ ("F ^p ""^a""", var.ref,
		   vartext);
	     free vartext in (free_area);
	  end;
         end;
         if (var.type >= 1) & (var.type <= 5)
         then do;
	  arr_ptr = var.ref;
	  if db_sw
	  then call ioa_ ("^p	^a ^a{^i:^i}", var_ptr, which,
		var.name, array.lower, array.lower + var.len - 1);
	  do arr_elem = 1 to var.len;
	     if (array.ref (arr_elem) ^= null ())
	     then do;
	        if al_sw
	        then call ioa_ ("^p	{^i} ""^a""",
		      array.ref (arr_elem),
		      -array.lower + arr_elem - 1, arrtext);
	        free arrtext in (free_area);
	     end;
	  end;
         end;
         if al_sw then call ioa_ ("F var-^a ^p", var.name, var_ptr);
         free var in (free_area);
      end;

   end free_um; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* set up an area						       */

get_area: proc;

      ai.version = area_info_version_1;
      string (ai.control) = "0"b;
      ai.extend = "1"b;
      ai.owner = sl_name;
      ai.size = 2000;
      ai.areap = null ();
      call define_area_ (addr (ai), ecode);
      free_area_p = ai.areap;

%include area_info;
dcl 1 ai		like area_info;

   end get_area; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* parse an array range specification.				       */

get_range: proc (ifp, ifi, ife, ofp, ofe, TF, i, j);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);

      if (inputa (ifi + 2) = "}")
         | (inputa (ifi + 2) = ",")
      then do;
         ifi = ifi + 2;
         return;
      end;
      ii = ofe;
      call arithmetic (ifp, ifi, ife, ofp, ofe, TF);
      i, j = fixed (substr (output, ii + 1, ofe - ii));
      ofe = ii;
      if (inputa (ifi) = ":")
      then do;
         ifi = ifi - 1;
         call arithmetic (ifp, ifi, ife, ofp, ofe, TF);
         j = fixed (substr (output, ii + 1, ofe - ii));
         ofe = ii;
      end;

   end get_range; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* parse the next input token					       */

get_token: proc (ifp, ifi, ife);

dcl ifp		ptr,
    ifi		fixed bin (24),
    ife		fixed bin (24);
dcl input		char (ife) based (ifp);

      call strip (ifp, ifi, ife);
      if (substr (input, ifi, 1) ^= "&")
      then do;
         c32 = "";
         return;
      end;
      i = verify (substr (input, ifi + 1), "abcdefghijklmnopqrstuvwxyz");
      if (i = 0)
      then i = ife - ifi + 1;
      else if (i = 1)
      then i = 2;
      c32 = substr (input, ifi, i);

   end get_token; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* determine and format the line number of a given point in a segment	       */

lineno: proc (segi) returns (char (6) var);

dcl segi		fixed bin (24);

dcl c6		pic "zzzzz9";
dcl cv6		char (6) var;
dcl j		fixed bin (24);
dcl line		fixed bin (24);
dcl e		fixed bin (24);

      line = 0;
      i = 1;
      e = min (segi, sege);
      do while (i <= segi);
         line = line + 1;
         j = index (substr (seg, i), NL);
         if (j = 0)
         then i = sege + 1;
         else i = i + j;
      end;
      cv6 = ltrim (char (line));
      return (cv6);

   end lineno; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* process a logical expression				       */

logical: proc (ifp, ifi, ife, ofp, ofe, TF);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj, kk) fixed bin (24);
dcl loc		(24) fixed bin (24);
dcl sep_ct	fixed bin (24);
dcl argstrl	fixed bin (24);
dcl rel		fixed bin (24);

      jj = ofe;
      construct_nest = construct_nest + 1;
      call strip (ifp, ifi, ife);
      begl = ifi;
loop:
      i = search (substr (input, ifi), "&=^<>");
      if (i = 0)
      then do;
log_err:
         msg = "Missing termination of logical expression. ";
         goto add_identification;
      end;
      if (i > 1)
      then do;
         i = i - 1;
         call putout (ofp, ofe, substr (input, ifi, i));
         ifi = ifi + i;
      end;
      rel = index ("&=^=<^>=", inputa (ifi));
      goto type (rel);

type (1):				/* & */ /* & */
      if (substr (input, ifi, 5) = "&then")
         | (substr (input, ifi, 2) = "&;")
      then do;
         kk = ofe;
         if db_sw | tr_sw
         then do;
	  call ioa_$nnl ("#^a:^a^-log-^.1b (", lineno (begl), lineno (ifi - 1),
	     TF);
	  call show_string (substr (output, jj + 1, kk - jj), ")
");
         end;
         ofe = jj;
         if (TF = "00"b)
         then return;
         c32 = translate (substr (output, jj + 1, kk - jj),
	  "  ABCDEFGHIJKLMNOPQRSTUVWXYZ", "
	abcdefghijklmnopqrstuvwxyz");
         if (c32 = "0")
	  | (c32 = "FALSE")
	  | (c32 = "F")
	  | (c32 = "NO")
         then TF = "01"b;
         else TF = "10"b;
         return;
      end;
      call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
      goto loop;
type (3):				/* ^ */ /* ^ */
type (5):				/* < */ /* < */
type (7):				/* > */ /* > */
      if (inputa (ifi + 1) = "=")
      then do;
         rel = rel + 1;
         ifi = ifi + 1;
      end;
      else if (rel = 3)
      then do;
         ifi = ifi + 1;
         call putout (ofp, ofe, "^");
         goto loop;
      end;
type (2):				/* = */ /* = */
				/* 2 = 	4 ^=		       */
				/* 5 <    6 <=		       */
				/* 7 >	8 >=		       */
      ifi = ifi + 1;
      ii = ofe;
loop1:
      call strip (ifp, ifi, ife);
      j = index (substr (input, ifi), "&") -1;
      if (j < 0)
      then goto log_err;
      if (j > 0)
      then do;
         call putout (ofp, ofe, substr (input, ifi, j));
         ifi = ifi + j;
      end;
      if (substr (input, ifi, 5) = "&then")
         | (substr (input, ifi, 2) = "&;")
      then do;
         construct_nest = construct_nest - 1;
         kk = ofe;
         if db_sw | tr_sw
         then do;
	  call ioa_$nnl ("#^a:^a^-log-^.1b (", lineno (begl),
	     lineno (ifi - 1), TF);
	  call show_string (substr (output, jj + 1, ii - jj), "");
	  call ioa_$nnl (")^a(", relat (rel));
	  call show_string (substr (output, ii + 1, kk - ii), ")
");
         end;
         ofe = jj;
         if (TF = "00"b)
         then return;
dcl relat		(2:8) char (2) int static
		init ("=", "!!", "^=", "<", "<=", ">", ">=");
         goto comp (rel);
      end;
      call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
      goto loop1;

comp (2):
      if (substr (output, jj + 1, ii - jj) = substr (output, ii + 1, kk - ii))
      then TF = "10"b;
      else TF = "01"b;
      return;

comp (4):
      if (substr (output, jj + 1, ii - jj) ^= substr (output, ii + 1, kk - ii))
      then TF = "10"b;
      else TF = "01"b;
      return;

comp (5):
      if (substr (output, jj + 1, ii - jj) < substr (output, ii + 1, kk - ii))
      then TF = "10"b;
      else TF = "01"b;
      return;

comp (6):
      if (substr (output, jj + 1, ii - jj) <= substr (output, ii + 1, kk - ii))
      then TF = "10"b;
      else TF = "01"b;
      return;

comp (7):
      if (substr (output, jj + 1, ii - jj) > substr (output, ii + 1, kk - ii))
      then TF = "10"b;
      else TF = "01"b;
      return;

comp (8):
      if (substr (output, jj + 1, ii - jj) >= substr (output, ii + 1, kk - ii))
      then TF = "10"b;
      else TF = "01"b;
      return;

   end logical; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* look up a specified name in the variable lists			       */

lookup: proc (vname) returns (fixed bin) recursive;

dcl vname		char (32) var;

/* first look up local variables				       */

      var_ptr = local_var_ptr;
      do while (var_ptr ^= null ());
         if (var.name = vname)
         then return (3);
         var_ptr = var.next;
      end;

/* then look up internal static variables			       */

      if (int_var_ptr = null ())
      then do;
         int_var_ptr = int_vars_base;
         do while (int_var_ptr ^= null ());
	  if (macname = int_vars.macro)
	  then goto found;
	  else int_var_ptr = int_vars.next;
         end;
         allocate int_vars in (free_area);
         if al_sw
         then call ioa_ ("A int_vars ^a^i ^p", macname, size (int_vars),
	       int_var_ptr);
         int_vars.next = int_vars_base;
         int_vars.ref = null ();
         int_vars.macro = macname;
         int_vars_base = int_var_ptr;
      end;

found:
      var_ptr = int_vars.ref;
      do while (var_ptr ^= null ());
         if (var.name = vname)
         then return (2);
         var_ptr = var.next;
      end;

/* then look up external static variables */

      var_ptr = ext_var_ptr;
      do while (var_ptr ^= null ());
         if (var.name = vname)
         then return (1);
         var_ptr = var.next;
      end;

      return (0);
   end lookup; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* handle the active function call				       */

macro_af: proc (ifp, ifi, ife, ofp, ofe, TF);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl level		fixed bin (24);

/* &[ ... ] */

      begl = ifi;
      ifi = ifi + 2;
      call strip (ifp, ifi, ife);
      if db_sw then call dumper ("af..", ifp, ifi, ife, ofp, ofe, TF);
      ii = ofe;
      level = 1;
      construct_nest = construct_nest + 1;
loop:
      i = search (substr (input, ifi), "&[]");
      if (i = 0)
      then do;
         msg = "]";
         call error_missing ("[", begl, ife);
      end;
      if (i > 1)
      then do;
         i = i - 1;
         call putout (ofp, ofe, substr (input, ifi, i));
         ifi = ifi + i;
      end;
      goto type (index ("&[]", inputa (ifi)));

type (1):				/* & */ /* */
      call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
      if (c32 = "&;")
      then goto misplaced;
      goto loop;

type (2):				/* [ */ /* */
      call putout (ofp, ofe, "[");
      ifi = ifi + 1;
      level = level + 1;
      goto loop;

type (3):				/* ] */ /* */
      call putout (ofp, ofe, "]");
      ifi = ifi + 1;
      level = level - 1;
      if (level > 0)
      then goto loop;

      construct_nest = construct_nest - 1;
      ofe = ofe - 1;
      if (TF = "00"b)
      then do;
         ofe = ii;
         return;
      end;
      varlen = 500;
dcl varlen	fixed bin;
      begin;
dcl rval		char (varlen) var;
         rval = "";
dcl cu_$evaluate_active_string entry (ptr, char(*), fixed bin, char(*) var,
		fixed bin(35));
%include cp_active_string_types;
         call cu_$evaluate_active_string (null (),
	  substr (output, ii + 1, ofe - ii),
	  ATOMIC_ACTIVE_STRING, rval, ecode);
         if (ecode ^= 0)
         then do;
	  err_ct = 0;
	  msg = "Processing active functtion. ";
	  msg_etc = substr (output, ii + 1, ofe - ii);
	  goto add_id;
         end;
         ofe = ii;
         call putout (ofp, ofe, (rval));
      end;
      return;

   end macro_af; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* handle a macro call					       */

macro_call: proc (ifp, ifi, ife, ofp, ofe, TF) recursive;

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl loc		(100) fixed bin (24);
dcl (sep_ct, level) fixed bin (24);
dcl argstrl	fixed bin (24);
dcl callseg	char (32) var;
dcl callmac	char (32) var;

/*    &xxx( ... , ... , ...) */
/* &xxx$yy( ... , ... , ...) */

      begl = ifi;
      callseg = c32x;
      callmac = c32;
      call strip (ifp, ifi, ife);
      if db_sw then call dumper ("call", ifp, ifi, ife, ofp, ofe, TF);
      ii = ofe;
      call putout (ofp, ofe, "(");
      loc (1) = ofe;
      sep_ct = 1;
      level = 1;
      construct_nest = construct_nest + 1;
loop:
      i = search (substr (input, ifi), "&(),");
      if (i = 0)
      then do;
         msg = ")";
         call error_missing (callmac || "(", begl, ife);
      end;
      if (i > 1)
      then do;
         i = i - 1;
         call putout (ofp, ofe, substr (input, ifi, i));
         ifi = ifi + i;
      end;
      goto type (index ("&(),", inputa (ifi)));

type (1):				/* & */ /* */
      call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
      if (c32 = "&;")
      then do;
         msg = "&;";
         call error_misplaced ("call", begl, ife);
      end;
      goto loop;

type (2):				/* ( */ /* */
      call putout (ofp, ofe, "(");
      ifi = ifi + 1;
      level = level + 1;
      goto loop;

type (3):				/* ) */ /* */
      call putout (ofp, ofe, ")");
      ifi = ifi + 1;
      level = level - 1;
      if (level > 0)
      then goto loop;

      construct_nest = construct_nest - 1;
      loc (sep_ct + 1) = ofe;
      argstrl = ofe - loc (1) + 1;
      if (argstrl > 16384)
      then do;
         msg = "&call arg-string > 16384 chrs.";
         goto add_identification;
      end;
      begin;
dcl 1 args	(sep_ct) like argl;
dcl argstr	(argstrl) char (1) unal;
         if db_sw | tr_sw
         then do;
	  call ioa_$nnl ("#^a:^a^-call ^a$^a ", lineno (begl),
	     lineno (ifi - 1), callseg, callmac);
	  call show_string (substr (output, loc (1), argstrl), NL);
         end;
         string (argstr) = substr (output, loc (1), argstrl);
         ofe = loc (1) - 1;
         if (argstrl = 2)
         then sep_ct = 0;
         do i = 1 to sep_ct;
	  args.l (i) = loc (i + 1) - loc (i) - 1;
	  j = loc (i) - ofe + 1;
	  args.p (i) = addr (argstr (j));
         end;
         call macro_ (sl_name, callseg, callmac,
	  ofp, ofe, addr (args), (sep_ct), msg, ifp, ecode);
         if (ecode = -1)
         then call error_gen ("call", begl, ifi);
         if (ecode ^= 0)
         then do;
	  ifi = begl;
	  call_err = "1"b;
	  goto add_id;
         end;
      end;
      return;

type (4):				/* , */ /* */
      call putout (ofp, ofe, ",");
      ifi = ifi + 1;
      if (level = 1)
      then do;
         if (sep_ct >= 100)
         then do;
	  msg = "Cannot handle over 100 ";
	  msg = msg || who_am_i;
	  msg = msg || " arguments.";
	  goto add_identification;
         end;
         sep_ct = sep_ct + 1;
         loc (sep_ct) = ofe;
         call strip (ifp, ifi, ife);
      end;
      goto loop;
   end macro_call; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* dynamically define a macro					       */

macro_define: proc (ifp, ifi, ife, ofp, ofe, TF);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl loc		(24) fixed bin (24);
dcl sep_ct	fixed bin (24);
dcl argstrl	fixed bin (24);

/* &define ... &dend */

      begl = ifi;
      ifi = ifi + 7;
      call strip (ifp, ifi, ife);
      if db_sw then call dumper ("defi", ifp, ifi, ife, ofp, ofe, TF);
      ii = ofe;
      construct_nest = construct_nest + 1;
loop:
      i = index (substr (input, ifi), "&");
      if (i = 0)
      then do;
         msg = "&dend";
         call error_missing ("define", begl, ife);
      end;
      if (i > 1)
      then do;
         i = i - 1;
         call putout (ofp, ofe, substr (input, ifi, i));
         ifi = ifi + i;
      end;
      if (substr (input, ifi, 5) = "&dend")
      then do;
         ifi = ifi + 5;
         call strip (ifp, ifi, ife);
         if (TF & "10"b)
         then do;
	  i = ii + 1;
	  i = i + verify (substr (output, i, ofe - i + 1), space) - 1;
	  j = verify (substr (output, i, ofe - i + 1),
	     "abcdefghijklmnopqrstuvwxyz" ||
	     "ABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789");
	  if (j = 0)
	  then do;
def_err:
	     call error_syntax ("define", begl, ifi);
	  end;
	  if (j < 2)
	  then do;
	     msg = "macroname";
	     call error_missing ("define", begl, ifi);
	  end;
	  j = j - 1;
	  c32 = substr (output, i, j);
	  i = i + j;
	  if (substr (output, i, 1) ^= NL)
	  then goto def_err;
	  macro_holder_l = ofe - i;
	  allocate macro_holder in (free_area);
	  macro_holder = substr (output, i + 1, macro_holder_l);
	  if db_sw | tr_sw
	  then do;
	     call ioa_$nnl ("#^a:^a^-&define ^a^/^-", lineno (begl),
	        lineno (ifi - 1), c32);
	     call show_string (macro_holder, "&dend
");
	  end;
	  call addmacro ("  &define'ed in " || myname || "  ", "", c32, "1"b,
	     macro_holder_p, 1, macro_holder_l);
         end;
         ofe = ii;
         construct_nest = construct_nest - 1;
         return;
      end;
      call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
      goto loop;
   end macro_define; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* handle the iteration construct				       */

macro_do: proc (ifp, ifi, ife, ofp, ofe, TF);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl tf		bit (2);

/* &do EXPAND &while LOGICAL &; EXPAND &od */
/* LOGICAL ::= arithmetic | compare */

      begl = ifi;
      ifi = ifi + 3;
      call strip (ifp, ifi, ife);
      if db_sw then call dumper ("do..", ifp, ifi, ife, ofp, ofe, TF);
      if (TF = "00"b)
      then goto skip;
      ii = ifi;
      jj = 0;
      construct_nest = construct_nest + 1;
loop:
      call expand (ifp, ifi, ife, ofp, ofe, (TF));
      if (c32 = "&while")
      then do;
         ifi = ifi + length (c32);
         jj = 1;
         tf = TF;
         call logical (ifp, ifi, ife, ofp, ofe, tf);
         call get_token (ifp, ifi, ife);
         if (c32 ^= "&;")
         then do;
	  msg = "&;";
	  call error_missing ("while", begl, ifi);
         end;
         ifi = ifi + length (c32);
         call strip (ifp, ifi, ife);
         if (tf = "01"b)
         then do;
skip:
	  i = index (substr (input, ifi), "&");
	  if (i = 0)
	  then do;
	     msg = "&od";
	     call error_missing ("do", begl, ife);
	  end;
	  ifi = ifi + i - 1;
	  call get_token (ifp, ifi, ife);
	  if (c32 = "&do")
	  then call macro_do (ifp, ifi, ife, ofp, ofe, "00"b);
	  else if (c32 = "&""")
	  then call protected (ifp, ifi, ife, ofp, (ofe));
	  else if (c32 = "&od")
	  then do;
	     jj = 0;
	     goto od;
	  end;
	  else ifi = ifi + 1;
	  goto skip;
         end;
         goto loop;
      end;
      if (c32 = "&od")
      then do;
od:
         ifi = ifi + length (c32);
         call strip (ifp, ifi, ife);
         if (jj = 0)
         then do;
	  construct_nest = construct_nest - 1;
	  return;
         end;
         ifi = ii;
         goto loop;
      end;
      msg = c32;
      call error_misplaced ("do", begl, ifi);
   end macro_do; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* make a list or array var be empty again			       */

macro_empty: proc (ifp, ifi, ife, ofp, ofe, TF);
dcl ifp		ptr,
    ifi		fixed bin (24),
    ife		fixed bin (24),
    ofp		ptr,
    ofe		fixed bin (24),
    TF		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl tf		bit (2);
dcl vname		char (32) var;

/* &empty name &; */

      begl = ifi;
      ifi = ifi + 6;
      call strip (ifp, ifi, ife);
      if db_sw then call dumper ("empt", ifp, ifi, ife, ofp, ofe, TF);
      i = verify (substr (input, ifi),
         "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789");
      if (i = 0)
      then i = ife - ifi + 1;
      if (i = 1)
      then do;
         msg = "array name";
         call error_missing ("empty", begl, ifi);
      end;
      vname = substr (input, ifi, i - 1);
      if (length (vname) > 16)
      then do;
         msg = """";
         msg = msg || vname;
         msg = msg || """ > 16 characters.";
         call error_gen ("empty", begl, ifi);
      end;
      ifi = ifi + length (vname);
      call strip (ifp, ifi, ife);
      if (substr (input, ifi, 2) ^= "&;")
      then do;
         msg = "&;";
         call error_missing ("empty", begl, ifi);
      end;
      call strip2 (ifp, ifi, ife);
      i = lookup (vname);
      if (i = 0)
      then do;
         msg = """";
         msg = msg || vname;
         msg = msg || """ undefined.";
         call error_gen ("empty", begl, ifi);
      end;
      if (var.type = 0)
      then do;
         msg = """";
         msg = msg || vname;
         msg = msg || """ is a scalar.";
         call error_gen ("empty", begl, ifi);
      end;
      arr_ptr = var.ref;
				/* free any allocated strings */
      if (var.type = 2)
      then do;
         array.h_bound = array.lower - 1;
         array.l_bound = array.lower + var.len;
      end;
      if (var.type = 3)
      then do;
         array.l_bound = 1;
         array.h_bound = 0;
      end;
   end macro_empty; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* print a user specified error message				       */

macro_error: proc (ifp, ifi, ife, ofp, ofe, TF);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl loc		(24) fixed bin (24);
dcl sep_ct	fixed bin (24);
dcl argstrl	fixed bin (24);
dcl ch8		pic "-------9";

/* &error ARITH , ... &; */

      begl = ifi;
      ifi = ifi + 6;
      call strip (ifp, ifi, ife);
      if db_sw then call dumper ("err.", ifp, ifi, ife, ofp, ofe, TF);
      ii = ofe;
      msg = "";
      construct_nest = construct_nest + 1;
      ifi = ifi - 2;
      call arithmetic (ifp, ifi, ife, ofp, ofe, TF);

      if (ofe ^= ii + 1)
         | (substr (output, ofe, 1) < "0")
         | (substr (output, ofe, 1) > "4")
      then do;
         ofe = ii;
         call putout (ofp, ofe, "4(Invalid &error severity, 4 assumed.) ");
      end;
      call strip (ifp, ifi, ife);
      if (inputa (ifi) ^= ",")
      then call putout (ofp, ofe, "(Missing comma after &error severity.) ");
      else ifi = ifi + 1;
loop:
      i = index (substr (input, ifi), "&") -1;
      if (i < 0)
      then do;
         msg = "&;";
         call error_missing ("error", begl, ife);
      end;
      if (i > 0)
      then do;
         call putout (ofp, ofe, substr (input, ifi, i));
         ifi = ifi + i;
      end;
      if (substr (input, ifi, 2) = "&;")
      then do;
         call strip2 (ifp, ifi, ife);
         i = index ("01234", substr (output, ii + 1, 1)) - 1;
         err_ct (i) = err_ct (i) + 1;
         msg = NL;
         if (i = 0)
         then msg = msg || "NOTE: ";
         else if (i = 1)
         then msg = msg || "WARNING. ";
         else do;
	  msg = msg || "ERROR SEVERITY ";
	  msg = msg || substr (output, ii + 1, 1);
	  msg = msg || ". ";
         end;
         msg = msg || who_am_i;
         msg = msg || " """;
         msg = msg || macname;
         msg = msg || """, line ";
         msg = msg || lineno (ifi);
         msg = msg || NL;
         call iox_$put_chars (iox_$error_output, addrel (addr (msg), 1),
	  length (msg), 0);
         msg = "";
         substr (output, ofe + 1, 1) = NL;
         call iox_$put_chars (iox_$error_output,
	  addr (substr (output, ii + 2, 1)), ofe - ii, 0);
         if (i = 4)
         then do;
	  msg = "Error detected by ";
	  msg = msg || who_am_i;
	  msg = msg || " """;
	  msg = msg || macname;
	  msg = msg || """.";
	  ecode = error_table_$translation_aborted;
	  goto exit;
         end;
         ofe = ii;
         construct_nest = construct_nest - 1;
         return;
      end;
      call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
      goto loop;

dcl iox_$error_output ptr ext static;
dcl iox_$put_chars	entry (ptr, ptr, fixed bin (21), fixed bin (35));
   end macro_error; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* handle the "if then [elseif] ... [else] fi" construct		       */

macro_if: proc (ifp, ifi, ife, ofp, ofe, tf);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    tf		bit (2);		/* 1x- process true		       */
				/* x1- process false	       */
				/* value not returned (modified)     */
dcl begl		fixed bin (24);
dcl beglt		fixed bin (24);
dcl skip_sw	bit (1);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl TF		bit (2);
dcl if_lineno	char (6) var;
dcl elseif	bit (1);


/* &if LOGICAL &then EXPAND {&elseif EXPAND} ... {&else EXPAND} &fi */

      begl, beglt = ifi;
      ifi = ifi + 3;
      call strip (ifp, ifi, ife);
      TF = tf;
      if db_sw then call dumper ("if..", ifp, ifi, ife, ofp, ofe, TF);
      elseif = "0"b;
      if_lineno = lineno (begl);

nother_logical:
      call logical (ifp, ifi, ife, ofp, ofe, TF);
      if (tf = "00"b)
      then TF = "00"b;
      if db_sw | tr_sw
      then call ioa_ ("#^a:^a^-&^[else^]if (^a) ^[skip^;F^;T^;TF^]",
	    lineno (beglt), lineno (ifi - 1), elseif, if_lineno,
	    fixed (TF) + 1);
      call get_token (ifp, ifi, ife);
      if (c32 ^= "&then")
      then do;
         msg = "&then";
         call error_missing ("if", begl, ifi);
      end;
      beglt = ifi;
      ifi = ifi + length (c32);
      call strip (ifp, ifi, ife);
      construct_nest = construct_nest + 1;
      if (TF & "10"b)
      then call expand (ifp, ifi, ife, ofp, ofe, (TF));
      else call skipper;
      if db_sw | tr_sw
      then call ioa_ ("#^a:^a^-&then (^a) ^[done^;skip^]", lineno (beglt),
	    lineno (ifi - 1), if_lineno, (TF & "10"b));
skip_again:
      beglt = ifi;
      if (c32 = "&elseif")
      then do;
         ifi = ifi + length (c32);
         call strip (ifp, ifi, ife);
         if (TF & "01"b)
         then do;
	  construct_nest = construct_nest - 1;
	  elseif = "1"b;
	  goto nother_logical;
         end;
         call skipper;
         if db_sw | tr_sw
         then call ioa_ ("#^a:^a^-&elseif (^a) skip",
	       lineno (beglt), lineno (ifi - 1), if_lineno);
         goto skip_again;
      end;
      if (c32 = "&else")
      then do;
         ifi = ifi + length (c32);
         call strip (ifp, ifi, ife);
         if (TF & "01"b)
         then call expand (ifp, ifi, ife, ofp, ofe, (TF));
         else call skipper;
         if db_sw | tr_sw
         then call ioa_ ("#^a:^a^-&else (^a) ^[done^;skip^]",
	       lineno (beglt), lineno (ifi - 1), if_lineno, TF & "01"b);
         beglt = ifi;
      end;
      if (c32 ^= "&fi")
      then do;
         msg = "&fi";
         call error_missing ("if", begl, ifi);
      end;
      construct_nest = construct_nest - 1;
      ifi = ifi + length (c32);
      call strip (ifp, ifi, ife);
      if db_sw | tr_sw
      then call ioa_ ("#^a:^a^-&fi (^a)",
	    lineno (beglt), lineno (ifi - 1), if_lineno);
      return;

skipper: proc;

      do while ("1"b);
         i = index (substr (input, ifi), "&");
         if (i = 0)
         then do;
	  c32 = "";
	  return;
         end;
         ifi = ifi + i - 1;
         call get_token (ifp, ifi, ife);
         if (c32 = "&if")
         then call macro_if (ifp, ifi, ife, ofp, ofe, "00"b);
         else if (c32 = "&fi")
         then return;
         else if (c32 = "&else")
         then return;
         else if (c32 = "&elseif")
         then return;
         else if (c32 = "&""")
         then call protected (ifp, ifi, ife, ofp, (ofe));
         else ifi = ifi + 1;
      end;

   end;

   end macro_if; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* return the length of a string				       */

macro_length: proc (ifp, ifi, ife, ofp, ofe, TF);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl loc		(24) fixed bin (24);
dcl sep_ct	fixed bin (24);
dcl argstrl	fixed bin (24);

/* &length ... &; */

      begl = ifi;
      ifi = ifi + 7;
      call strip (ifp, ifi, ife);
      if db_sw then call dumper ("leng", ifp, ifi, ife, ofp, ofe, TF);
      ii = ofe;
      construct_nest = construct_nest + 1;
loop:
      i = index (substr (input, ifi), "&") -1;
      if (i < 0)
      then do;
         msg = "&;";
         call error_missing ("length", begl, ife);
      end;
      if (i > 0)
      then do;
         call putout (ofp, ofe, substr (input, ifi, i));
         ifi = ifi + i;
      end;
      if (substr (input, ifi, 2) = "&;")
      then do;
         call strip2 (ifp, ifi, ife);
         i = ofe - ii;
         ofe = ii;
         call putout (ofp, ofe, ltrim (char (i)));
         construct_nest = construct_nest - 1;
         return;
      end;
      call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
      goto loop;
   end macro_length; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* process loc/int/ext/let statements (they look very much alike	       */

macro_let: proc (ifp, ifi, ife, ofp, ofe, TF, which) recursive;

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2),
    which		fixed bin (24);	/* 0-let, 1-ext, 2-int, 3-loc */
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl vname		char (32) var;
dcl vptr		ptr;
dcl found		fixed bin (24);
dcl (lower, higher) fixed bin (24);

/* &let var = EXPR &;
   &ext var = EXPR &;
   &ext var &;
   &int var = EXPR &;
   &int var &;
   &loc var = EXPR &;
   &loc var &; */
/* EXPR ::= arithmetic | string */

      begl = ifi;
      ifi = ifi + 4;
      call strip (ifp, ifi, ife);
      if db_sw then call dumper (cmd (which), ifp, ifi, ife, ofp, ofe, TF);
      i = verify (substr (input, ifi, 1),
         "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ");
      if (i ^= 0)
      then do;
         msg = "Variable name must begin with alphabetic char. ";
         call error_gen (cmd (which), begl, ifi);
      end;
      i = verify (substr (input, ifi),
         "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789");
      if (i = 0)
      then i = ife - ifi + 1;
      else i = i - 1;
      vname = substr (input, ifi, i);
      if (i > 16)
      then do;
         msg = "Data name > 16 characters. ";
         goto add_identification;
      end;
      ifi = ifi + i;
dcl reserved	(29) char (8) int static init (
		"arg",
		"comment",
		"define",
		"dend",
		"do",
		"else",
		"elseif",
		"empty",
		"error",
		"expand",
		"expend",
		"ext",
		"fi",
		"hbound",
		"if",
		"int",
		"let",
		"lbound",
		"length",
		"loc",
		"macro",
		"mend",
		"quote",
		"return",
		"scan",
		"substr",
		"unquote",
		"usage",
		"while");
      do i = 1 to hbound (reserved, 1);
         if (vname = reserved (i))
         then do;
	  msg = "Attempt to use reserved word """;
	  msg = msg || vname;
	  msg = msg || """ as variable. ";
	  goto add_identification;
         end;
      end;
      found = lookup (vname);
      if (found < which)
      then do;
         allocate var in (free_area) set (var_ptr);
         if al_sw
         then call ioa_ ("A var-^a ^i ^p", vname, size (var), var_ptr);
         var.name = vname;
         var.ref = null ();
         var.type = 0;
         var.len = 0;
         if (which = 1)
         then do;
	  var.next = ext_var_ptr;
	  ext_var_ptr = var_ptr;
	  if db_sw
	  then call ioa_ ("^p	ext ""^a""", var_ptr, var.name);
         end;
         else if (which = 2)
         then do;
	  var.next = int_vars.ref;
	  int_vars.ref = var_ptr;
	  if db_sw
	  then call ioa_ ("^p	int.^a ""^a""", var_ptr, macname,
		var.name);
         end;
         else do;
	  var.next = local_var_ptr;
	  local_var_ptr = var_ptr;
	  if db_sw
	  then call ioa_ ("^p	loc ""^a""", var_ptr, var.name);
         end;
      end;
      else if (found = 0)
      then do;
         msg = "Attempt to set undeclared variable """;
         msg = msg || vname;
         msg = msg || """. ";
         goto add_identification;
      end;
      vptr = var_ptr;
      call strip (ifp, ifi, ife);
      if (which > 0)
      then if (substr (input, ifi, 2) = "&;")
	 then do;
	    call strip2 (ifp, ifi, ife);
	    return;
	 end;
      if (inputa (ifi) = "{")
      then do;
         ifi = ifi - 1;
         if (var.type = 0)
         then do;
	  lower, higher = -9999;
         end;
         else do;
	  arr_ptr = var.ref;
	  lower = array.l_bound;
	  higher = array.h_bound;
         end;
         call get_range (ifp, ifi, ife, ofp, ofe, TF, lower, higher);
         if (inputa (ifi) ^= "}")
         then do;
	  msg = "}";
	  call error_missing (cmd (which), begl, ifi);
         end;
         ifi = ifi + 1;
         call strip (ifp, ifi, ife);
         var_ptr = vptr;
         if (which > 0)		/*  not let */
         then do;
	  if (lower = higher)
	  then do;
	     if (lower < 1)
	     then do;
	        msg = "Improper dimension. ";
	        goto add_identification;
	     end;
	     lower = 1;
	  end;
	  if (found ^= which)
	  then do;
	     var.type = 1;
	     var.len = higher - lower + 1;
	     allocate array in (free_area) set (arr_ptr);
	     var.ref = arr_ptr;
	     if al_sw
	     then call ioa_ ("A^a{^i:^i} ^i ^p", vname, lower,
		   higher, size (array), var.ref);
	     do arr_elem = 1 to var.len;
	        array.ref (arr_elem) = null ();
	        array.len (arr_elem) = 0;
	     end;
	     array.lower = lower;
	  end;
	  if (substr (input, ifi, 3) = "var")
	  then do;
	     ifi = ifi + 3;
	     if (found = which)
	     then do;
	        if (var.type ^= 2)
		 | (array.lower ^= lower)
		 | (var.len ^= higher - lower + 1)
	        then do;
dcl_err:
		 msg = "Data declaration does not match prior declaration for """;
		 msg = msg || vname;
		 msg = msg || """. ";
		 goto add_identification;
	        end;
	     end;
	     else do;
	        var.type = 2;
	        array.l_bound = higher + 1;
	        array.h_bound = lower - 1;
	     end;
	  end;
	  else if (substr (input, ifi, 4) = "list")
	  then do;
	     ifi = ifi + 4;
	     if (found = which)
	     then do;
	        if (var.type ^= 3)
		 | (var.len ^= higher)
	        then goto dcl_err;
	     end;
	     else do;
	        var.type = 3;
	        array.l_bound = 1;
	        array.h_bound = 0;
	     end;
	  end;
	  else if (substr (input, ifi, 4) = "fifo")
	  then do;
	     ifi = ifi + 4;
	     if (found = which)
	     then do;
	        if (var.type ^= 4)
		 | (array.l_bound ^= lower)
		 | (array.h_bound ^= higher)
	        then goto dcl_err;
	     end;
	     else do;
	        var.type = 4;
	        array.l_bound = 1;
	        array.h_bound = 0;
	     end;
	  end;
	  else if (substr (input, ifi, 4) = "lifo")
	  then do;
	     ifi = ifi + 4;
	     if (found = which)
	     then do;
	        if (var.type ^= 5)
		 | (array.l_bound ^= lower)
		 | (array.h_bound ^= higher)
	        then goto dcl_err;
	     end;
	     else do;
	        var.type = 5;
	        array.l_bound = 1;
	        array.h_bound = 0;
	     end;
	  end;
	  else do;
	     if (found = which)
	     then do;
	        if (var.type ^= 1)
		 | (array.l_bound ^= lower)
		 | (array.h_bound ^= higher)
	        then goto dcl_err;
	     end;
	     else do;
	        array.l_bound = lower;
	        array.h_bound = higher;
	     end;
	  end;
	  call strip (ifp, ifi, ife);
         end;
         else do;
	  if (var.type ^= 1) & (var.type ^= 2)
	  then do;
	     msg = "Attempt to do array assignment to non-array variable. ";
	     goto add_identification;
	  end;
	  arr_ptr = var.ref;
	  if (lower < array.lower)
	  then do;
	     msg = "Attempt to set below lower bound. ";
	     goto add_identification;
	  end;
	  if (higher > array.lower + var.len - 1)
	  then do;
	     msg = "Attempt to set above upper bound. ";
	     goto add_identification;
	  end;
         end;
         call strip (ifp, ifi, ife);
         if (which > 0)
         then if (substr (input, ifi, 2) = "&;")
	    then do;
	       call strip2 (ifp, ifi, ife);
	       return;
	    end;
      end;
      else do;
         if (var.type = 1)
	  | (var.type = 2)
         then do;
	  msg = "Attempt to do scalar assignment to array variable. ";
	  goto add_identification;
         end;
         if (var.type = 4)		/*  fifo */
         then do;
	  arr_ptr = var.ref;
	  if (array.l_bound + var.len - 1 > array.h_bound)
	  then do;
	     msg = "Out-of-bounds on fifo """;
	     msg = msg || vname;
	     msg = msg || """. ";
	     goto add_identification;
	  end;
	  if (array.l_bound + var.len - 1 = array.h_bound)
	  then do;
	     msg = "Attempt to stack too many elements. ";
	     goto add_identification;
	  end;
	  array.h_bound = array.h_bound + 1;
	  lower, higher = mod (array.h_bound, var.len) + 1;
         end;
         if (var.type = 5)
         then do;
	  arr_ptr = var.ref;
	  if (var.len < array.h_bound)
	  then do;
	     msg = "Out-of-bounds on lifo """;
	     msg = msg || vname;
	     msg = msg || """. ";
	     goto add_identification;
	  end;
	  if (var.len = array.h_bound)
	  then do;
	     msg = "Attempt to stack too many elements. ";
	     goto add_identification;
	  end;
	  array.h_bound, lower, higher = array.h_bound + 1;
         end;
      end;
      if (inputa (ifi) ^= "=")
      then do;
         msg = "=";
         call error_missing (cmd (which), begl, ifi);
dcl cmd		(0:3) char (4) int static init ("let ", "ext ", "int ", "loc ");
      end;
      ifi = ifi + 1;
      call strip (ifp, ifi, ife);
      jj = ofe;
      if (inputa (ifi) = "(")
      then do;
         msg = "Vector assignment not available yet.";
         call error_gen (cmd (which), begl, ifi);
      end;
      if (substr (input, ifi, 2) = "&(")
      then do;
         call arithmetic (ifp, ifi, ife, ofp, ofe, TF);
         call strip (ifp, ifi, ife);
      end;
      else do;
         construct_nest = construct_nest + 1;
loop:
         i = index (substr (input, ifi), "&") -1;
         if (i < 0)
         then do;
	  msg = "&;";
	  call error_missing (cmd (which), begl, ife);
         end;
         if (i > 0)
         then do;
	  call putout (ofp, ofe, substr (input, ifi, i));
	  ifi = ifi + i;
         end;
         if (substr (input, ifi, 2) ^= "&;")
         then do;
	  call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
	  goto loop;
         end;
         construct_nest = construct_nest - 1;
      end;
      if (substr (input, ifi, 2) ^= "&;")
      then do;
         msg = "&;";
         call error_missing (cmd (which), begl, ife);
      end;
      call strip2 (ifp, ifi, ife);
      if (found = 0)
         | (which = 0)
      then do;
         j = ofe - jj;
         var_ptr = vptr;
         if (var.type = 0)
         then do;
	  if (var.len ^= j)
	  then do;
	     if (var.len > 0)
	     then do;
	        if al_sw
	        then call ioa_ ("F ^a ^i ^p", vname, var.len,
		      var.ref);
	        free vartext in (free_area);
	     end;
	     var.len = j;
	     allocate vartext in (free_area) set (var.ref);
	     if al_sw
	     then call ioa_ ("A ^a ^i ^p", vname, size (vartext),
		   var.ref);
	  end;
	  vartext = substr (output, jj + 1, j);
	  if db_sw | tr_sw
	  then do;
	     call ioa_$nnl ("#^a:^a^-&^a ^a =", lineno (begl),
	        lineno (ifi - 1), cmd (which), var.name);
	     call show_string (vartext, "&;
");
	  end;
         end;
         else do;
	  arr_ptr = var.ref;
	  if (var.type = 2)
	  then do;
	     array.l_bound = min (array.l_bound, lower);
	     array.h_bound = max (array.h_bound, higher);
	  end;
	  if (var.type = 3)
	  then do;
	     do arr_elem = array.l_bound to array.h_bound;
	        if (arrtext = substr (output, jj + 1, j))
	        then do;
		 ofe = jj;
		 return;
	        end;
	     end;
	     if (array.h_bound = var.len)
	     then do;
	        msg = "Attempt to add too many elements to list. ";
	        goto add_identification;
	     end;
	     array.h_bound, lower, higher = array.h_bound + 1;
	  end;
	  do arr_elem = lower - array.lower + 1 to higher - array.lower + 1;
	     if (array.len (arr_elem) ^= j)
	     then do;
	        if (array.ref (arr_elem) ^= null ())
	        then do;
		 if al_sw
		 then call ioa_ ("F ^a{^i} ^i ^p", vname,
		         arr_elem, array.len (arr_elem),
		         array.ref (arr_elem));
		 free arrtext in (free_area);
	        end;
	        array.len (arr_elem) = j;
	        allocate arrtext in (free_area) set (array.ref (arr_elem));
	        if al_sw
	        then call ioa_ ("A ^a{^i} ^i ^p", vname,
		      arr_elem, size (arrtext),
		      array.ref (arr_elem));
	     end;
	     arrtext = substr (output, jj + 1, j);
	  end;
	  if db_sw | tr_sw
	  then do;
	     call ioa_$nnl ("#^a:^a^-&^a ^a{^i:^i} =", lineno (begl),
	        lineno (ifi - 1), cmd (which), var.name, lower, higher);
	     call show_string (substr (output, jj + 1, j), "&;
");
	  end;
         end;
      end;
      ofe = jj;
   end macro_let; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* double any quotes in a string				       */

macro_quote: proc (ifp, ifi, ife, ofp, ofe, tf);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    tf		bit (2);		/* 1x- process true		       */
				/* x1- process false	       */
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl inside	bit (1);
dcl ch		char (1);

/* &quote ... &; */

      begl = ifi;
      ifi = ifi + 6;
      call strip (ifp, ifi, ife);
      ii = ofe;
      construct_nest = construct_nest + 1;
loop:
      i = index (substr (input, ifi), "&") -1;
      if (i < 0)
      then do;
         msg = "&;";
         call error_missing ("quote", begl, ife);
      end;
      if (i > 0)
      then do;
         call putout (ofp, ofe, substr (input, ifi, i));
         ifi = ifi + 1;
      end;
      if (substr (input, ifi, 2) ^= "&;")
      then do;
         call ampersand (ifp, ifi, ife, ofp, ofe, tf, "0"b);
         goto loop;
      end;
      call strip2 (ifp, ifi, ife);
      i = ofe - ii;
      if (i > 16384)
      then do;
         msg = "Sorry, not yet handling &quote strings > 16384 chrs.";
         goto add_identification;
      end;
      construct_nest = construct_nest - 1;
      if (index (substr (output, ii + 1, i), """") = 0)
      then do;
         return;
      end;
      begin;
dcl argstr	char (i);
         argstr = substr (output, ii + 1, i);
         ofe = ii;
         j = 1;
loop:
         ii = index (substr (argstr, j), """");
         if (ii = 0)
         then ii = i - j + 1;
         call putout (ofp, ofe, substr (argstr, j, ii));
         j = j + ii;
         if (substr (output, ofe, 1) = """")
         then call putout (ofp, ofe, """");
         if (j > i)
         then return;
         goto loop;
      end;
   end macro_quote; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* rescan a result of macro expansion				       */

macro_scan: proc (ifp, ifi, ife, ofp, ofe, TF);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl loc		(24) fixed bin (24);
dcl sep_ct	fixed bin (24);
dcl argstrl	fixed bin (24);

/* &scan ... &; */

      begl = ifi;
      ifi = ifi + 5;
      call strip (ifp, ifi, ife);
      if db_sw then call dumper ("scan", ifp, ifi, ife, ofp, ofe, TF);
      ii = ofe;
      construct_nest = construct_nest + 1;
loop:
      i = index (substr (input, ifi), "&") -1;
      if (i < 0)
      then do;
         msg = "&;";
         call error_missing ("scan", begl, ife);
      end;
      if (i > 0)
      then do;
         call putout (ofp, ofe, substr (input, ifi, i));
         ifi = ifi + i;
      end;
      if (substr (input, ifi, 2) = "&;")
      then do;
         call strip2 (ifp, ifi, ife);
         argstrl = ofe - ii;
         if (argstrl > 16384)
         then do;
	  msg = "&scan string > 16384 chars.";
	  goto add_identification;
         end;
         begin;
dcl argstr	char (argstrl);
	  if db_sw | tr_sw
	  then do;
	     call ioa_$nnl ("#^a:^a^-&scan ", lineno (begl), lineno (ifi - 1));
	     call show_string (substr (output, ii + 1, argstrl), "&;
");
	  end;
	  string (argstr) = substr (output, ii + 1, argstrl);
	  ofe = ii;
	  call expand (addr (argstr), 1, argstrl, ofp, ofe, (TF));
	  construct_nest = construct_nest - 1;
	  return;
         end;
      end;
      call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
      goto loop;
   end macro_scan; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* return part of a string with needed padding			       */

macro_substr: proc (ifp, ifi, ife, ofp, ofe, TF);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl loc		(24) fixed bin (24);
dcl sep_ct	fixed bin (24);
dcl argstrl	fixed bin (24);

/* &substr ... , ARITH , ARITH &;
   &substr ... , ARITH &;
   &substr ... , ARITH : ARITH &; */

      begl = ifi;
      ifi = ifi + 7;
      call strip (ifp, ifi, ife);
      if db_sw then call dumper ("subs", ifp, ifi, ife, ofp, ofe, TF);
      ii = ofe;
      construct_nest = construct_nest + 1;
loop:
      i = search (substr (input, ifi), "&,") -1;
      if (i < 0)
      then do;
         msg = "&;";
         call error_missing ("substr", begl, ife);
      end;
      if (i > 0)
      then do;
         call putout (ofp, ofe, substr (input, ifi, i));
         ifi = ifi + i;
      end;
      if (inputa (ifi) = "&")
      then do;
         call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
         goto loop;
      end;
      argstrl = ofe - ii;
      if (argstrl > 16384)
      then do;
         msg = "&substr string > 16384 chrs.";
         goto add_identification;
      end;
      begin;
dcl argstr	char (argstrl);
dcl sepch		char (1);
         argstr = substr (output, ii + 1, argstrl);
         ofe = ii;
         ifi = ifi - 1;
         call arithmetic (ifp, ifi, ife, ofp, ofe, TF);
         i = fixed (substr (output, ii + 1, ofe - ii));
         sepch = " ";
         ofe = ii;
         if (inputa (ifi) = ",")
	  | (inputa (ifi) = ":")
         then do;
	  sepch = inputa (ifi);
	  ifi = ifi - 1;
	  call arithmetic (ifp, ifi, ife, ofp, ofe, TF);
	  j = fixed (substr (output, ii + 1, ofe - ii));
	  ofe = ii;
         end;
         if (substr (input, ifi, 2) ^= "&;")
         then goto misplaced;
         call strip2 (ifp, ifi, ife);
         if (TF ^= "00"b)
         then do;
	  if (i < 0)
	  then i = argstrl + i + 1;
	  if (sepch = " ")
	  then j = argstrl - i + 1;
	  if (sepch = ":")
	  then do;
	     if (j < 1)
	     then do;
	        msg = "Substr end location <0. ";
	        goto add_identification;
	     end;
	     if (j < i)
	     then do;
	        msg = "Substr end before begin. ";
	        goto add_identification;
	     end;
	     j = j - i + 1;
	  end;
	  if (j < 0)
	  then do;
	     jj = (argstrl - i + 1) + j;
	     if (jj < 0)
	     then do;
	        substr (output, ofe + 1, -jj) = " ";
	        ofe = ofe - jj;
	        j = -j + jj;
	     end;
	     else j = -j;
	  end;
	  if (i < 1)
	  then do;
	     msg = "Substr before string begin. ";
	     goto add_identification;
	  end;
	  if (i > argstrl)
	  then do;
	     msg = "Substr after string end. ";
	     msg_etc = ltrim (char (i));
	     msg_etc = msg_etc || ",";
	     msg_etc = msg_etc || ltrim (char (j));
	     msg_etc = msg_etc || " of ";
	     msg_etc = msg_etc || ltrim (char (argstrl));
	     msg_etc = msg_etc || """";
	     msg_etc = msg_etc || argstr;
	     msg_etc = msg_etc || """";
	     goto add_identification;
	  end;
	  jj = min (argstrl-i+1, j);
	  call putout (ofp, ofe, substr (argstr, i, jj));
	  if (j > jj)
	  then call putout (ofp, ofe, copy (" ",j-jj));
         end;
      end;
      construct_nest = construct_nest - 1;
   end macro_substr; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* remove doubled quotes and surrounding quotes (if any) from a string       */

macro_unquote: proc (ifp, ifi, ife, ofp, ofe, tf);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    tf		bit (2);		/* 1x- process true		       */
				/* x1- process false	       */
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl inside	bit (1);
dcl ch		char (1);

/* &unquote ... &; */

      begl = ifi;
      ifi = ifi + 8;
      call strip (ifp, ifi, ife);
      ii = ofe;
      construct_nest = construct_nest + 1;
loop:
      i = index (substr (input, ifi), "&") -1;
      if (i < 0)
      then do;
         msg = "&;";
         call error_missing ("unquote", begl, ife);
      end;
      if (i > 0)
      then do;
         call putout (ofp, ofe, substr (input, ifi, i));
         ifi = ifi + 1;
      end;
      if (substr (input, ifi, 2) ^= "&;")
      then do;
         call ampersand (ifp, ifi, ife, ofp, ofe, tf, "0"b);
         goto loop;
      end;
      call strip2 (ifp, ifi, ife);
      construct_nest = construct_nest - 1;
      i = ii;
      inside = "0"b;
      do ii = ii + 1 to ofe;
         ch = substr (output, ii, 1);
         if (ch = """")
         then do;
	  if inside
	  then do;
	     if (substr (output, ii + 1, 1) = """")
	     then do;
	        ii = ii + 1;
	        goto use_char;
	     end;
	     else inside = "0"b;
	  end;
	  else inside = "1"b;
         end;
         else do;
use_char:
	  i = i + 1;
	  substr (output, i, 1) = ch;
         end;
      end;
      ofe = i;

   end macro_unquote; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* show the macros used up to this point			       */

macro_usage: proc (ifp, ifi, ife, ofp, ofe, TF);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl loc		(24) fixed bin (24);
dcl sep_ct	fixed bin (24);
dcl argstrl	fixed bin (24);
dcl ctl		char (100) var;
dcl ret_str	char (256);
dcl ret_len	fixed bin (24);
dcl ioa_$rsnpnnl	entry options (variable);

/* &usage string &; */

      begl = ifi;
      ifi = ifi + 6;
      call strip (ifp, ifi, ife);
      if db_sw then call dumper ("usag", ifp, ifi, ife, ofp, ofe, TF);
      ii = ofe;
      construct_nest = construct_nest + 1;
loop:
      i = index (substr (input, ifi), "&") -1;
      if (i < 0)
      then do;
         msg = "&;";
         call error_missing ("usage", begl, ife);
      end;
      if (i > 0)
      then do;
         call putout (ofp, ofe, substr (input, ifi, i));
         ifi = ifi + i;
      end;
      if (substr (input, ifi, 2) = "&;")
      then do;
         call strip2 (ifp, ifi, ife);
         ctl = substr (output, ii + 1, ofe - ii);
         ofe = ii;
         do maclp = macro_list_p
	  repeat (macro_list.next)
	  while (maclp ^= null ());
	  call ioa_$rsnpnnl (ctl, ret_str, ret_len,
	     macro_list.dname, macro_list.ename,
	     macro_list.name);
	  call putout (ofp, ofe, substr (ret_str, 1, ret_len));
         end;
         construct_nest = construct_nest - 1;
         return;
      end;
      call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
      goto loop;
   end macro_usage; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* put a string into the output, making sure the length is updated before    */
/*  placing the data therein.					       */

putout: proc (ofp, ofe, str);

dcl ofp		ptr,		/* points to receiver	  (IN) */
    ofe		fixed bin (24),	/* length of receiver          (OUT) */
    str		char (*);		/* string to insert             (IN) */

dcl output	char (ofe) based (ofp);
dcl tofe		fixed bin (24);

      tofe = ofe + 1;
      ofe = ofe + length (str);
      substr (output, tofe, length (str)) = str;
      if dt_sw & db_sw
      then call ioa_ ("^i,^i `^va'", tofe, length (str), length (str), str);

end putout;

/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* process a protected string					       */

protected: proc (ifp, ifi, ife, ofp, ofe);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24);	/* last char of output used	       */
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl loc		(24) fixed bin (24);
dcl sep_ct	fixed bin (24);
dcl argstrl	fixed bin (24);

/* &" ... {&"&"} ... &" */

      begl = ifi;
      ifi = ifi + 2;
      do while ("1"b);
         i = index (substr (input, ifi), "&""") -1;
         if (i < 0)
         then do;
	  msg = "&""";
	  call error_missing ("""", begl, ife);
         end;
         call putout (ofp, ofe, substr (input, ifi, i));
         ifi = ifi + i + 2;
         if (substr (input, ifi, 2) ^= "&""")
         then return;
         call putout (ofp, ofe, "&""");
         ifi = ifi + 2;
      end;
   end protected; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* scan a string and print it indenting 1 HT.			       */

show_string: proc (str1, str2);

dcl (str1, str2)	char (*);
dcl (i, j, k)	fixed bin (24);
dcl HT_sw		bit (1);

      i = 1;
      do while (i <= length (str1));
         j = index (substr (str1, i), NL);
         if (j = 0)
         then do;
	  j = length (str1) - i + 1;
	  HT_sw = "0"b;
         end;
         else HT_sw = "1"b;
         k = i + j;
         call ioa_$nnl ("^a^[^-^]", substr (str1, i, j), HT_sw);
         i = k;
      end;
      call ioa_$nnl ("^a", str2);

   end show_string; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* skip over whitespace. strip2 moves ahead 2 first		       */

strip2: proc (ifp, ifi, ife);

      ifi = ifi + 2;

strip: entry (ifp, ifi, ife);

dcl ifp		ptr,
    ifi		fixed bin (24),
    ife		fixed bin (24);
dcl input		char (ife) based (ifp);

dcl i		fixed bin (24);

loop:
      i = verify (substr (input, ifi), space);
      if (i = 0)
      then ifi = ife + 1;
      else ifi = ifi + i - 1;
      if (substr (input, ifi, 1) ^= "&")
      then return;
      i = verify (substr (input, ifi + 1), token_chars);
      if (substr (input, ifi + 1, i) ^= "comment")
      then return;
      i = index (substr (input, ifi), "&;");
      if (i = 0)
      then do;
         msg = "&;";
         call error_missing ("comment", ifi, ifi + 8);
      end;
      ifi = ifi + i + 1;
      goto loop;			/* keep on stripping	       */

   end strip2; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* return the lbound/hbound of an array				       */

var_bound: proc (ifp, ifi, ife, ofp, ofe, TF) recursive;

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl loc		(24) fixed bin (24);
dcl (sep_ct, level) fixed bin (24);
dcl argstrl	fixed bin (24);
dcl vname		char (32) var;

/* &lbound xxx&;
   &hbound xxx&; */
      ii = ofe;
      call strip (ifp, ifi, ife);
loop:
      i = index (substr (input, ifi), "&") -1;
      if (i < 0)
      then do;
         msg = "Missing terminator on &";
         msg = msg || c32;
         msg = msg || ". ";
         goto add_identification;
      end;
      if (i > 0)
      then do;
         call putout (ofp, ofe, substr (input, ifi, i));
         ifi = ifi + i;
      end;
      if (substr (input, ifi, 2) ^= "&;")
      then do;
         call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
         goto loop;
      end;
      vname = substr (output, ii + 1, ofe - ii);
      ofe = ii;
      j = lookup (vname);
      if (j = 0)
      then do;
         msg = "Attempt to reference undeclared variable """;
         msg = msg || vname;
         msg = msg || """. ";
         goto add_identification;
      end;
      if (var.type = 0)
      then do;
         msg = "Attempt to get ";
         msg = msg || c32;
         msg = msg || " of a scalar. ";
         goto add_identification;
      end;
      arr_ptr = var.ref;
      if (var.type = 1)		/* array			       */
         | (var.type = 2)		/* array var		       */
         | (var.type = 3)		/* list			       */
      then do;
         if (c32 = "lbound")
         then i = array.l_bound;
         else i = array.h_bound;
      end;
      if (var.type = 4)		/* fifo			       */
         | (var.type = 5)		/* lifo			       */
      then do;
         msg = "Cannot get ";
         msg = msg || c32;
         msg = msg || " of ";
         if (var.type = 5)
         then msg = msg || "l";
         else msg = msg || "f";
         msg = msg || "ifo.";
         goto add_identification;
      end;
   end var_bound; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/*							       */

var_range: proc (ifp, ifi, ife, ofp, ofe, TF);

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl separator	char (150) var;
dcl vptr		ptr;
dcl limit		fixed bin;

/* &var{ ARITH }			yields argument ARITH	       */
/* &var{ ARITH : ARITH } 		yields arguments ARITH thru ARITH    */
/* 				      separated by a SP	       */
/* &var{ ARITH : ARITH , STRING }	yields arguments ARITH thru ARITH    */
/* 				      separated by STRING	       */

      begl = ifi;
      ii = ofe;
      i = lookup (c32);
      if (i = 0)
      then do;
         msg = "Attempt to reference undeclared array. ";
         goto add_identification;
      end;
      if (var.type = 0)
      then do;
         msg = "Attempt to make non-scalar ref to scalar variable """;
         msg = msg || c32;
         msg = msg || """. ";
         goto add_identification;
      end;
      vptr = var_ptr;
      arr_ptr = var.ref;
      i = array.l_bound;
      j = array.h_bound;
      ifi = ifi - 2;
      call get_range (ifp, ifi, ife, ofp, ofe, TF, i, j);
      var_ptr = vptr;
      arr_ptr = var.ref;
      if (TF ^= "00"b)
      then do;
         if (var.type = 4)
	  | (var.type = 5)
         then do;
	  if (i ^= j)
	  then do;
	     msg = "Attempt to make multiple ref to stack """;
	     msg = msg || c32;
	     msg = msg || """. ";
	     goto add_identification;
	  end;
	  if (i > 0)
	  then do;
	     msg = "Attempt to ref positive stack element """;
	     msg = msg || c32;
	     msg = msg || """. ";
	     goto add_identification;
	  end;
	  if (var.type = 4)
	  then do;
	     i, j = array.l_bound - i;
	     if (i > array.h_bound)
	     then do;
	        msg = "Attempt to ref non-existant stack element in """;
	        msg = msg || c32;
	        msg = msg || """. ";
	        goto add_identification;
	     end;
	  end;
	  else do;
	     i, j = array.h_bound + i;
	     if (i < array.l_bound)
	     then do;
	        msg = "Attempt to ref non-existant stack element in """;
	        msg = msg || c32;
	        msg = msg || """. ";
	        goto add_identification;
	     end;
	  end;
         end;
         else do;
	  if (i < array.l_bound)
	  then do;
	     msg = "Attempt to reference below lower bound. ";
	     goto add_identification;
	  end;
	  if (j > array.h_bound)
	  then do;
	     msg = "Attempt to reference above upper bound. ";
	     goto add_identification;
	  end;
         end;
      end;
      separator = " ";
      if (inputa (ifi) = ",")
      then do;
         ifi = ifi + 1;
         do while ("1"b);
	  jj = search (substr (input, ifi), "&}") -1;
	  if (jj < 0)
	  then do;
	     msg = "}";
	     call error_missing ("xxx{", begl, ife);
	  end;
	  if (jj > 0)
	  then do;
	     call putout (ofp, ofe, substr (input, ifi, jj));
	     ifi = ifi + jj;
	  end;
	  if (inputa (ifi) = "}")
	  then do;
	     separator = substr (output, ii + 1, ofe - ii);
	     ofe = ii;
	     goto end_range;
	  end;
	  call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b);
         end;
      end;
      if (inputa (ifi) = "}")
      then do;
end_range:
         ifi = ifi + 1;
         if (TF = "00"b)
         then return;
         var_ptr = vptr;
         arr_ptr = var.ref;
         limit = j - array.lower + 1;
         do arr_elem = i - array.lower + 1 to limit;
	  call putout (ofp, ofe, arrtext);
	  if (arr_elem ^= limit)
	  then call putout (ofp, ofe, (separator));
         end;
      end;
      else do;
         msg = "&var{ ... }";
         goto syntax_err;
      end;
   end var_range; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* reference a variable					       */

var_ref: proc (ifp, ifi, ife, ofp, ofe, TF) recursive;

dcl ifp		ptr,		/* pointer to input		       */
    ifi		fixed bin (24),	/* first char of input to use	       */
    ife		fixed bin (24),	/* last char of input to use	       */
    ofp		ptr,		/* pointer to output	       */
    ofe		fixed bin (24),	/* last char of output used	       */
    TF		bit (2);
dcl begl		fixed bin (24);
dcl inputa	(ife) char (1) based (ifp);
dcl input		char (ife) based (ifp);
dcl output	char (ofe) based (ofp);
dcl (i, j, ii, jj)	fixed bin (24);
dcl loc		(24) fixed bin (24);
dcl (sep_ct, level) fixed bin (24);
dcl argstrl	fixed bin (24);

/* &xxx */ /* xxx can be SCALAR, FIFI, or LIFO */
      if (TF = "00"b)
      then return;
      begl = ifi;
      j = lookup (c32);
      if (j = 0)
      then do;
         msg = "Attempt to reference undeclared variable """;
         msg = msg || c32;
         msg = msg || """. ";
         goto add_identification;
      end;
      if (var.type = 0)
      then do;
         if (c32 = watchword)
         then call ioa_ ("^a ^i ""^va""", watchword, var.len, var.len,
	       vartext);
         call putout (ofp, out_len, vartext);
      end;
      else do;
         arr_ptr = var.ref;
         if (var.type = 4)
         then do;
	  if (array.l_bound > array.h_bound)
	  then do;
	     msg = "Attempt to reference empty fifo """;
	     msg = msg || c32;
	     msg = msg || """. ";
	     goto add_identification;
	  end;
	  arr_elem = mod (array.l_bound, var.len) + 1;
	  if (c32 = watchword)
	  then call ioa_ ("^a{^i} ^i ""^va""", watchword, arr_elem,
		array.len (arr_elem), array.len (arr_elem), arrtext);
	  call putout (ofp, out_len, arrtext);
	  array.l_bound = array.l_bound + 1;
	  if al_sw
	  then call ioa_ ("F ^a{^i} ^i ^p", c32, arr_elem,
		array.len (arr_elem), array.ref (arr_elem));
	  free arrtext in (free_area);
         end;
         else if (var.type = 5)
         then do;
	  if (array.l_bound > array.h_bound)
	  then do;
	     msg = "Attempt to reference empty lifo """;
	     msg = msg || c32;
	     msg = msg || """. ";
	     goto add_identification;
	  end;
	  arr_elem = array.h_bound;
	  if (c32 = watchword)
	  then call ioa_ ("^a{^i} ^i ""^va""", watchword, arr_elem,
		array.len (arr_elem), array.len (arr_elem), arrtext);
	  call putout (ofp, out_len, arrtext);
	  array.h_bound = array.h_bound - 1;
	  if al_sw
	  then call ioa_ ("F ^a{^i} ^i ^p", c32, arr_elem,
		array.len (arr_elem), array.ref (arr_elem));
	  free arrtext in (free_area);
         end;
         else do;
	  msg = "Attempt to make scalar reference to non-scalar """;
	  msg = msg || c32;
	  msg = msg || """. ";
	  goto add_identification;
         end;
      end;
   end var_ref; %page;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* EXTERNAL entry to cleanup the processing environment		       */

dcl ref_path	char (168);
free: entry (pr_sw);

dcl pr_sw		bit (1);

dcl define_area_	entry (ptr, fixed bin (35));
dcl release_area_	entry (ptr);

      if free_area_p ^= null ()
      then do;
         tptr = ext_var_ptr;
         call free_um ("ext");
         ext_var_ptr = null ();
         do while (int_vars_base ^= null ());
	  int_var_ptr = int_vars_base;
	  if db_sw
	  then call ioa_ ("^p^-macro ^a", int_var_ptr, int_vars.macro);
	  int_vars_base = int_vars.next;
	  tptr = int_vars.ref;
	  call free_um ("int");
	  if al_sw then call ioa_ ("F int_vars ^p", int_var_ptr);
	  free int_vars in (free_area);
         end;
         tptr = macro_list_p;
         if (tptr ^= null ()) & pr_sw
         then call ioa_ ("^aS USED:", who_am_i);
         do while (tptr ^= null ());
	  maclp = tptr;
	  if pr_sw & (macro_list.dname ^= "")
	  then do;
	     call ioa_ ("^i:^i ^a>^a -- (^a.macro)", macro_list.from,
	        macro_list.to, macro_list.dname,
	        macro_list.ename, macro_list.name);
	  end;
	  tptr = macro_list.next;
	  macro_holder_p = macro_list.ref;
	  if (substr (macro_list.dname, 1, 4) = "   &")
	  then do;
	     macro_holder_l = macro_list.to;
	     if al_sw
	     then call ioa_ ("F macro_holder ^p", macro_holder_p);
	     free macro_holder in (free_area);
	  end;
	  if al_sw then call ioa_ ("F macro_list ^p", maclp);
	  free macro_list in (free_area);
         end;
         call release_area_ (free_area_p);
         free_area_p = null ();
      end;
      macro_list_p = null ();
      err_ct (*) = 0;
      macro_nest = 0;
      return;

dcl dname		char (168);
dcl ename		char (32);
dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin (24), char (*), fixed bin (35));


/* * * * * * * * * * * * * * INTERNAL STATIC DATA  * * * * * * * * * * * * * */

dcl al_sw		bit (1) int static init ("0"b);
dcl db_sw		bit (1) int static init ("0"b);
dcl dt_sw		bit (1) int static init ("0"b);
dcl end_sym	char (8) var;
dcl err_ct	(0:4) fixed bin int static init ((5) 0);
dcl ext_var_ptr	ptr int static init (null ());
dcl free_area_p	ptr int static init (null ());
dcl int_vars_base	ptr int static init (null ());
dcl lg_sw		bit (1) int static init ("0"b);
dcl macro_list_p	ptr int static init (null ());
dcl macro_nest	fixed bin int static init (0);
dcl pc_sw		bit (1) int static init ("0"b);
dcl watchword	char (32) int static init ("");
dcl who_am_i	char (12) var int static;

/* * * * * * * * * * * * * * * *  CONSTANTS  * * * * * * * * * * * * * * * * */

dcl NL		char (1) int static options (constant) init ("
");
dcl space		char (5) int static options (constant) init (" 	
");

/* * * * * * * * * * * * * * * *  STRUCTURES * * * * * * * * * * * * * * * * */

dcl var_ptr	ptr;
dcl 1 var		based (var_ptr),
      2 next	ptr,		/* next variable in list	       */
      2 name	char (16),
      2 type	fixed bin,	/* 0-scalar  1-array   2-array var   */
				/* 3-list    4-fifo    5-lifo	       */
      2 len	fixed bin,	/* length of data string	       */
      2 ref	ptr;		/* points to data string	       */
dcl vartext	char (var.len) based (var.ref);


dcl arr_ptr	ptr;
dcl 1 array	based (arr_ptr),
      2 lower	fixed bin,
      2 l_bound	fixed bin,	/* defined lower bound	       */
      2 h_bound	fixed bin,	/* defined higher bound	       */
      2 elem	(var.len),
        3 len	fixed bin,	/* length of data string	       */
        3 ref	ptr unal;		/* points to data string	       */
dcl arrtext	char (array.len (arr_elem)) based (array.ref (arr_elem));
dcl arr_elem	fixed bin (24);

dcl int_var_ptr	ptr;
dcl 1 int_vars	based (int_var_ptr),
      2 next	ptr unal,
      2 ref	ptr unal,		/* points to variable definition     */
      2 macro	char (32);	/* name of macro owning it	       */

dcl maclp		ptr;
dcl 1 macro_list	based (maclp),
      2 next	ptr,
      2 ref	ptr,
      2 dname	char (168),
      2 ename	char (32),
      2 from	fixed bin (24),
      2 to	fixed bin (24),
      2 name	char (32),
      2 int_mac	bit (1);		/* 1- &macro/&define'ed	       */

/* * * * * * * * * * * * * LOOSE ARRAYS and SCALARS  * * * * * * * * * * * * */

dcl argleng_less_than_zero condition;
dcl bc		fixed bin (24);
dcl c32		char (32) var;
dcl c32x		char (32) var;
dcl call_err	bit (1);
dcl ch_2nd	char (1);
dcl construct_nest	fixed bin (24);
dcl free_area	area based (free_area_p);
dcl i		fixed bin (24);
dcl jaf		fixed bin (24);
dcl local_var_ptr	ptr;
dcl macro_holder	char (macro_holder_l) based (macro_holder_p);
dcl macro_holder_l	fixed bin (24);
dcl macro_holder_p	ptr;
dcl msg_etc	char (1000) var;
dcl myname	char (32) var;
dcl output	char (ofe) based (out_ptr);
dcl save_db	bit (1);
dcl seg		char (sege) based (segptr);
dcl sega		(sege) char (1) based (segptr);
dcl sege		fixed bin (24);
dcl segi		fixed bin (24);
dcl segii		fixed bin (24);
dcl segment	char (sege) based (segptr);
dcl segptr	ptr;
dcl segtype	char (8) var;
dcl start_sym	char (8) var;
dcl tptr		ptr;
dcl token_chars	char (63) int static options (constant) init (
		"abcdefghijklmnopqrstuvwxyz" ||
		"ABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789");
dcl tr_sw		bit (1);

dcl error_table_$action_not_performed fixed bin (35) ext static;
dcl error_table_$archive_fmt_err fixed bin (35) ext static;
dcl error_table_$badsyntax fixed bin (35) ext static;
dcl error_table_$new_search_list fixed bin (35) ext static;
dcl error_table_$no_search_list fixed bin (35) ext static;
dcl error_table_$translation_aborted fixed bin (35) ext static;
dcl error_table_$translation_failed fixed bin (35) ext static;

dcl ioa_		entry options (variable);
dcl com_err_	entry options (variable);
dcl archive_util_$first_element entry (ptr, fixed bin (35));
dcl archive_util_$search entry (ptr, ptr, char (32), fixed bin (35));
dcl ioa_$nnl	entry options (variable);
dcl hcs_$make_ptr	entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
dcl hcs_$fs_get_seg_ptr entry (char (*), ptr, fixed bin (35));
dcl get_seg_ptr_	entry (char (*), bit (6), fixed bin (24), ptr, fixed bin (35));
dcl mac_sw	bit (1);

dcl (addr, addrel, char, convert, divide, fixed, hbound, index, length, ltrim,
    max, min, mod, null, reverse, rtrim, search, size, string, substr,
    translate, verify) builtin;
dbn: entry; db_sw = "1"b; return;
dtn: entry; dt_sw = "1"b; return;
aln: entry; al_sw = "1"b; return;
pcn: entry; pc_sw = "1"b; return;
lgn: entry; lg_sw = "1"b; return;
lgf: entry; lg_sw = "0"b; return;
pcf: entry; pc_sw = "0"b; return;
alf: entry; al_sw = "0"b; return;
dtf: entry; dt_sw = "0"b; return;
dbf: entry; db_sw = "0"b; return;

watch: entry (watchfor);
dcl watchfor	char (*);

      watchword = watchfor;
      return;

   end;
   



		    mrpg.pl1                        02/14/84  0905.4r w 02/14/84  0844.1       54153


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

mrpg: proc;

dcl MRPG_version	char (8) int static init ("1.1b");

/* report generator language					       */

      code = 0;
      ifp = null ();
      call cu_$arg_ptr (1, argp, argl, code);
      if (code = 0)
      then do;
         if (substr (arg, 1, 1) ^= "-")
         then do;
	  if (ifp ^= null ())
	  then do;
	     call com_err_ (0, command_name, "Multiple input segments not allowed.");
	     return;
	  end;
	  call expand_pathname_$add_suffix (arg, "mrpg", dname, ename, code);
	  if (code ^= 0)
	  then do;
	     call com_err_ (code, command_name, "^a", arg);
	     return;
	  end;
	  if (verify (before (ename, ".mrpg"), chars) ^= 0)
	     | (index ("_0123456789", substr (ename, 1, 1)) ^= 0)
	  then do;
	     call com_err_ (0, "mrpg", "Syntax error in report name.");
	     return;
	  end;
	  call hcs_$initiate_count (dname, ename, "", bc, 0, ifp, code);
	  if (ifp = null ())

	  then do;
	     call com_err_ (code, command_name, "^a>^a", dname, ename);
	     return;
	  end;
	  if (bc = 0)
	  then do;
	     call com_err_ (error_table_$zero_length_seg, command_name, "^a>^a", dname, ename);
	     return;
	  end;
	  ife = divide (bc, 9, 24, 0);
	  arg = before (ename, ".mrpg");
         end;
         else do;
	  call com_err_ (error_table_$badopt, command_name, "^a", arg);
	  return;
         end;
      end;
      else do;
         call com_err_ (code, command_name || MRPG_version, "
Usage:	mrpg pathname {PL/I options}");
         return;
      end;
      if (ifp = null ())
      then do;
         call com_err_ (error_table_$noarg, command_name, "Input segment.");
         return;
      end;
      call ioa_ ("MRPG ^a", MRPG_version);
      ai.version = area_info_version_1;
      ai.zero_on_alloc = "1"b;
      ai.zero_on_free = "0"b;
      ai.dont_free = "0"b;
      ai.no_freeing = "1"b;
      ai.owner = command_name;
      ai.size = sys_info$max_seg_size;
      if hold_sw
      then do;
         ai.extend = "0"b;
         call hcs_$make_seg (get_wdir_ (), "mrpg.area", "mrpg.area", 01010b, ai.areap, code);
         if (ai.areap = null ())
         then do;
	  call com_err_ (code, "mrpg", "Getting work area");
	  return;
         end;
      end;
      else do;
         ai.areap = null ();
         ai.extend = "1"b;
      end;
      call define_area_ (addr (ai), code);
      if (code ^= 0)
      then do;
         call com_err_ (code, command_name, "define_area_");
         return;
      end;
      on condition (cleanup) begin;
	  if ^hold_sw
	  then call release_area_ (ai.areap);
         end;
      on condition (mrpg_fatal) goto done;
      call mrpg_error_$init;
      call mrpg_parse_ (ifp, ife, ai.areap, code);
      if mrpg_error_$stat ()
      then goto done;
      call mrpg_generate_ (ai.areap, ename, ifp, code);
      if (code ^= 0)
      then goto done;
      if ^hold_sw then
	 call release_area_ (ai.areap);
      ai.areap = null ();
      call hcs_$make_ptr (null (), "pl1", "pl1", pl1p, code);
      call cu_$arg_list_ptr (arglp);
      call cu_$gen_call (pl1p, arglp);
done:
      if ^hold_sw & (ai.areap ^= null ()) then
	 call release_area_ (ai.areap);
      return;

dcl 1 ai		like area_info;
%include area_info;
dcl arg		char (argl) based (argp); /* current argument	       */
dcl argl		fixed bin (24);	/* length of current argument	       */
dcl arglp		ptr;
dcl argp		ptr;		/* pointer to current argument       */
dcl bc		fixed bin (24);
dcl chars		char (63) int static
  init ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789");
dcl cleanup	condition;
dcl code		fixed bin (35);
dcl com_err_	entry options (variable);
dcl command_name	char (4) int static init ("mrpg");
dcl cu_$arg_list_ptr entry (ptr);
dcl cu_$arg_ptr	entry (fixed bin (24), ptr, fixed bin (24), fixed bin (35));
dcl cu_$gen_call	entry (ptr, ptr);
dcl define_area_	entry (ptr, fixed bin (35));
dcl dname		char (168);	/* directory portion of input name   */
dcl ename		char (32);	/* entry portion of input name       */
dcl error_table_$zero_length_seg fixed bin (35) ext static;
dcl error_table_$badopt fixed bin (35) ext static;
dcl error_table_$noarg fixed bin (35) ext static;
dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl get_wdir_	entry returns (char (168));
dcl hcs_$initiate_count entry options (variable);
dcl hcs_$make_ptr	entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl hcs_$make_seg	entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl i		fixed bin (24);
dcl ife		fixed bin (24);	/* length of input segment	       */
dcl ifp		ptr;		/* pointer to input sgment	       */
dcl ioa_		entry options (variable);
dcl mrpg_error_$init entry;
dcl mrpg_error_$stat entry returns (bit (1));
dcl mrpg_fatal	condition;
dcl mrpg_generate_	entry (ptr, char (32), ptr, fixed bin (35));
dcl mrpg_parse_	entry (ptr, fixed bin (24), ptr, fixed bin (35));
dcl pl1p		ptr;
dcl release_area_	entry (ptr);
dcl sys_info$max_seg_size fixed bin (24) ext static;

dcl (addr, before, codeptr, divide, index, null, substr, verify) builtin;

dcl hold_sw	bit (1) int static init ("0"b);
holdn: entry; hold_sw = "1"b; return;
holdf: entry; hold_sw = "0"b; return;
   end;
   



		    mrpg_date_.pl1                  02/14/84  0905.4r w 02/14/84  0844.2       22599


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

mrpg_date_: proc (DAY, HHMMSS, MMDDYY, MONTH, YYDDD);

dcl DAY		char (12) var,
    HHMMSS	char (8),
    MMDDYY	char (8),
    MONTH		char (12) var,
    YYDDD		char (5);

dcl clock_	entry returns (fixed bin (71));
dcl month		fixed bin;
dcl day		fixed bin;
dcl year		fixed bin;
dcl hour		fixed bin;
dcl minute	fixed bin;
dcl second	fixed bin;
dcl dow		fixed bin;
dcl dayr		fixed bin;

dcl datebin_$dayr_clk entry (fixed bin (71), fixed bin);
dcl datebin_	entry (fixed bin (71), fixed bin, fixed bin, fixed bin,
		fixed bin, fixed bin, fixed bin, fixed bin, fixed bin,
		fixed bin);
dcl clock		fixed bin (71);

      clock = clock_ ();
      call datebin_ (clock, 0,
         month, day, year,
         hour, minute, second,
         dow, 0);
      call datebin_$dayr_clk (clock, dayr);

      DAY = DAYn (dow);
dcl DAYn		(7) char (12) var int static init (
		"Monday",
		"Tuesday",
		"Wednesday",
		"Thursday",
		"Friday",
		"Saturday",
		"Sunday");

dcl 1 tri,
      2 p1	pic "99",
      2 f1	char (1),
      2 p2	pic "99",
      2 f2	char (1),
      2 p3	pic "99";
      tri.f1, tri.f2 = ":";
      tri.p1 = hour;
      tri.p2 = minute;
      tri.p3 = second;
      HHMMSS = string (tri);

      tri.f1, tri.f2 = "/";
      tri.p1 = month;
      tri.p2 = day;
      tri.p3 = year - 1900;
      MMDDYY = string (tri);

      MONTH = MONTHn (month);
dcl MONTHn	(12) char (12) var int static init (
		"January",
		"February",
		"March",
		"April",
		"May",
		"June",
		"July",
		"August",
		"September",
		"October",
		"November",
		"December");

dcl 1 dbl,
      2 p1	pic "99",
      2 p2	pic "999";

      dbl.p1 = year - 1900;
      dbl.p2 = dayr;
      YYDDD = string (dbl);


   end;
 



		    mrpg_dump_.pl1                  02/14/84  0905.4r w 02/14/84  0844.1      132768


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

/**** a utility for generating debug output for mrpg.		       */

mrpg_dump_:
dump: proc (exptr, indent);		/* dump an element		       */
      next_sw, all_sw = "0"b;
      goto start;

all: entry (exptr, indent);		/* dump the whole thing	       */
      next_sw, all_sw = "1"b;
      goto start;

list: entry (exptr, indent);		/* dump a list of elements	       */
      next_sw = "1"b;
      all_sw = "0"b;
      goto start;


dcl (exptr, xptr)	ptr unal;
dcl jptr		ptr;
dcl indent	fixed bin;

dcl mssg		char (32);
dcl check_pointer_$packed entry (ptr, char (32));
				/* hcs_$get_uid can probably be used */
				/*  in place of check_pointer_       */

start:
      xptr = exptr;
      text = "xptr";
loop:
      call check_pointer_$packed (addr (xptr), mssg);
      if (mssg ^= "")
      then do;
         call ioa_ ("^a is ^p  ""^12.3b""o (^a)", text, xptr, unspec (xptr), mssg);
         return;
      end;
      text = "next";

      if (xptr -> symtab.type = "ID")
         | (xptr -> symtab.type = "NU")
         | (xptr -> symtab.type = "ST")
      then do;
         call stmt_hdr ("symtab", xptr, "0"b);
         call ioa_ ("  ^3i ""^a""", xptr -> symtab.leng, xptr -> symtab.data);
         call ioa_ ("	^vxuse ^p   ^p", indent,
	  xptr -> symtab.use.b, xptr -> symtab.use.e);
         if next_sw & ^all_sw & (xptr -> symtab.type = "ID") then do;
	  indent = indent + 5;
	  do jptr = xptr -> symtab.use.b
	     repeat (jptr -> datum.usage)
	     while (jptr ^= null ());
	     call stmt_hdr ("----", (jptr), "0"b);
	     call ioa_ ("  sym  ^p", jptr -> datum.sym);
	     if (jptr -> datum.type ^= "SY")
	     then do;
	        call stmt_hdr ("    ----", jptr -> datum.sym, "0"b);
	        call ioa_ ("  sym  ^p", jptr -> datum.sym -> datum.sym);
	     end;
	  end;
	  indent = indent - 5;
         end;
         return;
      end;
      if (xptr -> datum.type = "DC")
         | (xptr -> datum.type = "IN")
      then do;
         call stmt_hdr ("datum", xptr, "0"b);
         call ioa_ ("  sym  ^p", xptr -> datum.sym);
         if all_sw & (xptr -> datum.sym ^= null ())
         then call mrpg_dump_$all ((xptr -> datum.sym), indent + 5);
         call ioa_ ("	^vxkind ^a ^i", indent,
	  kind_char (min (xptr -> datum.kind, hbound (kind_char, 1))),
	  xptr -> datum.kind);
         call ioa_ ("	^vxleng ^i", indent, xptr -> datum.leng);
         call ioa_ ("	^vxpos ^i", indent, xptr -> datum.pos);
         call ioa_ ("	^vxcheck ^p	^p", indent,
	  xptr -> datum.check.b, xptr -> datum.check.e);
         if all_sw & (xptr -> datum.check.b ^= null ())
         then call mrpg_dump_$all ((xptr -> datum.check.b), indent + 5);
         call ioa_ ("	^vxdatal ^p	^p", indent,
	  xptr -> datum.datal.b, xptr -> datum.datal.e);
         if all_sw & (xptr -> datum.datal.b ^= null ())
         then call mrpg_dump_$all ((xptr -> datum.datal.b), indent + 5);
         if next_sw
         then do;
	  xptr = xptr -> datum.next;
	  if (xptr ^= null ())
	  then goto loop;
         end;
         return;
      end;

      if (xptr -> symref.type = "SY")
      then do;
         call stmt_hdr ("symref", xptr, "0"b);
         call ioa_ ("  sym  ^p", xptr -> symref.sym);
         call ioa_ ("	^vxkind ^a ^i", indent,
	  kind_char (xptr -> symref.kind), xptr -> symref.kind);
         if all_sw & (xptr -> symref.sym ^= null ())
         then call mrpg_dump_$all ((xptr -> symref.sym), indent + 5);
         call ioa_ ("	^vxusage ^p", indent, xptr -> symref.usage);
         if next_sw
         then do;
	  xptr = xptr -> symref.next;
	  if (xptr ^= null ())
	  then goto loop;
         end;
         return;
      end;

      if (xptr -> opn.type = "OP")
      then do;
         call stmt_hdr ("opn", xptr, "1"b);
         call ioa_ ("	^vxop ^a ^i", indent,
	  op_char (min (xptr -> opn.op, hbound (op_char, 1))),
	  xptr -> opn.op);
         call ioa_ ("	^vxkind ^a ^i", indent,
	  kind_char (xptr -> opn.kind), xptr -> opn.kind);
         call ioa_ ("	^vxop1 ^p", indent, xptr -> opn.op1);
         if all_sw & (xptr -> opn.op1 ^= null ())
         then call mrpg_dump_$all ((xptr -> opn.op1), indent + 5);
         call ioa_ ("	^vxop2 ^p", indent, xptr -> opn.op2);
         if all_sw & (xptr -> opn.op2 ^= null ())
         then call mrpg_dump_$all ((xptr -> opn.op2), indent + 5);
         call ioa_ ("	^vxop3 ^p", indent, xptr -> opn.op3);
         if all_sw & (xptr -> opn.op3 ^= null ())
         then call mrpg_dump_$all ((xptr -> opn.op3), indent + 5);
         if next_sw
         then do;
	  xptr = xptr -> opn.next;
	  if (xptr ^= null ())
	  then goto loop;
         end;
         return;
      end;

      if (xptr -> report.type = "RP")
      then do;
         call stmt_hdr ("report", xptr, "0"b);
         call ioa_ ("  sym  ^p", xptr -> report.sym);
         if all_sw & (xptr -> report.sym ^= null ())
         then call mrpg_dump_$all ((xptr -> report.sym), indent + 5);
         call ioa_ ("	^vxpw ^i", indent, xptr -> report.pw);
         call ioa_ ("	^vxpl ^i", indent, xptr -> report.pl);
         call ioa_ ("	^vxminl ^i", indent, xptr -> report.minl);
         call ioa_ ("	^vxmaxl ^i", indent, xptr -> report.maxl);
         call ioa_ ("	^vxonlist	^p   ^p", indent,
	  xptr -> report.onlist.b, xptr -> report.onlist.e);
         if all_sw & (xptr -> report.onlist.b ^= null ())
         then call mrpg_dump_$all ((xptr -> report.onlist.b), indent + 5);
         call ioa_ ("	^vxbrlist	^p   ^p", indent,
	  xptr -> report.brlist.b, xptr -> report.brlist.e);
         if all_sw & (xptr -> report.brlist.b ^= null ())
         then call mrpg_dump_$all ((xptr -> report.brlist.b), indent + 5);
         call ioa_ ("	^vxpart	^p   ^p", indent,
	  xptr -> report.part.b, xptr -> report.part.e);
         if xptr -> tree.mmddyy then call ioa_ ("    ^vxmmddyy", indent);
         if xptr -> tree.yyddd then call ioa_ ("    ^vxyyddd", indent);
         if xptr -> tree.month then call ioa_ ("    ^vxmonth", indent);
         if xptr -> tree.day then call ioa_ ("    ^vxday", indent);
         if xptr -> tree.hhmmss then call ioa_ ("    ^vxhhmmss", indent);
         if all_sw & (xptr -> report.part.b ^= null ())
         then call mrpg_dump_$all ((xptr -> report.part.b), indent + 5);
         if next_sw
         then do;
	  xptr = xptr -> report.next;
	  if (xptr ^= null ())
	  then goto loop;
         end;
         return;
      end;

      if (xptr -> part.type = "RH")
         | (xptr -> part.type = "PH")
         | (xptr -> part.type = "DH")
         | (xptr -> part.type = "DT")
         | (xptr -> part.type = "DF")
         | (xptr -> part.type = "PF")
         | (xptr -> part.type = "RF")
      then do;
         call stmt_hdr ("part", xptr, "0"b);
         call ioa_ ("  sym  ^p", xptr -> part.sym);
         if all_sw & (xptr -> part.sym ^= null ())
         then call mrpg_dump_$all ((xptr -> part.sym), indent + 5);
         call ioa_ ("	^vxmaxl  ^i", indent, xptr -> part.maxl);
         call ioa_ ("	^vxctl	^p", indent, xptr -> part.ctl);
         if all_sw & (xptr -> part.ctl ^= null ())
         then call mrpg_dump_$all ((xptr -> part.ctl), indent + 5);
         call ioa_ ("	^vxlines	^p   ^p", indent,
	  xptr -> part.lines.b, xptr -> part.lines.e);
         if all_sw & (xptr -> part.lines.b ^= null ())
         then call mrpg_dump_$all ((xptr -> part.lines.b), indent + 5);
         if next_sw
         then do;
	  xptr = xptr -> part.next;
	  if (xptr ^= null ())
	  then goto loop;
         end;
         return;
      end;

      if (xptr -> lines.type = "LN")
      then do;
         call stmt_hdr ("lines", xptr, "0"b);
         call ioa_ ("  number ^i", xptr -> lines.number);
         call ioa_ ("	^vxctl ^p", indent, xptr -> lines.ctl);
         if all_sw & (xptr -> lines.ctl ^= null ())
         then call mrpg_dump_$all ((xptr -> lines.ctl), indent + 5);
         call ioa_ ("	^vxfield	^p   ^p", indent,
	  xptr -> lines.field.b, xptr -> lines.field.e);
         if all_sw & (xptr -> lines.field.b ^= null ())
         then call mrpg_dump_$all ((xptr -> lines.field.b), indent + 5);
         if next_sw
         then do;
	  xptr = xptr -> lines.next;
	  if (xptr ^= null ())
	  then goto loop;
         end;
         return;
      end;

      if (xptr -> field.type = "FD")
      then do;
         call stmt_hdr ("field", xptr, "1"b);
         call ioa_ ("	^vxvalue	^p   ^p", indent,
	  xptr -> field.value.b, xptr -> field.value.e);
         if all_sw & (xptr -> field.value.b ^= null ())
         then call mrpg_dump_$all ((xptr -> field.value.b), indent + 5);
         call ioa_ ("	^vxlet	^p   ^p", indent,
	  xptr -> field.let.b, xptr -> field.let.e);
         if all_sw & (xptr -> field.let.b ^= null ())
         then call mrpg_dump_$all ((xptr -> field.let.b), indent + 5);
         call ioa_ ("	^vxkind ^a ^i", indent,
	  kind_char (min (xptr -> field.kind, hbound (kind_char, 1))),
	  xptr -> field.kind);
         call ioa_ ("	^vxalign ^a ^i", indent,
	  kind_char (min (xptr -> field.align, hbound (kind_char, 1))),
	  xptr -> field.align);
         call ioa_ ("	^vxalch ""^1a""", indent, xptr -> field.alch);
         call ioa_ ("	^vxbsp ""^1.1b""", indent, xptr -> field.bsp);
         call ioa_ ("	^vxfill ^i-^i", indent, xptr -> field.fill);
         call ioa_ ("	^vxcol ^i", indent, xptr -> field.col);
         call ioa_ ("	^vxleng ^i", indent, xptr -> field.leng);
         call ioa_ ("	^vxdata ^p", indent, xptr -> field.data);
         if all_sw & (xptr -> field.data ^= null ())
         then call mrpg_dump_$all ((xptr -> field.data), indent + 5);
         if next_sw
         then do;
	  xptr = xptr -> field.next;
	  if (xptr ^= null ())
	  then goto loop;
         end;
         return;
      end;

      if (xptr -> value.type = "VL")
         | (xptr -> value.type = "FL")
         | (xptr -> value.type = "SW")
         | (xptr -> value.type = "AT")
      then do;
         call stmt_hdr ("value", xptr, "0"b);
         call ioa_ ("  sym  ^p", xptr -> value.sym);
         if all_sw & (xptr -> value.sym ^= null ())
         then call mrpg_dump_$all ((xptr -> value.sym), indent + 5);
         call ioa_ ("	^vxnumb ^i", indent, xptr