compdv.rd                       03/17/86  1520.3rew 03/17/86  1430.1     1133901



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

/*++
INCLUDE ERROR						        \
BEGIN
   /   / PUSH (BEGIN)
	  [call push ("BEGIN")]				       /\

\" if "dcl" or "MediaChars" appear first, take them.
   / dcl :
       /	  [if db_start = "dcl" then db_sw, dt_sw = "1"b;
	   if db_sw
	   then call ioa_ ("^[^/^]===Declare", dt_sw)]
         LEX(2)					            / dcl \
   / MediaChars :
       / LEX(2) pop
	  [mediachars_p = area_free_p]
         PUSH (done_MediaChars)
	  [call push ("done_MediaChars")]		     / MediaChars \
				\" any of these need a MediaChars table
				\" (which may be empty), so define
				\" a dummy table.
   / Media /					  / no_MediaChars \
   / View /					  / no_MediaChars \
   / Def /					  / no_MediaChars \
   / Font /					  / no_MediaChars \
   / Size /					  / no_MediaChars \
   / Device /					  / no_MediaChars \
   / <no-token> /					  / no_MediaChars \
				\" anything else here must be a 
				\" global device value. they dont need
				\" MediaChars.
   /   /						  / global_device \

no_MediaChars
   /   / pop
	  [call ERROR (missing_MediaChars)]
	  [mediachars_p = area_free_p;
	   mediachars.count = 1;	\" supply a dummy one
	   mediachars.name (1) = "<mediachar>";
	   mediachars.out_r (1) = "0"b]			       /\
				\" finish the MediaChars table
done_MediaChars
  / /	        [area_free_p = addr_inc (mediachars_p, size (mediachars))] /\

Media
     /	/	[if (db_start = "media") then db_sw, dt_sw = "1"b]       /\
     /	/	[media_p = area_free_p;
		 media.count = 0]				       /\
       / View	/	/ no_Media \
       / Def	/	/ no_Media \
       / Font	/	/ no_Media \
       / Size	/	/ no_Media \
       / Device	/	/ no_Media \
       / <no-token>	/	/ no_Media \
Media_
     /	/PUSH (Media_)[call push ("Media_")]			       /\
     / Media :
	/LEX(2)					        / Mwidths \
     / View	/pop				     / done_Media \
       / Def	/pop	/ done_Media \
       / Font	/pop	/ done_Media \
       / Size	/pop	/ done_Media \
       / Device	/pop	/ done_Media \
     /	/					  / global_device \
no_Media
     /	/[call ERROR (missing_Media)]
		[media.count = 1;	\" supply a dummy one
		 media.name (1) = "<media>";
		 media.rel_units (1) = 0;
		 media.width (1, 1) = 0]			       /\
done_Media
     /	/	[area_free_p = addr_inc (media_p, size (media))]	       /\

start_View
     /	/	[if (db_start = "view") then db_sw, dt_sw = "1"b]	       /\
     /	/	[view_p = area_free_p;
		 view.count = 0]				       /\
       / Def	/	/ no_View \
       / Font	/	/ no_View \
       / Size	/	/ no_View \
       / Device	/	/ no_View \
       / <no-token>	/	/ no_View \
View_
     /	/PUSH (View_)[call push ("View_")]			       /\
     / View :
	/LEX(2)	 				       / Viewrest \
       / Def	/pop	/ done_View \
       / Font	/pop	/ done_View \
       / Size	/pop	/ done_View \
       / Device	/pop	/ done_View \
     /	/					  / global_device \
no_View
     /	/[call ERROR (missing_View)]
		[view.count = 1;	\" supply a dummy one
		 view.name (1) = "<view>";
		 view.media (1) = 1]			       /\
done_View
     /	/	[area_free_p = addr_inc (view_p, size (view))]           /\

start_Def
     /	/	[if (db_start = "def") then db_sw, dt_sw = "1"b]	       /\
     /	/	[Def_p = area_free_p;
		 Def.count = 0]				       /\
       / Font	/	/ no_Def \
       / Size	/	/ no_Def \
       / Device	/	/ no_Def \
       / <no-token> /	/ no_Def \
Def_
     /	/PUSH (Def_)[call push ("Def_")]			       /\
     / Def :
	/LEX(2)					        / Defrest \
     / Font	/pop				       / done_Def \
       / Size	/pop       / done_Def \
       / Device	/pop       / done_Def \
     /	/					  / global_device \
no_Def
     /	/	[Def.count = 1;
		 Def.name (1) = "<Def>";
		 Def.pt (1) = null()]			       /\
done_Def
     /	/	[area_free_p = addr_inc (Def_p, size (Def))]	       /\

start_Font
     /	/	[if (db_start = "font") then db_sw, dt_sw = "1"b]	       /\
       / Size	/	/ no_Font \
       / Device	/	/ no_Font \
       / <no-token>	/	/ no_Font \
Font_
     /	/PUSH (Font_)[call push ("Font_")]			       /\
     / Font :
	/LEX(2)					       / Fontrest \
     / Size	/pop				      / done_Font \
       / Device	/pop	/ done_Font \
     /	/					  / global_device \
no_Font
     /	/[call ERROR (missing_Font)]			     / start_Size \
done_Font
     /	/	[area_free_p = addr_inc (oput_p, size (oput))]	       /\

start_Size
     /	/	[if (db_start = "size") then db_sw, dt_sw = "1"b]	       /\
     /	/	[size_list_p = area_free_p;
		 size_list.count = 0;
		 area_free_p, sizel_p = addr (size_list.start)]	       /\
       / Device	/	/ no_Size \
       / <no-token>	/	/ no_Size \
Size
     /	/PUSH (Size)[call push ("Size")]			       /\
     / Size :
	/LEX(2)					       / Sizerest \
     / Device
	/pop					      / done_Size \
     /	/					  / global_device \
no_Size
     /	/[call ERROR (missing_Size)]
		[size_list.count = 1;	\" supply a dummy one
		 size_list.name (1) = "<size>";
		 size_list.pt (1) = addr(size_list.start)]       / Device \
done_Size
     /	/	[if Sizes = 0
		 then if size_list.count > 0
		 then Sizes = 1;

		 tp = Ptoken;
		 do fnt_p = fntl_p (1) repeat (fnt.next)
		    while (fnt_p ^= null ());
		    Ptoken, Pthis_token = fnt.node;
		    if (font.min_wsp = -1)
		    then call ERROR (no_wordspace_val);
		 end;
		 Ptoken, Pthis_token = tp]		                 /\

Device
     /	/	[if (db_start = "dev") then db_sw, dt_sw = "1"b]	       /\
     /	/ PUSH (Device)[call push ("Device")]			       /\
     / Device :
	/	[Device_Pthis_token = Pthis_token]
	  LEX(2)
		[if db_sw then
		 call ioa_ ("===Device ^a", token_value)]    / Devicerest \
     / <no-token>
	/	[if const.devptr = null ()
		 then call ERROR (no_Device)]		         / RETURN \
     /	/  					  / global_device \

stack_pop
     /	/[if tr_sw
	  then call ioa_(" STACK_POP(^a,^i)",Stack(STACK_DEPTH),STACK_DEPTH)]
						     / STACK_POP \
     /	/[;
push: proc (name);
dcl name		char (*);

      Stack (STACK_DEPTH) = name;
      if tr_sw then call ioa_ (" PUSH(^a,^i)", name,STACK_DEPTH);
   end push;

pop: proc;
      if tr_sw then call ioa_ (" POP(^a,^i)", Stack (STACK_DEPTH),STACK_DEPTH);
      STACK_DEPTH = max (STACK_DEPTH - 1, 0);
   end pop;	]					       /\

\" define local named symbols for various strings
dcl
   / <ident> ,     
      /	  [dclname = token_value]
         LEX(2)
         PUSH (dcl_1)[call push ("dcl_1")]		       / output_0 \
dcl_1
     / ; /        [dcl_p = area_free_p;
	         dcl_.leng = length (part_str (1));
	         dcl_.dcl_v = part_str (1);
	         dcl_.dcl_name = dclname;
	         area_free_p = addr (dcl_.dummy);
	         if dt_sw
	         then call ioa_ ("^p^-dcl ^8a ""^a""", dcl_p, dcl_name,
	           dcl_v);
	         call link (dcl_l_p, dcl_p)]
	 LEX(1)					      / stack_pop \
     /	/[call ERROR (syntax_dcl)] NEXT_STMT		      / stack_pop \

MediaChars
     / <ident2>
	/	[media1, media2=token_value]		        / Media_3 \
     / <input>
	/	[media1, media2="[" || Input || "]"]
	 LEX(1)					        / Media_1 \
Media_err
     /	/[call ERROR (syntax_MediaChars)] 			       /\
Media_skip	\" scan forward looking for a "," or ";"
     / ,	/LEX(1)					     / MediaChars \
     / ;	/					        / Media_9 \
     / <any-token>
	/LEX(1)					     / Media_skip \

Media_1
     / :	/LEX(1)					        / Media_2 \
     /	/LEX(-1)					        / Media_3 \
Media_2
     / <input>
	/	[media2="[" || Input || "]"]		        / Media_3 \
     /	/					      / Media_err \
Media_3
     /	/	[held_Pthis_token = Pthis_token] \" for error msgs
	 LEX(1) PUSH (Media_4)[call push ("Media_4")]	       / output_0 \
Media_4
     /	/	[hold_Pthis_token = Pthis_token;
		 Ptoken, Pthis_token = held_Pthis_token;
					 \"in case any ERRORS
		 the_string = part_str (1);

		 if (media1 ^= media2)
		 then do;
		    if (substr (media1, 1, 1) ^= "[")
		    | (substr (media2, 1, 1) ^= "[")
		    then call ERROR (inv_MediaChar_range);
		    else if (media1 > media2)
		    then call ERROR (inv_Multics_char_range);
		 end;

		 do while (media1 <= media2);
		    do i = 1 to mediachars.count;
		       if (mediachars.name (i) = media1)
		       then do;
			call ERROR (dup_MediaChars);
			i = mediachars.count;
		       end;
		    end;

		    i = index (the_string, o777);
		    if (i > 0)
		    then do;
		       if (substr (media1, 1, 1) ^= "[")
		       then call ERROR (inv_MediaChar_SELF_ref);
		       substr (the_string, i, 1) = substr (media1, 2, 1);
		    end;
		    mediachars.count = mediachars.count + 1;
		    mediachars.name (mediachars.count) = media1;
		    mediachars.out_r (mediachars.count)
		       = rel (find_str (1));
		    if (i > 0)
		    then substr (the_string, i, 1) = o777;
		    substr (media1, 2, 1)
		       = byte (rank (substr (media1, 2, 1)) + 1);
		   	\" media has form "[x]" when in a range
		 end;
		 Ptoken, Pthis_token = hold_Pthis_token]	       /\
     / ,	/LEX(1)					     / MediaChars \
Media_9
     / ;	/ LEX(1)					      / stack_pop \
     /	/					      / Media_err \

Mwidths
     /	/	[mediact = 0;
		 mediabase = media.count]			       /\
Mwidth_1
     / <valid_Media_name>
	/	[mediact = mediact + 1;
		 media.count = media.count + 1;
		 media.name (media.count) = token_value;
		 media.rel_units (media.count) = Strokes;
		 media.width (media.count, *) = nulwidth]
	 LEX(1)					       / Mwidth_2 \
Mwidth_err
     /	/[call ERROR (syntax_Media_sec)] NEXT_STMT	       / Mwidth_3 \

Mwidth_2
     / ,	/LEX(1)					       / Mwidth_1 \
     / ;	/LEX(1)					       / Mwidth_3 \
     /	/					     / Mwidth_err \
Mwidth_3
     / strokes :
	/LEX(2)	[media_i = 1]			      / Mwidth_s1 \
     /	/					       / Mwidth_4 \
Mwidth_s1
     / <num>
	/	[if (media_i > mediact)
		 then call ERROR (too_many_stroke_values);
		 media.rel_units (media_i+mediabase) = token.Nvalue]
	 LEX(1)						       /\
     / ,	/LEX(1)	[media_i = media_i + 1]		      / Mwidth_s1 \
     / ;	/LEX(1)					       / Mwidth_3 \
     /	/					     / Mwidth_err \
Mwidth_4
     / <charname>
	/	[charid=token.Nvalue;
		 media1 = media2;		\" charname sets media2
		 media_i = 1;
		 mediawidth = nulwidth]
						       / Mwidth_A \
     /	/					      / stack_pop \
Mwidth_A
     / <input_>
	/LEX(1)					       / Mwidth_B \
     /	/LEX(1)					       / Mwidth_6 \
Mwidth_B
     / :	/LEX(1)					       / Mwidth_C \
     /	/					       / Mwidth_6 \
Mwidth_C
     / <charname>
	/					       / Mwidth_D \
     /	/					     / Mwidth_err \
Mwidth_D
     / <input_>
	/LEX(1)					       / Mwidth_6 \
     /	/					     / Mwidth_err \
Mwidth_6
     / <num>
	/					       / Mwidth_7 \
     / <negnum>
	/					       / Mwidth_7 \
     / =	/					       / Mwidth_8 \
     /	/					       / Mwidth_9 \
Mwidth_7
     /	/	[mediawidth = token.Nvalue]			       /\
Mwidth_8
     /	/LEX(1)	[media_ = media1;
		 charid_ = charid;
		 if (mediawidth = nulwidth)
		 then call ERROR (no_prior_width);
		 else if (media_ > media2)
		 then call ERROR (inv_Media_range);
		 else do while (media_ <= media2);
		    if (media_i > mediact)
		    then do;
		       call ERROR (too_many_widths);
		       media_ = "~" || rtrim (media2);
		    end;
		    else do;
		       media.width (media_i + mediabase, charid_)
			= mediawidth;
		       if (media_ < media2)
		       then do;
			substr (media_, 2, 1) =
			   byte (rank (substr (media_, 2, 1))+1);
			charid_ = 0;
			do i = 1 to mediachars.count
			   while (charid_ = 0);
			   if (mediachars.name (i) = media_)
			   then charid_ = i;
			end;
			if (charid_ = 0)
			then do;
			   call ERROR (inv_Media_range);
			   media_ = "~" || rtrim (media2);
			end;
		       end;
		       else media_ = "~" || rtrim (media2);   \" force it HI
		    end;
		 end]					       /\
Mwidth_9
     / ;	/LEX(1)					       / Mwidth_3 \
     / ,	/	[media_i = media_i + 1]
	 LEX(1)					       / Mwidth_6 \
     /	/					     / Mwidth_err \

Viewrest
     / <ident>
	/	[viewname=token_value]
	 LEX(1)					         / View_1 \
View_err
     /	/[call ERROR (syntax_View)] NEXT_STMT		      / stack_pop \

View_1
     / <medianame>
	/	[view.count = view.count + 1;
		 view.name (view.count) = viewname;
		 view.media (view.count) = token.Nvalue]
	 LEX(1)					         / View_2 \
     /	/					       / View_err \
View_2
     / ,	/LEX(1)					       / Viewrest \
     / ;	/LEX(1)					      / stack_pop \
     /	/					       / View_err \

Defrest
     / <ident> ;
	/	[Def.count = Def.count + 1;
		 Def.name (Def.count) = token_value]
	 LEX(2)	[Def.pt (Def.count) = Pthis_token;
		 vals_ct = 0]			          / Def_1 \
\" the token pointer is saved here so that at ref time parsing can be
\" temporarily diverted back here.

     /	/[call ERROR (no_name_Def)] NEXT_STMT			       /\


\" This keeps parsing until either a DEF, FONT, or INVALID STATEMENT occurs.
\" Nothing is done with the results of the parse other than invalid statements
\" are deleted so they will not cause further errors.
Def_1
     / Def /					      / stack_pop \
     / Font /					      / stack_pop \
       / Size	/	/ stack_pop \
       / Device	/	/ stack_pop \
       / <no-token>	/	/ stack_pop \
     /	/	[this_view = -1]
	 PUSH (Def_2)[call push ("Def_2")]		      / font_char \
Def_2
     / ;	/LEX(1)						/ Def_1 \
     /	/DELETE_STMT				          / Def_1 \
		\" font_char has already said why it is bad.
		\" Deleting statement is so error won't happen again
		\" during reparse at ref time.

font_char
     /	/	[vals_ct = 0]				       /\
fch_1
     / <all_input>
	/LEX(1)	[vals_ct = vals_ct + 1;
		 vals (vals_ct) = rank (Input)]		/ fch_2 \
     / art
	/LEX(1)						/ fch_0 \
     /	/[call ERROR (inv_Mul_char_spec)]		 	/ fch_e \
fch_0
     / <part>
	/LEX(1)	[vals_ct = vals_ct + 1;
		 vals (vals_ct) = rank (Input)]		/ fch_5 \
     /	/[call ERROR (inv_artwork_spec)]		 	/ fch_e \
fch_2
     / :	/LEX(1)						/ fch_3 \
     /	/						/ fch_5 \
fch_3
     / <all_input>
	/LEX(1)	[i = rank (Input);
		if (vals (vals_ct) > i)
		then do;
		   call ERROR (inv_Multics_char_range);
		   call LEX (-2);
	\" ******* back up to the ":" to force error exit at fch_4
		end;
		else do;
		   j = vals (vals_ct);
		   do while (j < i);
		      j = j + 1;
		      vals_ct = vals_ct + 1;
		      vals (vals_ct) = j;
		   end;
		end]	 				/ fch_4 \
     /	/[call ERROR (syntax_after_colon)]			/ fch_e \
fch_4
     / :	\" ******* this catches error forced above
        	/						/ fch_e \
fch_5
     / ,	/LEX(1)						/ fch_1 \
     / <is_viewname>
	/	[if (this_view ^= -1)
		then this_view = token.Nvalue]
	 LEX(1)						       /\

	\" MC_STRING is an alternate entry point to this routine.
mc_string
     /	/	[mediawidth, self_ct = 0;
		 the_string = ""]				       /\
     / <quoted-string> /					/ fch_6 \
     / (	/LEX(1)						/ fch_A \
     / <num> (	/					/ fch_6 \
     / SELF	/					/ fch_6 \
     / <charname>	/					/ fch_6 \
     /	/[call ERROR (not_charname)]				       /\
fch_6
     /	/	[part_nest = 0]
	 PUSH (fch_7)[call push ("fch_7")]			/ fch_l \
fch_7
     /	/	[the_string = part_str (1);
		testwidth = nulwidth;
		mediawidth = part_width (1)]		       /\
     / =	/LEX(1)						/ fch_9 \
fch_8
     / ;	/					      / stack_pop \
		\" normal return is with ";" token current
     / ,	/					      / stack_pop \
		\" but don't complain about a "," either.
     /	/[call ERROR (not_charname)] LEX (1)		          / fch_6 \
fch_9
     / <negnum>
	/	   [testwidth = token.Nvalue]
	 LEX(1)						/ fch_8 \
     / <num>
	/	   [testwidth = token.Nvalue]
	 LEX(1)						/ fch_8 \
     /	/[call ERROR (no_test_width)]				/ fch_8 \

fch_A
     /	/	[part_nest = 0]
	 PUSH (fch_B)[call push ("fch_B")]			/ fch_l \
fch_B
     / ) =
	/LEX (2)	[the_string = part_str (1);
		testwidth = nulwidth]			/ fch_C \
     /	/[call ERROR (paren_equal_expected)]			/ fch_8 \
fch_C
     / <negnum>
	/	   [mediawidth = token.Nvalue]
	 LEX(1)						/ fch_8 \
     / <num>
	/	   [mediawidth = token.Nvalue]
	 LEX(1)						/ fch_8 \
     /	/[call ERROR (missing_width)]				/ fch_8 \

fch_e
     / ;	/LEX(-1)					      / stack_pop \
		\" error return can't be with token ";" current
     /	/					      / stack_pop \
fch_l
     /	/	[part_nest = part_nest + 1;
		 part_str (part_nest) = "";
		 part_width (part_nest) = 0]			       /\
fch_M
     / <num> (
	/	[part_repl (part_nest) = token.Nvalue]
	 LEX(2) PUSH (fch_el)[call push ("fch_el")]		/ fch_l \
     / SELF
	/LEX(1)	[part_str (part_nest) = part_str (part_nest) || o777]
							/ fch_M \
     / <charname>
	/PUSH(fch_M)[call push("fch_M")]			/ fch_K \
     / <quoted-string>
	/LEX(1)	[list_ndx = 1]				/ fch_L \
     /	/	[part_nest = part_nest - 1]		      / stack_pop \
fch_L
     /	/LEX(-1)						       /\
     / <charlist>	\" peel them off one char at a time
	/PUSH(fch_L)[call push("fch_L")]			/ fch_K \
     /	/LEX(1)						/ fch_M \
fch_K
     /	/	[str_p = ptr (next_str_p, mediachars.out_r (token.Nvalue));
		 part_str (part_nest) = part_str (part_nest) || bstr.str;
		 if this_view > 0
		 then do;
		    if (media.rel_units (view.media (this_view))
		       ^= font.rel_units)
		    then call ERROR (bad_stroke_value);
		    mw = media.width (view.media (this_view),
		       token.Nvalue);
		    if mw = nulwidth
		    then call ERROR_ (no_width_specified,
		       view.name (this_view),
		       show_name (mediachars.name (token.Nvalue)));
		    part_width (part_nest) = part_width (part_nest) + mw;
		 end]
	 LEX(1)					      / stack_pop \

fch_el
     / )	/LEX(1)	[part_str (part_nest) = part_str (part_nest)
		    || copy (part_str(part_nest+1), part_repl (part_nest));
		 part_width (part_nest) = part_width (part_nest)
		    + part_width (part_nest+1) * part_repl (part_nest)]
							/ fch_M \
     /	/[call ERROR (unbal_parens)]		 	      / stack_pop \

Fontrest
     / <ident>
	/	[fnt_p = find_font ("1"b);
		 if fnt.pt ^= null ()
		 then call ERROR (dup_fontname);
		 font_ptr, fnt.pt = area_free_p;
		 area_free_p = addr_inc (area_free_p, size (font));
		 uni_p = area_free_p;
		 area_free_p = addr_inc (area_free_p, size (uni));
		 call link (unil_p, uni_p);
		 uni.seqno, uni.refno, uni_ct = uni_ct + 1;
		 units_ptr, uni.ref_p = area_free_p;
		 area_free_p = addr_inc (area_free_p, size (units));
		 opu_p = area_free_p;
		 area_free_p = addr_inc (area_free_p, size (opu));
		 call link (opul_p, opu_p);
		 opu.refno, opu.seqno = uni_ct;
		 oput_p, opu.ref_p = area_free_p;
		 font.units_r = rel (uni_p);
		 font.oput_r = rel (opu_p);
		 font.rel_units = -1;
		 font.footsep = Footsep;
		 font.min_wsp = MinWordsp;
		 font.avg_wsp = AvgWordsp;
		 font.max_wsp = MaxWordsp;
		 units (*) = 0;
		 oput.data_ct = 0;
		 default_view = 1]
	 LEX(1)					         / Font_1 \
     /	/[call ERROR (not_valid_Font_name)] NEXT_STMT	         / Font_3 \

Font_1
     / <is_viewname>
	/	[default_view = token.Nvalue;
		 font.rel_units
		    = media.rel_units (view.media (default_view))]
	 LEX(1)					         / Font_2 \
     /	/[call ERROR (not_viewname)] NEXT_STMT		         / Font_3 \

Font_2
     / ;	/					         / Font_3 \
     /	/[call ERROR (syntax_Font)]				       /\
Font_3
     /	/	[if Wordspace_p = null()
		 then goto RD_NEXT_REDUCTION;
		 hold_Pthis_token = Pthis_token;
		 Ptoken, Pthis_token = Wordspace_p]
	 PUSH(Font_4)[call push("Font_4")]		      / wordspace \
     /	/					         / Font_5 \
Font_4
     / ;	/	[Ptoken, Pthis_token = hold_Pthis_token]         / Font_8 \
     /    /[call ERROR (syntax_Wordspace)]
		[Ptoken, Pthis_token = hold_Pthis_token]         / Font_5 \

font_err
     /	/[call ERROR (syntax_Font_sec)] NEXT_STMT	      / stack_pop \

Font_5
     /	/PUSH (endFont)[call push("endFont")]			       /\
Font_6
     / <all_input>
	/	[this_view = default_view]
	 PUSH (Font_8)[call push ("Font_8")]		      / font_char \
     / art
	/	[this_view = default_view]
	 PUSH (Font_8)[call push ("Font_8")]		      / font_char \
     / Def	\" This is here for purposes of ref closure
	/					      / stack_pop \
     / footrefseparator :
	/LEX(2)					     / footrefsep \
     / wordspace :
	/LEX(2) PUSH(Font_9)[call push("Font_9")]	      / wordspace \
     / ref :
	/LEX(2)						  / ref \
     / Font	/				      / stack_pop \
     / Size	/				      / stack_pop \
       / Device	/	/ stack_pop \
       / <no-token>	/	/ stack_pop \
     / 	/PUSH (Font_6)[call push ("Font_6")]		  / global_device \

Font_8
     / ;	/	[self_ct = 0;
		 j = index (the_string, o777);
		 if (j = 0)
		 then the_string_r = rel (find_str (2));
		 else do;
		    do while (j <= length(the_string));
		       self_ct = self_ct + 1;
		       self_i (self_ct) = j;
		       j = j + 1;
		       if (j < length (the_string))
		       then do;
			i = index (substr (the_string, j), o777);
			if (i = 0)
			then j = length (the_string)+1;
			else j = j + i - 1;
		       end;
		    end;
		 end;
		 media1 = "[ ]";
		 jj= 0;
		 do i = 1 to vals_ct;
		    ii = vals (i);
		    if (self_ct > 0)
		    then do;
		       substr (media1, 2, 1) = byte (ii);
		       do j = 1 to self_ct;
			substr (the_string, self_i (j), 1) = byte (ii);
		       end;
		       the_string_r = rel (find_str (2));
		       charid = 0;
		       do jj = 1 to mediachars.count
			while (charid = 0);
			if (mediachars.name (jj) = media1)
			then charid = jj;
		       end;
		       if (charid = 0)	\" a MediaChar must be
		       then do;		\" defined with this name
			call ERROR (inv_Font_SELF_ref);
			jj = 0;
		       end;
		       else do;
			jj = media.width (view.media (this_view),
			   charid);
			if jj = nulwidth
			then call ERROR_ (no_width_specified,
			   view.name (this_view),
			   show_name (mediachars.name (charid)));
		       end;
		    end;
		    units (ii) = mediawidth + jj * self_ct;
		    oput.data_ct = max (oput.data_ct, ii);
		    oput.which (ii) = this_view;
		    oput.what_r (ii) = the_string_r;
		    if (testwidth ^= nulwidth)
		    then if (units (ii) ^= testwidth)
		    then call ERROR_ (bad_width_value,
		       ltrim (char (units (ii))),
		       ltrim (char (testwidth)));
		 end]
	 LEX(1)					         / Font_6 \
		\" the LEX(1) needs to be after so error msg will display
		\"  proper statement.
     /	/NEXT_STMT				         / Font_6 \
		\" font_char already told why in error


footrefsep
     / <all_input> ;
	/LEX(2)	[font.footsep = Input]		         / Font_6 \
Font_9
     / ;	/LEX(1)					         / Font_6 \
     /    /[call ERROR (syntax_wordspace)] NEXT_STMT LEX(-1)         / Font_6 \


wordspace
     / <num> ,
	/	[font.min_wsp = token.Nvalue]
	 LEX(2)					        / font_s2 \
     /	/					        / font_se \
font_s2
     / <num> ,
	/	[font.avg_wsp = token.Nvalue]
	 LEX(2)					        / font_s3 \
     /	/					        / font_se \
font_s3
     / <num> ,
	/	[font.max_wsp = token.Nvalue]
	 LEX(2)					        / font_s4 \
     /	/					        / font_se \
font_s4
     / <charname> ;
	/	[this_view = default_view;
		 vals_ct = 1;
		 vals (1) = 32]			      / mc_string \
	\" Consistency between AvgWordsp and mediawidth will be checked later.
font_se
    / ;	/ LEX(-1)					      / stack_pop \
	\" make sure NOT pointing to ";" token when return

    /	/					      / stack_pop \

endFont
    /	/	[tp = unil_p (2);	\" see if units is like a prior one
		 done = "0"b;
		 do uni_p = unil_p (1) repeat (uni.next)
		    while ((uni_p ^= unil_p (2)) & ^done);
		    if (uni.refno = uni.seqno)
		    then do;	\" check only "real" ones
		       if (unspec (uni.ref_p -> units)
		          = unspec (tp -> uni.ref_p -> units))
		       then do;
		          tp -> uni.refno = uni.seqno; \"its a duplicate
		          done = "1"b;
		       end;
		    end;
		 end;
		 tp = opul_p (2);	\" see if oput is like a prior one
		 done = "0"b;
		 do opu_p = opul_p (1) repeat (opu.next)
		    while ((opu_p ^= opul_p (2)) & ^done);
		    if (opu.refno = opu.seqno)
		    then do;	\" check only "real" ones
		       if (unspec (opu.ref_p -> oput)
			= unspec (tp -> opu.ref_p -> oput))
		       then do;
		          tp -> opu.refno = opu.seqno; \"its a duplicate
		          done = "1"b;
		       end;
		    end;
		 end]				      / stack_pop \


\" ----------------------------------------------------------------------------
\" This routine reparses the source following the named Def and then continues
\" following the ref statement.
ref
     / <is_Defname>
	/	[i = token.Nvalue]
	 LEX(1)						/ ref__ \
     /	/[call ERROR (not_Defname)] NEXT_STMT		         / Font_6 \
ref__
     / ;	/						/ ref_0 \
     /	/[call ERROR (missing_semicolon)]			       /\
ref_0
     /	/	[hold_Pthis_token = Pthis_token;
		 Ptoken, Pthis_token = Def.pt (i)]
	 PUSH (ref_1)[call push ("ref_1")]		         / Font_6 \
		\" divert parsing back to the Def source
ref_1
     /	/	[Ptoken, Pthis_token = hold_Pthis_token]
	 NEXT_STMT				         / Font_6 \
		\" have reached end of Def,
		\" continue parsing where we left off
\" ----------------------------------------------------------------------
Sizerest
     / <ident>
	/	[size_list.count = size_list.count + 1;
		 size_list.name (size_list.count) = token_value;
		 size_list.pt (size_list.count) = sizel_p;
		 sizel.val_ct = 0]
	 LEX(1)					        / point_1 \
     /	/[call ERROR (no_Size_name)] NEXT_STMT		      / stack_pop \

point_1
     / , <num>
	/LEX(1)	[sizel.val_ct = sizel.val_ct + 1;
		 sizel.val (sizel.val_ct) = scale_unit (1000)]
	 LEX(1)					        / point_1 \
     /	/	[area_free_p, sizel_p = addr_inc (sizel_p, size (sizel))]/\
     / ;	/LEX(1)					      / stack_pop \
     /	/[call ERROR (syntax_Size)] NEXT_STMT		      / stack_pop \
\"
global_device
     / Units : <unitkey> ;
	/LEX(2)	[if db_sw then call ioa_ ("^[^/^]===Units ^a",
			dt_sw, token_value);
		 Hscale = hscales (token.Nvalue);
	           Vscale = vscales (token.Nvalue)]
	 LEX(2)					     / stack_pop \
     / Artproc : <ident>
	/LEX(2)	[ArtProc = token_value]
	 LEX(1)					        / Artproc \
     / Attach : <quoted-string> ;
	/LEX(2)	[the_string = token_value;
		 Atd_r = rel (find_str (2))]
	 LEX(2)					      / stack_pop \
     / Cleanup :
	/LEX(2)	[part_nest = 0]
	 PUSH (Cleanup)[call push ("Cleanup")]		      / mc_string \
     / Font :
	/					      / stack_pop \
     / Comment : <quoted-string> ;
	/LEX(2)	 [the_string = token_value;
		  Com_r = rel (find_str (2))]
	 LEX(2)					      / stack_pop \
     / DefaultMargs : <num> , <num> , <num> , <num> ;
	/LEX(2)	[DefVmt = scale_unit (Vscale)]
	 LEX(2)	[DefVmh = scale_unit (Vscale)]
	 LEX(2)	[DefVmf = scale_unit (Vscale)]
	 LEX(2)	[DefVmb = scale_unit (Vscale)]
     	 LEX(2)					      / stack_pop \
     / DevClass : <quoted-string> ;
     	/LEX(2)	[if db_sw then call ioa_ ("^[^/^]===DevClass", dt_sw);
		 DevClass = token_value]
	 LEX(2)					      / stack_pop \
     / DevName : <quoted-string> ;
     	/LEX(2)	[if db_sw then call ioa_ ("^[^/^]===DevName", dt_sw);
		 DevName = token_value]
	 LEX(2)					      / stack_pop \
     / Endpage : <all_input> ;
	/LEX(2)	[EndPage = unspec (Input)]
	 LEX(2)					      / stack_pop \
     / Footproc :
	/	[if db_sw
		 then call ioa_ ("^[^/^]===Footproc", dt_sw)]
	 LEX(2)				 	       / Footproc \
     / Footrefseparator :
	/	[if db_sw
		 then call ioa_ ("^[^/^]===Footrefseparator", dt_sw)]
	 LEX(2)					     / Footrefsep \
     / Justify : <switch> ;
     	/LEX(2)	[if db_sw then call ioa_ ("^[^/^]===Justify", dt_sw);
		 Justify = (token.Nvalue > 0)]
	 LEX(2)					     / stack_pop \
     / Interleave : <switch> ;
     	/LEX(2)	[if db_sw then call ioa_ ("^[^/^]===Interleave", dt_sw);
		 Interleave = (token.Nvalue > 0)]
	 LEX(2)					     / stack_pop \
     / Letterspace : <num> ;
	/LEX(2)	[if db_sw then call ioa_ ("^[^/^]===Letterspace", dt_sw);
		 Letterspace = token.Nvalue]
	 LEX(2)					      / stack_pop \
     / MaxFiles : <limit> ;
	/LEX(2)	[MaxFiles = token.Nvalue]
	 LEX(2)					      / stack_pop \
     / MaxPages : <limit> ;
	/LEX(2)	[MaxPages = token.Nvalue]
	 LEX(2)					      / stack_pop \
     / MaxPageLength : <limit> ;
          /LEX(2)	[MaxPageLength = scale_unit (Vscale)]
	 LEX(2)					      / stack_pop \
     / MaxPageWidth : <num> ;
	/LEX(2)	[if db_sw
		 then call ioa_ ("^[^/^]===MaxPageWidth", dt_sw);
		 MaxPageWidth = scale_unit (Hscale)]
	 LEX(2)				                / stack_pop \
     / MinBotMarg : <num> ;
     	/LEX(2)	[MinVmb = scale_unit (Vscale)]
	 LEX(2)					      / stack_pop \
     / MinLead : <num> ;
          /LEX(2)	[if db_sw then call ioa_ ("^[^/^]===MinLead", dt_sw);
		 MinLead = scale_unit (Vscale)]
	 LEX(2)					      / stack_pop \
     / MinSpace : <num> ;
          /LEX(2)	[if db_sw then call ioa_ ("^[^/^]===MinSpace", dt_sw);
		 MinSpace = scale_unit (Hscale)]
	 LEX(2)					      / stack_pop \
     / MinTopMarg : <num> ;
     	/LEX(2)	[MinVmt = scale_unit (Vscale)]
	 LEX(2)					      / stack_pop \
     / Outproc : <ident>
     	/LEX(2)	[if db_sw then call ioa_ ("^[^/^]===Outproc", dt_sw);
		 OutProc, DisplayProc = token_value]
	 LEX(1)					        / Outproc \
     / Strokes : <num> ;
	/LEX(2)	[if db_sw then call ioa_ ("^[^/^]===Strokes", dt_sw);
		 Strokes = token.Nvalue]
	 LEX(2)					      / stack_pop \
     / Wordspace :
	/LEX(2)	[if db_sw then call ioa_ ("===Wordspace");
		 Wordspace_p = Pthis_token] NEXT_STMT         / stack_pop \
		\" just remember where this is for later use.
     / Sizes : <sizename> ;
     	/LEX(2)	[Sizes = token.Nvalue]
	 LEX(2)					      / stack_pop \
     / Stream : <switch> ;
	/LEX(2)	[if db_sw then call ioa_ ("^[^/^]===Stream", dt_sw);
		 Openmode = 5 - 3 * token.Nvalue]
	 LEX(2)					      / stack_pop \
     / TapeRec : <limit> ;
     	/LEX(2)	[TapeRec = token.Nvalue]
	 LEX(2)					      / stack_pop \
     / <no-token> /[call ERROR (end_of_source)]		         / RETURN \
     / dcl
	/					   / out_of_place \
     / MediaChars
	/					   / out_of_place \
     / Media
	/					   / out_of_place \
     / View
	/					   / out_of_place \
     / Def
	/					   / out_of_place \
     / Font
	/					   / out_of_place \
     / Size
	/					   / out_of_place \
     / Device
	/					   / out_of_place \
     /  	/[call ERROR (inv_statement)] NEXT_STMT		      / stack_pop \
out_of_place
     /	/[call ERROR (stmt_out_of_place)] NEXT_STMT	      / stack_pop \

Artproc
     / $ <ident> ;
	/LEX(1)	[ArtEntry = token_value]
	 LEX(2)					      / stack_pop \
     /	/	[ArtEntry = ArtProc]
	 LEX(1)					      / stack_pop \

Footrefsep
     / <all_input> ;
	/	[Footsep = Input]
	 LEX(2)					      / stack_pop \
     /	/[call ERROR (syntax_Footrefsep)] NEXT_STMT	      / stack_pop \

Footproc
     / <ident>
	/	[FootProc = token_value]
	 LEX(1)					         / Foot_1 \
     / ,	/LEX(1)					         / Foot_2 \
     /	/[call ERROR (syntax_Footproc)] NEXT_STMT	      / stack_pop \

Foot_1
     / $ <ident>
	/LEX(1)	[FootEntry = token_value]
	 LEX(1)					        / Foot_2  \
     /	/	[FootEntry = FootProc]			       /\

Foot_2
     / , <fam_mem>
	/LEX(2)	[FootFamily = font_fam;
		 FootMember = font_mem]		                 /\
     / ;	/LEX(1)			                          / stack_pop \
     /	/[call ERROR (syntax_Footproc)] NEXT_STMT	      / stack_pop \

Outproc
     / $ <ident> ;
	/LEX(1)	[OutEntry = token_value]
	 LEX(2)					      / stack_pop \
     / ;	/	[OutEntry = OutProc]
	 LEX(1)			                          / stack_pop \
     /	/[call ERROR (syntax_Outproc)] NEXT_STMT	      / stack_pop \

Cleanup
     / ;	/LEX(1)	[ Clean_r = rel (find_str (2))]	      / stack_pop \
     /	/[call ERROR (syntax_Cleanup)] NEXT_STMT	      / stack_pop \

output_0
     /	/	[iii, parenct, part_nest = 0]			       /\
output_1
     /	/	[part_nest = part_nest + 1;
		 part_repl (part_nest) = iii;
		 part_str (part_nest) = ""]		                 /\

output_2
     / <octal>
	/	[part_str (part_nest) = part_str (part_nest) || Input]
	 LEX(1)					       / output_2 \
     / <quoted-string>
	/	[part_str (part_nest) = part_str (part_nest) || token_value]
	 LEX(1)					       / output_2 \
     / SELF
	/	[part_str (part_nest) = part_str (part_nest) || o777]
	 LEX(1)					       / output_2 \
     / <num> (
	/	[iii = token.Nvalue;
		 parenct = parenct + 1]
	 LEX(2) PUSH (output_3)[call push ("output_3")]	       / output_1 \
     / <dcl_ed>
	/	[part_str(part_nest) = part_str(part_nest)||bstr.str]
	 LEX(1)					       / output_2 \
     /	/					      / stack_pop \

output_3
     / )	/LEX(1)	[part_str (part_nest-1) = part_str (part_nest-1)
		    || copy (part_str (part_nest), part_repl (part_nest));
		 part_nest = part_nest - 1;
		 parenct = parenct - 1]		       / output_2 \
     / ;	/[call ERROR (unbal_parens)]			      / stack_pop \
     /	/					      / stack_pop \

Devicerest
     /	/	[comp_dvid_ct = comp_dvid_ct+1;
		 comp_dvid_new="1"b;
		 like_table = -1]				       /\
Device_0
     / <valid_Device_name>
	/	[if (dvid_ct = 0)
		 then dvid_ct = dvid_ct + 1;   \" add Device name
	           dvid_p = area_free_p;
		 area_free_p = addr (dvid.dummy);
		 call link (dvidl_p, dvid_p);
		 dvid.ndx = comp_dvid_ct;
		 dvid.real = comp_dvid_new;
		 dvid.refname = token_value;
		 dvid.devname = DevName;
		 dvid.dvt_ndx = dvt_ct + 1;
		 comp_dvid_new = "0"b]
	 LEX(1)					       / Device_1 \

table_e
     /	/[call ERROR (syntax_Device)] NEXT_STMT		      / stack_pop \

Device_1
     / ,	/LEX(1)					       / Device_0 \
     / like 
          /LEX(1)					     / like_table \
     / ;	/LEX(1) PUSH (startDevice)[call push ("startDevice")]    / Device_I \
     /	/					        / table_e \

like_table
     / <table_name> ;
          /	[like_table = token.Nvalue]
	 LEX(2)					    / like_table2 \
     /	/					        / table_e \

like_table3
     /	/	[do dvid_p = dvidl_p (1) repeat (dvid.next)
		    while (dvid_p ^= null ());
		    if dvid.dvt_ndx = dvt_ct + 1
		    then dvid.dvt_ndx = like_table;
		 end]				      / stack_pop \
like_table2
     / Device
	/					    / like_table3 \
     / <no-token>
          /					    / like_table3 \
     /    / PUSH (copy_table)[call push ("copy_table")]	       / Device_I \

Device_I
     /	/	[dvt_p = area_free_p;
		 area_free_p = addr (dvt.dummy);
		 call link (dvtl_p, dvt_p);
		 dvt.ndx, dvt_ct = dvt_ct + 1;
		 dvt.med_sel = area_free_p;
		 med_sel_tab.count = font_count;
		 area_free_p
		    = addr_inc (area_free_p, size (med_sel_tab));
		 med_sel_tab.ref_r (*) = "0"b;

		 dvt.prent, prent_p = area_free_p;
		 area_free_p = addr (prent.dummy);

		 dvt.ref, const.devptr = area_free_p;
		 dvt_ct = dvt_ct + 1]		      / stack_pop \

copy_table
     /	/	[tp = null ();
		 do dvt_p = dvtl_p (1) repeat (dvt.next)
		    while (dvt_p ^= null () & tp = null ());
		    if dvt.ndx = like_table
		    then tp = dvt_p;
		 end;

		 dvt_p = tp;
		 med_sel_tab = dvt.med_sel -> med_sel_tab;
		 prent = dvt.prent -> prent;
		 comp_dvt.family_ct = dvt.ref -> comp_dvt.family_ct;
		 comp_dvt = dvt.ref -> comp_dvt]	       / Device_2 \

startDevice
     /	/	[prent.outproc = OutProc || "$" || OutEntry;
		 prent.artproc = ArtProc || "$" || ArtEntry;
		 prent.footproc = FootProc || "$" || FootEntry;
		 initfamily, initmember = "";
		 footfamily = FootFamily;
		 footmember = FootMember;
		 hscale = Hscale;
		 vscale = Vscale;
		 comp_dvt.devclass = DevClass;
		 comp_dvt.min_WS = MinSpace;
		 comp_dvt.min_lead = MinLead;
		 comp_dvt.vmt_min = MinVmt;
		 comp_dvt.vmb_min = MinVmb;
		 comp_dvt.def_vmt = DefVmt;
		 comp_dvt.def_vmh = DefVmh;
		 comp_dvt.def_vmf = DefVmf;
		 comp_dvt.def_vmb = DefVmb;
		 comp_dvt.pdw_max = MaxPageWidth;
		 comp_dvt.pdl_max = MaxPageLength;
		 comp_dvt.upshift = 0;
		 comp_dvt.init_ps = 0;
		 comp_dvt.lettersp = Letterspace;
		 comp_dvt.max_pages = MaxPages;
		 comp_dvt.max_files = MaxFiles;
		 comp_dvt.init_family = "";
		 comp_dvt.init_member = "";
		 comp_dvt.atd_r = Atd_r;
		 comp_dvt.dvc_r = ""b;
		 comp_dvt.comment_r = Com_r;
		 comp_dvt.cleanup_r = Clean_r;
		 comp_dvt.medsel_table_r = ""b;
		 comp_dvt.foot_family = "";
		 comp_dvt.foot_member = "";

		 comp_dvt.sws.interleave = Interleave;
		 comp_dvt.sws.justifying = Justify;
		 comp_dvt.sws.mbz = "0"b;
		 comp_dvt.sws.endpage = EndPage;
		 comp_dvt.open_mode = Openmode;
		 comp_dvt.recleng = TapeRec;
		 comp_dvt.family_ct = 0]			       /\

Device_2
     / units : <unitkey> ;
	/LEX(2)	[hscale = hscales (token.Nvalue);
	           vscale = vscales (token.Nvalue)]
	 LEX(2)					       / Device_2 \
     / artproc : <ident>
	/LEX(2)	[prent.artproc = token_value]
	 LEX(1)					        / artproc \
     / attach : <quoted-string> ;
	/LEX(2)	[the_string = token_value;
		 comp_dvt.atd_r = rel (find_str (2))]
	 LEX(2)					       / Device_2 \
     / cleanup :
	/LEX(2) PUSH (cleanup)[call push ("cleanup")]	      / mc_string \
     / comment : <quoted-string> ;
	/LEX(2)	[the_string = token_value;
		 comp_dvt.comment_r = rel (find_str (2));
		 if length (token_value) > length (the_string)
		 then call ERROR (comment_gt_8000)]
	 LEX(2)					       / Device_2 \

     / defaultmargs : <num> , <num> , <num> , <num> ;
	/LEX(2)	[comp_dvt.def_vmt = scale_unit (vscale)]
	 LEX(2)	[comp_dvt.def_vmh = scale_unit (vscale)]
	 LEX(2)	[comp_dvt.def_vmf = scale_unit (vscale)]
	 LEX(2)	[comp_dvt.def_vmb = scale_unit (vscale)]
	 LEX(2)					       / Device_2 \
     / devclass : <quoted-string> ;
	/LEX(2)	[comp_dvt.devclass = token_value]
	 LEX(2)					       / Device_2 \
     / devname : <quoted-string> ;
	/LEX(2)	[do dvid_p = dvidl_p (1) repeat (dvid.next)
		    while (dvid_p ^= null ());
		    if dvid.dvt_ndx = dvt_ct
		    then dvid.devname = token_value;
		 end]
	 LEX(2)					       / Device_2 \
\"     / dvc : <ident> ,
\"	/LEX(2)	[dvcname = token_value]
\"	 LEX(2)	[dvcproc, the_string = ""]		       / dvc_1    \
     / endpage : <all_input> ;
	/LEX(2)	[comp_dvt.endpage = unspec (Input)]
	 LEX(2)					       / Device_2 \
     / family :
	/	[bach_sw = "0"b]
	 LEX(2) PUSH(family)[call push("family")]	     / add_family \
     / footproc :
	/LEX(2)					       / footproc \
     / init :
	/LEX(2)					        / init_f0 \
     / interleave : <switch> ;
	/LEX(2)	[comp_dvt.interleave = (token.Nvalue > 0)]     / Device_2 \
     / justify : <switch> ;
	/LEX(2)	[comp_dvt.justifying = (token.Nvalue > 0)]     / Device_2 \
     / letterspace : <num> ;
	/LEX(2)	[comp_dvt.lettersp = token.Nvalue]
	 LEX(2)					       / Device_2 \
     / maxfiles : <limit> ;
	/LEX(2)	[comp_dvt.max_files = token.Nvalue]
	 LEX(2)					       / Device_2 \
     / maxpages : <limit> ;
	/LEX(2)	[comp_dvt.max_pages = token.Nvalue]
	 LEX(2)					       / Device_2 \
     / maxpagelength : <limit> ;
	/LEX(2)	[comp_dvt.pdl_max = scale_unit (vscale)]
	 LEX(2)					       / Device_2 \
     / maxpagewidth : <num> ;
	/LEX(2)	[comp_dvt.pdw_max = scale_unit (hscale)]
	 LEX(2)					       / Device_2 \
     / minbotmarg : <num> ;
	/LEX(2)	[comp_dvt.vmb_min = scale_unit (vscale)]
	 LEX(2)					       / Device_2 \
     / minlead : <num> ;
	/LEX(2)	[comp_dvt.min_lead = scale_unit (vscale)]
	 LEX(2)					       / Device_2 \
     / minspace : <num> ;
	/LEX(2)	[comp_dvt.min_WS = scale_unit (hscale)]
	 LEX(2)					       / Device_2 \
     / mintopmarg : <num> ;
	/LEX(2)	[comp_dvt.vmt_min = scale_unit (vscale)]
	 LEX(2)					       / Device_2 \
     / outproc : <ident>
	/LEX(2)	[prent.outproc = token_value]
	 LEX(1)					        / outproc \
     / stream : <switch> ;
	/LEX(2)	[comp_dvt.open_mode = 5 - 3 * token.Nvalue]
	 LEX(2)					       / Device_2 \
     / taperec : <limit> ;
	/LEX(2)	[comp_dvt.recleng = token.Nvalue]
	 LEX(2)					       / Device_2 \
     / bachelor :
	/	[bach_sw = "1"b]
	 LEX(2) PUSH(bachelor)[call push("bachelor")]	     / add_family \
     / viewselect :
	/LEX(2)					     / viewselect \
     / Device
	/					      / endDevice \
     / <no-token>
	/					      / endDevice \
     /	/ PUSH (Device_2)[call push ("Device_2")]	  / global_device \

endDevice
     /	/	[tp = Pthis_token;
		 Ptoken, Pthis_token = Device_Pthis_token;

		 done = "0"b;
		 do dvid_p = dvidl_p (1) repeat (dvid.next)
		    while ((dvid_p ^= null ()) & ^done);
		    if (dvid.dvt_ndx = dvt_ct)
		    then if (dvid.devname = "")
		    then do;
		       call ERROR (no_devname);
		       done = "1"b;
		    end;
	           end;
		 dvid_p = dvidl_p (2);
		 if (comp_dvt.family_ct = 0)
		 then call ERROR (no_fonts_selected);
		 if (initfamily = "")
		 then call ERROR (no_init_font);
		 if (footfamily = "")
		 then do;
		    footfamily = initfamily;
		    footmember = initmember;
		 end;

		 views_selected = 0;
		 do i = 1 to view.count;
		    if (med_sel_tab.ref_r (i) ^= "0"b)
		    then views_selected = views_selected + 1;
		 end;

		 do i = 1 to comp_dvt.family_ct;
		    mem_p = ptr (area1_p, comp_dvt.member_r (i));
		    member_ptr = mem.ref_p;
		    do ii = 1 to member.count;
		       if initfamily = comp_dvt.family (i).name
		       & initmember = member.name (ii)
		       then do;
			comp_dvt.init_fam = i;
			comp_dvt.init_family = initfamily;
			comp_dvt.init_mem = ii;
			comp_dvt.init_member = initmember;
		       end;
		       if footfamily = comp_dvt.family (i).name
		       & footmember = member.name (ii)
		       then do;
			comp_dvt.foot_fam = i;
			comp_dvt.foot_family = footfamily;
			comp_dvt.foot_mem = ii;
			comp_dvt.foot_member = footmember;
		       end;

		       if views_selected < view.count
		       then do;
			fnt_p = ptr (area2_p, member.font_r (ii));
			font_ptr = fnt.pt;
			uni_p = ptr (fnt.pt, font.units_r);
			units_ptr = uni.ref_p;
			opu_p = ptr (fnt.pt, font.oput_r);
			oput_p = opu.ref_p;

			do iii = 0 to oput.data_ct;
			   j = oput.which (iii);
			   if (j > 0)	\" is the char defined?
			   then do;	\"  YES
			      if (med_sel_tab.ref_r (j) = "0"b)
			      then do;  	\" but you can't get at it!
			         call ERROR_ (no_viewselect,
				  view.name (j), dvid.refname);
			         med_sel_tab.ref_r (j) = "000001"b3;
				\" don't want to say this again.
			         views_selected = views_selected + 1;
			      end;
			   end;
			end;
		       end;
		    end;
		 end;
		 if (comp_dvt.init_family = "")
		 then call ERROR (init_font_not_on_Device);
		 if (comp_dvt.foot_family = "")
		 then call ERROR (foot_font_not_on_Device);
		 Ptoken, Pthis_token = tp;
		 area_free_p = addr_inc (area_free_p, size (comp_dvt))]
				\" finish allocation
						      / stack_pop \

artproc
     / $ <ident> ;
	/LEX(1)	[prent.artproc = prent.artproc || "$";
		 prent.artproc = prent.artproc || token_value]
	 LEX(2)					       / Device_2 \
     /	/LEX(1)	[prent.artproc 
		    = prent.artproc || "$" || prent.artproc]   / Device_2 \

outproc
     / $ <ident> ;
	/LEX(1)	[prent.outproc = prent.outproc || "$" || token_value]
	 LEX(2)					       / Device_2 \
     / ;	/LEX(1)					       / Device_2 \
     /	/[call ERROR (syntax_outproc)] NEXT_STMT	       / Device_2 \

cleanup
     / ;	/LEX(1)	[comp_dvt.cleanup_r = rel (find_str (2))]      / Device_2 \
     /	/[call ERROR (syntax_cleanup)] NEXT_STMT	       / Device_2 \

add_family
     /	/	[new_family = "1"b]				       /\
family_1
     / <fam_bach>
          /	[if new_family
		 then do;
		    if (member_ptr = null ())
		    then mem_p = area1_p;
		    else mem_p = addr_inc ((member_ptr), size (member));
		    call link (meml_p, mem_p);
		    mem.seqno, mem.refno, mem_ct = mem_ct + 1;
		    member_ptr, mem.ref_p = addr (mem.dummy);
		    member.count = 0;
		    new_family = "0"b;
		 end;
		 comp_dvt.family_ct = comp_dvt.family_ct + 1;
		 comp_dvt.member_r (comp_dvt.family_ct) = rel (mem_p);
		 if ^bach_sw
		 then comp_dvt.family (comp_dvt.family_ct).name
		    = translate (token_value, az, AZ);
		 else comp_dvt.family (comp_dvt.family_ct).name
		    = token_value;
		 Scale_x, Scale_y = Scale_scale]
	 LEX(1)					       / family_2 \
     /	/[call ERROR (fam_bach_name_expected)]		      / stack_pop \
family_2
     / ,	/LEX(1)					       / family_1 \
     /	/					      / stack_pop \
family
     / ; member
          /LEX(1)					         / member \
family_err
     /    /[call ERROR (syntax_family)] NEXT_STMT		       / Device_2 \
member
     / member :
          /	[new_member = member.count+1]
	 LEX(2)					       / member_1 \
     /	/					         / endmem \

member_1
     / <membername>
          /	[member.count = member.count + 1;
		 member.font_r (member.count) = "0"b;
		 member.size_r (member.count) = "0"b;
		 member.name (member.count)
		    = translate (token_value, az, AZ)]
	 LEX(1)					       / member_2 \
     /    /[call ERROR (syntax_member)] NEXT_STMT		       / Device_2 \
member_2
     / ,	/LEX(1) 					       / member_1 \
     /	/PUSH (member) [call push ("member")]			       /\
member_3
     / <font_name>
	/LEX(1)					       / member_4 \
     /	/[call ERROR (no_fontname)]				       /\
member_4
     / ;	/LEX(1)					       / member_6 \
     /    /[call ERROR (syntax_member)] NEXT_STMT		      / stack_pop \
member_6
     / Scale :
	/LEX(2)					       / member_7 \
     /	/					       / member_A \
member_7
     / <num>
	/	[Scale_x, Scale_y
		    = convert (fd12_8, token_value)* Scale_scale]
	 LEX(1)					       / member_8 \
     /	/					      / Scale_err \
member_8
     / , <num>
	/LEX(1)	[Scale_y = convert (fd12_8, token_value) * Scale_scale]
	 LEX(1)					       / member_9 \
     /	/					      / Scale_err \
member_9
     / ;	/LEX(1)					       / member_A \
Scale_err
     /	/[call ERROR (syntax_Scale)] NEXT_STMT			       /\
member_A
     /	/	[the_string_r = rel (find_str (2));
		 do i = new_member to member.count;
		    member.font_r (i) = rel (the_font);
		    member.Scalex (i) = Scale_x;
		    member.Scaley (i) = Scale_y;
		    addr (member.size_r (i)) -> bfb = Sizes;
		 end]				      / stack_pop \

init_f0
     / <fam_mem>
	/LEX(1)	[initfamily = font_fam;
		 initmember = font_mem]		        / init_f2 \
     /	/[call ERROR (missing_font)]NEXT_STMT		       / Device_2 \
init_f2
     / <num>
	/	[comp_dvt.init_ps = scale_unit (1000)]
	 LEX(1)					        / init_f3 \
     /	/[call ERROR (no_init_ps)]NEXT_STMT		       / Device_2 \
init_f3
     / ;	/LEX(1)					       / Device_2 \
     /	/[call ERROR (missing_semicolon)]NEXT_STMT	       / Device_2 \

bachelor
     /	/	[new_member, member.count = 1;
		 member.font_r (1) = "0"b;
		 member.size_r (1) = "0"b;
		 member.Scalex (1) = Scale_x;
		 member.Scaley (1) = Scale_y;
		 member.name (1) = ""]
	PUSH (endmem) [call push ("endmem")]		       / member_3 \
endmem
     /	/	[done = "0"b;	\" put into "normal" form
		 do while (^done);
		    done = "1"b;
		    do i = 1 to member.count-1;
		       call memorder;
		    end;
		    if ^done
		    then do;
		       done = "1"b;
		       do i = member.count-1 to 1 by -1;
			call memorder;
		       end;
		    end;
		 end;
memorder: proc;
	if member.name (i) > member.name (i+1)
	then do;
	   member_hold = member.e (i);
	   member.e (i) = member.e (i+1);
	   member.e (i+1) = member_hold;
	   done = "0"b;
	end;
       end memorder;
		 tp = meml_p (2);	\" see if member is like a prior one
		 done = "0"b;
		 do mem_p = meml_p (1) repeat (mem.next)
		    while (mem_p ^= meml_p (2));
		    if (mem.seqno = mem.refno)
		    then do;	\" check only "real" ones
		       if (unspec (mem.ref_p -> mem)
		          = unspec (tp -> mem.ref_p -> mem))
		       then do;
		          tp -> mem.refno = mem.seqno; \"its a duplicate
		          done = "1"b;
		       end;
		    end;
		 end]				       / Device_2 \

\"dvc_1
\"     / <ident>$<ident>
\"	/	[dvcproc = token_value]
\"	 LEX(2)	[dvcentry = token_value]
\"	 LEX(1)					       	       /\
\"	/ <quoted-string>
\"	/	[the_string = token_value]
\"	 LEX(1)					       	       /\
\"     / ;	/LEX(1)	[the_string = ""] 			       / Device_2 \

footproc
     / <ident>
	/	[prent.footproc = token_value]
	 LEX(1)					         / foot_1 \
     / ,	/LEX(1)					         / foot_2 \
     / ;	/LEX(1)					       / Device_2 \
     /	/[call ERROR (syntax_footproc)] NEXT_STMT	       / Device_2 \

foot_1
     / $ <ident>
	/LEX(1)	[prent.footproc = prent.footproc || "$" || token_value]
	 LEX(1)						       /\

foot_2
     / , <fam_mem>
	/LEX(2)	[FootFamily = font_fam;
		 FootMember = font_mem]		         / foot_3 \
     /	/					         / foot_e \
foot_3
     / ;	/LEX(1)					       / Device_2 \
foot_e
     /	/[call ERROR (syntax_footproc)] NEXT_STMT	       / Device_2 \

viewselect
     / <is_viewname>
	/	[default_view = token.Nvalue;
		 this_view = -1]
	 LEX(1) PUSH (viewsel1)[call push ("viewsel1")]	      / mc_string \
viewselect_err
     /	/[call ERROR (syntax_viewselect)] NEXT_STMT	       / Device_2 \
viewsel1
     /	/	[med_sel_tab.ref_r (default_view) = rel (find_str (2))]  /\
     / ;	/LEX(1)					       / Device_2 \
     / ,	/LEX(1)					     / viewselect \
     /	/					 / viewselect_err \
++*/
%page;
compdv:
  proc;

    dcl version	   char (10) var static options (constant) init ("2.0a");
    dcl compdv_severity_
		   fixed bin (35) ext static;

    compstat$compconst.ptr = addr (compstat$compconst.ptr);
    dt_sw = "0"b;

/* initialize static on first call in the process */
    if first_time
    then
      do;
        breaks, ignored_breaks =
	   substr (collate (), 1, 33) || substr (collate (), 128, 1);
        breaks = breaks || ":,()$=";
        call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b,
				/* suppress quote, keep statement */
	   breaks, ignored_breaks, lex_delims, lex_ctl_chars);
        first_time = "0"b;		/* static init done, reset switch */
      end;

/* ******************** PROCESS COMMAND LINE******************** */

    call cu_$arg_count (nargs);	/* how many given? */

    compdv_severity_ = 5;		/* preset for command parser */

    if nargs = 0			/* if none are given ... */
    then
      do;
        call com_err_ (0, "compdv",
	   "(Vers. ^a) Proper usage is: compdv"
	   || " <input_pathname>{.compdv}^/^-[-check | -ck | -list | -ls]",
	   version);
        return;
      end;			/**/
				/* fetch input pathname */
    call cu_$arg_ptr (1, argp, argl, ercd);
    if ercd ^= 0
    then
      do;
        call com_err_ (ercd, "compdv", "Reading input pathname.");
        return;
      end;

    if search ("<>", arg) = 0		/* if a search is needed */
    then
      do;				/* check entry name length */
        if length (before (arg, ".compdv")) > 25
        then
	do;
	  call com_err_ (0, "compdv", "Input entryname ""^a"" is too long",
	       rtrim (arg));
	  return;
	end;

        ename = before (arg, ".compdv");/* strip the suffix */

        call search_paths_$find_dir ("compose",
				/* use compose list */
	   null (), rtrim (ename) || ".compdv", "", dname, ercd);
        if ercd ^= 0
        then
	do;
	  call com_err_ (ercd, "compdv", "Searching for ""^a""",
	       rtrim (ename) || ".compdv");
	  return;
	end;
      end;

    else
      do;
        call expand_pathname_$add_suffix (arg, "compdv", dname, ename, ercd);
        if ercd ^= 0
        then
	do;
	  call com_err_ (ercd, "compdv", "Expanding path for ""^a""",
	       rtrim (arg));
	  return;
	end;			/**/
				/* trim the suffix */
        ename = before (ename, ".compdv");
      end;

    check_opt, list_opt = "0"b;	/* reset option flags */

    if nargs > 1			/* any control args? */
    then
      do;
        call cu_$arg_ptr (2, argp, argl, ercd);
        if ercd ^= 0
        then
	do;
	  call com_err_ (ercd, "compdv", "Reading control argument.");
	  return;
	end;

        if arg = "-check" | arg = "-ck"
        then check_opt = "1"b;

        else if arg = "-list" | arg = "-ls"
        then list_opt = "1"b;

        else
	do;
	  call com_err_ (error_table_$badopt, "compdv", """^a""", arg);
	  return;
	end;
      end;

    call hcs_$initiate_count (dname, rtrim (ename) || ".compdv", "",
         input_bitcount, 0, input_ptr, ercd);
    if input_ptr = null ()
    then
      do;
        call com_err_ (ercd, "compdv", "Initiating ^a>^a.compdv",
	   rtrim (dname), rtrim (ename));
        return;
      end;

    on condition (cleanup) call cleaner;/* we now need cleaning */

    input_charcount = divide (input_bitcount, 9, 24, 0);

    call translator_temp_$get_segment ("compdv", lex_temp_ptr, ercd);
    if ercd ^= 0			/* get a temp seg for lex_string_ */
    then
      do;
        call com_err_ (ercd, "compdv", "Getting a translator temp seg.");
        call cleaner;
        return;
      end;

    call get_temp_segments_ ("compdv", temp_ptrs, ercd);
    if ercd ^= 0
    then
      do;
        call com_err_ (ercd, "compdv", "Getting temp segments");
        call cleaner;
        return;
      end;

/* ******************** INITIALIZE FOR EXECUTION ******************** */

    call ioa_ ("COMPDV ^a-^d", version, comp_dvid_version);

    compdv_severity_ = 0;		/* clear for execution */
    dcl_l_p (*) = null ();
    next_str_p = ptr (string_area_p, 1);/* next string definition */
    size_list_p = null ();

    area_free_p = area2_p;		/* next symbol declaration	       */
    mediachars_p = null ();		/* good housekeeping	       */
    media_p = null ();
    view_p = null ();
    Def_p = null ();

    dvid_ct = 0;
    dvidl_p (*) = null ();
    dvt_ct = 0;
    dvtl_p (*) = null ();

    font_count = 0;
    member_ptr = null ();
    fntl_p (*) = null ();
    meml_p (*) = null ();
    unil_p (*) = null ();
    opul_p (*) = null ();

    the_string = "";
    if rel (find_str (1))
    then ;			/* put null string as first	       */
    if rel (find_str (2))
    then ;			/*   string table entries	       */

    ArtProc, FootProc, OutProc, DisplayProc, OutEntry =
         rtrim (ename) || "_writer_";
    FootFamily, FootMember = "";
    Com_r, Clean_r = "0"b;
    Vscale = vscales (6);		/* default to points	       */
    Hscale = hscales (6);

    if input_charcount = 0
    then
      do;
        code = error_table_$zero_length_seg;
        goto empty_seg;
      end;

    call lex_string_$lex (input_ptr, input_charcount, 0, lex_temp_ptr, "1000"b,
         """", """", "/*", "*/", ";", breaks, ignored_breaks, lex_delims,
         lex_ctl_chars, null (), first_token_p, code);
    if code ^= 0
    then
      do;
empty_seg:
        if code = error_table_$zero_length_seg
        then call com_err_ (0, "compdv",
	        "Source contains no statements. ^a>^a.compdv.", dname, ename)
	        ;
        else call com_err_ (code, "compdv",
	        "^a does not end with a statement delimiter.",
	        pathname_ (dname, ename));
        call cleaner;
        return;
      end;

    Ptoken, Pthis_token = first_token_p;

/* ***************************** GO ***************************** */
    call SEMANTIC_ANALYSIS;
    compdv_severity_ = MERROR_SEVERITY;

    if MERROR_SEVERITY < 3
    then
      do;
        dvid_p = dvidl_p (1);
        ename = rtrim (dvid.refname) || ".comp_dsm";
        call iox_$attach_name ("comp_gen_", ALM,
	   "vfile_ " || rtrim (ename) || ".alm", null (), code);
        call iox_$open (ALM, 2, "0"b, code);
        call outputter;
        call iox_$close (ALM, code);
        call iox_$detach_iocb (ALM, code);

        if ^check_opt
        then
	do;
	  if list_opt
	  then call alm (ename, "-list");
	  else call alm (ename);

	  do dvid_p = dvidl_p (1) repeat (dvid.next)
	       while (dvid_p ^= null ());
	    call hcs_$chname_file (get_wdir_ (), ename, "",
	         rtrim (dvid.refname) || ".comp_dsm", code);
	    if (code = error_table_$segnamedup)
	    then code = 0;
	    if code ^= 0
	    then call com_err_ (code, "compdv",
		    "Trying to add name ^a.comp_dsm to ^a>^a",
		    dvid.refname, get_wdir_ (), ename);
	  end;
	end;
      end;

    call cleaner;
    return;

/**** +++[Syntax Function]++++++++ A_DEBUG +++++++++++++++++++++++++++++++++ */
/*							       */
/* This routine helps in debugging. To use it a change must be made to the   */
/* output of rdc before compilation. At the label RD_MATCH this must be put: */
/*      if db_sw then call a_debug;				       */

a_debug:
  proc;
    call ioa_$nnl (" ""^a""", token_value);
    if (token_value = ",") | (token_value = ";")
    then call ioa_$nnl ("^/");
  end a_debug;

/**** +++[Function]+++++++++++++++ ADDR_INC ++++++++++++++++++++++++++++++++ */
/*							       */
/* this is an addrel function which increments by double words	       */
addr_inc:
  proc (a_ptr, an_inc) returns (ptr);

    dcl a_ptr	   ptr,
        an_inc	   fixed bin (24);

    return (addrel (a_ptr, divide (an_inc + 1, 2, 17, 0) * 2));
  end addr_inc;

/**** +++[Syntax Function]++++++++ CHARLIST ++++++++++++++++++++++++++++++++ */
/*							       */
/* Tests for the chars of a quoted string being defined charnames. Each      */
/*  entry processes the next char in the list.			       */
/* USES:	token_value - current token				       */
/*	list_ndx - character to process this time		       */
/* SETS:	token.Nvalue - index of found charname			       */

charlist:
  proc returns (bit (1) aligned);

    dcl i		   fixed bin;

    if list_ndx > length (token_value)
    then return ("0"b);
    media2 = "[" || substr (token_value, list_ndx, 1) || "]";

    do i = 1 to mediachars.count;	/* look thru the mediachars list     */
      if (mediachars.name (i) = media2)
      then
        do;
	token.Nvalue = i;
	if dt_sw
	then call ioa_$nnl ("<charlist-^i>", list_ndx);
	list_ndx = list_ndx + 1;
	return ("1"b);
        end;
    end;
    call ERROR_ (not_charname, show_name (media2), "");
    return ("0"b);

  end charlist;

/**** +++[Syntax Function]++++++++ CHARNAME ++++++++++++++++++++++++++++++++ */
/*							       */
/* Tests for the token being a defined charname.			       */
/* USES:	token_value - current token				       */
/* SETS:	token.Nvalue - index of found charname			       */

charname:
  proc returns (bit (1) aligned);

    dcl i		   fixed bin;

    if input_ ()			/* (sets Input if true)	       */
    then media2 = "[" || Input || "]";
    else if ident_ ()
    then media2 = token_value;
    else return ("0"b);
    do i = 1 to mediachars.count;	/* look thru the mediachars list     */
      if (mediachars.name (i) = media2)
      then
        do;
	token.Nvalue = i;
	if dt_sw
	then call ioa_$nnl ("<charname>");
	return ("1"b);
        end;
    end;
    return ("0"b);

  end charname;

/**** +++[Procedure]++++++++++++++ CLEANER +++++++++++++++++++++++++++++++++ */
/*							       */
/* Does all the needed stuff for condition(cleanup). However, doesn't report */
/*  any errors since we may be in trouble.			       */

cleaner:
  proc;

    if db_sw
    then call ioa_ ("===cleaner");

    call hcs_$terminate_noname (input_ptr, code);

    if lex_temp_ptr ^= null ()
    then call translator_temp_$release_all_segments (lex_temp_ptr, code);

    if temp_ptrs (1) ^= null ()
    then call release_temp_segments_ ("compdv", temp_ptrs, code);

    if ALM ^= null ()
    then
      do;
        call iox_$close (ALM, code);
        call iox_$detach_iocb (ALM, code);
        ALM = null ();
      end;

    if ^check_opt
    then call delete_$path (get_wdir_ (), rtrim (ename) || ".alm", "100100"b,
	    "compdv", code);

  end cleaner;

/**** +++[Syntax Function]+++++++++ DCL_ED +++++++++++++++++++++++++++++++++ */

dcl_ed:
  proc returns (bit (1) aligned);

    do dcl_p = dcl_l_p (1) repeat (dcl_.next) while (dcl_p ^= null ());
      if (dcl_.dcl_name = token_value)
      then
        do;
	str_p = addr (dcl_.leng);
	if dt_sw
	then call ioa_$nnl ("<dcl_ed>");
	return ("1"b);
        end;
    end;
    return ("0"b);

  end dcl_ed;

/**** +++[Procedure]+++++++++++++++ ERROR_ +++++++++++++++++++++++++++++++++ */
/*							       */
/* This routine prints error messages which need "non-standard" insertions.  */

ERROR_:
  proc (Nerror, Arg1, Arg2);

    dcl Nerror	   fixed bin,
        Arg1	   char (*),	/* The need is currently for 2       */
        Arg2	   char (*);	/* arguments, (may need expansion).  */

    dcl Pstmt	   ptr,
        1 erring_token aligned based (Perring_token) like token,
        Perring_token  ptr,
        erring_token_value
		   char (erring_token.Lvalue) based (erring_token.Pvalue);
    dcl lex_error_	   entry options (variable);

    Perring_token = Pthis_token;

    if error_control_table.Soutput_stmt (Nerror)
    then Pstmt = erring_token.Pstmt;	/* addr statement descriptor.    */
    else Pstmt = null ();

    call lex_error_ (Nerror, SERROR_PRINTED (Nerror),
         (error_control_table.severity (Nerror)), MERROR_SEVERITY, Pstmt,
         null (), SERROR_CONTROL, (error_control_table.message (Nerror)),
         (error_control_table.brief_message (Nerror)), Arg1, Arg2);

    compdv_severity_ =
         max (compdv_severity_, error_control_table.severity (Nerror));
  end ERROR_;

/**** +++[Syntax Function]++++++++ FAM_MEM +++++++++++++++++++++++++++++++++ */

fam_mem:
  proc returns (bit (1) aligned);

    if token.quoted_string		/* quoted string?		       */
         | token_value = "SELF"	/* the reserved word?	       */
    then return ("0"b);		/* any of these, return false	       */
				/* extract the first name */
    font_fam = before (token_value, "/");
    if font_fam = ""		/* no family given */
    then return ("0"b);		/**/
				/* extract possible second name */
    font_mem = after (token_value, "/");/* invalid names? */
    if (verify (font_fam, az_AZ09) ^= 0) | (verify (font_mem, az_AZ09) ^= 0)
         | (search (font_fam, "0123456789_") = 1)
         | (search (font_mem, "0123456789_") ^= 0)
    then return ("0"b);

    if (index (token_value, "/") ^= 0)
    then
      do;
        font_mem = "/" || rtrim (font_mem);
        font_fam = translate (font_fam, az, AZ);
        font_mem = translate (font_mem, az, AZ);
      end;

    if dt_sw
    then call ioa_$nnl ("<fam_mem>");

    return ("1"b);

  end fam_mem;

/**** +++[Syntax Function]++++++++ FAM_BACH ++++++++++++++++++++++++++++++++ */

fam_bach:
  proc returns (bit (1) aligned);

    dcl i		   fixed bin;
    dcl name	   char (32);

    if token.quoted_string		/* quoted string?		       */
         | token_value = "SELF"	/* the reserved word?	       */
    then return ("0"b);		/* any of these, return false	       */
				/* invalid names? */
    if (verify (token_value, az_AZ09) ^= 0)
         | (search (token_value, "0123456789_") = 1)
    then return ("0"b);

    if ^bach_sw
    then name = translate (token_value, az, AZ);
    else name = token_value;

    do i = 1 to comp_dvt.family_ct;
      if name = comp_dvt.family (i).name
      then
        do;
	call ERROR (duplicate_font_name);
	return ("0"b);
        end;
    end;

    if dt_sw
    then call ioa_$nnl ("<fam_bach>");

    return ("1"b);

  end fam_bach;

/**** +++[Function]++++++++++++++ FIND_FONT ++++++++++++++++++++++++++++++++ */

find_font:
  proc (create) returns (ptr);

/* PARAMETERS */

    dcl create	   bit (1);	/* 1 = font is to be created */

/* LOCAL STORAGE */

    dcl tp	   ptr;
    dcl fname	   char (32);

    if db_sw
    then call ioa_ ("===find_font");

    fname = token_value;
    if token_value = "SELF"		/* can't use "SELF" as a font name */
         | token.quoted_string	/* can't be a literal */
         | octal_ ()		/* or an octal value */
         | num ()			/* or a numeric */
    then
      do;
        if create
        then goto bad_news;
        return (null ());
      end;			/* go thru all defined fonts	       */
    do tp = fntl_p (1) repeat (tp -> fnt.next) while (tp ^= null ());
      if tp -> fnt.name = token_value	/* is this the one we want?	       */
      then return (tp);		/*  YES, return its addr	       */
    end;

    if ^create			/* not found; if not creating	       */
    then return (null);		/* return a null value	       */

    if ^ident_ ()			/* but must be a legal name	       */
    then
      do;
bad_news:
        call ERROR (not_valid_Font_name);
        fname = "";			/* supply something		       */
      end;

    if (font_count > 0)
    then area_free_p = addr_inc (oput_p, size (oput));
    tp = area_free_p;
    area_free_p = addr (tp -> fnt.dummy);
    font_count = font_count + 1;	/* record new font info */
    call link (fntl_p, tp);
    tp -> fnt.name = fname;		/* fill in the internal font name    */
    tp -> fnt.refno = font_count;	/*  and the reference #	       */
    tp -> fnt.node = Ptoken;		/* keep statement ptr for error msgs */
    tp -> fnt.pt = null ();		/* no table started yet	       */

    return (tp);			/* return the new addr	       */

  end find_font;

/**** +++[Function]+++++++++++++++ FIND_STR ++++++++++++++++++++++++++++++++ */
/*							       */
/* Finds the location of a string in a string table. If the string is not    */
/* in the table, then it is entered.				       */

find_str:
  proc (which) returns (ptr);

    dcl which	   fixed bin;	/* 1- temporary string area	       */
				/* 2- DSM string area	       */

    dcl i		   fixed bin;

    if dt_sw
    then call ioa_$nnl ("`^a'", the_string);
    if (string_l (which) > 0) & (length (the_string) = 0)
    then
      do;
        if dt_sw
        then call ioa_ ("--is ^i,1", which);
        return (strl_p (which, 1));
      end;


    do i = 1 to string_l (which);
      str_p = strl_p (which, i);
      if (length (bstr.str) = length (the_string))
      then if (bstr.str = the_string)
	 then
	   do;
	     if dt_sw
	     then call ioa_ ("--found ^i,^i", which, i);
	     return (str_p);
	   end;
    end;
    str_p = next_str_p;
    bstr.leng = length (the_string);
    bstr.str = the_string;
    string_l (which), i = string_l (which) + 1;
    strl_p (which, i) = str_p;
    next_str_p = addr (bstr.dummy);
    if dt_sw
    then call ioa_ ("--new ^i,^i", which, i);
    return (strl_p (which, i));

  end find_str;

/**** +++[Syntax Function]+++++++ FONT_NAME ++++++++++++++++++++++++++++++++ */
/*							       */
/* Test for token being a defined fontname.			       */

font_name:
  proc returns (bit (1) aligned);

    the_font = find_font ("0"b);
    if the_font ^= null ()
    then
      do;
        if dt_sw
        then call ioa_$nnl ("<font_name>");
        return ("1"b);
      end;
    the_font = fntl_p (1);		/* fill in a value so program will   */
				/*  keep running		       */
    return ("0"b);

  end font_name;

/**** +++[Syntax Function]++++++ IDENT/IDENT2 ++++++++++++++++++++++++++++++ */
/*							       */
/* check for legal <name> string				       */

ident:
  proc returns (bit (1) aligned);

    ldt_sw = dt_sw;
    goto start;

ident2:
  entry returns (bit (1) aligned);

    ldt_sw = dt_sw;
    if (token.Lvalue = 1)
    then return ("0"b);
    goto start;

ident_:
  entry returns (bit (1) aligned);

    ldt_sw = "0"b;			/* never db displays */

    dcl ldt_sw	   bit (1);

start:
    if token.quoted_string		/* quoted string?		       */
         | token_value = "SELF"	/* the reserved word?	       */
         | verify (token_value, az_AZ09) ^= 0
				/* non-(alphanumeric or _)?    */
    then return ("0"b);		/* any of these, return false	       */

    if (index ("0123456789_", substr (token_value, 1, 1)) ^= 0)
    then return ("0"b);
    if ldt_sw
    then call ioa_$nnl ("<ident>");
    return ("1"b);			/* must not have leading number or _ */
  end ident;

/**** +++[Syntax Function]++++ INPUT/ALL_INPUT +++++++++++++++++++++++++++++ */
/*							       */
/* Tests for token being a single char in either octal or quoted form.       */
/* ALL_INPUT also checks for a whole slew of builtin char names.	       */
/* SETS:	Input - 9-bit char value which results			       */

input:
  proc returns (bit (1) aligned);

    dcl which	   char (12);
    dcl ldt_sw	   bit (1);

    which = "<input>";
    ldt_sw = dt_sw;
    goto some;

input_:
  entry returns (bit (1) aligned);

    ldt_sw = "0"b;			/* never db displays */
    goto some;

all_input:
  entry returns (bit (1) aligned);

    which = "<all_input>";
    ldt_sw = dt_sw;

    if (token_value = "EM")
    then Input = EM;

    else if (token_value = "EN")
    then Input = EN;

    else if (token_value = "THICK")
    then Input = THICK;

    else if (token_value = "MEDIUM")
    then Input = MEDIUM;

    else if (token_value = "THIN")
    then Input = THIN;

    else if (token_value = "HAIR")
    then Input = HAIR;

    else if (token_value = "DEVIT")
    then Input = DEVIT;

    else if (token_value = "STROKE")
    then Input = STROKE;

    else if (token_value = "EM-")
    then Input = EMdash;

    else if (token_value = "EN-")
    then Input = ENd;

    else if (token_value = "EM_")
    then Input = EM_;
    else if (token_value = "EN_")
    then Input = EN_;
    else if (token_value = "^0")
    then Input = sup0;
    else if (token_value = "^1")
    then Input = sup1;
    else if (token_value = "^2")
    then Input = sup2;
    else if (token_value = "^3")
    then Input = sup3;
    else if (token_value = "^4")
    then Input = sup4;
    else if (token_value = "^5")
    then Input = sup5;
    else if (token_value = "^6")
    then Input = sup6;
    else if (token_value = "^7")
    then Input = sup7;
    else if (token_value = "^8")
    then Input = sup8;
    else if (token_value = "^9")
    then Input = sup9;
    else if (token_value = "''")
    then Input = rquote;
    else if (token_value = "``")
    then Input = lquote;
    else if (token_value = "PS")
    then Input = PS;
    else if (token_value = "lslnt")
    then Input = lslnt;
    else if (token_value = "vrule")
    then Input = vrule;
    else if (token_value = "bullet")
    then Input = bullet;
    else if (token_value = "cright")
    then Input = cright;
    else if (token_value = "modmark")
    then Input = modmark;
    else if (token_value = "delmark")
    then Input = delmark;
    else if (token_value = "multiply")
    then Input = multiply;
    else if (token_value = "nabla")
    then Input = nabla;
    else if (token_value = "pl_mi")
    then Input = pl_mi;
    else
some:
         if token.quoted_string
    then
      do;
        if token.Lvalue ^= 1
        then return ("0"b);
        Input = token_value;
      end;
    else if ^octal_ ()
    then return ("0"b);
    if ldt_sw
    then call ioa_$nnl ("^a", which);
    return ("1"b);

  end input;

/**** +++[Syntax Function]+++++++ IS_DEFNAME +++++++++++++++++++++++++++++++ */
/*							       */
/* Tests for a token being a defined Defname.			       */
/* SETS:	token.Nvalue - index of the found Defname		       */

is_Defname:
  proc returns (bit (1) aligned);

    do i = 1 to Def.count;
      if (Def.name (i) = token_value)
      then
        do;
	token.Nvalue = i;
	if dt_sw
	then call ioa_$nnl ("<is_Defname>");
	return ("1"b);
        end;
    end;
    return ("0"b);

  end is_Defname;

/**** +++[Syntax Function]++++++ IS_VIEWNAME +++++++++++++++++++++++++++++++ */
/*							       */
/* Tests for token being a defined viewname.			       */
/* SETS:	token.Nvalue - index of the found viewname		       */

is_viewname:
  proc returns (bit (1) aligned);

    do i = 1 to view.count;
      if (view.name (i) = token_value)
      then
        do;
	token.Nvalue = i;
	if dt_sw
	then call ioa_$nnl ("<is_viewname>");
	return ("1"b);
        end;
    end;
    return ("0"b);

  end is_viewname;

/**** +++[Procedure]++++++++++++++++ LINK ++++++++++++++++++++++++++++++++++ */
/*							       */
/* link an element to end of a list				       */

link:
  proc (l_p, e_p);
    dcl l_p	   (2) ptr,	/* begin/end list ptrs	       */
        e_p	   ptr;		/* element to be linked	       */

    dcl next	   ptr based (e_p); /* first word of element -> next     */

    if (l_p (1) = null ())
    then l_p (*) = e_p;		/* initialize list		       */
    else
      do;
        l_p (2) -> next = e_p;	/* last one points to this one       */
        l_p (2) = e_p;		/* this one is now last	       */
      end;
    next = null ();			/* this one points nowhere	       */

  end link;

/**** +++[Syntax Function]+++++++ MEDIANAME ++++++++++++++++++++++++++++++++ */
/*							       */
/* Test for the token being a defined medianame			       */
/* SETS: token.Nvalue - the index of the found medianame		       */

medianame:
  proc returns (bit (1) aligned);

    dcl i		   fixed bin;

    if ^ident_ ()
    then return ("0"b);
    do i = 1 to media.count;
      if (media.name (i) = token_value)
      then
        do;
	token.Nvalue = i;
	if dt_sw
	then call ioa_$nnl ("<medianame>");
	return ("1"b);
        end;
    end;
    return ("0"b);

  end medianame;

/**** +++[Syntax Function]+++++++ MEMBERNAME +++++++++++++++++++++++++++++++ */

membername:
  proc returns (bit (1) aligned);

    dcl i		   fixed bin;

    if (substr (token_value, 1, 1) ^= "/")
    then return ("0"b);
    if (token.Lvalue > 32)
    then return ("0"b);
    if (token.Lvalue > 1)
    then
      do;
        if (index ("0123456789", substr (token_value, 2, 1)) ^= 0)
        then return ("0"b);
        if (verify (substr (token_value, 2), az_AZ09) ^= 0)
        then return ("0"b);
      end;
    if dt_sw
    then call ioa_$nnl ("<membername>");
    return ("1"b);

  end membername;

/**** +++[Syntax Function]+++++++++ NEGNUM +++++++++++++++++++++++++++++++++ */
/*							       */
/* Tests token for being a negative number			       */

negnum:
  proc returns (bit (1) aligned);	/* check negative decimal value */

    if (substr (token_value, 1, 1) ^= "-")
				/* must start with - sign       */
    then return ("0"b);
    if (token_value = "-.")		/* just in case they throw a curve   */
    then return ("0"b);
    if (verify (substr (token_value, 2), "0123456789.") ^= 0)
				/* and have  */
    then return ("0"b);		/* only legal decimal chars &	       */
    if (index (after (token_value, "."), ".") ^= 0)
				/* only 1 decimal pt  */
    then return ("0"b);
    if dt_sw
    then call ioa_$nnl ("<negnum>");
    token.Nvalue = convert (token.Nvalue, token_value);
    return ("1"b);

  end negnum;

/**** +++[Syntax Function]+++++++ NUM/LIMIT ++++++++++++++++++++++++++++++++ */
/*							       */
/* Tests token for being UNLIMITED or being a number		       */
/* Tests token for being a number				       */

limit:
  proc returns (bit (1) aligned);

    if (token_value = "unlimited")
    then
      do;
        token.Nvalue = -1;
        return ("1"b);
      end;

num:
  entry returns (bit (1) aligned);	/* check decimal value */

    if token_value = "."
    then return ("0"b);
    if verify (token_value, "0123456789.") ^= 0
				/* legal decimal chars */
    then return ("0"b);

    if (index (after (token_value, "."), ".") ^= 0)
				/* only 1 dec pt */
    then return ("0"b);
    if dt_sw
    then call ioa_$nnl ("<num>");
    token.Nvalue = convert (token.Nvalue, token_value);
    return ("1"b);

  end limit;

/**** +++[Syntax Function]+++++++++ OCTAL ++++++++++++++++++++++++++++++++++ */
/*							       */
/* Tests token for being an octal character representation		       */
/* SETS:	Input - 9-bit char gotten by converting the 3 octal digits	       */

octal:
  proc returns (bit (1) aligned);

    ldt_sw = dt_sw;
    goto start;

octal_:
  entry returns (bit (1) aligned);

    ldt_sw = "0"b;			/* never db displays */

    dcl ldt_sw	   bit (1);
    dcl 1 bits	   (3) unal,	/* copy of the 3 token chars as bits */
	2 f	   bit (6),
	2 b	   bit (3);

start:
    if token.Lvalue ^= 3		/* if token is not exactly 3 chars */
    then return ("0"b);		/* it can't be octal */

    if verify (token_value, "01234567") ^= 0
				/* it can't have any chars */
    then return ("0"b);		/* outside the octal range */

    string (bits) = unspec (token_value);
				/* copy token into structure */
    unspec (Input) = b (1) || b (2) || b (3);
				/* convert octal to binary */
    if ldt_sw
    then call ioa_$nnl ("<octal>");
    return ("1"b);

  end octal;

/**** +++[Procedure]+++++++++++++ OUTPUTTER ++++++++++++++++++++++++++++++++ */
/*							       */
/* Outputs the whole schmeer to an alm source file.		       */
/* USES:	most everything of value				       */

outputter:
  proc;

    dcl addname	   bit (1);	/* 1 = table name is an addname      */
/**** format: off */
dcl bitname	(0:511) char (16)	/* char names for tables	       */
		int static options (constant) init
  ("000", "001", "002", "003", "004", "005", "006", "007", "010 BSP", "011 HT",
   "012 NL", "013 VT", "014 FF", "015 CR", "016", "017", "020", "021 ctl-str",
   "022", "023", "024", "025", "026", "027", "030", "031", "032", "033 ESC",
   "034", "035", "036", "037", "040 SP", "041 !", "042 """, "043 #", "044 $",
   "045 %", "046 &", "047 '", "050 Lp", "051 Rp", "052 *", "053 +", "054 ,",
   "055 -", "056 .", "057 /", "060 0", "061 1", "062 2", "063 3", "064 4",
   "065 5", "066 6", "067 7", "070 8", "071 9", "072 :", "073 ;", "074 <",
   "075 =", "076 >", "077 ?", "100 @", "101 A", "102 B", "103 C", "104 D",
   "105 E", "106 F", "107 G", "110 H", "111 I", "112 J", "113 K", "114 L",
   "115 M", "116 N", "117 O", "120 P", "121 Q", "122 R", "123 S", "124 T",
   "125 U", "126 V", "127 W", "130 X", "131 Y", "132 Z", "133 [", "134 \",
   "135 ]", "136 ^", "137 _", "140 `", "141 a", "142 b", "143 c", "144 d",
   "145 e", "146 f", "147 g", "150 h", "151 i", "152 j", "153 k", "154 l",
   "155 m", "156 n", "157 o", "160 p", "161 q", "162 r", "163 s", "164 t",
   "165 u", "166 v", "167 w", "170 x", "171 y", "172 z", "173 {", "174 |",
   "175 }", "176 ~", "177 PAD", "200", "201", "202", "203", "204", "205",
   "206", "207", "210", "211", "212", "213", "214", "215", "216", "217",
   "220", "221", "222", "223", "224", "225", "226", "227", "230", "231",
   "232", "233", "234", "235", "236", "237", "240", "241", "242", "243",
   "244", "245", "246", "247", "250", "251", "252 mlpy", "253 +_", "254 nabla",
   "255 EMdash", "256", "257 slash", "260", "261 dagger", "262", "263", "264",
   "265", "266", "267", "270", "271", "272", "273 _|", "274", "275 /=", "276",
   "277", "300", "301 dbl dagger", "302", "303 copyright", "304 delta", "305",
   "306", "307", "310", "311", "312", "313", "314", "315 bullet", "316||",
   "317", "320 PI", "321", "322", "323", "324", "325", "326 therefore", "327",
   "330", "331", "332 = ", "333", "334", "335", "336", "337 infinity", "340",
   "341", "342", "343", "344", "345", "346", "347", "350", "351", "352 theta",
   "353", "354", "355", "356", "357", "360 pi", "361", "362", "363", "364",
   "365", "366", "367", "370", "371", "372", "373", "374", "375 square",
   "376 overbar", "377 punct SP", "400 superior 0", "401 superior 1",
   "402 superior 2", "403 superior 3", "404 superior 4", "405 superior 5",
   "406 superior 6", "407 superior 7", "410 superior 8", "411 superior 9",
   "412 EM", "413 EM _dash", "414 EN", "415 EN _dash", "416 EN dash",
   "417 thin space", "420", "421 ``", "422 ''", "423 1hi X", "424",
   "425 v|", "426", "427 dia left", "430 delete mark", "431 dia right",
   "432 dia top", "433 <", "434 1hi {", "435 1hi [", "436 left circle", "437",
   "440 ->", "441 1hi }", "442 1hi ]", "443 right circle", "444", "445 ^|",
   "446", "447", "450", "451", "452", "453", "454", "455", "456", "457",
   "460", "461", "462", "463", "464", "465", "466", "467", "470", "471",
   "472", "473", "474", "475", "476", "477", "500", "501", "502", "503",
   "504", "505", "506", "507", "510", "511", "512", "513", "514", "515",
   "516", "517", "520", "521", "522", "523", "524", "525", "526", "527",
   "530", "531", "532", "533", "534", "535", "536", "537", "540", "541",
   "542", "543", "544", "545", "546", "547", "550", "551", "552", "553",
   "554", "555", "556", "557", "560", "561", "562", "563", "564", "565",
   "566", "567", "570", "571", "572", "573", "574", "575", "576", "577",
   "600", "601", "602", "603", "604", "605", "606", "607", "610", "611",
   "612", "613", "614", "615", "616", "617", "620", "621", "622", "623",
   "624", "625", "626", "627", "630", "631", "632", "633", "634", "635",
   "636", "637", "640", "641", "642", "643", "644", "645", "646", "647",
   "650", "651", "652", "653", "654", "655", "656", "657", "660", "661",
   "662", "663", "664", "665", "666", "667", "670", "671", "672", "673",
   "674", "675", "676", "677", "700", "701", "702", "703", "704", "705",
   "706", "707", "710", "711", "712", "713", "714", "715", "716", "717",
   "720", "721", "722", "723", "724", "725", "726", "727", "730", "731",
   "732", "733", "734", "735", "736", "737", "740", "741", "742", "743",
   "744", "745", "746", "747", "750", "751", "752", "753", "754", "755",
   "756", "757", "760", "761", "762", "763", "764", "765", "766", "767",
   "770", "771", "772", "773", "774", "775", "776", "777");
/**** format:  on */

    dcl (i, j)	   fixed bin;	/* working index */
    dcl oct_p	   ptr;
    dcl jjj	   fixed bin;
    dcl 1 oct	   based,
	2 ct	   fixed bin (35),
	2 e	   (o_s) fixed bin (35);
    dcl o_s	   fixed bin;
    dcl out	   entry automatic options (variable);
    out = ioa_$ioa_switch;		/* to shrink the line size below     */

/* This writes things in this sequence:				       */
/*  1)  "include compdv"					       */
/*  2)  ({comp_dvid} segdef's)'s				       */
/*  3)  (comp_dvt member's med_sel)'s				       */
/*  4)  font's						       */
/*  5)  sizel's						       */
/*  6)  strings ...						       */
/*  7)  "end"						       */

    if db_sw
    then call ioa_ ("===outputter");

    call out (ALM, "^-include^-compdv");

    do dvid_p = dvidl_p (1) repeat (dvid.next) while (dvid_p ^= null ());
      if dvid.real
      then
        do;
	call out (ALM, "^/dvid.^i:", dvid.ndx);
	call out (ALM, "^-dvid.version^-^i", comp_dvid_version);
	call out (ALM, "^-dvid.devname^-^a,^i", dvid.devname,
	     length (dvid.devname));
	call out (ALM, "^-dvid.dvt_r^-dvt.^i", dvid.dvt_ndx);
        end;
      call out (ALM, "^/^-dvid_segdef^-^i,^a", dvid.ndx, dvid.refname);
    end;

    do dvt_p = dvtl_p (1) repeat (dvt.next) while (dvt_p ^= null ());
      prent_p = dvt.prent;
      const.devptr = dvt.ref;
      call out (ALM, "^-even^/dvt.^i:", dvt.ndx);
      call out (ALM, "^-dvt.devclass^-^a,^i", comp_dvt.devclass,
	 length (comp_dvt.devclass));
      call out (ALM, "^-dvt.outproc^-^a", prent.outproc);
      call out (ALM, "^-dvt.footproc^-^a", prent.footproc);
      call out (ALM, "^-dvt.artproc^-^a", prent.artproc);
      call out (ALM, "^-dvt.displayproc^-^a", DisplayProc || "$display");
      call out (ALM, "^-dvt.min_WS^-^i", comp_dvt.min_WS);
      call out (ALM, "^-dvt.min_lead^-^i", comp_dvt.min_lead);
      call out (ALM, "^-dvt.vmt_min^-^i", comp_dvt.vmt_min);
      call out (ALM, "^-dvt.vmb_min^-^i", comp_dvt.vmb_min);
      call out (ALM, "^-dvt.def_vmt^-^i", comp_dvt.def_vmt);
      call out (ALM, "^-dvt.def_vmh^-^i", comp_dvt.def_vmh);
      call out (ALM, "^-dvt.def_vmf^-^i", comp_dvt.def_vmf);
      call out (ALM, "^-dvt.def_vmb^-^i", comp_dvt.def_vmb);
      call out (ALM, "^-dvt.pdw_max^-^i", comp_dvt.pdw_max);
      call out (ALM, "^-dvt.pdl_max^-^i", comp_dvt.pdl_max);
      call out (ALM, "^-dvt.upshift^-^i", comp_dvt.upshift);
      call out (ALM, "^-dvt.init_ps^-^i", comp_dvt.init_ps);
      call out (ALM, "^-dvt.lettersp^-^i", comp_dvt.lettersp);
      call out (ALM, "^-dvt.max_pages^-^i", comp_dvt.max_pages);
      call out (ALM, "^-dvt.max_files^-^i", comp_dvt.max_files);
      call out (ALM, "^-dvt.init_fam^-^i", comp_dvt.init_fam);
      call out (ALM, "^-dvt.init_mem^-^i", comp_dvt.init_mem);
      call out (ALM, "^-dvt.foot_fam^-^i", comp_dvt.foot_fam);
      call out (ALM, "^-dvt.foot_mem^-^i", comp_dvt.foot_mem);
      call out (ALM, "^-dvt.init_family^-^a,^i", comp_dvt.init_family,
	 length (comp_dvt.init_family));
      call out (ALM, "^-dvt.init_member^-^a,^i", comp_dvt.init_member,
	 length (comp_dvt.init_member));
      call out (ALM, "^-dvt.atd_r^2-^a", fmt_str_r (comp_dvt.atd_r));
      call out (ALM, "^-dvt.dvc_r^2-dvc^.3b", comp_dvt.dvc_r);
      call out (ALM, "^-dvt.comment_r^-^a", fmt_str_r (comp_dvt.comment_r));
      call out (ALM, "^-dvt.cleanup_r^-^a", fmt_str_r (comp_dvt.cleanup_r));
      call out (ALM, "^-dvt.medsel_table_r^-med_sel.^d", dvt.ndx);
      call out (ALM, "^-dvt.foot_family^-^a,^i", comp_dvt.foot_family,
	 length (comp_dvt.foot_family));
      call out (ALM, "^-dvt.foot_member^-^a,^i", comp_dvt.foot_member,
	 length (comp_dvt.foot_member));
      call out (ALM, "^-dvt.sws^2-^w", string (comp_dvt.sws));
      call out (ALM, "^-dvt.open_mode^-.^[str^;seq^]_out.",
	 (comp_dvt.open_mode = 2));
      call out (ALM, "^-dvt.recleng^-^i", comp_dvt.recleng);
      call out (ALM, "^-dvt.family_ct^-^i", comp_dvt.family_ct);

      do family_i = 1 to comp_dvt.family_ct;
        mem_p = ptr (area1_p, comp_dvt.family (family_i).member_r);
        call out (ALM, "^-dvt..member_r^-mem.^d", mem.refno);
        call out (ALM, "^-dvt..name^2-^a,^i", comp_dvt.family (family_i).name,
	   32);
      end;

      call out (ALM, "^/med_sel.^i:", dvt.ndx);
      call out (ALM, "^-med_sel_tab.count^-^i", view.count);
      do med_sel_i = 1 to view.count;
        call out (ALM, "^-med_sel_tab..ref_r^-^a^-^i",
	   fmt_str_r (med_sel_tab.ref_r (med_sel_i)), med_sel_i);
      end;
    end;

    do mem_p = meml_p (1) repeat (mem.next) while (mem_p ^= null ());
      if mem.refno = mem.seqno
      then
        do;
	member_ptr = mem.ref_p;
	call out (ALM, "mem.^d:", mem.seqno);
	call out (ALM, "^-member.count^-^i", member.count);
	do mem_i = 1 to member.count;
	  fnt_p = ptr (area2_p, member.font_r (mem_i));
	  call out (ALM, "^-member..font_r^-f.^i", fnt.refno);
	  call out (ALM, "^-member..size_r^-size.^i",
	       addr (member.size_r (mem_i)) -> bfb);
	  call out (ALM, "^-member..Scale^-^i,^i", member.Scalex (mem_i),
	       member.Scaley (mem_i));
	  call out (ALM, "^-member..name^-^a,^i", member.name (mem_i),
	       length (member.name (mem_i)));
	end;
        end;
    end;

    call out (ALM, "^|");		/* eject page before fonts	       */
    do fnt_p = fntl_p (1) repeat (fnt.next) while (fnt_p ^= null ());
      font_ptr = fnt.pt;
      uni_p = ptr (fnt.pt, font.units_r);
      opu_p = ptr (fnt.pt, font.oput_r);
      call out (ALM, "f.^i:^2-""^a", fnt.refno, fnt.name);
      call out (ALM, "^-font.oput_r^-opu.^i", opu.refno);
      call out (ALM, "^-font.units_r^-uni.^i", uni.refno);
      call out (ALM, "^-font.rel_units^-^i", font.rel_units);
      call out (ALM, "^-font.footsep^-(^1a)", font.footsep);
      call out (ALM, "^-font.fill^-   ");
      call out (ALM, "^-font.min_wsp^-^i", font.min_wsp);
      call out (ALM, "^-font.avg_wsp^-^i", font.avg_wsp);
      call out (ALM, "^-font.max_wsp^-^i", font.max_wsp);
    end;

    do uni_p = unil_p (1) repeat (uni.next) while (uni_p ^= null ());
      if uni.refno = uni.seqno
      then
        do;
	call out (ALM, "uni.^i:", uni.seqno);
	units_ptr = uni.ref_p;
	mediawidth = units (0);
	dup_ct = 1;
	do i = 1 to 511;
	  if (mediawidth = units (i))
	  then dup_ct = dup_ct + 1;
	  else
	    do;
	      call out (ALM, "^-units (^i),^[0^;^i^]", dup_ct,
		 (mediawidth = nulwidth), mediawidth);
	      mediawidth = units (i);
	      dup_ct = 1;
	    end;
	end;
	call out (ALM, "^-units (^i),^[0^;^i^]", dup_ct,
	     (mediawidth = nulwidth), mediawidth);
        end;
    end;

    do opu_p = opul_p (1) repeat (opu.next) while (opu_p ^= null ());
      if opu.refno = opu.seqno
      then
        do;
	call out (ALM, "opu.^i:", opu.seqno);
	oput_p = opu.ref_p;
	call out (ALM, "^-oput.data_ct^-^i", oput.data_ct);
	skip_ct = 0;
	do i = 0 to oput.data_ct;
	  if (oput.what_r (i) = "0"b)
	  then skip_ct = skip_ct + 1;
	  else
	    do;
	      if (skip_ct > 0)
	      then call out (ALM, "^-no_ch (^i)", skip_ct);
	      skip_ct = 0;
	      call out (ALM, "^-ch    ^i,^a  [^[null^s^;^i^]]^-^a",
		 oput.which (i), fmt_str_r ((oput.what_r (i))),
		 (units (i) = nulwidth), units (i), bitname (i));
	    end;
	end;
        end;
    end;

    do i = 1 to size_list.count;
      sizel_p = size_list.pt (i);
      call out (ALM, "^/size.^i:", i);
      call out (ALM, "^-sizel.val_ct^-^i", sizel.val_ct);
      do j = 1 to sizel.val_ct;
        call out (ALM, "^-sizel..val^-^d", sizel.val (j));
      end;
    end;

    call out (ALM, "^/.nul_str.:^-zero");
    do j = 2 to string_l (2);
      oct_p = strl_p (2, j);
      o_s = divide (oct_p -> bstr.leng + 3, 4, 17, 0);
      if j = 2
      then call out (ALM, "^/str:^-dec^-^d", oct_p -> oct.ct);
      else call out (ALM, "^/^-dec^-^d^2-^a", oct_p -> oct.ct,
	      fmt_str_r (rel (oct_p)));
      do jjj = 1 to o_s;
        call out (ALM, "^-oct^-^w^-^a", oct_p -> oct.e (jjj),
	   fmt_str_cmt (oct_p -> oct.e (jjj),
	   oct_p -> oct.ct - 4 * (jjj - 1)));
      end;
    end;

    call out (ALM, "^/^-end");

  end outputter;

/**** +++ OUTPUTTER UTILITY:  FMT_STR_CMT ++++++++++++++++++++++++++++++++++ */

fmt_str_cmt:
  proc (Oct, Len) returns (char (4) aligned);

    dcl Oct	   fixed bin (35);
    dcl Len	   fixed bin;
    dcl idx	   fixed bin;
    dcl str	   char (4) aligned;

    unspec (str) = unspec (Oct);
    if Len < 4
    then substr (str, Len + 1) = "";

    do idx = 1 to min (4, Len);
      if substr (str, idx, 1) = ";"
	 | rank (substr (str, idx, 1)) < rank (" ")
	 | rank (substr (str, idx, 1)) > rank ("~")
      then substr (str, idx, 1) = ".";
    end;

    return (str);

  end fmt_str_cmt;

/**** +++ OUTPUTTER UTILITY: FMT_STR_R +++++++++++++++++++++++++++++++++++++ */

fmt_str_r:
  proc (Rel) returns (char (9));

    dcl Rel	   bit (18) aligned;
    dcl pic	   picture "99999";

    if Rel = ""b
    then return (".no_repl.");

    if Rel = rel (strl_p (2, 1))
    then return (".nul_str.");

    pic = binary (Rel, 18) - wordno (strl_p (2, 2));
    return ("str+" || pic);

  end fmt_str_r;

/**** +++[Syntax Function]++++++++++ PART ++++++++++++++++++++++++++++++++++ */

part:
  proc returns (bit (1) aligned);

/**** format:  off */
dcl art_tokens	char (388) init	/* token string */
   ("[   ]   {   }   (   )   |   ||  o   /   X   d   m   \   c   t   " ||
    "v   ^   <-  ->  D^  D<  D>  Dv  Clf Crt -str-rul-stp|rul/rul\rul" ||
    "[tp ]tp {tp }tp lptprptp|tp ||tp[ht ]ht {ht }ht lphtrpht|ht ||ht" ||
    "[md ]md {md }md lpmdrpmd|md ||md[hb ]hb {hb }hb lphbrphb|hb ||hb" ||
    "[bt ]bt {bt }bt lpbtrpbt|bt ||bt[fl ]fl {fl }fl lpflrpfl|fl ||fl" ||
    "PI  pi  bxtlbxt bxtrbxl bxx bxr bxblbxb bxbrlztllztrlzl lzr lzbllzbr");
dcl art_codes	(97) char (1) init	/* codes */
  (art.one (1), art.one (2), art.one (3), art.one (4), art.one (5),
   art.one (6), art.one (7), art.one (8), art.one (9), art.one (10),
   art.one (11), art.one (12), art.one (13), art.lslnt, cright, tmark,
   art.daro, art.uparo, art.laro, art.raro, art.diam.top, art.diam.lvert,
   art.diam.rvert, art.diam.bottom, art.lcirc, art.rcirc, art.horiz.start,
   art.horiz.line, art.horiz.term, art.vpart, art.rslnt, art.lslnt,
   art.top (1), art.top (2), art.top (3), art.top (4), art.top (5),
   art.top (6), art.top (7), art.top (8), art.half_top (1), art.half_top (2),
   art.half_top (3), art.half_top (4), art.half_top (5), art.half_top (6),
   art.half_top (7), art.half_top (8), art.middle (1), art.middle (2),
   art.middle (3), art.middle (4), art.middle (5), art.middle (6),
   art.middle (7), art.middle (8), art.half_bottom (1), art.half_bottom (2),
   art.half_bottom (3), art.half_bottom (4), art.half_bottom (5),
   art.half_bottom (6), art.half_bottom (7), art.half_bottom (8),
   art.bottom (1), art.bottom (2), art.bottom (3), art.bottom (4),
   art.bottom (5), art.bottom (6), art.bottom (7), art.bottom (8),
   art.other_part (1), art.other_part (2), art.other_part (3),
   art.other_part (4), art.other_part (5), art.other_part (6),
   art.other_part (7), art.other_part (8), art.PI, art.pi,
   art.box.tl, art.box.t, art.box.tr, art.box.l, art.box.x, art.box.r, 
   art.box.bl, art.box.b, art.box.br, art.loz.tl, art.loz.tr,
   art.loz.l, art.loz.r, art.loz.bl, art.loz.br);
/**** format:  on */

    dcl i		   fixed bin;	/* working index */
    dcl part_token	   char (4);	/* token expanded to 4 chars */

    part_token = token_value;		/* copy the token */

    i = index (art_tokens, part_token); /* scan art tokens */
    if i > 0			/* found? */
    then
      do;
        i = divide (i, 4, 17, 0) + 1;	/* calculate code index */
        Input = art_codes (i);	/* fetch the code */
        if dt_sw
        then call ioa_$nnl ("<part>");
        return ("1"b);		/* return true */
      end;

    else return ("0"b);
  end part;

/**** +++[Debug Routine]+++++++++ PUSH/POP +++++++++++++++++++++++++++++++++ */
/*							       */

    dcl Stack	   (20) char (16);


/**** +++[Function]++++++++++++++ SCALE_UNIT +++++++++++++++++++++++++++++++ */
/*							       */
/* convert units to millipoints				       */

scale_unit:
  proc (the_scale) returns (fixed bin (31));

    dcl the_scale	   fixed bin (31);
    dcl (pi, pt)	   char (10);

    if (the_scale > 0)		/* not pica/point form	       */
    then return (the_scale * bin (before (token_value, "."))
	    +
	    divide (the_scale
	    * bin (substr (after (token_value, ".") || "000", 1, 3)), 1000,
	    17, 0));

    return (hscales (5) * bin (before (token_value, "."))
         + hscales (6) * bin (after (token_value, ".")));

  end scale_unit;

/**** +++[Syntax Function]++++++++ SIZENAME ++++++++++++++++++++++++++++++++ */

sizename:
  proc returns (bit (1) aligned);

    dcl i		   fixed bin;

    do i = 1 to size_list.count;	/* scan sizetable names */
      if size_list.name (i) = token_value
      then
        do;
	token.Nvalue = i;		/* set index value */
	if dt_sw
	then call ioa_$nnl ("<sizename>");
	return ("1"b);
        end;
    end;

    return ("0"b);
  end sizename;

/**** +++[Function]++++++++++++++ SHOW_NAME ++++++++++++++++++++++++++++++++ */
/*							       */
/* converts a MediaChar name into display form if needed.		       */
show_name:
  proc (str) returns (char (32));

    dcl str	   char (*);

    dcl bits	   (3) bit (3) unal;
    dcl bins	   (3) fixed bin (3) unsigned unal based (addr (bits));

    if (substr (str, 1, 1) ^= "[")
    then return (str);
    if (substr (str, 2, 1) > " ") & (substr (str, 2, 1) <= "~")
    then return ("""" || substr (str, 2, 1) || """");
    string (bits) = unspec (substr (str, 2, 1));
    return (substr ("01234567", bins (1) + 1, 1)
         || substr ("01234567", bins (2) + 1, 1)
         || substr ("01234567", bins (3) + 1, 1));

  end show_name;

/**** +++[Syntax Function]+++++++++ SWITCH +++++++++++++++++++++++++++++++++ */
/*							       */
/* check for on/off						       */
/* SETS:	token.Nvalue - 0 (off) 1 (on)				       */
switch:
  proc returns (bit (1) aligned);

    if token_value = "on"
    then token.Nvalue = 1;
    else if token_value = "off"
    then token.Nvalue = 0;
    else return ("0"b);
    if dt_sw
    then call ioa_$nnl ("<switch>");
    return ("1"b);

  end switch;

/**** +++[Syntax Function]+++++++ TABLE_NAME +++++++++++++++++++++++++++++++ */

table_name:
  proc returns (bit (1) aligned);

    dcl i		   fixed bin;	/* scan dvid list names */
    do dvid_p = dvidl_p (1) repeat (dvid.next) while (dvid_p ^= null ());
      if dvid.refname = token_value
      then
        do;
	if dvid.dvt_ndx = dvt_ct + 1
	then
	  do;
	    call ERROR (circular_Device_def);
	    return ("0"b);
	  end;
	token.Nvalue = dvid.dvt_ndx;	/* set index value		       */
	if dt_sw
	then call ioa_$nnl ("<table_name>");
	return ("1"b);
        end;
    end;
    return ("0"b);

  end table_name;

/**** +++[Syntax Function]++++++++ UNITKEY +++++++++++++++++++++++++++++++++ */

unitkey:
  proc returns (bit (1) aligned);

    dcl i		   fixed bin;	/* working index */
    dcl unit_key_list  (7) char (2)	/* list of Units keywords */
		   static options (constant)
		   init ("pi", "el", "in", "mm", "pc", "pt", "pp");

    do i = 1 to hbound (unit_key_list, 1)
         while (token_value ^= unit_key_list (i));
    end;

    if i > hbound (unit_key_list, 1)
    then
      do;
        call ERROR (inv_Units_keyword);
        return ("0"b);
      end;

    token.Nvalue = i;
    if dt_sw
    then call ioa_$nnl ("<unitkey>");
    return ("1"b);

  end unitkey;

/**** +++[Syntax Function]+++	VALID_DEVICE_NAME ++++++++++++++++++++++++++++ */
/*							       */
/* Test for token being a valid Device name, i.e. an <ident> which is not    */
/*  already defined as a Device name.				       */

valid_Device_name:
  proc returns (bit (1) aligned);

    if ^ident_ ()
    then return ("0"b);
    do dvid_p = dvidl_p (1) repeat (dvid.next) while (dvid_p ^= null ());
      if token_value = dvid.refname
      then
        do;
	call ERROR (dup_Device);
	return ("0"b);
        end;
    end;
    if dt_sw
    then call ioa_$nnl ("<valid_Device_name>");
    return ("1"b);

  end valid_Device_name;

/**** +++[Syntax Function]+++	VALID_MEDIA_NAME ++++++++++++++++++++++++++++ */
/*							       */
/* Test for token being a valid Media name, i.e. an <ident> which is not    */
/*  already defined as a Media name.				       */

valid_Media_name:
  proc returns (bit (1) aligned);

    if ^ident_ ()
    then return ("0"b);
    do i = 1 to media.count;
      if (media.name (i) = token_value)
      then
        do;
	call ERROR (dup_Media);
	return ("0"b);
        end;
    end;
    if dt_sw
    then call ioa_$nnl ("<valid_Media_name>");
    return ("1"b);

  end valid_Media_name;

save_unref:
    if "0"b
    then call a_debug;
    goto save_unref;

dbs:
  entry (xxxx);
    db_start = xxxx;
    return;
    dcl xxxx	   char (*);

dbn:
  entry;
    db_sw = "1"b;
    return;
dbf:
  entry;
    db_sw = "0"b;
    return;

dtn:
  entry;
    dt_sw = "1"b;
    return;
dtf:
  entry;
    dt_sw = "0"b;
    return;

trn:
  entry;
    tr_sw = "1"b;
    return;
trf:
  entry;
    tr_sw = "0"b;
    return;
%page;
/* +++++++++++++++++++++++++++ LOOSE VARIABLES +++++++++++++++++++++++++++++ */

    dcl ALM	   ptr init (null ());
				/* iocb pointer for alm output file */
    dcl arg	   char (argl) based (argp);
				/* a command line argument */
    dcl argl	   fixed bin;	/* length of arg */
    dcl argp	   ptr;		/* pointer to arg */
    dcl ArtEntry	   char (32) var init ("artproc");
				/* artwork proc entry */
    dcl ArtProc	   char (32) varying;
				/* artwork procedure entryname */
    dcl Atd_r	   bit (18) init ("000000"b3);
				/* default attach descr relp */
    dcl attach	   char (256) var;
    dcl AvgWordsp	   fixed bin init (-1);
				/* global average wordspace */
    dcl az_AZ09	   char (64) int static options (constant)
		   init ("abcdefghijklmnopqrstuvwxyz_"
		   || "ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789");
    dcl bach_sw	   bit (1);
    dcl bfb	   fixed bin (35) based aligned;
    dcl bpptr	   ptr based;
    dcl breaks	   char (128) var static;
				/* control string for lex_string_ */
    dcl ch1	   char (1);
    dcl char_val	   fixed bin;
    dcl charid	   fixed bin;
    dcl charid_	   fixed bin;
    dcl check_opt	   bit (1) static;	/* check mode flag */
    dcl cleanup	   condition;
    dcl code	   fixed bin (35);
    dcl Com_r	   bit (18);
    dcl Clean_r	   bit (18);
    dcl db_start	   char (12) int static init ("");
    dcl db_sw	   bit (1) int static init ("0"b);
    dcl dclname	   char (8);
    dcl default_view   fixed bin;
    dcl DefVmt	   fixed bin (31) init (48000);
    dcl DefVmh	   fixed bin (31) init (24000);
    dcl DefVmf	   fixed bin (31) init (24000);
    dcl DefVmb	   fixed bin (31) init (48000);
    dcl DevClass	   char (24) init ("typewriter");
				/* default device class */
    dcl Device_Pthis_token
		   ptr;
    dcl DevName	   char (24) init ("ascii");
				/* default device name */
    dcl dname	   char (168);	/* name of dir containing ename */
    dcl done	   bit (1);
    dcl dt_sw	   bit (1);
    dcl dup_ct	   fixed bin;
    dcl dvt_i	   fixed bin;
    dcl ename	   char (32);	/* input entryname (no suffix) */
    dcl EndPage	   bit (9) init ("0"b);
    dcl ercd	   fixed bin (35);	/* error code */
    dcl family_i	   fixed bin;
    dcl fd12_8	   fixed dec (12, 8);
    dcl first_time	   bit (1) static init ("1"b);
				/* initing control switch */
    dcl first_token_p  ptr;
    dcl font_fam	   char (32);
    dcl font_mem	   char (32);
    dcl FootEntry	   char (32) varying/* footnote procedure entrypoint */
		   init ("footproc");
    dcl footentry	   char (32);
    dcl FootFamily	   char (32);	/* global footnote font family name  */
    dcl footfamily	   char (32);
    dcl FootMember	   char (32);	/* global footnote font member name  */
    dcl footmember	   char (32);
    dcl FootProc	   char (32) varying;
				/* footnote procedure entryname */
    dcl Footsep	   char (1) init (",");
    dcl held_Pthis_token
		   ptr;
    dcl hold_Pthis_token
		   ptr;
    dcl Hscale	   fixed bin (31);	/* global hor scale */
    dcl hscale	   fixed bin (31);	/* local hor scale */
    dcl hscales	   (7) fixed bin (31)
				/* hor scale factors */
		   static options (constant)
		   init (7200, 6000, 72000, 2834.65, 12000, 1000, 0);
    dcl i		   fixed bin;
    dcl ignored_breaks char (128) var static;
				/* control string for lex_string_ */
    dcl ii	   fixed bin;
    dcl iii	   fixed bin;
    dcl initfamily	   char (32);
    dcl initmember	   char (32);
    dcl Input	   char (1);
    dcl input_bitcount fixed bin (24);	/* bit count for ename segment */
    dcl input_charcount
		   fixed bin (24);	/* char count for ename segment */
    dcl input_file	   char (input_charcount)
				/* source file overlay */
		   based (input_ptr);
    dcl input_ptr	   ptr;		/* point to ename segment */
    dcl Interleave	   bit (1) init ("0"b);
    dcl j		   fixed bin;
    dcl jj	   fixed bin;
    dcl Justify	   bit (1) init ("0"b);
    dcl Letterspace	   fixed bin (31) init (0);
    dcl lex_ctl_chars  char (128) var static;
				/* control string for lex_string_ */
    dcl lex_delims	   char (128) var static;
				/* control string for lex_string_ */
    dcl lex_temp_ptr   ptr init (null ());
				/* temp seg for lex_string_ */
    dcl like_table	   fixed bin;
    dcl list_ndx	   fixed bin;
    dcl list_opt	   bit (1);	/* list option flag */
				/* font locator */
    dcl loc_font	   fixed bin (35) based;
    dcl (
        MaxFiles,			/* global maximum file/reel	       */
        MaxWordsp,			/* global maximum wordspace	       */
        MaxPages,			/* global maximum pages/file	       */
        MaxPageLength
        )		   fixed bin (31) init (-1);
    dcl MaxPageWidth   fixed bin (31) init (979200);
    dcl media1	   char (32);
    dcl media2	   char (32);
    dcl mediabase	   fixed bin;
    dcl mediact	   fixed bin;
    dcl mediawidth	   fixed bin;
    dcl media_	   char (32);
    dcl media_i	   fixed bin;
    dcl 1 member_hold  like member.e;
    dcl mem_i	   fixed bin;
    dcl med_sel_i	   fixed bin;
    dcl MinLead	   fixed bin (31) init (7200);
				/* global minimum lead */
    dcl MinSpace	   fixed bin (31) init (7200);
    dcl MinWordsp	   fixed bin init (-1);
				/* global minimum wordspace */
    dcl MinVmb	   fixed bin (31) init (0);
    dcl MinVmt	   fixed bin (31) init (0);
    dcl mw	   fixed bin;
    dcl nargs	   fixed bin;	/* command line arg count */
    dcl new_family	   bit (1);
    dcl new_member	   fixed bin;
    dcl next_dcl_p	   ptr;
    dcl next_str_p	   ptr;
    dcl nulwidth	   fixed bin int static options (constant) init (-100000);
    dcl o777	   char (1) int static options (constant) init ("ÿ");
    dcl Openmode	   fixed bin init (5);
				/* opening mode for compout file */
    dcl OutEntry	   char (32) var;
    dcl OutProc	   char (32) var;
    dcl DisplayProc	   char (32) var;
    dcl parenct	   fixed bin;	/* next 4 vars for "n(medchars)"     */
				/*  and "n(output)"		       */
    dcl part_repl	   (10) fixed bin;	/* replication count for a part      */
    dcl part_str	   (10) char (400) var;
				/* the string for a part	       */
    dcl part_width	   (10) fixed bin;	/* the width of a part	       */
    dcl part_nest	   fixed bin;	/* nesting of parts		       */
    dcl Scale_scale	   fixed bin (35) int static options (constant)
		   init (100000000);
    dcl Scale_x	   fixed bin (35);
    dcl Scale_y	   fixed bin (35);
    dcl self_sw	   bit (1);
    dcl self_ct	   fixed bin;	/* number of SELFs in mediachar list */
    dcl self_i	   (16) fixed bin;	/* location of these SELFs	       */
    dcl Sizes	   fixed bin init (0);
    dcl skip_ct	   fixed bin;
    dcl string_l	   (2) fixed bin init (0, 0);
    dcl Strokes	   fixed bin init (1);
    dcl TapeRec	   fixed bin init (-1);
    dcl testwidth	   fixed bin;
    dcl the_font	   ptr;
    dcl the_string	   char (8000) var;
    dcl the_string_r   bit (18) aligned;/* offset in string table	       */
    dcl this_view	   fixed bin;
    dcl top_dcl_p	   ptr init (null ());
    dcl tp	   ptr;
    dcl tr_sw	   bit (1) int static init ("0"b);
    dcl vals_ct	   fixed bin;	/* count of entries in vals array */
    dcl vals	   (1:512) fixed bin;
    dcl views_selected fixed bin;
    dcl viewname	   char (32);
    dcl Vscale	   fixed bin (31);	/* global vertical scale */
    dcl vscale	   fixed bin (31);	/* local vertical scale */
    dcl vscales	   (7) fixed bin (31)
				/* vertical scale factors */
		   static options (constant)
		   init (12000, 9000, 72000, 2834.65, 12000, 1000, 0);
    dcl Wordspace_p	   ptr init (null ());

    dcl (addr, addrel, after, before, bin, bit, byte, collate, convert, copy,
        dec, dimension, divide, fixed, hbound, index, length, ptr, rel, size,
        unspec, verify, max, null, rank, rtrim, search, string, substr,
        translate)	   builtin;
%page;
/* ++++++++++++++++++ ERROR CODES & EXTERNAL PROCEDURES ++++++++++++++++++++ */

    dcl error_table_$badopt
		   fixed bin (35) ext static;
    dcl error_table_$namedup
		   fixed bin (35) ext static;
    dcl error_table_$segnamedup
		   fixed bin (35) ext static;
    dcl error_table_$zero_length_seg
		   fixed bin (35) ext static;

    dcl alm	   entry options (variable);
    dcl az	   char (26) int static
		   init ("abcdefghijklmnopqrstuvwxyz");
    dcl AZ	   char (26) int static
		   init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
    dcl com_err_	   entry options (variable);
    dcl cu_$arg_count  entry (fixed bin);
    dcl cu_$arg_ptr	   entry (fixed bin, ptr, fixed bin, fixed (35));
    dcl delete_$path   entry (char (*), char (*), bit (6) aligned, char (*),
		   fixed bin (35));
    dcl expand_pathname_$add_suffix
		   entry (char (*), char (*), char (*), char (*),
		   fixed (35));
    dcl get_temp_segments_
		   entry (char (*), (*) ptr, fixed bin (35));
    dcl get_wdir_	   entry returns (char (168));
    dcl hcs_$chname_file
		   entry (char (*), char (*), char (*), char (*),
		   fixed bin (35));
    dcl hcs_$initiate_count
		   entry (char (*), char (*), char (*), fixed bin (24),
		   fixed bin (2), ptr, fixed bin (35));
    dcl hcs_$terminate_noname
		   entry (ptr, fixed bin (35));
    dcl ioa_$ioa_switch
		   entry options (variable);
    dcl iox_$attach_name
		   entry (char (*), ptr, char (*), ptr, fixed bin (35));
    dcl iox_$close	   entry (ptr, fixed bin (35));
    dcl iox_$detach_iocb
		   entry (ptr, fixed bin (35));
    dcl iox_$open	   entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
    dcl lex_string_$init_lex_delims
		   entry (char (*), char (*), char (*), char (*), char (*),
		   bit (*), char (*) var, char (*) var, char (*) var,
		   char (*) var);
    dcl lex_string_$lex
		   entry (ptr, fixed bin (24), fixed bin (24), ptr,
		   bit (*), char (*), char (*), char (*), char (*),
		   char (*), char (*) var, char (*) var, char (*) var,
		   char (*) var, ptr, ptr, fixed bin (35));
    dcl pathname_	   entry (char (*), char (*)) returns (char (168));
    dcl release_temp_segments_
		   entry (char (*), (*) ptr, fixed bin (35));
    dcl search_paths_$find_dir
		   entry (char (*), ptr, char (*), char (*), char (*),
		   fixed (35));
    dcl translator_temp_$get_segment
		   entry (char (*), ptr, fixed bin (35));
    dcl translator_temp_$release_all_segments
		   entry (ptr, fixed bin (35));
%page;
/* ++++++++++++++++++++++++++++++ STRUCTURES +++++++++++++++++++++++++++++++ */

    dcl temp_ptrs	   (4) ptr init ((4) null ());

/* These 4 segments are used to hold these structures (in order):	       */
/*	1	2	3	4			       */
/*	strl_p	bstr		dcl_			       */
/*				mediachars		       */
/*				media			       */
/*				view			       */
/*				Def			       */
/*				fnt, font, units, oput ...	       */
/*				size_list, sizel...		       */
/*			mem	dvid..., dvt, med_sel, comp_dvt ...  */

    dcl strl_p	   (2, 2000) ptr based (temp_ptrs (1));
				/* list of strings */
    dcl string_area_p  ptr defined (temp_ptrs (2));
				/* place to hold strings    */
    dcl area1_p	   ptr defined (temp_ptrs (3));
    dcl area2_p	   ptr defined (temp_ptrs (4));
    dcl area_free_p	   ptr;		/* next free location in area2       */

    dcl size_list_p	   ptr;
    dcl 1 size_list	   based (size_list_p),
	2 count	   fixed bin,
	2 free	   ptr,		/* where to put next list	       */
	2 e	   (50),
	  3 name	   char (32),	/* name of size list	       */
	  3 pt	   ptr,		/* point to size list	       */
	2 start	   ptr;		/* start of list area	       */

/*	        COMPDV/COMP_DSM STRUCTURE INTERCONNECTION		       */

/*		 TABLES USED BY compdv WHILE PARSING,		       */
/*		NAMES MARKED WITH * ARE internal ONLY		       */
/*	      Tables are generally shown in order generated	       */
/*	       (except for strings, which crop up all over)	       */

/*++
/* dcl_l_p(1)>----+						       */
/* dcl_l_p(2)>-+  |				dcls are made first.       */
/*	     |  |	 dcl_*	    		They are strings which     */
/*	     |  |	  ________    		are referenced by name     */
/*	     |  +->|next    >--+		as an aid to understanding */
/*	     |	 |dcl_name|  |		the DSM definition. They   */
/*	     |	 |leng    |  |		are not necessary to do    */
/*	     |	 |dcl_v   |  |		the job.		       */
/*	     |	 |________|  |				       */
/*	     |  +--------------+	Strings used by mediachars are       */
/*	     |  |  dcl_*	    	temporary, i.e. only used by compdv, */
/*	     |  |   ________    	pointers to these go in strl_p(1,*). */
/*	     |  +->|next    >--+				       */
/*	     |	 |dcl_name|  |	Strings used by font, cleanup, etc.  */
/*	     | 	 |leng    |  |	are permanent, i.e. they end up in   */
/*	     |	 |dcl_v   |  |	the DSM, pointers to these go in     */
/*	     |	 |________|  |	strl_p(2,*).		       */
/*	     |  +--------------+				       */
/*	     |  |  dcl_*		strl_p*			       */
/*	     |  |   ________	 _________ 	bstr*	       */
/*	     +--+->|next    >null	|1,1 |2,1 >...	 ____	       */
/*		 |dcl_name|	|1,2 |2,2 >-------->|leng|	       */
/*	 	 |leng    |	.    .    .	|str |	       */
/*	 	 |dcl_v   |	:    :    :	|____|	       */
/*	 	 |________|				       */

    dcl str_p	   ptr;
    dcl 1 bstr	   based (str_p),	/* based string used for building    */
	2 leng	   fixed bin,	/*  pseudo-char_var strings	       */
	2 str	   char (bstr.leng),
	2 dummy	   bit (36) aligned;/* where next structure will go      */

    dcl dcl_l_p	   (2) ptr;	/* dcl_ list begin/end	       */
    dcl dcl_p	   ptr;
    dcl 1 dcl_	   based (dcl_p),	/* ** symbol declaration	       */
	2 next	   ptr,		/* linked list next element	       */
	2 dcl_name   char (8),	/* declared name		       */
	2 leng	   fixed bin,	/* length of definition string       */
	2 dcl_v	   char (dcl_.leng),/* symbol definition string	       */
	2 dummy	   ptr;		/* where next one is based	       */
%page;
/*      mediachars*						       */
/*       _______			Next, all mediachars are defined     */
/*      |count=n|__ 		in terms of dcl'ed symbols or	       */
/*   (1)|name|out_r>----------+	literals.			       */
/*   (2)|name|out_r>...	|		 	bstr*	       */
/*      .    .     .	|		 	 ____	       */
/*      :    :     :	+---------------------------->|leng|	       */
/*   (n)|name|out_r>...			 	|str |	       */
/*      |____|_____|			 	|____|	       */
    dcl mediachars_p   ptr;
    dcl 1 mediachars   based (mediachars_p),
	2 count	   fixed bin,	/* how many have been defined	       */
	2 e	   (mediachars.count),
	  3 name	   char (32),	/* name of the char		       */
	  3 out_r	   bit (18) aligned;/* output string to get it	       */

/*	       media*			       
/*	        _______			Then, all media are	       */
/*	 ______|count=m|_________ ... ______	described in terms of the  */
/*     (1)|name|rel_units|w11 |w12 |... |w1n |	mediachars, with the       */
/*     (2)|name|rel_units|w21 |w22 |... | @  |	widths being defined for   */
/*	.    .         .    .    .    .    .	each. Values might not     */
/*	:    :         :    :    :    :    :	exist for all mediachars   */
/*     (m)|name|rel_units|wm1 | @  |... |wmn |	in all media (shown as @). */
/*	|____|_________|____|____|... |____|			       */
/*    mediachar # -->     (1)  (2)  ...  (n)			       */
    dcl media_p	   ptr;
    dcl 1 media	   based (media_p),
	2 count	   fixed bin,	/* how many have been defined	       */
	2 e	   (media.count),
	  3 name	   char (32),	/* name of the media	       */
	  3 rel_units
		   fixed bin,	/* its stroke value		       */
	  3 width	   (mediachars.count) fixed bin;
				/* for each mediachar    */
%page;
/*	 view*						       */
/*          _______				Views are then made up     */
/*         |count=k|__			from the defined media.    */
/*      (1)|view1|med4|			Views can share a media,   */
/*      (2)|view2|med2|			but will differ media      */
/*         .     .    .			select string. Each Device */
/*         :     :    :			specifies its own set of   */
/*      (k)|viewk|med4|			media select strings.
/*         |_____|____|					       */

    dcl view_p	   ptr;
    dcl 1 view	   based (view_p),
	2 count	   fixed bin,	/* how many defined		       */
	2 e	   (view.count),
	  3 name	   char (32),	/* viewname		       */
	  3 media	   fixed bin;	/* media being referenced	       */


/*	Def*						       */
/*	 _______		Def's are a sort of macro definition.	       */
/*	|count=d|_	Whenever a set of Multics chars have the same  */
/*     (1)|name1|pt1|	definition in several fonts, instead of	       */
/*     (2)|name2|pt2|	entering the description again and again, a    */
/*	.     .   .	Def is made containing the needed info and     */
/*	:     :   :	then they are ref'ed in each table as needed.  */
/*     (d)|named|ptd|					       */
/*	|_____|___|					       */

    dcl Def_p	   ptr;
    dcl 1 Def	   based (Def_p),
	2 count	   fixed bin,	/* how many Def's present	       */
	2 e	   (Def.count),
	  3 name	   char (32),	/* internal name of this Def	       */
	  3 pt	   ptr;		/* Points to the node in the	       */
				/*  lex_string_ list at which source */
				/*  of the Def begins.  At ref time, */
				/*  this source will be be re-parsed */
				/*  via this pointer.	       */
%page;
/* fntl_p(1)>----+						       */
/* fntl_p(2)>---)|(---------------------+			       */
/*    +----------+			|			       */
/*    |	fnt*		fnt*	|	fnt*		       */
/*    |	 _____		 _____	|	 _____		       */
/*    +-->|next >------------>|next >---+-------->|next >null	       */
/*	|name |		|name |		|name |		       */
/*	|refno|		|refno|		|refno|		       */
/*	|node >...	|node >...	|node >...	       */
/*	|pt   >---+	|pt   >...	|pt   >...	       */
/*	|_____|  	|	|_____|		|_____|		       */
/*    +-------------+					       */
/*    |    font			Fonts are made up by selecting one   */
/*    |    _________		or more mediachars from a view and   */
/*    +-->|units_r  >-----+		associating them to Multics (input)  */
/*	|oput_r   >--+  |		characters. To speed up measuring,   */
/*	|rel_units|  |  |		the width portion of the font table  */
/*	|footsep  |  |  |		is a fixed size.		       */
/*	|min_spb  |  |  |		  To save space, however, the output */
/*	|avg_spb  |  |  |		string portion of the font is only   */
/*	|max_spb  |  |  |		as long as the highest Multics char  */
/*	|_________|  |  |		defined.			       */
/*    +----------------+  |					       */
/*    |	 opu*	      |	 uni*		   The oput and units      */
/*    |    _____	      |	 _____         units   tables often end up     */
/*    +-->|next >...      +-->|next >...     _____   looking like others of  */
/*	|ref_p>---+    	|ref_p>------>|(0)  |  their kind. Thus when   */
/*	|seqno|	|	|seqno|	    |(1)  |  each is completed, it   */
/*	|refno|   |	|refno|	    .     .  is matched against all  */
/*	|_____|	|	|_____|	    :     :  prior ones & logically  */
/*    +-------------+    	       	    |(511)|  removed if already      */
/*    |  	oput	    	       	    |_____|  there, reducing DSM     */
/*    |	 ____________			   size.		       */
/*    +-->|data_count=k|		       			       */
/*     (0)|which|what_r>...					       */
/*     (1)|which|what_r>...			From compdv's point of     */
/*  	.     .      .	    medchar_sel 	view, medchar_sel is a     */
/*  	:     :      :	   ________..._	bstr.		       */
/*     (k)|which|what_r>------->|len|text... |			       */
/*        |_____|______|	  |___|________|			       */
/*		    					       */
/*		    		oput.which references an entry in    */
/*		    		the Device's med_sel_table.	       */
%page;
    dcl font_count	   fixed bin;	/* # font entries present	       */
    dcl fntl_p	   (2) ptr;	/* begin/end fnt list	       */
    dcl fnt_p	   ptr;
    dcl 1 fnt	   based (fnt_p),	/* === font info entry	       */
	2 next	   ptr,		/* next entry		       */
	2 name	   char (32),	/* internal reference only	       */
	2 refno	   fixed bin,	/* internal reference #	       */
	2 node	   ptr,		/* rdc node for Font: statement      */
				/*  used for error messages	       */
	2 pt	   ptr,		/* points to the font table	       */
	2 dummy	   ptr;		/* where next structure goes	       */

    dcl uni_ct	   fixed bin init (0);
    dcl unil_p	   (2) ptr;
    dcl uni_p	   ptr;
    dcl 1 uni	   based (uni_p),	/* === units entry		       */
	2 next	   ptr,		/* next entry		       */
	2 ref_p	   ptr,		/* points to units table	       */
	2 seqno	   fixed bin,	/* internal sequence #	       */
	2 refno	   fixed bin;	/* internal reference #	       */
				/* when seqno=refno this is a "real" */
				/* entry, otherwise it's a duplicate */

    dcl opul_p	   (2) ptr;
    dcl opu_p	   ptr;
    dcl 1 opu	   based (opu_p),	/* === oputs entry		       */
	2 next	   ptr,		/* next entry		       */
	2 ref_p	   ptr,		/* points to oput table	       */
	2 seqno	   fixed bin,	/* internal sequence #	       */
	2 refno	   fixed bin;	/* internal reference #	       */
				/* when seqno=refno this is a "real" */
				/* entry, otherwise it's a duplicate */

%page;
/* 		           dvid*				       */
/*		           _______				       */
/*  dvidl_p(1)>-------------->|next   >------+     dvid*		       */
/*  dvidl_p(2)>----------+	|ndx    |	     |     _______		       */
/*		     |	|real   |	     +--->|next   >null	       */
/*		     |    |refname|	     |	|ndx    |		       */
/*		     |	|devname|	     |	|real   |		       */
/*		     |	|dvt_ndx|	     |	|refname|		       */
/*		     |	|_______|	     |	|devname|		       */
/*		     |		     |	|dvt_ndx|		       */
/*		     +-------------------+	|_______|		       */
    dcl comp_dvid_new  bit (1);	/* a new comp_dvid is being started  */
    dcl comp_dvid_ct   fixed bin init (0);
				/* how many actual comp_dvid defined */
    dcl dvid_ct	   fixed bin;	/* # dvid entries present	       */
    dcl dvidl_p	   (2) ptr;	/* begin/end of dvid list	       */
    dcl dvid_p	   ptr;
    dcl 1 dvid	   based (dvid_p),	/* === comp_dvid data	       */
	2 next	   ptr,		/* link to next entry	       */
	2 ndx	   fixed bin,	/* which dvid being referenced       */
	2 real	   bit (1) aligned, /* 1- defines a comp_dvid	       */
	2 refname	   char (32),	/* external reference name	       */
	2 devname	   char (32),	/* comp_dvid.devname	       */
	2 dvt_ndx	   fixed bin,	/* comp_dvid.dvt_r derived from this */
	2 dummy	   ptr;		/* place where next structure goes   */

/* This structure contains all the info necessary to generate comp_dvid.     */
%page;
/*					     	 dvt*	       */
/*  dvtl_p(1) >------+			        	 _______	       */
/*  dvtl_p(2) >-----)|(-------------------------------+---->|next   >null    */
/*		 |        dvt*		    |	|ndx    |	       */
/*		 |        _______		    |	|prent  >-...    */
/*		 +------>|next   >----------------+	|med_sel>--...   */
/*		         |ndx    |		          |ref    >-...    */
/*		         |prent  >--------+	          |_______|	       */
/*		         |med_sel>-----+  |			       */
/*		         |ref    >--+  |  |	    	 prent*	       */
/*		         |_______|	|  |  |		 __________      */
/*	    +-------------------------+  |  +------------>|outproc   |     */
/*	    |			   |  		|artproc   |     */
/*	    |      comp_dvt	    	   |   med_sel	|footproc  |     */
/*	    |      _________    	   |    _________	|__________|     */
/*	    +---->| details	|   	   +-->| details |		       */
/*		| below   |	       |  below  |		       */
/*		|_________|   	       |_________|		       */

    dcl dvt_ct	   fixed bin;	/* # dvt entries present	       */
    dcl dvtl_p	   (2) ptr;	/* begin/end of dvt list	       */

    dcl dvt_p	   ptr;
    dcl 1 dvt	   based (dvt_p),	/* === comp_dvt reference info       */
	2 next	   ptr,		/* link to next entry	       */
	2 ndx	   fixed bin,	/* which index this represents       */
	2 prent	   ptr,		/* ptr to prent data	       */
	2 med_sel	   ptr,		/* ptr to associated med_sel array   */
	2 ref	   ptr,		/* ptr to comp_dvt		       */
	2 dummy	   ptr;		/* place where next structure goes   */

    dcl prent_p	   ptr;
    dcl 1 prent	   based (prent_p), /* === entryname strings, comp_dvt   */
	2 outproc	   char (68) var,
	2 artproc	   char (68) var,
	2 footproc   char (68) var,
	2 dummy	   ptr;		/* place where next structure goes   */

    dcl 1 med_sel_tab  aligned based (dvt.med_sel),
	2 count	   fixed bin,
	2 ref_r	   (med_sel_tab.count) bit (18) aligned;
%page;
/*	              mem*					       */
/*	         	    ______				       */
/*  meml_p(1) >----	+->|next  >--+				       */
/*  meml_p(2) >--+ 	   |ref_p >  |				       */
/* 	       |     |seqno |  |				       */
/*	       | 	   |______|  |				       */
/*	       +---------------+				       */
/*	       |     mem*					       */
/*	       |	   ______	          member			       */
/*	       +--->|next  >null      _________			       */
/*		  |ref_p >-------->| details |		       */
/*		  |seqno |         |  below  |		       */
/*		  |______|         |_________|		       */

    dcl meml_p	   (2) ptr;	/* begin/end member list	       */
    dcl mem_ct	   fixed bin init (0);
				/* internal sequence counter	       */
    dcl mem_p	   ptr;
    dcl 1 mem	   based (mem_p),	/* === member table (code gen only)  */
	2 next	   ptr,		/* next entry		       */
	2 ref_p	   ptr,		/* pointer to the member table       */
	2 seqno	   fixed bin,	/* internal sequence #	       */
	2 refno	   fixed bin,	/* internal reference #	       */
				/* when seqno=refno this is a "real" */
				/* entry, otherwise it's a duplicate */
	2 dummy	   ptr;		/* where next structure goes	       */

/*		 EXTERNAL INTERCONNECTION in the DSM		       */
/*  linkage						       */
/*  section				             comp_dvid     */
/*  ______     +-----------------------------------------+     _______       */
/* |      |    |				       +--->|       |      */
/* |name1 >----+				            |devname|      */
/* |name2 >---)|(-------------------+    comp_dvid            |dvt_r  >--+   */
/* |name3 >----+   comp_dvid	      |    _______	            |_______|  |   */
/* |name4 >--+     _______	      +-->|       |	    comp_dvt	   |   */
/* | etc. |  +--->|       |	          |devname|	    ________	   |   */
/* |______|       |devname|	          |dvt_r  >--->| ...		   |   */
/*                |dvt_r  >--+          |_______|    |		   |   */
/*                |_______|  |				   |   */
/*  +-------<----------------+-----------------------------------<-------+   */
/*  |    comp_dvt						       */
/*  |    _____________			             bstr	       */
/*  +-->|             |			             ___________   */
/*      |atd_r        >-------------------------------------->|len|str... |  */
/*      |dvc_r        >...			    	  |___|_______|  */
/*      |med_sel_tab_r>-----------------+    med_sel_tab		       */
/*      | ...         |		|    _______       	   med_sel       */
/*      |family_ct=F  |		+-->|count=K|      	   ___________   */
/*   (1)|.member_r    >--+		 (1)|ref_r>---------->|len|str... |  */
/*   (1)|.name        |  |		    .     .           |___|_______|  */
/*      | ...         |  |		 (n)|ref_r>nullo		       */
/*      |_____________|  |		    .     .		       */
/*       +---------------+		 (K)|ref_r>...	 sizel	       */
/*       |    member		    |_____| 	 ________	       */
/*       |    _______	 +--------------------------->|val_ct=S|       */
/*       +-->|count=L|_________|________________	       (1)|val     |       */
/*	(1)|font_r> size_r>  | lex|Scaley|name|		.        .       */
/*	(2)|font_r> size_r>--+ lex|Scaley|name|		:        :       */
/*	   .      .       .       .      .    .	       (S)|val     |       */
/*	   :      :       :       :      :    :		|________|       */
/*	(L)|font_r>---+   > Scalex|Scaley|name|			       */
/*	   |______|___|___|_______|______|____|			       */
/*	              |					       */
/*    +-----------------+					       */
/*    |    font					units	       */
/*    |    _________				_____	       */
/*    +-->|units_r  >-------------------------------------->|(0)  |	       */
/*	|oput_r   >---+ 				|(1)  |	       */
/*	|rel_units|   |		  		.     .	       */
/*	|footsep  |   |  	oput	    	       	:     :	       */
/*	|min_spb  |   |    _________		       	|(511)|	       */
/*	|avg_spb  |   +-->|data_ct=k|__		|_____|	       */
/*	|max_spb  |    (0)|which|what_r>...			       */
/*	|_________|    (1)|which|what_r>...			       */
/*		        .     .      .	    medchar_sel	       */
/*		        :     :      :	   ________..._	       */
/*		     (k)|which|what_r>--------->|len|text... |	       */
/*		        |_____|______|	  |___|________|	       */
/*							       */
/*		    		oput.which references an entry in    */
/*		    		the Device's med_sel_table.	       */
%page;
%include comp_art_parts;
%include comp_metacodes;
%include comp_dvid;
%include comp_dvt;
%include comp_fntstk;
%include comp_font;
%include compstat;
%include compdv_msgs;




		    compose_index.pl1               04/23/85  1100.9rew 04/23/85  0911.1      294669



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* A compose support tool embodying all the functionality of the older
   index_process.ted, index_sort.ted, and index_print. */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

compose_index:
comp_index:
cndx:
  proc;

/* SYNTAX

   compose_index path {-control_args}

   where:

       path
	the pathname of the compin file producing the raw index data.
	The compin suffix need not be given.

       {-control_args} may be:

       -alpha_header, -ahdr
	insert centered uppercase alphabetic characters as group separators
	whenever the first character of the primary key changes.

       -control_file CTL_PATH, -cf CTL_PATH
	use CTL_PATH.index.control as the control file for this index.
	The suffix "cndxctl" is assumed if not given.

       -number N, -nb N
	one of the 10 (0 thru 9) possible raw index data files.
	The default value is 0. See Notes below.

	UNDOCUMENTED
       -debug
	display debug info


   Notes:
	The raw index data files are produced by compose when the .hit 
	control is used.  See WORDPRO Reference Guide (AZ98) for further 
	information on this control.  The default raw data file is
	<path>.0.cndx. The output file is [wd]><path entryname>.0.index.

	The raw data in <path>.N.cndx is processed into a arbitrarily chosen
	format the style of which is partially by constants built into the
	program and partially by statements in the control file. The default 
	control file is <path>.cndxctl. See Notes on Index Control 
	Files below.

   Notes on Index Control Files

	The output file created by this program is to be treated just like
 	any other section of the document to which it applies.  That output
	file contains references to several of the variables defined by the
	documentation macros; therefore, the first line of a control file
	must be a call to one of the various init.compin entrypoints.
*/
/* LOCAL STORAGE */

    dcl ahdr_sw	   bit (1);	/* alpha header control switch */
    dcl arg			/* a command line argument */
		   char (argl) based (argp);
    dcl argl	   fixed bin (21);
    dcl argp	   ptr;		/**/
				/* line array for sorting */
    dcl 1 bead	   aligned based (bead_ptr),
	2 ct	   fixed bin,	/* bead count */
	2 e	   (0 refer (bead.ct)),
	  3 linptr   ptr,		/* -> line text */
	  3 len	   fixed bin (24),	/* length of given text */
	  3 type	   char (1),	/* hit type */
	  3 sortptr  ptr;		/* -> line text to be compared */
    dcl bead_ptr	   ptr;
    dcl code	   fixed bin (35);	/* error code */
    dcl 1 control_file aligned like null_file;
    dcl d		   fixed bin;	/* bead separation for sorting */
    dcl debug	   bit (1);	/* debug option */
    dcl 1 delim,			/* hit line delimiters */
	2 key	   char (1),
	2 sep	   char (1),
	2 end	   char (1);	/**/
				/* default delimiters */
    dcl 1 dflt_delim   static options (constant),
	2 key	   char (1) init ("|"),
	2 sep	   char (1) init ("~"),
	2 end	   char (1) init (";");
    dcl EMPTY	   char (3) static options (constant) init ("`~'");
    dcl EN	   char (1) static options (constant) init ("");
    dcl END	   char (3) static options (constant) init ("  ");
				/* = <SP><035><SP> */
    dcl excl_ptr	   ptr;		/* exclusions for permuting */
    dcl 1 excl	   aligned based (excl_ptr),
	2 ct	   fixed bin,	/* count of entries */
	2 key	   (0 refer (excl.ct)) char (128) var;
    dcl hit_type	   char (1);	/* given hit type character */
    dcl (i, j, k)	   fixed bin;	/* working index */
    dcl iarg	   fixed bin;	/* argument counter */
    dcl ignore	   char (128) var;	/* chars to ignore during sorting */
    dcl index_nbr	   char (1);	/* index data number, 0-9 */
    dcl key_string	   char (1024) var; /* current key string */
    dcl lastkey	   char (1024) var; /* lastkey string */
    dcl 1 last_hit	   aligned,
	2 key	   (5) char (1024) var,
	2 pageref	   char (64) var;
    dcl line	   char (1024) var; /* a working line */
    dcl linect	   fixed bin;	/* line counter */
    dcl linstr	   char (1024) based;
    dcl lower_case	   char (26) static options (constant)
		   init ("abcdefghijklmnopqrstuvwxyz");
    dcl max_chars	   fixed bin (21);	/* limit for chars in a segment */
    dcl me	   char (13) static options (constant)
		   init ("compose_index");
    dcl nargs	   fixed bin;	/* command argument count */
    dcl NL	   char (1) static options (constant) init ("
");				/**/
				/* empty file data structure */
    dcl 1 null_file	   aligned static options (constant),
	2 charct	   fixed bin (24) init (0),
	2 entryname  char (32) aligned init (""),
	2 dir	   char (168) aligned init (""),
	2 lineno	   fixed bin init (0),
	2 name	   char (32) var init (""),
	2 path	   char (200) var init (""),
	2 posn	   fixed bin (21) init (1),
	2 ptr	   ptr init (null ());
				/* -> data file */
    dcl 1 output_file  aligned like null_file;
    dcl pageref	   char (1024) var; /* pageref string */
    dcl pct	   fixed bin;	/* pct counter for sort routine */
    dcl 1 raw_file	   aligned like null_file;
    dcl SEP	   char (3) static options (constant) init ("  ");
				/* = <SP><036><SP> */
    dcl 1 sorted_file  aligned like null_file;
    dcl sortstr	   char (1024) var based (sortstr_ptr);
    dcl sortstr_ptr	   ptr;
    dcl swp	   bit (1);	/* swap flag for sorting */
    dcl 1 tbead	   like bead.e;	/* temporary for sorting */
    dcl 1 this_hit	   aligned,
	2 key	   (5) char (1024) var,
	2 pageref	   char (64) var;
    dcl tline	   char (1024) var; /* a working line */
				/* transformations of permuting */
    dcl 1 tran	   aligned based (tran_ptr),
	2 ct	   fixed bin,	/* count of pairs */
	2 e	   (0 refer (tran.ct)),
	  3 in	   char (128) var,
	  3 out	   char (128) var;
    dcl tran_ptr	   ptr;
    dcl tsegs	   (6) ptr;	/* temp seg pointers */
    dcl upper_case	   char (26) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ")
		   static options (constant);
    dcl 1 work_file	   aligned like null_file;

    dcl (addr, after, before, divide, index, length, null, rtrim, substr,
        translate)	   builtin;

    dcl cleanup	   condition;

    dcl error_table_$bad_arg
		   fixed bin (35) ext static;
    dcl error_table_$badopt
		   fixed bin (35) ext static;
    dcl error_table_$zero_length_seg
		   fixed bin (35) ext static;
    dcl sys_info$max_seg_size
		   fixed bin (18) ext static;

    dcl com_err_	   entry options (variable);
    dcl cu_$arg_count  entry (fixed bin);
    dcl cu_$arg_ptr	   entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
    dcl expand_pathname_
		   entry (char (*) aligned, char (*) aligned,
		   char (*) aligned, fixed bin (35));
    dcl get_temp_segments_
		   entry (char (*), (*) ptr, fixed bin (35));
    dcl get_wdir_	   entry returns (char (168));
    dcl hcs_$initiate_count
		   entry (char (*) aligned, char (*) aligned,
		   char (*) aligned, fixed bin (24), fixed bin (1), ptr,
		   fixed bin (35));
    dcl hcs_$make_seg  entry (char (*) aligned, char (*) aligned,
		   char (*) aligned, fixed bin (5), ptr, fixed bin (35));
    dcl hcs_$set_bc_seg
		   entry (ptr, fixed bin (24), fixed bin (35));
    dcl hcs_$truncate_seg
		   entry (ptr, fixed bin (19), fixed bin (35));
    dcl ioa_	   entry options (variable);
    dcl release_temp_segments_
		   entry (char (*), (*) ptr, fixed bin (35));
    dcl term_$seg_ptr  entry (ptr, fixed bin (35));

    max_chars = 4 * sys_info$max_seg_size;
    ahdr_sw, debug = "0"b;		/* alpha headers & debug off */
    index_nbr = "0";		/* default index data number */
/****    tsegs (*) = null ();		/* clean up any garbage */
    ignore = "";			/* no ignore chars */
    raw_file = null_file;		/* pl1 bug 1815 wont allow multiple */
    control_file = null_file;		/* aggregate assignments */
    output_file = null_file;

/* PROCESS COMMAND LINE */

    call cu_$arg_count (nargs);	/* how many args? */

    if nargs = 0			/* must have at least one arg */
    then
      do;
        call ioa_ ("^a: Proper usage is: compose_index path {-control_arg}",
	   me);
        return;
      end;

    else
      do iarg = 1 to nargs;		/* process the args */
        call cu_$arg_ptr (iarg, argp, argl, code);
        if code ^= 0
        then
	do;
arg_err:
	  call com_err_ (code, me, "Reading argument ^d", iarg);
	  return;
	end;

        if index (arg, "-") = 1	/* control arg? */
        then
	do;
	  if arg = "-alpha_header" | arg = "-ahdr"
	  then ahdr_sw = "1"b;

	  else if arg = "-control_file" | arg = "-cf"
	  then
	    do;
	      iarg = iarg + 1;
	      call cu_$arg_ptr (iarg, argp, argl, code);
	      if code ^= 0
	      then goto arg_err;

	      control_file.path = before (arg, ".cndxctl") || ".cndxctl";

	      if index (control_file.path, "<>") ^= 0
	      then
	        do;
		call expand_pathname_ ((control_file.path),
		     control_file.dir, control_file.entryname, code);
		if code ^= 0
		then
		  do;
		    call com_err_ (code, me, "Expanding path for ""^a"".",
		         control_file.path);
		    return;
		  end;
	        end;

	      else
	        do;
		control_file.dir = get_wdir_ ();
		control_file.entryname = control_file.path;
	        end;

	      control_file.path =
		 rtrim (control_file.dir) || ">"
		 || rtrim (control_file.entryname);
	    end;

	  else if arg = "-number" | arg = "-nb"
	  then
	    do;
	      iarg = iarg + 1;
	      call cu_$arg_ptr (iarg, argp, argl, code);
	      if code ^= 0
	      then goto arg_err;

	      if argl > 1 | index ("0123456789", arg) = 0
	      then
	        do;
		call com_err_ (error_table_$bad_arg, me,
		     "A single decimal digit expected for argument ^d.",
		     iarg);
		return;
	        end;

	      index_nbr = arg;
	    end;			/**/
				/* UNDOCUMENTED */
	  else if arg = "-debug"
	  then debug = "1"b;

	  else
	    do;
	      call com_err_ (error_table_$badopt, me,
		 "Argument ^d - ""^a"".", iarg, arg);
	      return;
	    end;
	end;

        else
	do;			/* file name */
	  raw_file.path = before (arg, ".compin");

	  if search (raw_file.path, "<>") ^= 0
	  then
	    do;
	      call expand_pathname_ ((raw_file.path), raw_file.dir,
		 raw_file.entryname, code);
	      if code ^= 0
	      then
	        do;
		call com_err_ (code, me, "Expanding path for ""^a"".",
		     raw_file.path);
		return;
	        end;
	    end;

	  else
	    do;
	      raw_file.dir = get_wdir_ ();
	      raw_file.entryname = raw_file.path;
	    end;

	  raw_file.path =
	       rtrim (raw_file.dir) || ">" || rtrim (raw_file.entryname);
	end;
      end;

/* PROCESS THE RAW FILE */

    raw_file.name = rtrim (raw_file.entryname) || "." || index_nbr || ".cndx";

    call hcs_$initiate_count (raw_file.dir, (raw_file.name), "",
         raw_file.charct, 0, raw_file.ptr, code);
    if raw_file.ptr = null ()
    then
      do;
        call com_err_ (code, me, "Initiating ^a>^a.", rtrim (raw_file.dir),
	   raw_file.name);
        return;
      end;

    on cleanup goto clean;		/* we now have something to clean */

    if raw_file.charct = 0
    then
      do;
        call com_err_ (error_table_$zero_length_seg, me, "^a>^a.",
	   rtrim (raw_file.dir), raw_file.name);
        goto clean;
      end;			/**/
				/* we are GO for this run */
    work_file = null_file;
    sorted_file = null_file;
    output_file.dir = get_wdir_ ();	/* hook up to the output file */
    output_file.entryname, output_file.name =
         rtrim (raw_file.entryname) || "." || index_nbr || ".index";

    call hcs_$make_seg (output_file.dir, output_file.entryname, "", 10,
         output_file.ptr, code);
    if output_file.ptr = null ()
    then
      do;
        call com_err_ (code, me, "Accessing the output compin file.");
        goto clean;
      end;

    call hcs_$truncate_seg (output_file.ptr, 0, code);
				/* get some temp segs */
    call get_temp_segments_ (me, tsegs, code);
    if code ^= 0
    then
      do;
        call com_err_ (code, me, "Creating temporary segments.");
        goto clean;
      end;
    work_file.ptr = tsegs (1);
    bead_ptr = tsegs (2);
    sorted_file.ptr = tsegs (3);
    tran_ptr = tsegs (4);
    excl_ptr = tsegs (5);
    sortstr_ptr = tsegs (6);

    if control_file.dir = ""		/* no control file given? */
    then
      do;				/* use raw data file for control */
        control_file.dir = raw_file.dir;
        control_file.entryname = raw_file.entryname;
        control_file.name = rtrim (control_file.entryname) || ".cndxctl";
      end;

    call hcs_$initiate_count (control_file.dir, (control_file.name), "",
         control_file.charct, 0, control_file.ptr, code);

    if control_file.ptr = null ()	/* no control file? */
    then
      do;
no_ctl_file:
        call write (output_file, "..init """"");
        call write (output_file, "..l0index");
        goto GO;
      end;

    if control_file.charct = 0	/* empty control file? */
    then
      do;
        control_file.ptr = null ();
        goto no_ctl_file;
      end;			/* in case the user forgets them */
    call write (output_file, ".srv MPM_SPACE");
    call write (output_file, ".srv INDEXSPACE 1");
				/* process control file */
    control_file.charct = divide (control_file.charct, 9, 21, 0);
    tran.ct = 0;
    excl.ct = 0;

    do while (control_file.posn < control_file.charct);
      line = read (control_file);	/**/
				/* transformations */
      if substr (line, 1, 6) = ".*tran"
      then
        do;
	tline = translate (after (line, ".*tran "), lower_case, upper_case);
	if substr (tline, 1, 1) ^= ","
	then
tran_err:
	  call ioa_ ("^a: Missing comma at line ^d.^/^-^a", me,
	       raw_file.lineno, line);

	else
	  do;
	    tline = after (tline, ",");
	    if index (tline, ",") = 0
	    then goto tran_err;

	    else
	      do;
	        i = tran.ct + 1;
	        tran.in (i) = rtrim (before (tline, ","));
	        tline = after (tline, ",");
	        tran.out (i) = rtrim (before (tline, ","));
	        tran.ct = i;
	      end;
	  end;
        end;

      else if substr (line, 1, 8) = ".*phrase"
      then
        do;
	i = tran.ct + 1;
	tran.in (i) = tline;
	tran.out (i) = translate (tline, "", " ");
	tran.ct = i;
        end;

      else if substr (line, 1, 6) = ".*excl"
				/* exclusions */
      then
        do;
	tline = translate (after (line, ".*excl "), lower_case, upper_case);

	do excl.ct = excl.ct + 1 by 1 while (tline ^= "");
	  if tline ^= "," & substr (tline, 1, 2) ^= ",,"
	  then excl.key (excl.ct) = before (tline, ",");
excl_loop:			/* convert ~s to SEPs */
	  j = index (excl.key (excl.ct), "~");
	  if j > 0
	  then
	    do;
	      excl.key (excl.ct) =
		 substr (excl.key (excl.ct), 1, j - 1) || SEP
		 || substr (excl.key (excl.ct), j + 1);
	    end;

	  tline = after (tline, ",");
	end;

	excl.ct = excl.ct - 1;	/* back out extra count */
        end;

      else if substr (line, 1, 8) = ".*ignore"
	 | substr (line, 1, 7) = ".*blind"
      then ignore = after (line, " ");	/* write it to output & let compose */
      else call write (output_file, line);
				/* worry about it */
    end;

GO:
    work_file.name = "work_file";

    last_hit.key (*), this_hit.key (*) = EMPTY;
    last_hit.pageref, this_hit.pageref = "";

    raw_file.charct = divide (raw_file.charct, 9, 21, 0);
    linect, bead.ct = 0;		/**/
				/* run thru raw data file */
    do while (raw_file.posn < raw_file.charct);
      delim = dflt_delim;		/* reinitialize delimiters */

      line = read (raw_file);		/* read a line */
      linect = linect + 1;		/* and count it */
				/* process only those lines having*/
      if index (line, ".~ HIT ") ^= 0	/* a hit flag string */
      then
        do;
	if debug
	then call ioa_ ("HIT line: ""^a""", line);

	tline = after (line, ".~ HIT ");
				/* strip off hit flag string */

	if substr (tline, 1, 1) = "=" /* delimiter change for this line? */
	then
	  do;
	    delim.key = substr (tline, 2, 1);
	    delim.sep = substr (tline, 3, 1);
	    delim.end = substr (tline, 4, 1);
	    tline = substr (tline, 5);
	  end;			/* skip null key strings */
	if substr (tline, 1, 1) = delim.end
	then goto skip_hit;		/* copy the hit type char */
	hit_type = substr (tline, 1, 1);
	tline = after (tline, hit_type);
				/* and strip it off */

	if index (tline, delim.key) = 0
				/* check for required key delim */
	then
	  do;
	    call ioa_ ("No key delimiter for line ^d, one will be provided."
	         || "^/^-^a", raw_file.lineno, line);
	    tline = delim.key || tline;
	  end;

	i = 0;			/* convert given delimiters */
	do while (i <= length (tline));
	  j, k = 0;

	  j = index (tline, delim.sep);
	  if j > 0
	  then tline = before (tline, delim.sep) || SEP
		  || after (tline, delim.sep);

	  k = index (tline, delim.end);
	  if k > 0
	  then tline = before (tline, delim.end) || END
		  || after (tline, delim.end);

	  if j > 0 | k > 0
	  then i = i + min (j, k);
	  else i = length (tline) + 1;
	end;

	if substr (tline, 1, 1) ^= delim.key
				/* is there a lastkey? */
	then
	  do;
	    lastkey = before (tline, delim.key);
	    tline = after (tline, lastkey);
	  end;
	else lastkey = "";

	tline = after (tline, delim.key);
				/* strip key delim */
	pageref =			/* copy pageref string */
	     before (ltrim (after (tline, END)), " ");
	tline = substr (tline, 1, length (tline) - length (pageref));
				/* trim pageref string */

	if tline = ""		/* skip empty key strings */
	then goto skip_hit;

/* K type - specifed key */
/* S type - "see" reference */
	if hit_type = "K" | hit_type = "S"
	then
	  do while (tline ^= "");
	    key_string = before (tline, delim.key) || lastkey;
	    if hit_type = "K"
	    then key_string = key_string || pageref;
				/* make a new bead */
	    call make_bead (key_string);

	    tline = after (tline, delim.key);
	  end;

/* U type - permuted upper case */

/* The key string may be ONLY a level 1 key. Each "word" of the key is 
   translated to uppercase and emitted as a level 1 key and followed by the 
   given key string at level 2. */

	if hit_type = "U"
	then
	  do;

/*
{trans:="1,$U/^.*%%%/"} " 	set special translation
>(permute) \B(exec) "	call permuter

1,$U/^.*~/ 1,$M(rf) "	translate all to uppercase and copy to b(rf)
:(no_U)
*/

	    call permute (tline);
	  end;
skip_hit:
        end;
    end;				/* sort the hits */
    if bead.ct > 0
    then
      do;
        pct = 0;
        d = bead.ct;
sort:
        d = divide (d + 1, 2, 17, 0);
pass:
        pct = pct + 1;
        swp = "0"b;
        do i = 1 to bead.ct - d;
	j = i + d;

	if bead.sortptr (i) -> sortstr > bead.sortptr (j) -> sortstr
	then
	  do;
	    tbead = bead.e (j);
	    bead.e (j) = bead.e (i);
	    bead.e (i) = tbead;
	    swp = "1"b;
	  end;
        end;

        if swp
        then goto pass;
        if d > 1
        then goto sort;
      end;

    sorted_file.name = "sorted_file";

    do i = 1 to bead.ct;
      call write (sorted_file,
	 substr (bead.linptr (i) -> linstr, 1, bead.len (i)));
    end;

    pageref = "";			/* erase leftovers */
    sorted_file.posn = 1;		/* "rewind" sorted file */
    linect = 0;

    do while (sorted_file.posn <= sorted_file.charct);
				/* get key strings from */
      call get_keys;		/* next sorted file line */
      linect = linect + 1;

      do i = 1 to 5 while (this_hit.key (i) ^= EMPTY);
				/* break at this level? */
        if translate (this_hit.key (i), lower_case, upper_case)
	   ^= translate (last_hit.key (i), lower_case, upper_case)
        then
	do;
	  if pageref ^= ""
	  then
	    do;
	      call write (output_file, pageref);
	      pageref = "";
	    end;

	  if i = 1		/* first level break? */
	  then
	    do;
	      if ahdr_sw		/* alpha headers wanted? */
	      then
	        do;		/* does first char change? */
		if translate (substr (this_hit.key (1), 1, 1), lower_case,
		     upper_case)
		     ^=
		     translate (substr (last_hit.key (1), 1, 1),
		     lower_case, upper_case)
		then
		  do;
		    call write (output_file,
		         ".ur .ur .spt %%{%INDEXSPACE% + %MPM_SPACE%}%%");
		    call write (output_file,
		         ".tlh 1 0 ||%.fnt HBR%"
		         ||
		         translate (substr (this_hit.key (1), 1, 1),
		         upper_case, lower_case) || "%.fnt%||");
		  end;
	        end;

	      call write (output_file, ".ur .spt %INDEXSPACE%");
				/* set split title */
	      call write (output_file,
		 ".dfu block_split .stl |" || this_hit.key (1)
		 || " (cont.) |");
	    end;

	  call write (output_file, ".unl " || ltrim (char (2 * (5 - i))));
	  call write (output_file, this_hit.key (i));

	  do j = i + 1 to 4;	/* clear subordinate keys */
	    last_hit.key (j) = EMPTY;
	  end;
	end;
      end;

      if pageref = ""
      then pageref = this_hit.pageref;
      else if this_hit.pageref ^= last_hit.pageref
      then pageref = pageref || ", " || this_hit.pageref;

      last_hit = this_hit;
    end;				/* and finally, the pageref */
    if pageref ^= ""
    then call write (output_file, pageref);

clean:
    call term_$seg_ptr (raw_file.ptr, code);
    if code ^= 0
    then call com_err_ (code, me, "Terminating ^a>^a.", rtrim (raw_file.dir),
	    raw_file.name);

    code = 0;
    if control_file.ptr ^= null ()
    then call term_$seg_ptr (control_file.ptr, code);
    if code ^= 0
    then call com_err_ (code, me, "Terminating ^a>^a.",
	    rtrim (control_file.dir), control_file.name);

    code = 0;
    if output_file.ptr ^= null ()
    then
      do;
        call hcs_$set_bc_seg (output_file.ptr, 9 * output_file.charct, code);
        if code ^= 0
        then call com_err_ (code, me, "Setting bitcount for ^a>^a",
	        rtrim (output_file.dir), rtrim (output_file.entryname));
        code = 0;

        call term_$seg_ptr (output_file.ptr, code);
        if code ^= 0
        then call com_err_ (code, me, "Terminating ^a>^a.",
	        rtrim (output_file.dir), output_file.name);
      end;

    code = 0;
    call release_temp_segments_ (me, tsegs, code);
    if code ^= 0
    then call com_err_ (code, me, "Releasing temporary segments.");
%page;
/* convert digit strings to pictures for proper sorting */
conv_nbrs:
  proc (str);

/* PARAMETERS */

    dcl str	   char (1024) var;

/* LOCAL STORAGE */

    dcl (i, j, k)	   fixed bin;	/* working index */
    dcl pic	   pic "(9)9";	/* output pciture */

    i = 1;			/* scan the string */
    do while (i <= length (str));
      j = search (substr (str, i), "0123456789");
				/* look for numbers */

      if j > 0			/* found one */
      then
        do;
	i = i + j - 1;		/* skip to first digit */
	k = verify (substr (str, i), "0123456789");
				/* how many? */
	if k = 0			/* all the rest of str */
	then k = length (str) - i + 1;
	else k = k - 1;

	pic = convert (pic, substr (str, i, k));
				/* convert to picture */
	str = substr (str, 1, i - 1) || pic || substr (str, i + k);
	i = i + 9;
        end;

      else i = length (str) + 1;	/* for loop control */
    end;

  end conv_nbrs;
%page;
/* read a line from the sorted data file and break it into keys */
get_keys:
  proc;

    dcl i		   fixed bin;	/* working index */

    this_hit.key (*) = EMPTY;		/* preset to empty */
    this_hit.pageref = "";

    line = read (sorted_file);	/* read a line from the sorted file */

    do i = 1 to 5 while (line ^= "");	/* break it into key fields */
      j, k = 0;
      j = index (line, SEP);		/* look for a key separator */
      if j > 0			/* found a separator? */
      then
        do;
	this_hit.key (i) = before (line, SEP);
	line = after (line, SEP);
        end;

      else k = index (line, END);	/* look a key terminator */
      if k > 0			/* found a terminator? */
      then
        do;
	this_hit.key (i) = before (line, END);
	line = after (line, END);
        end;

      if i = 1
      then
        do;
	if hit_type = "U"
	then this_hit.key (1) =
		translate (this_hit.key (1), upper_case, lower_case);
        end;


      else if j = 0			/* found neither, rest is pageno */
      then
        do;
	this_hit.pageref = ltrim (line);
	line = "";
        end;
    end;

  end get_keys;
%page;
/* cleans up a key string and add it to the list of sortable beads */
make_bead:
  proc (str);

/* PARAMETERS */

    dcl str	   char (1024) var; /* key string (INPUT) */

/* LOCAL STORAGE */

    dcl end	   fixed bin;	/* position of END */
    dcl (k, l)	   fixed bin;	/* working index */
    dcl bdstr	   char (1024) var; /* working string */
    dcl blind_char	   char (1);	/* blind sort character */

    bdstr = str;			/* copy given string */

    k = 1;			/* discard pad characters */
    do while (k > 0);
      k = search (bdstr, "ÿ");	/* <177><777> */
      if k > 0
      then bdstr = substr (bdstr, 1, k - 1) || substr (bdstr, k + 1);
    end;

    k = index (bdstr, SEP || END);	/* trim trailing SEPs */
    if k > 0
    then bdstr = substr (bdstr, 1, k - 1) || substr (bdstr, k + 3);

    bead.ct = bead.ct + 1;		/* make a new bead */
    bead.linptr (bead.ct) =		/* point to given line */
         addr (substr (work_file.ptr -> linstr, work_file.posn));
    bead.len (bead.ct) = length (bdstr);/* len of cleaned up key string */
    bead.type = hit_type;		/* record hit type */
    call write (work_file, bdstr);	/* save given line */
				/* force lower case */
    bdstr = translate (bdstr, lower_case, upper_case);

    k = 1;			/* discard blind pad char for sort */
    do while (k > 0);
      k = search (bdstr, "¿");	/* <277> */
      if k > 0
      then bdstr = substr (bdstr, 1, k - 1) || substr (bdstr, k + 1);
    end;

    call conv_nbrs (bdstr);		/* convert numbers to pictures */
				/* process ignore chars */
    if hit_type = "S"		/* S type? */
    then
      do;				/* position of "see" */
        end = index (bdstr, "see") - 1;
        if end > 1			/* parens on it? */
        then if substr (bdstr, end, 1) = "("
	   then end = end - 1;
      end;

    else end = index (bdstr, END);
    l = end - 1;			/* length of string to scan */

    k = 1;			/* massage ignore chars */
    if ignore ^= ""
    then
      do while (k > 0);
        k = search (bdstr, ignore);
        if k > 0
        then
	do;
	  blind_char = substr (bdstr, k, 1);
				/* copy blind char */
	  blind_char = byte (rank (blind_char) + 128);
				/* kick it upstairs */
	  bdstr = substr (bdstr, 1, k - 1) || substr (bdstr, k + 1, 1)
	       || blind_char || substr (bdstr, k + 2);
	end;
      end;

    sortstr = bdstr;		/* string to be sorted */
    bead.sortptr (bead.ct) = sortstr_ptr;
    sortstr_ptr = addrel (sortstr_ptr, bin ((length (bdstr) + 7) / 4, 35, 0));

  end make_bead;
%page;
/* Permutes "words" in given key string and creates beads from them */
permute:
  proc (str);

/* PARAMETERS */

    dcl str	   char (1024) var; /* key string to be permuted */

/* LOCAL STORAGE */

    dcl (i, j, k)	   fixed bin;	/* working index */
    dcl lstr	   char (1024) var; /* local string for exclusions */
    dcl pkey	   char (128) var;	/* permutation word */
    dcl pstr	   char (1024) var; /* local string for permuting */
    dcl tran_sw	   bit (1);	/* control transformation loop */
				/* copy key string, translating HTs */
				/* to SPs, ltrimming, and */
				/* forcing lower case */
    pstr = ltrim (translate (before (str, END), " ", "	"));
    pstr = translate (pstr, lower_case, upper_case);

    i = 1;			/* cast out multiple blanks */
    do while (i <= length (pstr));
      j = index (substr (pstr, i), " ") - 1;
      if j > 0
      then
        do;
	i = i + j;
	j = verify (substr (pstr, i), " ");
				/* how many? */
	if j > 0
	then pstr = substr (pstr, 1, i) || substr (pstr, i + j - 1);
	i = i + 1;
        end;
      else i = length (pstr) + 1;	/* loop control */
    end;

    j, k = 1;			/* remove underscores */
    do while (j + k > 0);
      j, k = 0;

      j = index (pstr, "_");		/* <BS>_ */
      if j > 0
      then pstr = substr (pstr, 1, j - 1) || substr (pstr, j + 2);

      k = index (pstr, "_");		/* _<BS> */
      if k > 0
      then pstr = substr (pstr, 1, k - 1) || substr (pstr, k + 2);

      if j + k > 0
      then i = i + min (j, k);
      else i = length (pstr) + 1;
    end;

    pstr = translate (pstr, " ", "_");	/* convert _'s to SPs */

    if tran.ct > 0			/* apply tran's to pstr */
    then
      do i = 1 to tran.ct by 2;
        tran_sw = "1"b;		/* condition loop control switch */
        k = 1;			/* string scan index */
        do while (tran_sw);
	tran_sw = "0"b;
	j = index (substr (pstr, k), tran.in (i));
	if j > 0
	then
	  do;
	    pstr = substr (pstr, k, j - 1) || tran.out (i)
	         ||
	         substr (pstr, k + j + length (tran.in (i)) - 1,
	         length (pstr) - k - j - length (tran.in (i)) + 2);
	    k = k + j;
	    tran_sw = "1"b;
	  end;
        end;
      end;

    lstr = pstr;			/* save final result for exclusions */
				/* finally, we get to permute! */
    if pstr ^= "" & index (pstr, " ") = 0
				/* phsaw! nothing to permute */
    then call make_bead (pstr || END || pageref);

    else
      do while (pstr ^= "");		/* copy permute word */
        pkey = ltrim (rtrim (before (pstr, " "), ")"), "(");

        if excl.ct > 0		/* apply exclusions */
        then
	do i = 1 to excl.ct;
	  if pkey = excl.key (i)
	  then goto skip_pkey;

	  if substr (pkey || SEP || lstr, 1, length (excl.key (i)))
	       = excl.key (i)
	  then goto skip_pkey;
	end;

        call make_bead (pkey || SEP || str || pageref);

/*
:(permute)
"			prepend every line with its own 1st string
1,$S/^.*;/&%;&/ "		followed by a %
1,$S/;%;/ %%%/ "		replace any null prepends with SP%%%
1,$S/|/ / "		make |'s SPs

"				CREATE key,phrase LINES
b(hits) l
1,$S/)/ ) / "		move parens out of the way
{level:=0}
:(create) "		generate a level of key
1,$S/^(// "		remove initial (
1,$S/^)  <<*>>// 1,$S/^ *%%%/~~ %%%/ "	remove initial ), drop empty keys created
\v{trans} "		apply translation for current type
\B(tran) "			DO SPECIFIED TRANSFORMATIONS
1,$K(index) "		copy all lines onto index
1,$S/^.* // "		strip off first word of key
gd/^ *%%%/ "		delete any lines with empty keys
?1,1,$v<<*>>/%%%/ m(excl)
b(excl) ?1 t!Improper .*tran causes these lines to appear during permutation; they were deleted.! l 1,$p l 1,$d
b(hits) ?1 >(create) "		if any lines left, try again
b(index)
gd/^~~ / "		remove an excluded lines
1,$S/ .*%%%/~/ "		replace "surplus" key plus separator with tilde
1,$S/ ) /)/ "		put paren back together
1,$S/// "		remove the padding character \000
1,$S/^~// "		remove null keys which may have cropped up.
\B(let) "			do final changes
"1,$S/&/ / "		remove linking character
1zif {debug} t|After:| l 1,$P l
" return from permute
> */

skip_pkey:
        pstr = after (pstr, " ");
      end;

  end permute;
%page;
/* Reads one line from the given file and puts it in the 
   char (1024) var string 'line' */
read:
  proc (file) returns (char (*) var);

/* PARAMETERS */

    dcl 1 file	   aligned like null_file;
				/* file being read (INPUT) */

/* LOCAL STORAGE */

    dcl input	   char (max_chars) based (file.ptr);
				/* input string */
    dcl llen	   fixed bin (24);	/* length of line */
    dcl lptr	   ptr;		/* -> line */
				/* point to line */
    lptr = addr (substr (input, file.posn));
				/* set input line length */
    if file.posn <= file.charct	/* if not at EOF, take up to NL */
    then llen =
	    index (substr (input, file.posn, file.charct - file.posn + 1),
	    NL) - 1;		/* take all the rest */
    else llen = file.charct - file.posn + 1;

    if debug
    then call ioa_ ("read: (^a,^d) ""^a""", file.name, linect + 1,
	    substr (input, file.posn, llen));

    file.posn = file.posn + llen + 1;	/* advance file position */
    file.lineno = file.lineno + 1;	/* count input lines */

    return (substr (lptr -> input, 1, llen));
  end read;
%page;
/* Writes the line to the given file */
write:
  proc (file, line);

/* PARAMETERS */

    dcl 1 file	   aligned like null_file;
				/* file being written */
    dcl line	   char (1024) var; /* line to write */

/* LOCAL STORAGE */

    dcl output	   char (max_chars) based (file.ptr);
				/* output string */
    dcl linlen	   fixed bin;	/* length of written */
				/* set output line length */
    linlen = length (line) + 1;	/* 1 for NL */

    substr (output, file.posn, linlen) = line || NL;
    file.posn = file.posn + linlen;	/* advance file position */
    file.charct = file.charct + linlen; /* count output chars */
    file.lineno = file.lineno + 1;	/* and lines */

    if debug
    then call ioa_ ("write: (^a) ""^a""", file.name, line);
  end write;

  end compose_index;




		    convert_runoff.pl1              04/23/85  1100.9rew 04/23/85  0911.3      207378



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   * Copyright, (C) Honeywell Information Systems Inc., 1980 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* Program to convert runoff source files to compose source files. */

/* format: style2,ind3,ll80,dclind4,idind16,comcol41,linecom */

convert_runoff:
cv_rf:
   proc;

/* SYNTAX:  convert_runoff X		no * convention */

/* Written: JAF ?????? */
/* Modified:
01/??/82 - EJW - Rewritten because of various problems.
10/07/82 - EJW - Fixed bug that truncated input pathname.
*/

/* LOCAL STORAGE */

      dcl arg	      char (argl) based (argp);
				/* command line argument */
      dcl argl	      fixed bin;
      dcl argp	      ptr;
      dcl bitct	      fixed bin (24);
				/* segment bitcount */
      dcl cect	      fixed bin;	/* .ce line count */
      dcl code	      fixed bin (35);
				/* system error code */
      dcl CREATE	      bit (1) static options (constant) init ("1"b);
      dcl csd	      char (1) init ("%");
				/* current symbol delimiter */
      dcl ctd	      char (1);	/* local title delimiter */
      dcl db_line	      fixed bin init (-1);
				/* debug ilino */
      dcl eqct	      fixed bin;	/* .eq line count */
      dcl eqsw	      bit (1) init ("1"b);
				/* first .eq switch */
      dcl error_table_$badopt
		      fixed bin (35) ext static;
      dcl error_table_$empty_file
		      fixed bin (35) ext static;
      dcl ftntglsw	      bit (1);	/* footnote toggle switch */
      dcl i	      fixed bin;	/* working index */
      dcl ilin	      char (ilinl) based (ilinp);
				/* current input line */
      dcl ilinl	      fixed bin (24);
				/* length of input line */
      dcl ilino	      fixed bin;	/* input line counter */
      dcl ilinp	      ptr;	/* -> input line */
      dcl in_chars	      fixed bin (24);
				/* input segment char count */
      dcl in_file	      char (200) var;
				/* input file entryname */
      dcl indx	      fixed bin (24);
				/* input file position index */
      dcl input_ptr	      ptr init (null ());
				/* pointer to input file */
      dcl iseg	      char (in_chars) based (input_ptr);
				/* input chars */
      dcl lict	      fixed bin;	/* literal count */
      dcl ME	      char (14) static options (constant)
		      init ("convert_runoff");
      dcl nargs	      fixed bin;	/* number of command line args */
      dcl NL	      char (1) static options (constant) init ("
");
      dcl olin	      char (1024) var;
				/* output line */
      dcl olino	      fixed bin;	/* output line counter */
      dcl olinox	      fixed bin;	/* extra olines used */
      dcl ondx	      fixed bin (24);
				/* output file position index */
      dcl oseg	      char (out_chars) based (output_ptr);
				/* output chars */
      dcl out_chars	      fixed bin (24);
				/* output segment char count */
      dcl out_file	      char (200) var;
				/* output file entryname */
      dcl output_ptr      ptr init (null ());
				/* pointer to output file */

      dcl (before, convert, divide, hbound, index, reverse, rtrim, search,
	substr)	      builtin;

      dcl (cleanup, conversion)
		      condition;

      dcl com_err_	      entry options (variable);
      dcl cu_$arg_count   entry (fixed bin);
      dcl cu_$arg_ptr     entry (fixed bin, ptr, fixed bin, fixed bin (35));
      dcl ioa_	      entry options (variable);

/* PROCESS COMMAND LINE */

      call ioa_ ("convert_runoff 1.6");

      call cu_$arg_count (nargs);
      if nargs < 1
      then
         do;
	  call com_err_ (0, ME,
	       "Usage: convert_runoff <runoff-file-pathname>");
	  return;
         end;

      call cu_$arg_ptr (1, argp, argl, code);
      if code ^= 0
      then
         do;
	  call com_err_ (code, ME, "Reading pathname of input segment.");
	  return;
         end;

      in_file = before (arg, ".runoff") || ".runoff";
      call get_seg_ptr ((in_file), ^CREATE, bitct, input_ptr, code);
      if code ^= 0
      then
         do;
in_file_err:
	  call com_err_ (code, ME, "^a", in_file);
	  return;
         end;

      on condition (cleanup)
         begin;			/* we now have something to clean up */
	  out_chars = 0;
	  call clean;
         end;

      if bitct = 0
      then
         do;
	  call clean;
	  code = error_table_$empty_file;
	  goto in_file_err;
         end;

      in_chars = divide (bitct, 9, 24, 0);
				/* if arg is a path, */
      i = search (reverse (arg), "<>"); /* take only entryname */
      if i = 0
      then i = argl + 1;

      out_file = before (substr (arg, argl + 2 - i), ".runoff") || ".compin";
      call get_seg_ptr (out_file, CREATE, 0, output_ptr, code);
      if code ^= 0
      then
         do;
	  call com_err_ (code, ME, "^a", out_file);
	  goto finish;
         end;

      if input_ptr = output_ptr
      then
         do;
	  call com_err_ (0, ME,
	       "Attempt to specify same segment as input and output.");
	  goto finish;
         end;			/* any more args? */
      call cu_$arg_ptr (2, argp, argl, code);
      if code = 0
      then
         do;
	  if arg = "-db"
	  then
	     do;
	        call cu_$arg_ptr (3, argp, argl, code);

	        on condition (conversion)
		 begin;
		    call com_err_ (0, ME, "Numeric value expected.");
		    db_line = -1;
		    goto revert;
		 end;

	        if code = 0
	        then db_line = convert (db_line, arg);
	        else db_line = 1;

revert:
	        revert conversion;
	     end;

	  else
	     do;
	        call com_err_ (error_table_$badopt, ME, "^a", arg);
	        return;
	     end;
         end;

      indx, ondx = 1;		/* initialize */
      ilino, olino, olinox, lict, cect, eqct, out_chars = 0;
      ftntglsw = "0"b;
%page;
/* SCAN INPUT FILE */
scan_loop:
      do while (indx <= in_chars);
         ilinl = index (substr (iseg, indx, in_chars - indx + 1), NL) - 1;
         if ilinl < 0		/* if no NL, take rest of seg */
				/* MSFs SHOULD BE HANDLED HERE */
         then ilinl = in_chars - indx + 1;

         ilinp = addr (substr (iseg, indx));
				/* point to input line */
         ilino = ilino + 1;		/* count input lines */
         olino = olino + olinox + 1;	/* and output lines */
         olinox = 0;		/* reset extra line count */

         if ilino >= db_line & db_line > 0
         then call ioa_ ("^6d^-in  = ^a", ilino, ilin);

         if lict > 0		/* if a literal */
         then
	  do;
	     olin = ilin;		/* move line to output */
	     lict = lict - 1;	/* count literals */
	  end;

         else
	  do;
	     if substr (ilin, 1, 1) ^= "."
				/* or not a control */
				/* or either comment */
		| substr (ilin, 1, 2) = ".*" | substr (ilin, 1, 2) = ".~"
	     then olin = ilin;	/* move line to output */

	     else
	        do;
		 olin = "";	/* clear output line */
		 call lookup;	/* check for a runoff control */

		 if (index (olin, csd) ^= 0)
		 then call builtin;

		 if (index (olin, BSP) ^= 0)
		 then call relational;
	        end;

	     cect = cect - 1;	/* count .ce lines */
	     if cect = 0
	     then
	        do;
		 olin = olin || NL || ".tbe";
				/* end title block */
		 olin = olin || NL || ".brb";
				/* make it an orphan */
		 olinox = olinox + 2;
	        end;

	     eqct = eqct - 1;	/* count .eq lines */
	     if eqct = 0
	     then
	        do;
		 olin = olin || NL || ".bet";
				/* end title block */
		 olinox = olinox + 1;

		 if ctd ^= "|"
		 then
		    do;
		       olin = olin || NL || ".ctd";
		       olinox = olinox + 1;
		    end;
	        end;
	  end;

         out_chars = out_chars + length (olin) + 1;
				/* grow the output */
				/* MSFs HERE? */
         substr (oseg, ondx) = olin || NL;
				/* append line to output */
         ondx = out_chars + 1;	/* next output position */
         indx = indx + ilinl + 1;	/* advance to next input line */

         if ilino >= db_line & db_line > 0
         then call ioa_ ("^8d^-out = ^a", olino, olin);
      end scan_loop;

finish:
      call clean;
exit:
      return;
%page;
/* CONVERT RUNOFF CONTROLS */

lookup:
   proc;

      dcl ctl_token	      char (4);	/* the runoff control */
      dcl varfld	      char (512) var;
				/* variable field for control */

/* 'tokens' declared at the end of the segment */

relook:
      ctl_token = substr (ilin, 1, min (length (ilin), 4));
      if length (ilin) > 4
      then varfld = rtrim (substr (ilin, 4));
				/* take SP, too */
      else varfld = "";

      do i = 1 to hbound (tokens, 1);	/* go thru token list */

         if substr (tokens (i), 1, 4) = ctl_token
				/* is this the one? */
         then
	  do;			/* if a 1-to-1 token replacement */
	     if substr (tokens (i), 5, 1) = " "
		| substr (tokens (i), 5, 1) = "*"
	     then
	        do;
		 olin = olin || substr (tokens (i), 6);
		 olin = olin || varfld;
				/* varfld starts with SP */
		 return;
	        end;

	     else
	        do;
		 goto rtn (index ("123456789.", substr (tokens (i), 6, 1)));

rtn (0):
		 call ioa_ ("Line ^i: ^a not handled.", ilino, ctl_token);
		 return;

rtn (1):				/* .ar */
		 olin = olin || ".ur .brp " || csd || "PageNo" || csd
		      || " ar";
		 return;


rtn (2):				/*  .ro */
		 olin = olin || ".ur .brp " || csd || "PageNo" || csd
		      || " rl";
		 return;

rtn (3):				/* .ce */
		 olin = olin || ".tbb";
				/* start a title block */
		 olin = olin || NL || ".alc";
				/* centered */
		 olin = olin || NL || ".fif";
				/* and unfilled */
		 olinox = olinox + 2;

		 if varfld = ""	/* default count is 1 */
		 then cect = 2;	/* must be set one too high because */
				/* of the way counting is done in the */
				/* main loop */
		 else
		    do;		/* use given count */
		       on conversion
			begin;
			   call ioa_ ("^a: Numeric value expected in ^a",
			        ME, ilin);
			   cect = 2;
				/* again, 1 too high */
			   goto revert3;
			end;

		       cect = convert (cect, varfld) + 1;
				/* 1 too high */

revert3:
		       revert conversion;
		    end;

		 return;

rtn (4):				/* .eq  */
		 olin = ".bbt";

		 if varfld = ""	/* default count is 1 */
		 then eqct = 2;	/* must be set one too high because */
				/* of the way counting is done in the */
				/* main loop */
		 else
		    do;		/* use given count */
		       on conversion
			begin;
			   call ioa_ ("^a: Numeric value expected in ^a",
			        ME, ilin);
			   eqct = 2;
				/* again, 1 too high */
			   goto revert4;
			end;

		       eqct = convert (eqct, varfld) + 1;
				/* 1 too high */

revert4:
		       revert conversion;
		    end;		/* need a delimiter change? */
		 ctd =		/* get first char of next line */
		      substr (iseg, indx + ilinl + 1, 1);
		 if ctd ^= "|"
		 then
		    do;
		       olin = olin || NL || ".ctd " || ctd;
		       olinox = olinox + 1;
		    end;

		 return;

rtn (5):				/* .fr  */
		 varfld = ltrim (varfld);

		 if varfld = "t"
		 then olin = ".ftp";

		 else if varfld = "f"
		 then olin = ".ftr";

		 else if varfld = "u"
		 then olin = ".ftu";

		 else olin = ".ftp";
		 return;


rtn (6):				/* .ft  */
		 if ftntglsw
		 then olin = ".bef";
		 else olin = ".bbf";
		 ftntglsw = ^ftntglsw;
		 return;

rtn (7):				/* .li  */
		 if varfld = ""	/* default count is 1 */
		 then varfld = " 1";

		 on conversion
		    begin;
		       call ioa_ ("^a: Numeric value expected in ^a", ME,
			  ilin);
		       varfld = " 1";
		       goto revert7;
		    end;

		 lict = convert (lict, varfld);

revert7:
		 revert conversion;

		 olin = ".bbl" || varfld;

		 return;

rtn (8):				/* .ma  */
		 if varfld = ""	/* default is 1 */
		 then varfld = " 1";

		 olin = ".vmt" || varfld || NL;
		 olinox = olinox + 1;
		 olin = olin || ".vmb" || varfld;

		 return;

rtn (9):				/* .ur  */
		 do while (substr (ilin, 1, 3) = ".ur");
				/* do all .ur's */
		    olin = olin || ".ur ";
				/* place a .ur */
		    j = 2 +	/* step over .ur */
		         verify (substr (ilin, min (ilinl, 4)), " ");
		    indx = indx + j;
		    ilinp = addr (substr (iseg, indx));
				/* move input pointer */
		    ilinl = ilinl - j;
		 end;

		 if length (olin) > 4
		 then call ioa_ (
			 "Output line ^i: Multiple .ur's. Check for "
			 || "correct symbol delimiter nesting.", olino);

		 if index (ilin, ".") = 1
				/* is it a control? */
		 then goto relook;
		 else
		    do;
		       olin = olin || ilin;
		       return;
		    end;

rtn (10):				/* headers/footers */
				/* need a delimiter change? */
		 j = verify (varfld, " 0123456789");
		 ctd = substr (varfld, j, 1);
		 if ctd ^= "|"
		 then
		    do;
		       olin = olin || ".ctd " || ctd || NL;
		       olinox = olinox + 1;
		    end;

		 olin = olin || substr (tokens (i), 6);
		 olin = olin || varfld;

		 if ctd = "|"
		 then return;

		 olin = olin || NL || ".ctd";
		 olinox = olinox + 1;
		 return;

	        end;
	  end;
      end;

/* table search failed. line isnt a control */
      olin = ilin;
   end lookup;

/* CONVERT RUNOFF BUILTINS */
builtin:
   proc;

/* Scan the line for cds, extracting the contained variable names.
   If there is no valid variable name, output a csd||PageNo||csd.
   If there is a valid variable name, then search the builtin list;
   if found, then process according to the list.
   if not, then output it, as-is. */

      dcl bname	      char (32) var;/* extracted variable name */
      dcl csdct	      fixed bin;	/* count of opening csd's */
      dcl (i, j, k)	      fixed bin;	/* working index */

      i = 1;			/* init line scan index */

      do while (i <= length (olin));
         j = index (substr (olin, i), csd);
				/* look for a csd */
         if j = 0			/* if none, */
         then return;		/* we're done */
         else i = i + j - 1;		/* move to csd */

         csdct = verify (substr (olin, i), csd) - 1;
				/* step over csd's */

         if csdct < 0		/* a trailing csd? */
         then
	  do;
	     olin = olin || "PageNo" || csd;
	     return;
	  end;

         i = i + csdct;		/* move to first name char */
         j = index (substr (olin, i), csd);
				/* look for next csd */

         if j = 0			/* no more in olin? */
         then goto Np_ref;
         else j = j - 1;

         bname = substr (olin, i, j);	/* extract old name, j holds length */
         k = verify (bname,		/* and validate it */
	    "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789")
	    ;

         if k ^= 0			/* use %PageNo% for invalid names */
         then
	  do;
Np_ref:
	     olin = substr (olin, 1, i - 1) || "PageNo" || csd
		|| substr (olin, i);
	     i = i + 7;
	  end;

         else
	  do;
	     do k = 1 to hbound (builtin_name, 1);
	        if (bname = substr (builtin_name (k), 1, 20))
	        then
		 do;
		    if length (builtin_name (k)) < 21
		    then
		       do;	/* not supported? */
			call ioa_ (
			     "Line ^i: Builtin %^a% is not supported.",
			     ilino, bname);
			goto found;
		       end;

		    else if substr (builtin_name (k), 21, 1) = "."
		    then
		       do;
			olin = ".ur " || olin;
				/* prepend another .ur */
			i = i + 4;/* bif ref has moved */
			call ioa_ (
			     "Output line ^i: Multiple .ur's. Check for "
			     || "correct symbol delimiter nesting.",
			     olino);

			goto bif (
			     index ("1234",
			     substr (builtin_name (k), 22, 1)));

bif (0):				/* error */
			call ioa_ ("Line ^d: Program error processing "
			     || "builtin ^a", ilino, bname);
			goto found;

bif (1):				/* %(%AlignMode% = ""both"")% */
			bname = csd || "(" || csd || "AlignMode" || csd
			     || "= ""both"")" || csd;
			goto found;

bif (2):				/* %(%FootReset% = ""paged"")% */
			bname = csd || "(" || csd || "FootReset" || csd
			     || "= ""paged"")" || csd;
			goto found;

bif (3):				/* %(%FootReset% = ""u"")% */
			bname = csd || "(" || csd || "FootReset" || csd
			     || "= ""u"")" || csd;
			goto found;

bif (4):				/* %(%Device% = ""printer"")% */
			bname = csd || "(" || csd || "Device" || csd
			     || "= ""Printer"")" || csd;
			goto found;
		       end;

		    else
		       do;
			bname = substr (builtin_name (k), 21);
				/* get new name */
			goto found;
		       end;
		 end;
	     end;
found:
	     olin = substr (olin, 1, i - 1) || bname || substr (olin, i + j);
	     i = i + length (bname);	/* move to csd */
	     i = i + csdct;		/* step over closing csd's */
	  end;
      end;
   end builtin;

relational:
   proc;

      dcl (i, k)	      fixed bin;	/* working index */
      dcl relop	      char (3);	/* local copy of rel operator */
      dcl rels	      (8) char (6) static options (constant)
		      init ("/= ^=", "=/ ^=",
				/* these all doubled so */
		      "<_ <=", "_< <=",
				/* canonical form isnt needed */
		      "=_ ==", "_= ==", ">_ >=", "_> >=");

      i = 1;
      do while (i <= length (olin));
         k = index (substr (olin, i), BSP);
				/* look for a BSP */
         if k = 0 | k = length (olin)	/* if none or trailing BSP, */
         then return;		/* we're done */
         else i = i + k - 2;		/* move to preceding char */

         relop = substr (olin, i, 3);	/* extract the rel operator */

         do k = 1 to 8;
	  if (relop = substr (rels (k), 1, 3))
	  then
	     do;
	        olin = substr (olin, 1, i - 1) || substr (rels (k), 5)
		   || substr (olin, i + 3);
	     end;
         end;
         i = i + 3;			/* step over relop */
      end;

   end relational;
%page;
get_seg_ptr:
   proc (pname, create, bitct, ptr, code);

      dcl pname	      char (200) var;
				/* given pathname */
      dcl create	      bit (1);	/* create switch */
      dcl bitct	      fixed bin (24);
				/* bitcount */
      dcl ptr	      ptr;	/* seg pointer */
      dcl code	      fixed bin (35);
				/* error code */

      dcl dname	      char (168);	/* file dirname */
      dcl ename	      char (32);	/* file entryname */

      dcl expand_pathname_
		      entry (char (*), char (*), char (*), fixed bin (35));
      dcl hcs_$initiate_count
		      entry (char (*), char (*), char (*), fixed bin (24),
		      fixed bin (2), ptr, fixed bin (35));
      dcl hcs_$make_seg   entry (char (*), char (*), char (*), fixed bin (5),
		      ptr, fixed bin (35));

      call expand_pathname_ ((pname), dname, ename, code);
      if code ^= 0
      then return;

      call hcs_$initiate_count (dname, ename, "", bitct, 0, ptr, code);
      if ptr ^= null ()
      then
         do;
	  code = 0;
	  return;
         end;

      if create
      then call hcs_$make_seg (dname, ename, "", 01010b, ptr, code);

   end get_seg_ptr;
%page;
release_seg_ptr_:
   proc (pt, bitct, code);

      dcl pt	      ptr,
	bitct	      fixed bin (24),
	code	      fixed bin (35);

      dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
      dcl hcs_$terminate_noname
		      entry (ptr, fixed bin (35));

      code = 0;
      if (pt = null ())
      then return;
      if (bitct > -1)
      then call hcs_$set_bc_seg (pt, bitct, code);
      if (code = 0)
      then call hcs_$terminate_noname (pt, code);

   end;


clean:
   proc;
      if (output_ptr ^= null ())
      then call release_seg_ptr_ (output_ptr, out_chars * 9, code);
      if (input_ptr ^= null ())
      then call release_seg_ptr_ (input_ptr, -1, code);
   end;
%page;
      dcl BSP	      char (1) int static init ("");
      dcl iox_$attach_name
		      entry (char (*), ptr, char (*), ptr, fixed bin (35));
      dcl iox_$close      entry (ptr, fixed bin (35));
      dcl iox_$detach_iocb
		      entry (ptr, fixed bin (35));
      dcl iox_$get_line   entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35))
		      ;
      dcl iox_$open	      entry (ptr, fixed bin, bit (1), fixed bin (35));
      dcl j	      fixed bin;
      dcl recl	      fixed bin;

      dcl (addr, length, mod)
		      builtin;
%page;
/***** CONSTANT ARRAYS */
      dcl builtin_name    (58) char (50) var static options (constant)
		      init ("Ad                  .1", "Ce", "CharsTable",
		      "Charsw", "Console             UserInput",
		      "ConvTable", "Date                Date",
		      "Device              Device", "DeviceTable", "Eq",
		      "Eqcnt               Eqcnt",
		      "ExtraMargin         ExtraMargin",
		      "Fi                  FillMode",
		      "Filesw              OutputFileOpt",
		      "Foot                Footcnt", "FootRef", "Fp",
		      "Fr                  .2", "From",
		      "Ft                  FootnoteMode",
		      "Hyphenating         Hyphenating",
		      "In                  Indent",
		      "InputFileName       InputFileName",
		      "InputLines          InputLineno",
		      "LinesLeft           LinesLeft",
		      "Ll                  PageWidth", "Lp",
		      "Ma1                 VMargTop",
		      "Ma2                 VMargHeader",
		      "Ma3                 VMargFooter",
		      "Ma4                 VMargBottom",
		      "Ms                  LineSpace",
		      "MultiplePagecount   PageSpace",
		      "NestingDepth        InsertIndex",
		      "Nl                  PageLine",
		      "NNp                 NextPageNo",
		      "NoFtNo              .3",
		      "NoPaging            Galley",
		      "Np                  PageNo", "PadLeft",
		      "PageNo              PageNo",
				/* compose bif needed for */
				/* correct handling of .ar and .ro */
		      "Parameter           Parameter",
		      "Passes              Pass",
		      "Pi                  PictureCount",
		      "Pl                  PageLength",
		      "Printersw           .4",
		      "PrintLineNumbers    LineNumberOpt", "Roman", "Selsw",
		      "SpecCh              SymbolDelimiter", "Start",
		      "Stopsw              StopOpt", "TextRef", "Time",
		      "To", "TrTable             TrTable",
		      "Un                  Undent",
		      "Waitsw              WaitOpt");
				/* entries in this array are coded */
				/* chars 1,4 - runoff control */
				/* char  5   - action flag */
				/* chars 6,$ - replacement or */
				/*	     function index */
/**** format: off */
dcl tokens	(55) char (12) var static options (constant) init (
		".ad  .alb", ".ar -1",      ".bp  .brp", ".br  .brf",
		".cc  .csd", ".ce -3",      ".ch  .tre", ".ds  .ls 2",
		".ef -.fle", ".eh -.hle",   ".eq -4",    ".ep  .brp e",
".ex  .exc",
		".fh -.hlf", ".fi  .fin",   ".fo -.fla", ".fr -5",
		".ft -6",    ".gb  .go",    ".gf  .go",  ".he -.hla",
		".if  .ifi", ".in  .inl",   ".la  .la",  ".li -7",
		".ll  .pdw", ".m1  .vmt",   ".m2  .vmh", ".m3  .vmf",
		".m4  .vmb", ".ma -8",      ".mp  .ps",  ".ms  .ls",
		".na  .all", ".ne  .brn",   ".nf  .fif", ".of -.flo",
		".oh -.hlo", ".op  .brp o", ".pa  .brp", ".pi  .bbp",
		".pl  .pdl", ".rd  .rd",    ".ro -2",    ".rt  .rt",
		".sk  .brs", ".sp  .spb",   ".sr  .srv", ".ss  .ls 1",
		".tr  .trn", ".ts  .ts",    ".ty  .ty",  ".un  .unl",
		".ur -9",    ".wt  .wt");
/*** format: on */
   end convert_runoff;




		    display_comp_dsm.pl1            02/16/88  1455.7r w 02/16/88  1411.9      284742



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

/* Written: ??/80 - Jim Falksen
/* Modified: 6/83 - Ed Wallman - Added -all, cleaned up and modernized.
/* Modified: 9/83 - Ed Wallman - Added lcdsm command entry. Changed
/*		display_comp_dsm short name to dcdsm.
*/

display_comp_dsm:
dcdsm:
  proc;

/* Usage:	dcdsm dsm_path {-linelength N}			       */
/* 	This displays all the external DSM names in the specified segment. */
/* Usage:	dcdsm dsm_path -device {-linelength N}			       */
/*	This displays all the names and synonyms on the specified device,  */
/*	also lists all the family/member names and bachelors in the DSM.   */
/* Usage:	dcdsm dsm_path -long {-linelength N}			       */
/*	This is like the previous one with the addition of a list of many  */
/*	parameters about the device, max pagelength, etc.		       */
/* Usage:	dcdsm dsm_path family{/member} -{linelength N}		       */
/*	This shows all the defined graphics in the specified family/member */
/*	or bachelor with their widths.			       */
/* Usage:	dcdsm dsm_path family{/member} -long {-linelength N}	       */
/*	This shows all the defined graphics with their widths and output   */
/*	strings.						       */


/* Usage:	lcdsm {starname}					       */
/* 	This displays all the matching DSM names found with compose search */
/*	list. Default starname is **.				       */
/* Usage:	lcdsm {starname} -pathname PATH			       */
/* 	This displays all the matching DSM names found in the directory    */
/*	PATH. Default starname is **.				       */
/* Usage:	lcdsm {starname} -working_dir				       */
/* 	This displays all the matching DSM names found in the working      */
/*	directory. Default starname is **.			       */
%page;
    dcl code	   fixed bin (35);	/* error code */
    dcl colwidth	   fixed bin;
    dcl dname	   char (168);	/* module dir name */
    dcl dsmpath	   char (200);	/* module path name */
    dcl dsmptr	   ptr;		/* module object pointer */
    dcl DSNAME	   char (16) int static options (constant)
		   init ("display_comp_dsm");
    dcl ename	   char (32);	/* module entry name */
    dcl familyname	   char (32);	/* font family name */
    dcl i		   fixed bin;	/* working index */
    dcl indent	   fixed bin;	/* display indentation */
    dcl ipath	   fixed bin;	/* search path coutner */
    dcl istar	   fixed bin;	/* star name counter */
    dcl linea	   char (200) var;	/* an output line */
    dcl lineb	   char (200) var;	/* another */
    dcl linelength	   fixed bin;
    dcl LSNAME	   char (16) int static options (constant)
		   init ("list_comp_dsm");
    dcl me	   char (16) var;
    dcl membername	   char (32);
    dcl sl_info_area   area (2048);
    dcl star_area	   area (2048);
    dcl star_code	   fixed bin (35);	/* starname type code */
    dcl starname	   char (200);
    dcl 1 sws,			/* control switches */
	2 debug	   bit (1) unal,	/* 1= -debug */
	2 device	   bit (1) unal,	/* 1= -device */
	2 error	   bit (1) unal,	/* 1= command line error */
	2 long	   bit (1) unal,	/* 1= -long */
	2 path	   bit (1) unal,	/* 1= -pathname */
	2 mbz	   bit (31) unal;

    dcl (addr, after, before, binary, length, null, ptr, rank, size, substr,
        sum, unspec)   builtin;

    dcl cleanup	   condition;

    dcl error_table_$name_not_found
		   fixed bin (35) ext static;
    dcl error_table_$no_dir
		   fixed bin (35) ext static;
    dcl error_table_$no_ext_sym
		   fixed bin (35) ext static;
    dcl error_table_$nomatch
		   fixed bin (35) ext static;
    dcl error_table_$unimplemented_version
		   fixed bin (35) ext static;

    dcl com_err_	   entry options (variable);
    dcl expand_pathname_
		   entry (char (*), char (*), char (*), fixed bin (35));
    dcl expand_pathname_$add_suffix
		   entry (char (*), char (*), char (*), char (*),
		   fixed bin (35));
    dcl hcs_$star_	   entry (char (*), char (*), fixed bin (2), ptr,
		   fixed bin, ptr, ptr, fixed bin (35));
    dcl ioa_$rsnnl	   entry options (variable);
    dcl pathname_	   entry (char (*), char (*)) returns (char (168));
    dcl search_paths_$get
		   entry (char (*), bit (36), char (*), ptr, ptr,
		   fixed bin, ptr, fixed bin (35));

    me = DSNAME;

    goto join;

list_comp_dsm:
lcdsm:
  entry;

    me = LSNAME;

join:				/* set constants structure pointer */
    compstat$compconst.ptr = addr (compstat$compconst.ptr);

    call proc_args;			/* process args */

    if error			/* cant continue */
    then return;

    if (familyname ^= "") | long	/* these options need the switch */
    then device = "1"b;
    lineb = "";

    on cleanup call clean;

    if me = LSNAME
    then
      do;
        if path			/* was a pathname given? */
        then
	do;			/* expand possible relative name */
	  call expand_pathname_ (dsmpath, dname, ename, code);
	  if (code ^= 0)
	  then
	    do;
	      call com_err_ (code, me, "^/^5xExpanding given pathname, ^a",
		 dsmpath);
	      return;
	    end;
	  dname = pathname_ (dname, ename);

	  call			/* get list of dsm's in this dir */
	       hcs_$star_ (dname, starname, star_ALL_ENTRIES,
	       addr (star_area), star_entry_count, star_entry_ptr,
	       star_names_ptr, code);
	  if (code ^= 0)
	  then
	    do;
	      call com_err_ (code, me, "^/^5xGetting comp_dsm names in ^a",
		 dname);
	      return;
	    end;

	  if debug
	  then call ioa_ ("star used = ^i",
		  size (star_entries) + size (star_names));

	  do istar = 1 to star_entry_count;
	    ename = star_names (star_entries (istar).nindex);
	    call show_dsm;
	  end;
	end;

        else			/* user wants them all */
	do;
	  call search_paths_$get ("compose", sl_control_default, "", null,
	       addr (sl_info_area), sl_info_version_1, sl_info_p, code);
	  if (code ^= 0)
	  then
	    do;
	      call com_err_ (code, me, "^/^Getting compose search list.");
	      return;
	    end;

	  do ipath = 1 to sl_info.num_paths;
	    dname = sl_info.paths (ipath).pathname;
				/* dont repeat any dirs */
	    do i = 1 to ipath while (dname ^= sl_info.paths (i).pathname);
	    end;

	    if i = ipath
	    then
	      do;
	        call		/* get list of dsm's in this dir */
		   hcs_$star_ (dname, starname, star_ALL_ENTRIES,
		   addr (star_area), star_entry_count, star_entry_ptr,
		   star_names_ptr, code);
	        if code ^= 0 & code ^= error_table_$nomatch
		   & code ^= error_table_$no_dir
	        then call com_err_ (code, me,
		        "^/^5xGetting comp_dsm names in ^a", dname);

	        else if code ^= error_table_$nomatch
	        then
		do;
		  call ioa_ ("^/^-At ^a...", dname);

		  if debug
		  then call ioa_ ("star used = ^i",
			  size (star_entries) + size (star_names));

		  do istar = 1 to star_entry_count;
		    ename = star_names (star_entries (istar).nindex);
		    call show_dsm;
		  end;
		end;
	      end;
	  end;
	end;
      end;

    else				/* only a module name */
      do;
        call expand_pathname_$add_suffix (dsmpath, "comp_dsm", dname, ename,
	   code);
        if (code ^= 0)
        then
	do;
	  call com_err_ (code, me, "^/^5xExpanding given module name, ^a",
	       dsmpath);
	  return;
	end;

        call show_dsm;
      end;

    return;
%page;
show_dsm:
  proc;

    dcl ACCptr	   ptr;		/* ACC strings */
    dcl 1 ACC	   aligned based (ACCptr),
	2 len	   fixed bin (8) unal,
	2 string	   char (ACC.len) unal;
    dcl bitcount	   fixed bin (24);	/* module object bit count */
    dcl defptr	   ptr;		/* dsminfo definition pointer */
    dcl 1 dsminfo	   like object_info;
    dcl dvtcount	   fixed bin;	/* number of device tables to do */
    dcl dvtname	   char (32) var;	/* device table name */
    dcl 1 objseg	   (0:100),	/* interesting object segment ptrs */
	2 symbolptr  ptr,
	2 name	   char (32),
	2 dvidptr	   ptr,
	2 dvtptr	   ptr;

    dcl addrel	   builtin;

    dcl error_table_$improper_data_format
		   fixed bin (35) ext static;

    dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24),
		   fixed bin (35));
    dcl ioa_$nnl	   entry options (variable);
    dcl object_info_$brief
		   entry (ptr, fixed bin (24), ptr, fixed bin (35));

    dsmptr = null ();		/* intialize auto storage */
    dsmpath = pathname_ (dname, ename);
    call initiate_file_ (dname, ename, R_ACCESS, dsmptr, bitcount, code);
    if (dsmptr = null ())
    then
      do;
        call com_err_ (code, me, "^/^5xInitiating ^a", dsmpath);
        return;
      end;			/* */
				/* get object info for the module */
    dsminfo.version_number = object_info_version_2;
    call object_info_$brief (dsmptr, bitcount, addr (dsminfo), code);
    if (code ^= 0)
    then
      do;
        call com_err_ (code, me, "^/^5xGetting object info for ^a", dsmpath);
        call clean;
        return;
      end;

    if ^dsminfo.format.standard	/* must be a standard object segment */
    then
      do;
        call com_err_ (error_table_$improper_data_format, me,
	   "^/^5x^a is not a standard object segment.", dsmpath);
        call clean;
        return;
      end;

    dvtcount = 0;
    defptr =			/* point to first def */
         addrel (dsminfo.defp, dsminfo.defp -> definition_header.def_list_relp)
         ;

    if device			/* is device switch on? */
    then				/* look for given device */
      do;				/* form device table name */
        dvtname = before (ename, ".comp_dsm") || ".dvt";
        do defptr = defptr		/* walk the definition thread */
	   repeat addrel (dsminfo.defp, defptr -> definition.forward_relp)
	   while (defptr -> definition.forward_relp ^= 0);
				/* point to symbol's ACC */
	ACCptr = addrel (dsminfo.defp, defptr -> definition.name_relp);
	if (defptr -> definition.class = CLASS_TEXT) & (ACC.string = dvtname)
	then
	  do;
	    dvtcount = dvtcount + 1;	/* record interesting stuff */
	    objseg.symbolptr (dvtcount) = ACCptr;
	    objseg.dvidptr (dvtcount), const.dvidptr =
	         addrel (dsminfo.textp, defptr -> definition.thing_relp);
	    objseg.dvtptr (dvtcount) = ptr (dsminfo.textp, comp_dvid.dvt_r);
	    objseg.name (dvtcount) = before (ACC.string, ".");
	    goto found_device;
	  end;
        end;

        call com_err_ (error_table_$no_ext_sym, me,
	   "^/^5x^a symbol definition in ^a.", dvtname, dsmpath);
        call clean;
        return;
      end;

    else				/* device switch is off */
      do;				/* record module's segname def ptr */
        objseg.dvidptr (0) = ptr (dsminfo.defp, 0);
        do defptr = defptr		/* walk definition thread */
	   repeat addrel (dsminfo.defp, defptr -> definition.forward_relp)
	   while (defptr -> definition.forward_relp ^= 0);
				/* point to symbol's ACC */
	ACCptr = addrel (dsminfo.defp, defptr -> definition.name_relp);
				/* take only device tables */
	if (defptr -> definition.class = CLASS_TEXT)
	     & (after (ACC.string, ".") = "dvt")
	then
	  do;
	    dvtcount = dvtcount + 1;	/* record interesting stuff */
	    objseg.symbolptr (dvtcount) = ACCptr;
	    objseg.dvidptr (dvtcount), const.dvidptr =
	         addrel (dsminfo.textp, defptr -> definition.thing_relp);
	    objseg.dvtptr (dvtcount) = ptr (dsminfo.textp, comp_dvid.dvt_r);
	    objseg.name (dvtcount) = before (ACC.string, ".");
	  end;
        end;
      end;

found_device:
    objseg.dvidptr (dvtcount + 1) = null ();
    objseg.dvtptr (dvtcount + 1) = null ();
				/* display the requested info */
    do i = dvtcount to 0 by -1;	/* do it backwards because defs */
				/* are reverse threaded */
      if i > 0
      then const.dvidptr = objseg.dvidptr (i);
				/* check structure version */
      if comp_dvid.version < 0 | comp_dvid.version > comp_dvid_version
      then
        do;
	call com_err_ (error_table_$unimplemented_version, me,
	     "^/^5x^a is not a valid device table.", dsmpath);
	call clean;
	return;
        end;

      else
        do;			/* if this device is just an addname */
	if objseg.dvidptr (i + 1) = objseg.dvidptr (i)
	then call ioa_$nnl (", ^a", objseg.name (i));

	else			/* this is a real device table */
	  do;			/* is it "like" a previous device? */
	    do j = dvtcount to i + 2 by -1;
	      if (objseg.dvtptr (i + 1) = objseg.dvtptr (j)
		 & objseg.dvidptr (i + 1) ^= objseg.dvidptr (j))
	      then		/* yes */
	        do;
		call ioa_ (" like ^a;", objseg.name (j));
		goto found;
	        end;
	    end;

	    if i < dvtcount		/* don't do this for first device */
	    then call show_dvt;
found:
	    if i > 0		/* don't do this for last device */
	    then
	      do;
	        call ioa_$nnl ("Device:^-^a", objseg.name (i));
	        const.dvidptr = objseg.dvidptr (i);
	        const.devptr = pointer (const.dvidptr, comp_dvid.dvt_r);
	      end;
	  end;
        end;
    end;

    call clean;
    return;
%page;
show_dvt:
  proc;

    dcl charvp	   ptr;
    dcl charv	   char (5000) var based (charvp);

    call ioa_ (";^/  devclass: ^a;", comp_dvt.devclass);

    if ^device			/* thats all if device switch is off */
    then return;

    call comp_dvt.outproc (1, code);

    if familyname ^= ""		/* was a font given? */
    then call show_a_font;

    else				/* just show device info */
      do;
        if long			/* long form? */
        then
	do;
	  call			/* version ids */
	       ioa_ ("/* version: ^i (^i) */", comp_dvid.version,
	       comp_dvid_version);

	  call ioa_ ("  units: pt;"); /* canned til its implemented */

	  if comp_dvt.atd_r ^= "0"b	/* attach description */
	  then
	    do;
	      call display_new_str ((comp_dvt.atd_r));
	      call ioa_ ("  attach: ^a;", linea);
	    end;			/* */
				/* comment */
	  if comp_dvt.comment_r ^= "0"b
	  then
	    do;
	      charvp = pointer (const.dvidptr, comp_dvt.comment_r);
	      call ioa_ ("  comment: ""^a"";", charv);
	    end;			/**/
				/* cleanup string */
	  if comp_dvt.cleanup_r ^= "0"b
	  then
	    do;
	      call display_new_str ((comp_dvt.cleanup_r));
	      call ioa_ ("  cleanup: ^a;", linea);
	    end;			/**/
				/* default page margins */
	  call ioa_ ("  defaultmargs: ^f, ^f, ^f, ^f;",
	       dec (comp_dvt.def_vmt, 11, 3) / 1000,
	       dec (comp_dvt.def_vmh, 11, 3) / 1000,
	       dec (comp_dvt.def_vmf, 11, 3) / 1000,
	       dec (comp_dvt.def_vmb, 11, 3) / 1000);
				/* minimum top margin */
	  call ioa_ ("  mintopmarg: ^f;",
	       dec (comp_dvt.vmt_min, 11, 3) / 1000);
				/* minimum bottom margin */
	  call ioa_ ("  minbottommarg: ^f;",
	       dec (comp_dvt.vmb_min, 11, 3) / 1000);
				/* minimum horizontal whitespace */
	  call ioa_ ("  minspace: ^f;", dec (comp_dvt.min_WS, 11, 3) / 1000);
				/**/
				/* minimum vertical resolution */
	  call ioa_ ("  minlead: ^f;", dec (comp_dvt.min_lead, 11, 3) / 1000)
	       ;

	  call ioa_ ("  init: ^a^a ^f;", comp_dvt.init_family,
	       comp_dvt.init_member, dec (comp_dvt.init_ps, 11, 3) / 1000);
	  call ioa_ ("  interleave: ^[on^;off^];", comp_dvt.interleave);
	  call ioa_ ("  letterspace: ^i;", comp_dvt.lettersp);
	  call ioa_ ("  maxpages: ^[unlimited^;^i^];",
	       (comp_dvt.max_pages = -1), comp_dvt.max_pages);
	  call ioa_ ("  maxfiles: ^[unlimited^;^i^];",
	       (comp_dvt.max_files = -1), comp_dvt.max_files);
	  call ioa_ ("  maxpagelength: ^[unlimited^;^f^];",
	       (comp_dvt.pdl_max = -1), dec (comp_dvt.pdl_max, 11, 3) / 1000)
	       ;
	  call ioa_ ("  maxpagewidth: ^f;",
	       dec (comp_dvt.pdw_max, 11, 3) / 1000);
	  call ioa_ ("  minbotmarg: ^f;",
	       dec (comp_dvt.vmb_min, 11, 3) / 1000);
	  call ioa_ ("  mintopmarg: ^f;",
	       dec (comp_dvt.vmt_min, 11, 3) / 1000);
	  call ioa_ ("  stream: ^[on^;off^];", (comp_dvt.open_mode = 2));
	  call ioa_ ("  taperec: ^[unlimited^;^f^];",
	       (comp_dvt.pdl_max = -1), comp_dvt.pdl_max);
	end;
        call show_families;
      end;
%page;
show_a_font:			/* dispaly characters defined for a font */
  proc;

    dcl (f, m)	   fixed bin;	/* working index */

    dcl length	   builtin;

    do f = 1 to comp_dvt.family_ct;	/* search for the font */
      if comp_dvt.family.name (f) = familyname
      then
        do;
	member_ptr = ptr (const.dvidptr, comp_dvt.member_r (f));

	if (member.count > 1 | member.name (1) ^= "") & membername = ""
	then membername = "/m";

	do m = 1 to member.count;
	  if (member.name (m) = membername)
	  then goto found;
	end;

	call com_err_ (error_table_$name_not_found, me,
	     "^a not found in family ^a on device ^a.", membername,
	     familyname, before (dvtname, ".dvt"));
	return;
        end;
    end;

    call com_err_ (error_table_$name_not_found, me,
         "Font ^a not found on device ^a.", familyname,
         before (dvtname, ".dvt"));
    return;

found:
    if membername = ""
    then call ioa_ ("  bachelor: ^a;", familyname);
    else call ioa_ ("  family: ^a; member: ^a;", familyname, membername);

    font_ptr = ptr (const.devptr, member.font_r (m));
    oput_p = ptr (const.devptr, font.oput_r);
    medsel_table_ptr = ptr (const.dvidptr, comp_dvt.medsel_table_r);
    med_sel_p = pointer (const.devptr, medsel_table.ref_r (oput.which (32)));

    call ioa_ ("  strokes: ^i^/  wordspace: ^i,^i,^i^/  footsep: ^a^/  "
         || "medsel: ""^a""", font.rel_units, font.min_wsp, font.avg_wsp,
         font.max_wsp, comp_util_$display ((font.footsep), 0, "0"b),
         comp_util_$display
         ((med_sel_p -> substr (med_sel.str, 1, med_sel.str_l)), 0, "0"b));

    units_ptr = ptr (const.devptr, font.units_r);
    linea = "";

    if long
    then colwidth = 16;
    else colwidth = 10;

    do kk = 0 to oput.data_ct;
      if oput.what_r (kk) ^= "0"b
      then
        do;
	if kk >= 32 & kk < 127
	then linea = linea || byte (kk);
	else linea = linea || comp_util_$display ((byte (kk)), 0, "0"b);
	linea = linea || " (" || ltrim (char (units (kk)));

	if long
	then
	  do;
	    linea = linea || ",";
	    call display_str (oput.what_r (kk));
	  end;

	linea = linea || ")";
	call put_str (0);
	linea =
	     copy (" ", colwidth - mod (length (lineb) + 1, colwidth) + 1);
        end;
    end;
    if (lineb ^= "")
    then call ioa_ ("^a", lineb);

/* *** format: off */
    dcl bitname			/* char names for tables */
		   (0:511) char (16) var int static options (constant)
		   init ("NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK",
		   "BEL", "BSP", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
		   "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
		   "CAN", "031", "SUB", "ESC", "FS", "GS", "RS", "US",
		   "SP", """!""", """""""", """#""", """$""", """%""",
		   """&""", """'""", """(""", """)""", """*""", """+""",
		   """,""", """-""", """.""", """/""", """0""", """1""",
		   """2""", """3""", """4""", """5""", """6""", """7""",
		   """8""", """9""", """:""", """;""", """<""", """=""",
		   """>""", """?""", """@""", """A""", """B""", """C""",
		   """D""", """E""", """F""", """G""", """H""", """I""",
		   """J""", """K""", """L""", """M""", """N""", """O""",
		   """P""", """Q""", """R""", """S""", """T""", """U""",
		   """V""", """W""", """X""", """Y""", """Z""", """[""",
		   """\""", """]""", """^""", """_""", """`""", """a""",
		   """b""", """c""", """d""", """e""", """f""", """g""",
		   """h""", """i""", """j""", """k""", """l""", """m""",
		   """n""", """o""", """p""", """q""", """r""", """s""",
		   """t""", """u""", """v""", """w""", """x""", """y""",
		   """z""", """{""", """|""", """}""", """~""", "PAD",
		   "200", "201", "202", "203", "204", "205", "206", "207",
		   "210", "211", "212", "213", "214", "215", "216", "217",
		   "220", "221", "222", "223", "224", "225", "226", "227",
		   "230", "231", "232", "233", "234", "235", "236", "237",
		   "240", "241", "242", "243", "244", "245", "246", "247",
		   "250", "251", "252", "253", "254", "EMdash", "256",
		   "257", "260", "261", "262", "263", "264", "265", "266",
		   "267", "270", "271", "272", "273", "274", "275", "276",
		   "277", "300", "301", "302", "(c)", "304", "305", "306",
		   "307", "310", "311", "312", "313", "314", "o", "316",
		   "317", "320", "321", "322", "323", "324", "325", "326",
		   "327", "330", "331", "332", "333", "334", "335", "336",
		   "337", "340", "341", "342", "343", "344", "345", "346",
		   "347", "350", "351", "352", "353", "354", "355", "356",
		   "357", "360", "361", "362", "363", "364", "365", "366",
		   "367", "370", "371", "372", "373", "374", "375", "376",
		   "PS", "^0", "^1", "^2", "^3", "^4", "^5", "^6", "^7",
		   "^8", "^9", "EM", "EM_", "EN", "EN_", "ENd", "THIN",
		   "DEVIT", "``", "''", "1hi-X", "424", "dn-arrow", "426",
		   "dia-left", "delete-mark", "dia-right", "dia-top", "<",
		   "1hi-{", "1hi-[", "left-circle", "437", "->", "1hi-}",
		   "1hi-]", "right-circle", "444", "up-arrow", "446",
		   "447", "450", "451", "452", "453", "454", "455", "456",
		   "457", "460", "461", "462", "463", "464", "465", "466",
		   "467", "470", "471", "472", "473", "474", "475", "476",
		   "477", "500", "501", "502", "503", "504", "505", "506",
		   "507", "510", "511", "512", "513", "514", "515", "516",
		   "517", "520", "521", "522", "523", "524", "525", "526",
		   "527", "530", "531", "532", "533", "534", "535", "536",
		   "537", "540", "541", "542", "543", "544", "545", "546",
		   "547", "550", "551", "552", "553", "554", "555", "556",
		   "557", "560", "561", "562", "563", "564", "565", "566",
		   "567", "570", "571", "572", "573", "574", "575", "576",
		   "577", "600", "601", "602", "603", "604", "605", "606",
		   "607", "610", "611", "612", "613", "614", "615", "616",
		   "617", "620", "621", "622", "623", "624", "625", "626",
		   "627", "630", "631", "632", "633", "634", "635", "636",
		   "637", "640", "641", "642", "643", "644", "645", "646",
		   "647", "650", "651", "652", "653", "654", "655", "656",
		   "657", "660", "661", "662", "663", "664", "665", "666",
		   "667", "670", "671", "672", "673", "674", "675", "676",
		   "677", "700", "701", "702", "703", "704", "705", "706",
		   "707", "710", "711", "712", "713", "714", "715", "716",
		   "717", "720", "721", "722", "723", "724", "725", "726",
		   "727", "730", "731", "732", "733", "734", "735", "736",
		   "737", "740", "741", "742", "743", "744", "745", "746",
		   "747", "750", "751", "752", "753", "754", "755", "756",
		   "757", "760", "761", "762", "763", "764", "765", "766",
		   "767", "770", "771", "772", "773", "774", "775", "776",
		   "777");	/* *** format: on */
  end show_a_font;
%page;
show_families:
  proc;

    dcl bach_sw	   bit (1);
    dcl j		   fixed bin;

    dcl length	   builtin;

    first = "1"b;
    do j = 1 to comp_dvt.family_ct;
      member_ptr = ptr (const.dvidptr, comp_dvt.member_r (j));
      bach_sw = (member.name (1) = "");
      if first
      then
        do;
	if debug
	then
	  do;
	    if bach_sw
	    then call ioa_$rsnnl ("^.3b", linea, 0, member.font_r (1));
	    else linea = "";
	    linea = linea || copy (" ", 10 - length (linea));
	  end;
	else linea = "    ";
	if bach_sw
	then linea = linea || "bachelor:";
	else linea = linea || "family:";
        end;
      else
        do;
	linea = linea || ",";
	call put_str (indent);
	linea = "";
        end;
      linea = linea || " ";
      linea = linea || rtrim (comp_dvt.name (j));
      if debug
      then
        do;
	linea = linea || "(";
	linea = linea || ltrim (char (j));
	linea = linea || ")";
        end;
      first = "0"b;
      if (j = comp_dvt.family_ct)
      then call show_members;
      else if (comp_dvt.member_r (j) ^= comp_dvt.member_r (j + 1))
      then call show_members;
    end;
    call put_str (indent);
%page;
show_members:
  proc;

    first = "1"b;
    if (member.name (1) ^= "")
    then
      do;
        didmem (*) = "0"b;
        do k = 1 to member.count;
	if ^didmem (k)
	then
	  do;
	    if first
	    then
	      do;
	        linea = linea || ";";
	        call put_str (indent);
	        call ioa_ ("^a", lineb);
	        lineb = "";
	      end;
	    if debug
	    then call ioa_$rsnnl ("^.3b", linea, 0, member.font_r (1));
	    else linea = "";
	    linea = linea || "      member: ";
	    linea = linea || rtrim (member.name (k));
	    if debug
	    then
	      do;
	        linea = linea || "(";
	        linea = linea || ltrim (char (k));
	        linea = linea || ")";
	      end;
	    first = "0"b;
	    didmem (k) = "1"b;
	    do kk = k + 1 to member.count;
	      if (member.font_r (k) = member.font_r (kk))
	      then
	        do;
		linea = linea || ",";
		call put_str (indent);
		linea = " ";
		linea = linea || rtrim (member.name (kk));
		if debug
		then
		  do;
		    linea = linea || "(";
		    linea = linea || ltrim (char (kk));
		    linea = linea || ")";
		  end;
		didmem (kk) = "1"b;
	        end;
	    end;
	    first = "1"b;		/*	     if alt_sw
				   then do;
				   linea = linea || ";";
				   call put_str (indent);
				   call ioa_ ("^a", lineb);
				   lineb = "";
				   end;	       */
	  end;
        end;
      end;
    linea = linea || ";";
    call put_str (indent);
    call ioa_ ("^a", lineb);
    lineb = "";
    first = "1"b;

  end show_members;

  end show_families;

  end show_dvt;

  end show_dsm;

put_str:
  proc (indent);

    dcl indent	   fixed bin;

    if (length (linea) + length (lineb) > linelength)
    then
      do;
        if lineb ^= ""
        then
	do;
	  call ioa_ ("^a", lineb);
	  lineb = copy (" ", indent);
	end;
        else lineb = "";
        lineb = lineb || ltrim (linea);
      end;
    else lineb = lineb || linea;
    linea = "";

  end put_str;

display_new_str:
  proc (str_r);

    linea = "";

display_str:
  entry (str_r);

    dcl str_r	   bit (18);

    dcl ch	   char (1);
    dcl bins	   (3) fixed bin (3) unsigned unal based (addr (ch));
    dcl kkk	   fixed bin;
    dcl lined	   char (200) var;

    medchar_sel_p = ptr (const.devptr, str_r);
    lined = comp_util_$display ((medchar_sel.str), 0, "0"b);
    linea = linea || """" || lined;
    linea = linea || """";

  end display_new_str;
%page;
clean:
  proc;

    dcl terminate_file_
		   entry (ptr, fixed bin (24), bit (*), fixed bin (35));

    call terminate_file_ (dsmptr, 0, TERM_FILE_TERM, code);
    if (code ^= 0)
    then call com_err_ (code, me, "Terminating ^a", dsmpath);

  end clean;
%page;
proc_args:
  proc;

    dcl arg	   char (argl) based (argp);
    dcl argct	   fixed bin;	/* number of args given */
    dcl argl	   fixed bin (21);
    dcl argno	   fixed bin;	/* arg counter */
    dcl argp	   ptr;

    dcl (decat, index) builtin;

    dcl error_table_$badopt
		   fixed bin (35) ext static;
    dcl error_table_$noarg
		   fixed bin (35) ext static;
    dcl iox_$user_output
		   ptr ext static;

    dcl check_star_name_$entry
		   entry (char (*), fixed bin (35));
    dcl cu_$af_arg_count
		   entry (fixed bin, fixed bin (35));
    dcl cu_$arg_ptr	   entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
    dcl cv_dec_check_  entry (char (*), fixed bin (35))
		   returns (fixed bin (35));
    dcl get_line_length_$switch
		   entry (ptr, fixed bin (35)) returns (fixed bin);
    dcl get_wdir_	   entry returns (char (168));

    unspec (sws) = "0"b;		/* preset switches */
    star_code = 0;
    dsmpath, familyname, membername = "";

    call cu_$af_arg_count (argct, code);
    if code = 0
    then
      do;
        call com_err_ (0, me, "Not callable as an active function.");
        error = "1"b;
        return;
      end;

    if me = DSNAME			/* display_comp_dsm args */
    then
      do;
        if argct = 0
        then
	do;
	  call com_err_ (error_table_$noarg, me,
	       "^/^5xProper usage: dcdsm path {font} {-control_args}");
	  error = "1"b;
	  return;
	end;

        linelength = get_line_length_$switch (iox_$user_output, code);
        if code ^= 0
        then linelength = 80;
        indent = 10;

        do argno = 1 to argct;
	call cu_$arg_ptr (argno, argp, argl, code);

	if (code = 0)
	then
	  do;
	    if (index (arg, "-") = 1)
	    then
	      do;
	        if (arg = "-device") | (arg = "-dv")
	        then device = "1"b;

	        else if (arg = "-linelength") | (arg = "-ll")
	        then
		do;
		  if argno = argct
		  then
		    do;
missing_arg:
		      call com_err_ (error_table_$noarg, me,
			 "Value for ^a", arg);
		      error = "1"b;
		    end;

		  else
		    do;
		      argno = argno + 1;
		      call cu_$arg_ptr (argno, argp, argl, code);
		      linelength = cv_dec_check_ (arg, code);
		      if (code ^= 0)
		      then
		        do;
			call com_err_ (0, me,
			     "Invalid decimal value. ^a", arg);
			error = "1"b;
		        end;
		    end;
		end;

	        else if (arg = "-long") | (arg = "-lg")
	        then long = "1"b;

	        else if (arg = "-debug") | (arg = "-db")
	        then
		do;
		  debug = "1"b;
		  indent = 16;
		end;

	        else
		do;
badopt:
		  call com_err_ (error_table_$badopt, me, "^a", arg);
		  error = "1"b;
		end;
	      end;

	    else
	      do;
	        if dsmpath = ""	/* first name is the module */
	        then dsmpath = arg;

	        else if familyname = ""
				/* second name is a font */
	        then
		do;
		  familyname = before (arg, "/");
		  membername = decat (arg, "/", "011"b);
		end;

	        else
		do;
		  call com_err_ (0, me, "Too many positional args. ^a",
		       arg);
		  error = "1"b;
		end;
	      end;
	  end;

	else
	  do;
	    call com_err_ (code, me, "Reading argument ^i", argno);
	    error = "1"b;
	  end;
        end;

        if dsmpath = ""		/* must have a module */
        then
	do;
	  call com_err_ (error_table_$noarg, me, "No dsm_name specified.");
	  error = "1"b;
	end;
      end;

    else				/* list_comp_dsm args */
      do;
        starname = "";

        do argno = 1 to argct;
	call cu_$arg_ptr (argno, argp, argl, code);

	if (code = 0)
	then
	  do;
	    if (index (arg, "-") = 1)
	    then
	      do;
	        if (arg = "-debug") | (arg = "-db")
	        then
		do;
		  debug = "1"b;
		end;

	        else if (arg = "-pathname") | (arg = "-pn")
	        then
		do;
		  path = "1"b;

		  if argno = argct
		  then goto missing_arg;

		  argno = argno + 1;
		  call cu_$arg_ptr (argno, argp, argl, code);
		  dsmpath = arg;
		end;

	        else if (arg = "-working_dir") | (arg = "-wd")
	        then
		do;
		  path = "1"b;
		  dsmpath = get_wdir_ ();
		end;

	        else goto badopt;
	      end;

	    else if starname ^= ""
	    then
	      do;
	        call com_err_ (0, me, "Only one starname allowed. ^a", arg);
	        error = "1"b;
	      end;

	    else
	      do;
	        call check_star_name_$entry (arg, star_code);
	        if star_code > 2
	        then
		do;
		  call com_err_ (star_code, me, " starname ^a", arg);
		  error = "1"b;
		end;

	        else starname = arg;
	      end;

	  end;
        end;

        if starname = ""
        then starname = "**.comp_dsm";
        else
	do;
	  call expand_pathname_$add_suffix (starname, "comp_dsm", "",
	       starname, code);
	  if code ^= 0
	  then
	    do;
	      call com_err_ (code, me, "Assuring starname suffix.");
	      error = "1"b;
	      return;
	    end;
	end;

      end;
  end proc_args;

    dcl didmem	   (3600) bit (1) unal;
    dcl first	   bit (1);
    dcl j		   fixed bin;
    dcl k		   fixed bin;
    dcl kk	   fixed bin;

%include access_mode_values;
%include compstat;
%include comp_dvid;
%include comp_dvt;
%include comp_entries;
%include comp_fntstk;
%include comp_font;
%include definition_dcls;
%include object_info;
%include sl_control_s;
%include sl_info;
%include star_structures;
%include terminate_file;

  end display_comp_dsm;




		    expand_device_writer.pl1        04/23/85  1100.9rew 04/23/85  0911.5       80046



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* format: style2,ind3,ll80,dclind4,idind16,comcol41,linecom */

expand_device_writer:
xdw:
   proc;
      me = "xdw";
      ME = "XDW";
      suffix = ".xdw";
      goto start;

macro:
   entry;
      me = "macro";
      ME = "MACRO";
      suffix = ".macro";

      dcl version	      char (6) int static init ("1.2b");
      dcl me	      char (32) var;
      dcl ME	      char (8) var;

start:
      code = 0;
      segname = "";
      in_p, of_p = null ();
      in_l, of_l = 0;
      callp = null ();
      in_sw, of_sw, pr_sw, long_sw = "0"b;

      argno = 0;
      argct = 0;
      do while (code = 0);
         argno = argno + 1;
         call cu_$arg_ptr (argno, arg_p, arg_l, code);
         if (code = 0)
         then
	  do;
	     if (substr (arg, 1, 1) = "-")
	     then
	        do;
		 if (arg = "-pr") | (arg = "-print")
		 then pr_sw = "1"b;
		 if (arg = "-npr") | (arg = "-no_print")
		 then pr_sw = "0"b;
		 else if (arg = "-call")
		 then
		    do;
		       argno = argno + 1;
		       call cu_$arg_ptr (argno, arg_p, arg_l, code);
		       if (code ^= 0)
		       then
			do;
			   call com_err_ (code, me, "-call value");
			   return;
			end;
		       callp = arg_p;
		       calll = arg_l;
		    end;
		 else if (arg = "-long") | (arg = "-lg")
		 then long_sw = "1"b;
		 else if (arg = "-brief") | (arg = "-bf")
		 then long_sw = "0"b;
		 else if (arg = "-instr") | (arg = "-input_string")
		 then
		    do;
		       if in_sw
		       then
			do;
			   call com_err_ (0, me,
			        "Multiple input_strings supplied.");
			   return;
			end;
		       if (in_p ^= null ())
		       then goto not_both;
		       argno = argno + 1;
		       call cu_$arg_ptr (argno, arg_p, arg_l, code);
		       if (code ^= 0)
		       then
			do;
			   call com_err_ (0, me, "Value for -in keyword.")
			        ;
			   return;
			end;
		       in_sw = "1"b;
		       in_p = arg_p;
		       in_l = arg_l;
		    end;
		 else if (arg = "-ag") | (arg = "-arguments")
		 then
		    do;
		       do i = 1 to 25 while (code = 0);
			argno = argno + 1;
			call cu_$arg_ptr (argno, arg_p, arg_l, code);
			if (code = 0)
			then
			   do;
			      argct = argct + 1;
			      argl.p (argct) = arg_p;
			      argl.l (argct) = arg_l;
			   end;
		       end;
		    end;
		 else if (arg = "-of") | (arg = "-output_file")
		 then
		    do;
		       of_sw = "1"b;
		       argno = argno + 1;
		       call cu_$arg_ptr (argno, arg_p, arg_l, code);
		       if (code ^= 0)
		       then
			do;
			   call com_err_ (0, me, "Value for -of keyword.")
			        ;
			   return;
			end;
		       of_p = arg_p;
		       of_l = arg_l;
		    end;
		 else
		    do;
		       call com_err_ (error_table_$badopt, me, "^a", arg);
		       return;
		    end;
	        end;
	     else
	        do;
		 if (segname ^= "")
		 then
		    do;
		       call com_err_ (0, me,
			  "Multiple source names supplied.");
		       return;
		    end;
		 if (substr (arg, 1, 1) = "&")
		 then
		    do;
		       call com_err_ (0, me,
			  "Must now use -input_string to specify string to be expanded."
			  );
		       return;
		    end;
		 if (in_p ^= null ())
		 then
		    do;
not_both:
		       call com_err_ (0, me,
			  "Cannot supply both string and segment as input."
			  );
		       return;
		    end;
		 call expand_pathname_ (arg, dname, ename, code);
		 if (code ^= 0)
		 then
		    do;
		       call com_err_ (code, me, "^a", arg);
		       return;
		    end;
		 ename = before (ename, suffix);
		 segname = rtrim (ename);
		 call hcs_$initiate_count (dname, segname || suffix, "",
		      in_l, 0, in_p, code);
		 if (in_p = null ())
		 then
		    do;
		       call com_err_ (code, me, "^a>^a^a", dname, ename,
			  suffix);
		       return;
		    end;
		 in_l = divide (in_l, 9, 24, 0);
		 code = 0;
	        end;
	  end;

         else if argno = 1
         then
	  do;
	     call com_err_ (code, ME,
		"^/Usage is: expand_device_writer {path} {-control_args}");
	     return;
	  end;
      end;

      if (segname = "") & (in_p = null ()) | (argno = 1)
      then
         do;
	  if (suffix = ".macro")
	  then call com_err_ (0, me,
		  "(^a) Proper usage is: ^a {path} {-control_args}",
		  version, me);
	  return;
         end;

      if ^of_sw
      then if in_sw
	 then pr_sw = "1"b;
	 else dname = get_wdir_ ();
      call get_temp_segments_ ((me), ptra, code);
      out_ptr = ptra (1);
      if (code ^= 0)
      then
         do;
	  call com_err_ (code, me);
	  return;
         end;

      out_len = 0;
      call ioa_ ("^a ^a", ME, version);
      on condition (cleanup)
         begin;
	  call xdw_$free (long_sw);
	  call release_temp_segments_ ((me), ptra, code);
         end;
      call xdw_$expand (me, segname, "", out_ptr, out_len, addr (argl), (argct),
	 msg, in_p, in_l, code);
      call xdw_$free (long_sw);
      if (code ^= 0)
      then
         do;
	  if (code = 1) | (code = -1)
	  then icode = 0;
	  else icode = code;
	  call com_err_ (icode, me, "^a", msg);
         end;
      if pr_sw
      then
         do;
	  call iox_$put_chars (iox_$user_output, out_ptr, out_len, code);
         end;
      else if (code = 0)
      then
         do;
	  if (of_p ^= null ())
	  then
	     do;
	        arg_p = of_p;
	        arg_l = of_l;
	        call expand_pathname_ (arg, dname, ename, code);
	        if (code ^= 0)
	        then
		 do;
		    call com_err_ (0, me, "^a", arg);
		    goto done;
		 end;
	     end;
	  call hcs_$make_seg (dname, ename, "", 01010b, out_ptr, code);
	  if (out_ptr = null ())
	  then call com_err_ (code, me, "^a>^a", dname, ename);
	  else
	     do;
	        substr (out_ptr -> str, 1, out_len) =
		   substr (ptra (1) -> str, 1, out_len);
	        call hcs_$set_bc_seg (out_ptr, out_len * 9, code);
	        call hcs_$terminate_noname (out_ptr, code);
	        if (code ^= 0)
	        then call com_err_ (code, me);
	        if (code = 0) & (callp ^= null ())
	        then call cu_$cp (callp, calll, 0);
	     end;
         end;
done:
      call release_temp_segments_ ((me), ptra, code);


      dcl 1 argl	      (25),
	  2 p	      ptr,
	  2 l	      fixed bin (24);
      dcl argct	      fixed bin (24);

      dcl in_p	      ptr;
      dcl in_l	      fixed bin (24);
      dcl of_p	      ptr;
      dcl of_sw	      bit (1);
      dcl in_sw	      bit (1);
      dcl of_l	      fixed bin (24);
      dcl get_wdir_	      entry returns (char (168));
      dcl icode	      fixed bin (35);
      dcl dname	      char (168);
      dcl suffix	      char (32) var;
      dcl ename	      char (32);
      dcl expand_pathname_
		      entry (char (*), char (*), char (*), fixed bin (35));
      dcl arg	      char (arg_l) based (arg_p);
      dcl arg_l	      fixed bin;
      dcl arg_p	      ptr;
      dcl argno	      fixed bin;
      dcl calll	      fixed bin (24);
      dcl callp	      ptr;
      dcl cleanup	      condition;
      dcl code	      fixed bin (35);
      dcl com_err_	      entry options (variable);
      dcl cu_$arg_ptr     entry (fixed bin, ptr, fixed bin, fixed bin (35));
      dcl cu_$cp	      entry (ptr, fixed bin (24), fixed bin (35));
      dcl error_table_$badopt
		      fixed bin (35) ext static;
      dcl get_temp_segments_
		      entry (char (*), (*) ptr, fixed bin (35));
      dcl i	      fixed bin;
      dcl ioa_	      entry options (variable);
      dcl iox_$put_chars  entry (ptr, ptr, fixed bin (24), fixed bin (35));
      dcl iox_$user_output
		      ptr ext static;
      dcl long_sw	      bit (1);
      dcl segname	      char (32) var;
      dcl xdw_$expand     entry (char (32) var, char (32) var, char (32) var,
		      ptr, fixed bin (24), ptr, fixed bin, char (1000) var,
		      ptr, fixed bin (24), fixed bin (35));
      dcl xdw_$free	      entry (bit (1));
      dcl msg	      char (1000) var;
      dcl out_len	      fixed bin (24);
      dcl out_ptr	      ptr;
      dcl pr_sw	      bit (1);
      dcl hcs_$initiate_count
		      entry (char (*), char (*), char (*), fixed bin (24),
		      fixed bin (2), ptr, fixed bin (35));
      dcl hcs_$make_seg   entry (char (*), char (*), char (*), fixed bin (5),
		      ptr, fixed bin (35));
      dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
      dcl hcs_$terminate_noname
		      entry (ptr, fixed bin (35));
      dcl ptra	      (1) ptr;
      dcl release_temp_segments_
		      entry (char (*), (*) ptr, fixed bin (35));
      dcl str	      char (262144) based;
   end expand_device_writer;




		    process_compout.pl1             04/23/85  1100.9rew 04/23/85  0911.5      884169



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* compose routine to print sequential compout files */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

process_compout:
pco:
  proc;

/*
   This procedure implements one command and two active functions designed
   for processing compout files.
	process_compout (pco)	writes device images in various
				formats to mag/paper tape to user
				output
	[compout]			returns the name of a compout
	[compask ...]		"response" with a memory

/* Usage:	process_compout {path} {ctlargs}			       */
/*							       */
/* Processes one or more sequential compout files to the terminal, paper     */
/* tape, or mag tape. It supports various means of page selection and	       */
/* and several output display modes.				       */
/*							       */
/* args:							       */
/* path							       */
/*	the name of a compout to process, may be a starname. The compout   */
/*	suffix need not be supplied. If not given, then -pn must be used.  */
/*							       */
/* ctlargs:						       */
/* -block xx						       */
/*	Override the imbedded output blocking factor, using xx instead.    */
/* -brief, -bf                                                               */
/*        abbreviate various headers and labels                              */
/* -change_printwheel_for_file, -cpwf				       */
/*	change printwheel and reprint at end of file.		       */
/* -change-printwheel_for_pages, -cpwp				       */
/*	change printwheel and reprint at end of page.		       */
/* -comment						       */
/*	same as -mode comment				       */
/* -control_file path, -cf path	ACCEPTED, BUT NOT IMPLEMENTED        */
/*	path is the name of a control file (see below for format).	       */
/* -display, -ds						       */
/*	same as -mode display				       */
/* -dump							       */
/*	same as -mode dump					       */
/* -from xx, -fm xx						       */
/*	begin output from page xx (see page number conventions)	       */
/* -header, -he						       */
/*	show the file header with -dump or -mode dump.		       */
/* -long, -lg						       */
/*	add additional information to what is being displayed.	       */
/* -mode comment|display|dump|setup|?|xx|"STR"			       */
/*	comment	prints the compout control comment information	       */
/*	display	prints the image with all device controls interpreted    */
/*	dump	prints and ascii/octal dump of the image	       */
/*	setup	prints the machine setup information (font assignments,  */
/*		print wheel assignments, etc)			       */
/*	? 	prints the modes defined in the file header	       */
/*	xx	selects the mode with that name from the control comment */
/*	"STR"	uses STR as an attach descscription (atd) string	       */
/* -noheader, -nhe						       */
/*	do not show the file header with -dump or -mode dump (default).    */
/* -pages xx, -pgs xx, -page xx, -pg xx				       */
/*	selects a series of pages and/or ranges of pages (see page number  */
/*	conventions). Any number of xx's may follow		       */
/* -pages_changed {p|s}, -pgs {p|s}				       */
/*	causes only the changed pages to be selected. The "s" option says  */
/*	that only the single modified pages are wanted. The "p" option     */
/*	says that the obverse pages are wanted to match all modified       */
/*	pages.						       */
/* ----------------	"p" option accepted, but not implemented; gives warning  */
/* -pathname xx, -pn xx					       */
/*	causes xx to be used as an input file name without adding	       */
/*	".compout". May not be used when path is given.		       */
/* -stop, -sp						       */
/*	stop between pages					       */
/* -table, -tb						       */
/*	causes a table of all the pages selected to be printed, showing    */
/*	the page sequence number, front/back status, the changed status    */
/*	(via "#") and the page identification			       */
/* -to xx							       */
/*	This causes output to cease after page xx (see page number	       */
/*	conventions)					       */
/* -volume xx						       */
/*	this specifies the name of an output tape to be used	       */
/* -wait, -wt						       */
/*	stop before first page (only)				       */
/*							       */
/* Note: args apply to all input files.				       */
/*							       */
/* CONTROL FILE FORMAT --- NOT IMPLEMENTED			       */
/* A control file is used to specify what is to be done. Each entry has this */
/* form:							       */
/*       star_paths {ctlargs};				       */
/* The ctlargs in a entry apply to only the paths in that entry.  In this    */
/* manner, different selection can be done on various paths to be processed, */
/* to a single tape.					       */
/*							       */
/* PAGE NUMBER CONVENTIONS					       */
/* !n	absolute page number, sequence number in compout		       */
/* !0	reset to beginning of compout, used to enable output in order      */
/*	other than compout order				       */
/* +n	relative page number, forward from current position	       */
/* $-n    relative page number, referencing the last page (-n optional)      */
/* XXX	page identification, the page identifier XXX is searched for. An   */
/*	exact match must occur, no less/greater than check is possible     */
/*							       */
/* fileheader.comment is used to carry information which is needed to handle */
/* the file.  This information consists of lines (i.e. separated by NLs).    */
/* Each line begins with a keyword followed by a colon. Below, "xxx"	       */
/* represents the data pertaining to the keyword. All xxx strings are active */
/* function expanded ("[" and "]" are reserved for this purpose) before      */
/* being put to use. A NL need not follow the last line.  These options are  */
/* available (anything else is ignored):			       */

/*  mode:zzz=xxx	This defines a mode, zzz, to have the value xxx. The     */
/*		first mode present is the default mode. If any others    */
/*		are present, they represent alternatives available.      */
/*		A mode defines a method of disposing of the data. The    */
/*		output type is the first 4 characters of the mode	       */
/*		string.  These 3 are currently supported:	       */
/*		1) output_type=TAPE specified as		       */
/*		 "tape_ibm_  attach-description"    OR		       */
/*		 "tape_ansi_ attach-description"		       */
/*		2) output_type=PUNCH specified as		       */
/*		 "punch K"				       */
/*		3) output_type=ONLINE (default in none specified at all) */
/*	        --attach-description is everything needed except for       */
/*		    volume-id	-ring	-retain xxx	       */
/*		    -number nnn	-create/-append		       */
/*		These are all supplied as needed by pco.	       */
/*	        --K currently can only be "6".  punch 6 is used to put     */
/*		out TTS or reverse TTS information via a modified TN300  */
/*		paper tape punch (disable 2 upper punches)	       */
/*	        --online causes output to be sent user_output	       */

/*  leader:xxx	The string xxx is punched out in "big" letters on the    */
/*                  paper tape leader after the file identification.	       */

/*  setup:xxx       The string xxx is placed in the "contents" file which    */
/*                  is written first on mag tape.  When multiple files are   */
/*		being written to the same tape, this information is      */
/*		included only once (the first file's). This is intended  */
/*		to be used to convey the font setup, etc. information to */
/*		the receiver of the tape.			       */
/*		There may be multiple occurances of this statement. Each */
/*		occurance is added to the "contents" file followed by a  */
/*		CR/LF.					       */

/* file:xxx	The string xxx is placed in the "contents" file which    */
/*		is written first on mag tape. This information is used   */
/*		from EACH file written on tape. It is intended to give   */
/*		information specific to each file (document).	       */
/*		The active function [compout] will contain the name of   */
/*		each document in turn as this information is processed.  */
/*		The active function [compask ...] is designed to be of   */
/*		help in replying to the many occurances of the same      */
/*		question which will occur in this case.		       */

/* content_file:{^}seg,{^}tape				       */
/*		This controls the disposition of the "contents" file.    */
/*		If not specified, the default is "^tape,seg".	       */
/*    seg,^seg	do/dont create the segment XXX.contents. This will       */
/*		happen only if -volume XXX is specified. XXX is the name */
/*		of the tape being written.			       */
/*    tape,^tape	do/dont place the contents file at the beginning of the  */
/*		tape.					       */
/*  pack:xxx						       */
/*    where xxx is of the form				       */
/*	{<spec>[,<spec>]...}...				       */
/*    where <spec> is fN | cN | bN | '...'			       */
/*                  This signifies that the data is to be packed when	       */
/*		writing to mag tape.			       */
/*                --'...' is a literal bit string to be output, quoted this  */
/*		way because the comment in compdv is already in "'s      */
/*                --fN means to move forward N bits in the input byte	       */
/*                --cN means to copy N bits from the input byte	       */
/*                --bN means to move backward N bits in the input byte       */
/*                  (N is a single digit)			       */
/*                --"," separates parts within a "bytes-worth"	       */
/*                --";" separates between input bytes		       */

/*  blkhdr/blktlr	recognized but not implemented		       */

/*  DB: xxx	xxx is the seg$entry of routine to do the -db display    */
/*		This entry and any which follow it will not be shown if  */
/*		-mode comment is requested.			       */
%page;
/* Usage: [compout]						       */
/*							       */
/* While the comment string of a compout is being processed, this function   */
/*  will return the name (less ".compout") of this compout.		       */
/* If called at any other time it will print the message from	       */
/*	error_table_$out_of_sequence				       */
%skip (5);
/* Usage: [compask question {responses}]			       */
/*							       */
/* While the comment string of a compout is being processed, this function   */
/* asks a question of the user. It optionally constrains the answer to be    */
/*  one of a specified set. It also contains provision for the mapping of a  */
/*  specific user answer into a different return string.  This function      */
/*  remembers the text of each different question asked (within a single pco */
/*  execution), and keeps the last answer. Each question is asked, showing   */
/*  the remembered answer (if any). This last answer may be selected by      */
/*  answering only a NL. If a null answer is wanted instead of the last      */
/*  answer, a single "." must be the response.			       */
/*							       */
/* question	is whatever is to be asked. It is printed, followed by   */
/*		the last answer to this question in parentheses, but     */
/*		with no NL.				       */
/* response	if present specifies a value which is a valid response.  */
/*		This may be in one of two forms: "A" or "A=B". The "A"   */
/*		is a response to be checked for. If the "=" is present,  */
/*		whatever follows it (the "B" portion, which may be null) */
/*		is returned if the "A" is entered by the user.	       */
/* For example: (all on one line in a compout comment string)	       */
/*	file:Return[compask ""  Pasteup? "" no= ""yes= pasted up""]	       */
/*	 [compask ""original/copy? "" o=original original c=copy copy].    */
/* If 2 files are being processed, it will cause this kind of interaction:   */
/*          Pasteup? () yes					       */
/*	original/copy () copy				       */
/*	  Pasteup? (yes) no					       */
/*	original/copy (copy) o				       */
/* will cause generation of these lines:			       */
/*	Return pasted up copy.				       */
/*	Return original.					       */
/* Note that the pasteup question returns a null result if the answer is no  */
/* and the string " pasted up" if the answer is yes. The yes response must   */
/* be quoted because it contains SPs.				       */
/* The other question allows the user to reply "o" instead of having to type */
/* "original", yet the result is the more meaningful whole word.	       */
%page;
/* LOCAL STORAGE */

    dcl af_data_ptr	   ptr int static init (null ());
    dcl 1 af_data	   based (af_data_ptr),
	2 compout	   char (32) var,	/* [compout] data		       */
	2 count	   fixed bin,	/* [compask "..."] data list	       */
	2 e	   (af_data.count),
	  3 quest	   char (100) var,	/* question */
	  3 ans	   char (168) var;	/* answer */
    dcl answer	   char (4) var;	/* command_query answer */
				/* command argument	       */
    dcl arg	   char (argl) based (argp);
				/* arg list structure */
    dcl 1 arg_list	   based (arg_list_ptr),
				/* 1= use arg as name wo/compout   */
	2 asis	   (argct) bit (1) unal,
				/* can be an absolute path       */
	2 arg	   (argct) char (200) var,
	2 E	   ptr;		/* -> file if arg is a path */
    dcl arg_list_ptr   ptr defined tempsegs (5);
    dcl argct	   fixed bin;	/* number of command args given */
    dcl argl	   fixed bin (21);	/* length of arg		       */
    dcl argno	   fixed bin;	/* command line arg counter	       */
    dcl argp	   ptr;		/* pointer to arg		       */
    dcl BEGIN	   fixed bin static options (constant) init (1);
    dcl BELHT	   char (2) static options (constant) init ("	");
    dcl BOF	   fixed bin static options (constant) init (-1);
    dcl code	   fixed bin (35);	/* error code		       */
				/* -> tape contents list */
    dcl contents_ptr   ptr defined tempsegs (3);
    dcl contents	   char (262143) var based (contents_ptr);
    dcl contents_l	   fixed bin;
    dcl CR	   char (1) static options (constant) init ("
");
    dcl ctl_file	   (100) char (168) var;
				/* control file paths */
    dcl ctl_file_count fixed bin;	/* number of control files */
    dcl device_cleanup char (100) var;	/* cleanup string for device */

/*    dcl display_proc   entry (char (*) var, fixed bin (24), bit (1), bit (1))
/*		   returns (char (*) var) automatic;*/
/*    dcl display_rtn	   char (168) var;	/* name of -db/-display routine      */
    dcl done	   bit (1);	/* loop control switch */
    dcl END	   fixed bin static options (constant) init (2);
    dcl given_file_count		/* # of files given */
		   fixed bin;
    dcl file_entry_ptr ptr;		/* file entry structure */
    dcl 1 file_entry   aligned based (file_entry_ptr),
	2 link	   ptr,		/* -> next file in linked list */
	2 file	   char (168) var,	/* name of file to process*/
	2 ename	   char (32) var,	/* compout name		       */
	2 seq_no	   fixed bin,
	2 page_count fixed bin,	/* count of selected pages	       */
	2 sws,
	  3 pgc	   bit (1) unal,
	  3 obverse  bit (1) unal,	/* not yet implemented */
	  3 stop	   bit (1) unal,
	  3 wait	   bit (1) unal,
	  3 fill	   bit (32) unal,
	2 page_sel_ct
		   fixed bin,	/* count of page select fields */
	2 ll	   (file_entry.page_sel_ct),
	  3 from,
	    4 num	   fixed bin,	/* relative page count	       */
	    4 id	   char (32),	/* actual page id to look for	       */
	    4 sign   char (1),	/* "-" num is $- value	       */
				/* "+" num is + value	       */
				/* "x" num is absolute value	       */
				/* " " id is what to look for	       */
	  3 to	   like file_entry.from,
	2 next	   fixed bin;
    dcl file_entry_base_ptr
		   (2) ptr;	/* base of linked list of */
				/*     file entry ptrs */
				/* (1) - command line files */
				/* (2) - ??? (control files ) */
    dcl filno	   fixed bin;	/* file counter */
    dcl 1 from_to	   aligned like file_entry.from based (from_to_ptr);
    dcl from_to_ptr	   ptr;
    dcl FSPREC	   fixed bin static options (constant) init (0);
    dcl keyword	   char (64) var;	/* as needed for keyword checking    */
    dcl header_out_ptr ptr;		/* -> header of the current compout */
    dcl PADHT	   char (2) static options (constant) init ("	");
    dcl ii	   fixed bin;	/* working index */

/*    dcl init_proc	   entry automatic; /* writer init proc */
    dcl input_iocbp	   ptr;		/* -> IOCB for input file    */
    dcl ipage	   fixed bin;	/* page counter */
    dcl j		   fixed bin;	/* working index */
    dcl leader	   char (256) var;	/* fixed portion of leader */
    dcl max_tape_files fixed bin;	/* on a tape */
    dcl max_outrecs	   fixed bin;	/* max records in an output file */
    dcl max_records	   fixed bin;	/* -block value for max_outrecs */
    dcl me	   char (15) static options (constant)
		   init ("process_compout");
    dcl mode	   char (200) var;	/* a mode from the file */
    dcl mode_arg	   char (200) var;	/* arg given for -mode */
    dcl mounted_wheel  fixed bin static init (1);
    dcl next_image	   bit (36);	/* for loop control		       */
    dcl NOVOL	   char (6) static options (constant) init ("######");
    dcl ONLINE	   char (4) static options (constant) init ("onli");
    dcl output_medium  char (4);	/* = tape/punch/online */
    dcl output_text	   char (output_text_len) based (output_text_ptr);
    dcl output_text_len
		   fixed bin (21);
    dcl output_text_ptr
		   ptr defined tempsegs (6);
    dcl pack_ct	   fixed bin;	/* # entries in bit packing array */
    dcl page_length	   fixed bin (31);
    dcl page_selected  fixed bin;	/* pagelist.page ndx of page */
    dcl page_wrdct	   fixed bin;	/* word count for page overlay page */
    dcl pagelist_base  fixed bin;	/* base pagelist.page index */
    dcl pagelist_last  fixed bin;	/* last pagelist.page index */
				/* contents of all requested files */
    dcl pagelist_ptr   ptr defined tempsegs (4);
    dcl 1 pagelist	   based (pagelist_ptr),
	2 file_count fixed bin,	/* how many files in the list */
	2 page_count fixed bin,	/* how many pages in the list */
	2 file	   (pagelist.file_count),
	  3 name	   char (168) var,	/* file name */
	  3 from	   fixed bin,	/* beginning pagelist.page index */
	  3 to	   fixed bin,	/* ending pagelist.page index */
	2 page	   (pagelist.page_count),
	  3 id	   char (32),	/* page identification */
	  3 file_no  fixed bin,	/* pagelist.file index */
	  3 seq_no   fixed bin,	/* abs position in file */
	  3 sw,
	    4 changed
		   bit (1) unal,	/* page is changed		       */
	    4 obv_changed
		   bit (1) unal,	/* obverse is changed	       */
	    4 front  bit (1) unal,	/* page is a front		       */
	    4 blank  bit (1) unal,	/* page is intentionally blank       */
	    4 no_front
		   bit (1) unal,	/* obverse front not present	       */
	    4 no_back
		   bit (1) unal,	/* obverse back not present	       */
	    4 select bit (1) unal,	/* page is selected for output       */
	    4 fill   bit (29) unal;
    dcl preface	   char (500) var;	/* place to hold successive prefaces */
    dcl PUNCH	   char (4) static options (constant) init ("punc");
				/* internal proc to do the output */
    dcl put_out	   entry (fixed bin) automatic;
    dcl raw_record	   char (record_len) based (record_ptr);
    dcl record_bytes   fixed bin (21);	/* max tape record length in bytes */
    dcl record_count   fixed bin;	/* record counter		       */
    dcl record_hdrct   fixed bin;	/* input record header word count    */
    dcl record_len	   fixed bin (21);	/* input record length from iox_     */
    dcl record_wrdct   fixed bin;	/* input record word count	       */
    dcl reply_text	   char (256);	/* users response to a question */
    dcl setup	   char (2000) var; /* font setup info for contents file */
    dcl stop_signal	   char (5);	/* 2 ({BEL||}HT)||CR */
    dcl 1 sws,			/* control switches */
	2 brief_sw   bit (1) unal,	/* 1= brief output mode */
	2 comment_sw bit (1) unal,	/* 1= print comment value */
	2 contents_seg_sw		/* 1= TOC segment wanted */
		   bit (1) unal,
	2 contents_tap_sw		/* 1= TOC file on tape wanted */
		   bit (1) unal,
	2 cpwf_sw	   bit (1) unal,	/* 1= change pwheel at EOF */
	2 debug_sw   bit (1) unal,	/* 1= debugging */
	2 display_sw bit (1) unal,	/* 1= interpret file contents */
	2 dump_sw	   bit (1) unal,	/* 1= octal dump of file contents */
	2 error_sw   bit (1) unal,	/* global error flag	       */
	2 first_pref_sw		/* 1= first preface */
		   bit (1) unal,
	2 from_to_sw bit (1) unal,	/* 1= -from/-to arg given */
	2 header_sw  bit (1) unal,	/* 1= show file header */
	2 long_sw	   bit (1) unal,	/* 1= long output mode */
	2 mode_sw	   bit (1) unal,	/* 1= -mode has been given */
	2 nobell_sw  bit (1) unal,	/* 1= suppress BELs in stop signal */
	2 rawo_sw	   bit (1) unal,	/* 1= in RAWO mode   */
	2 setup_sw   bit (1) unal,	/* 1= print machine setup values */
	2 skip_pref_sw		/* 1= skip preface */
		   bit (1) unal,
	2 start_page_sw		/* 1- starting a page output         */
		   bit (1) unal,
	2 table_sw   bit (1) unal,	/* 1= table list wanted  */
	2 vol_sw	   bit (1) unal,	/* 1= volume ID has been given */
	2 MBZ	   bit (15) unal;
    dcl TAPE	   char (4) static options (constant) init ("tape");
    dcl tape_iocbp	   ptr;		/* -> IOCB for output tape */
    dcl tempsegs	   (6) ptr;	/* tempseg pointers */
    dcl text_cons	   (2) char (128) var;
    dcl text_pages	   fixed bin;	/* # of pages put into output file */
    dcl UNLIMITED	   fixed bin static options (constant) init (-1);
    dcl volid	   char (20) var;	/* tape label volume ID */
    dcl vol_file_ct	   fixed bin;	/* number of files on a tape volume */
    dcl wheel_done	   bit (36);	/* which wheels have been processed  */
    dcl wheel_need	   bit (36);	/* which wheels have been requested  */

    dcl (				/* page list value types */
        NEG_REL	   init ("-"),	/* $-value		       */
        POS_REL	   init ("+"),	/* +value			       */
        ABS	   init ("x"),	/* value			       */
        SEARCH_ID	   init (" ")	/* "PageNo string" */
        )				/* search for page id	       */
		   char (1) int static options (constant);

    dcl error_table_$end_of_info
		   fixed bin (35) ext static;
    dcl error_table_$unimplemented_version
		   fixed bin (35) ext static;

    dcl (addr, addrel, after, before, char, codeptr, collate, convert, dec,
        divide, hbound, index, length, ltrim, min, max, mod, null, rtrim, size,
        string, substr, unspec, verify)
		   builtin;

    dcl (cleanup, pco_error, quit)
		   condition;

    dcl com_err_	   entry options (variable);
    dcl command_query_ entry options (variable);
    dcl continue_to_signal_
		   entry (fixed bin (35));
    dcl cu_$arg_count  entry (fixed bin, fixed bin (35));
    dcl cu_$arg_ptr	   entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
    dcl dump_segment_  entry (ptr, ptr, fixed bin, fixed bin, fixed bin,
		   bit (*));
    dcl hcs_$make_ptr  entry (ptr, char (*), char (*), ptr, fixed bin (35));
    dcl get_temp_segments_
		   entry (char (*), (*) ptr, fixed bin (35));
    dcl iox_$attach_name
		   entry (char (*), ptr, char (*), ptr, fixed bin (35));
    dcl iox_$close	   entry (ptr, fixed bin (35));
    dcl iox_$detach_iocb
		   entry (ptr, fixed bin (35));
    dcl iox_$open	   entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
    dcl iox_$put_chars entry (ptr, ptr, fixed (21), fixed (35));
    dcl iox_$read_record
		   entry (ptr, ptr, fixed bin (21), fixed bin (21),
		   fixed bin (35));
%page;
/* INITIALIZE						       */
    call cu_$arg_count (argct, code);	/* check the call		       */
    if code ^= 0
    then
      do;
        call com_err_ (code, me);
        return;
      end;

    if argct = 0			/* show usage message */
    then
      do;
        call com_err_ (0, me,
	   "Proper usage is: ^a " || "paths {-control_args}", me);
        return;
      end;

/* preset stuff touched by clean     */
    unspec (sws) = "0"b;		/* clear all switches */
    device_cleanup = "";
    tempsegs (*), input_iocbp, tape_iocbp = null ();
				/* get temp segs	       */
    call get_temp_segments_ (me, tempsegs, code);
    if code ^= 0
    then
      do;
        call com_err_ (code, me, "Getting temp segments.");
        goto finish;		/* cleanup done at this label	       */
      end;

    query_info.version = 2;		/* set up in case query needed       */
    query_info.suppress_spacing = "1"b;
    query_info.yes_or_no_sw = "1"b;

    fileheader_ptr, record_ptr = tempsegs (1);
				/* build arg_list array in tempsegs (5) */
				/* the list is stored aside because */
				/* the control file feature will */
				/* change/augment the control args */
    do argno = 1 to argct;		/* for individual input files */
      call cu_$arg_ptr (argno, argp, argl, code);
      arg_list.arg (argno) = arg;
    end;

/* preset stuff touched by proc_args */
    file_entry_base_ptr (*) = null ();
    max_records, ctl_file_count, given_file_count = 0;
    mode_arg, mode, volid = "";

    call proc_args;			/* process the command args	       */

    if error_sw			/* any errors processing args?       */
    then return;

    if given_file_count = 0		/* check file count */
    then
      do;
        call com_err_ (0, me, "No compouts specified to process");
        return;
      end;

/* finish up initialization	       */
    preface, text_cons (*),		/*display_rtn,*/
         leader, setup = "";
    pack_ct = 0;
    skip_pref_sw = "1"b;
    max_tape_files = UNLIMITED;
    max_outrecs, record_bytes = 99999;
    output_medium = ONLINE;

    if volid = ""			/* -volume is allowed only in com    */
    then volid = NOVOL;		/*  line, not control file	       */

    if nobell_sw
    then stop_signal = PADHT || PADHT || CR;
    else stop_signal = BELHT || BELHT || CR;

/**** LEAVE THIS IN FOR FUTURE IMPLEMENTATION */
/*      do ii = 1 to ctl_file_count;	/* process any ctl_file's	       */
/*         call ioa_ ("control file not yet handled. ^a", ctl_file (ii));
/*      end;*/

    header_out_ptr = addr (file_entry.next);
    pagelist.file_count = given_file_count;
    filno, pagelist.page_count = 0;

/* make all the entrypoints needed are known (when PCO not in search rules) */
here:
    call hcs_$make_ptr (codeptr (here), "compout", "compout", null (), 0);
    call hcs_$make_ptr (codeptr (here), "compask", "compask", null (), 0);

    on condition (cleanup) call clean;
%page;
/* go thru everything, making sure all asked for exists		       */
    af_data_ptr = contents_ptr;	/* borrow the segment for a while    */
    af_data.count = 0;

    if dt_sw
    then call ioa_ ("FILE LIST ***");

file_loop_1:			/* for all files given */
    do file_entry_ptr = file_entry_base_ptr (1) repeat (file_entry.link)
         while (file_entry_ptr ^= null ());

      if open_compout ()		/* open compout and get file header */
      then			/* returns "1"b if open is OK */
        do;
	af_data.compout = rtrim (file_entry.ename, ".compout");
	filno = filno + 1;
	pagelist.file.name (filno) = file_entry.file;
	pagelist.file (filno).from = pagelist.page_count + 1;

	if device_cleanup = ""	/* extract device cleanup string */
	then
	  do;
	    l_cleanup = fileheader.cleanup_leng;
	    device_cleanup = fileheader.cleanup;
	  end;

	if debug_sw
	then call ioa_ (
		"header: record_len=^i^/Version: ^i Device: ^a/^a/^a "
		|| "MaxFiles: ^i; MaxPages: ^i;", record_len,
		fileheader.version, fileheader.device_class,
		fileheader.device_name, fileheader.device, max_tape_files,
		fileheader.max_pages);

	if ^table_sw
	then
	  do;
	    call proc_comment;
	    if debug_sw
	    then call ioa_ ("Cleanup: ^a",
		    comp_util_$display (
		    substr (device_cleanup, 1, l_cleanup), 0, "0"b));
	  end;

	done = "0"b;		/* set up for file processing */
	record_count = 0;
	if ^comment_sw & ^error_sw	/* if not just printing Comment: and */
	then			/* there have been no errors */
	  do while (^done);
	    call			/* read a record */
	         iox_$read_record (input_iocbp, record_ptr, record_len,
	         record_len, code);	/**/
				/* EOF? */
	    if (code = error_table_$end_of_info)
	    then done = "1"b;

	    else if (code ^= 0)	/* read error? */
	    then
	      do;
	        call com_err_ (code, me, "Reading ^a", file_entry.file);
	        done = "1"b;
	      end;

	    else			/* we have a valid record */
	      do;			/* count & copy stuff into pagelist */
	        record_count = record_count + 1;
	        pagelist.file (filno).to, pagelist.page_count =
		   pagelist.page_count + 1;
	        pagelist.page (pagelist.page_count).id = record.pageid;
	        pagelist.page (pagelist.page_count).file_no = filno;
	        pagelist.page (pagelist.page_count).seq_no = record_count;
	        pagelist.page (pagelist.page_count).changed = record.changed;
	        pagelist.page (pagelist.page_count).front = record.front;
	        pagelist.page (pagelist.page_count).blank = record.blank;
	        pagelist.page (pagelist.page_count).select,
		   pagelist.page (pagelist.page_count).no_front,
		   pagelist.page (pagelist.page_count).no_back = "0"b;

	        if (record_count > 1)
	        then if (pagelist.page (pagelist.page_count).front
		        = pagelist.page (pagelist.page_count - 1).front)
		   then if pagelist.page (pagelist.page_count).front
		        then pagelist.page (pagelist.page_count - 1)
			        .no_back = "1"b;
		        else pagelist.page (pagelist.page_count).no_front =
			        "1"b;
	      end;
	  end;

	if dt_sw & filno > 0
	then call ioa_ ("pagendx=^i:^i file=^a", pagelist.file (filno).from,
		pagelist.file (filno).to, pagelist.file (filno).name);

	call close_compout ();	/* close the compout */
        end;

      else file_entry.file = "";
    end file_loop_1;
%page;
    if filno = 0			/* no files to process */
    then return;

    filno = 0;			/* now, we know everything we need */
file_loop_2:			/* so process the files */
    do file_entry_ptr = file_entry_base_ptr (1) repeat (file_entry.link)
         while (file_entry_ptr ^= null ());

      filno = filno + 1;		/* count a file */
      record_count = 1;		/* and set up for processing */
      pagelist_base = pagelist.file (filno).from - 1;
      pagelist_last = pagelist.file.to (filno) - pagelist_base;

      if file_entry.file ^= ""	/* if file hasnt been discarded */
      then
page_select_loop:			/* go thru the pages selected */
        do ipage = 1 to file_entry.page_sel_ct;
				/* resetting to !0?		       */
	if (file_entry.from.sign (ipage) = ABS)
	     & (file_entry.from.num (ipage) = 0)
	then
	  do;
	    record_count = 0;
	    ipage = ipage + 1;
	    goto end_page_select_loop;
	  end;			/**/
				/* do a page select pair */
	do from_to_ptr = addr (file_entry.from (ipage)),
	     addr (file_entry.to (ipage));

	  if from_to.sign = NEG_REL	/* is this a $-n type?       */
	  then
	    do;
	      page_selected = pagelist_last - from_to.num;

	      if (page_selected < 0)
	      then
	        do;
		call command_query_ (addr (query_info), answer, me,
		     "File ^a: ^a < BOF. Use first page?", file_entry.file,
		     from_to.id);
		if (answer ^= "yes")
		then error_sw = "1"b;
		page_selected = 1;
	        end;
	    end;			/**/
				/* need to search for page id? */
	  else if (from_to.sign = SEARCH_ID)
	  then
	    do;
	      page_selected = record_count;
	      do j = record_count + pagelist_base
		 to pagelist_last + pagelist_base
		 while (from_to.id ^= pagelist.id (j));
	      end;

	      if j > pagelist_last + pagelist_base
	      then
	        do;
		call com_err_ (0, me, "Page ""^a"" not found in ^a",
		     from_to.id, file_entry.file);
		error_sw = "1"b;
	        end;

	      else page_selected = j - pagelist_base;
	    end;

	  else
	    do;
	      page_selected = from_to.num;
				/* is this +n form */
	      if (from_to.sign = POS_REL)
	      then page_selected = page_selected + record_count;
	      if (page_selected > pagelist_last)
	      then
	        do;
		call command_query_ (addr (query_info), answer, me,
		     "File ^a: ^a > EOF. Use last page?", file_entry.file,
		     from_to.id);
		if (answer ^= "yes")
		then error_sw = "1"b;
		page_selected = pagelist_last - 1;
	        end;
	    end;

	  from_to.num, record_count = page_selected;
	  from_to.sign = ABS;	/* now we know where we are	       */
	end;

	if (file_entry.from.num (ipage) > file_entry.to.num (ipage))
	then
	  do;
	    call command_query_ (addr (query_info), answer, me,
	         "File ^a: from_value ""^a"" (!^i) > to_value ""^a"" (!^i).
	Do you wish to ignore specification?", file_entry.file,
	         file_entry.from.id (ipage), file_entry.from.num (ipage),
	         file_entry.to.id (ipage), file_entry.to.num (ipage));
	    if (answer = "no")
	    then error_sw = "1"b;
	    file_entry.to.num (ipage), file_entry.from.num (ipage) = 0;
	  end;

	if file_entry.pgc		/* looking for changed pages?	       */
	then
	  do;

/* obverse needs to be handled here, too.			       */

	    do page_selected = file_entry.from.num (ipage) + pagelist_base
	         to file_entry.to.num (ipage) + pagelist_base;
	      if pagelist.changed (page_selected)
		 | pagelist.obv_changed (page_selected)
	      then
	        do;
		pagelist.select (page_selected) = "1"b;
		file_entry.page_count = file_entry.page_count + 1;
	        end;
	    end;
	  end;

	else
	  do page_selected = file_entry.from.num (ipage) + pagelist_base
	       to file_entry.to.num (ipage) + pagelist_base;
	    pagelist.select (page_selected) = "1"b;
	    file_entry.page_count = file_entry.page_count + 1;
	  end;

end_page_select_loop:
        end page_select_loop;
    end file_loop_2;

    if dt_sw
    then
      do;
        call ioa_ ("START ***");

        filno = 0;
        do file_entry_ptr = file_entry_base_ptr (1)
	   repeat (file_entry.link) while (file_entry_ptr ^= null ());

	filno = filno + 1;
	call ioa_ ("pagendx=^i:^i file=^a", pagelist.file (filno).from,
	     pagelist.file (filno).to, pagelist.file (filno).name);

	do i = pagelist.file (filno).from to pagelist.file (filno).to;
	  call ioa_ ("^[*^; ^]^5i ""^a""^[ CHANGED^]^[ FRONT^]^[ BLANK^]",
	       pagelist.page (i).select, i, pagelist.page (i).id,
	       pagelist.page (i).changed, pagelist.page (i).front,
	       pagelist.page (i).blank);
	end;
        end;
      end;

    af_data_ptr = null ();		/* give back the seg we borrowed */

    if comment_sw | setup_sw
    then goto finish;

    if (max_records ^= 0)
    then max_outrecs = max_records;

    if (output_medium = PUNCH)
    then
      do;
        call build_contents;

        if ^table_sw
        then call ioa_ ("Information to be punched:^/^a", contents);

        skip_pref_sw = "0"b;

        if (mode = "punch 6")
        then
	do;
	  if debug_sw | display_sw
	  then put_out = put_online;
	  else put_out = put_punch;
	end;

        else
	do;
no_handle:
	  call com_err_ (0, me, "Dont know how to handle ""^a""", mode);
	  error_sw = "1"b;
	end;
      end;

    else if (output_medium = TAPE)
    then
      do;
        call build_contents;

        if ^table_sw
        then call ioa_ ("^/Contents file:^/^20(-^)^/^a^20(-^)", contents);

        if contents_seg_sw
        then
	begin;
	  dcl hcs_$make_seg	 entry (char (*), char (*), char (*),
			 fixed bin (5), ptr, fixed bin (35));
	  dcl get_wdir_	 entry () returns (char (168));
	  dcl seg_p	 ptr;
	  dcl seg		 char (length (contents)) based (seg_p);
	  dcl hcs_$truncate_seg
			 entry (ptr, fixed bin (19), fixed bin (35));
	  dcl hcs_$terminate_noname
			 entry (ptr, fixed bin (35));
	  dcl hcs_$set_bc_seg
			 entry (ptr, fixed bin (24), fixed bin (35));

	  call hcs_$make_seg (get_wdir_ (), volid || ".contents", "", 01010b,
	       seg_p, code);
	  if (seg_p = null ())
	  then call com_err_ (code, me, "^a>^a.contents", get_wdir_ (),
		  volid);

	  else
	    do;
	      call hcs_$truncate_seg (seg_p,
		 divide (length (contents), 4, 19, 0), code);
	      seg = contents;
	      call hcs_$set_bc_seg (seg_p, length (contents) * 9, code);
	      call hcs_$terminate_noname (seg_p, code);
	    end;
	end;

        skip_pref_sw = "0"b;
        vol_file_ct = 0;

        if debug_sw | display_sw
        then put_out = put_online;
        else put_out = put_tape;
      end;

    else
      do;
        output_medium = ONLINE;

        if debug_sw | display_sw
        then put_out = put_online;
      end;

    if error_sw
    then
      do;
        call ioa_ ("An error has occurred, no output will be produced.");

        if dt_sw
        then signal condition (pco_error);

        goto finish;
      end;

    if (device_cleanup ^= "") & (output_medium = ONLINE) & ^debug_sw
         & ^display_sw		/* cleanup if QUIT during ONLINE */
    then on condition (quit)
	 begin;
	   call set_rawo;
	   call iox_$put_chars (iox_$user_output,
	        addrel (addr (device_cleanup), 1), length (device_cleanup),
	        code);
	   call reset_rawo;
	   call continue_to_signal_ (code);
	 end;
%page;
/* Now all validity checking is done; go thru the list and get all the       */
/*  pages wanted.						       */

    preface = "";
    filno = 1;

file_loop_3:
    do file_entry_ptr = file_entry_base_ptr (1) repeat (file_entry.link)
         while (file_entry_ptr ^= null ());

      if file_entry.file = ""		/* if file has been discarded */
      then goto end_file_loop_3;

      if ^open_compout ()		/* cant open compout? skip it */
      then goto end_file_loop_3;

      if dump_sw & header_sw		/* if file is being dumped */
      then
        do;
	call			/* header label */
	     ioa_ ("^/Record 0 ^i(^o)8 bytes", record_len, record_len);

	if ^brief_sw
	then call			/* header contents */
		dump_segment_ (iox_$user_output, fileheader_ptr, 0, 0,
		divide (record_len + 3, 4, 17, 0), format);
        end;

      if table_sw			/* making a table? */
      then call ioa_ ("-pathname ^a -pages", file_entry.ename);

      if display_sw & ^brief_sw	/* display header */
      then call ioa_ ("  **  From file: ^a", file_entry.file);
				/* if actually writing the file */
      if ^(display_sw | dump_sw | table_sw)
      then if cpwf_sw & fileheader.version < filedata_version_4
	 then
	   do;
	     call com_err_ (error_table_$unimplemented_version, me,
		"^/^5x The -cpwf option cant be used with ^a",
		file_entry.file);
	     goto end_file_loop_3;
	   end;

      if file_entry.wait		/* wait for a NL before starting */
      then call sync (begin_file);

begin_file:
      wheel_need = "0"b;
reprint_file:
      pagelist_base = pagelist.file (filno).from - 1;
      text_pages, record_count, output_text_len = 0;
      first_pref_sw = "1"b;
      done, wheel_done = "0"b;
      ipage = 1;

record_loop_2:
      do while (^done);		/* read all records in this file */
        if file_entry.from.num (ipage) = 0
        then			/* if no (more) pages for this file */
	do;			/* rewind it */
	  call iox_$position (input_iocbp, BOF, 0, code);
	  goto next_file;
	end;

        record_count = record_count + 1;/* count the record	       */
				/* need to be further down file      */
        if file_entry.from.num (ipage) > record_count
        then
	do;
	  record_count = file_entry.from.num (ipage);
	  call iox_$position (input_iocbp, BOF, 0, code);
	  if code = 0
	  then call iox_$position (input_iocbp, FSPREC, record_count, code);
	end;

        if code = 0
        then call iox_$read_record (input_iocbp, record_ptr, 262144,
	        record_len, code);
        if code ^= 0
        then
	do;
	  if code ^= error_table_$end_of_info
	  then call com_err_ (code, me, "Reading ^a", file_entry.file);
	  goto end_file_loop_3;
	end;

        if file_entry.pgc & record.changed | ^file_entry.pgc
        then
	do;
	  if debug_sw
	  then call ioa_ ("text: record ^i length=^i", record_count,
		  record_len);	/**/
				/* erase any trailing garbage */
(nostrg):
	  substr (raw_record, record_len + 1, 8) = NULs;

reprint:				/* calculate record word count       */
	  record_wrdct = divide (record_len + 3, 4, 17, 0);
				/* adjust for size of record header  */
	  record_hdrct = size (record) - 1;
	  record_wrdct = record_wrdct - record_hdrct;

	  if dump_sw
	  then
	    do;
	      call ioa_ ("^/Record ^i ^i(^o)8 bytes", record_count,
		 record_len, record_len);

	      if ^brief_sw
	      then call dump_segment_ (iox_$user_output, record_ptr, 0, 0,
		      record_hdrct, format);
	    end;

	  start_page_sw, next_image = "1"b;
				/* start at top of page */
image_loop:
	  do page_record_ptr = addr (record.page_record)
	       repeat (addr (page_record.nextref))
	       while (next_image ^= "0"b);

	    if (table_sw & debug_sw) | dump_sw
	    then call ioa_ ("^5x^[ HALT^]^[ 2^]^[ 3^]^[ .wt^]^[ preface^]"
		    || "^[ id_preface^]^[ pwhl=^d^] ^i(^o)8 bytes",
		    page_record.halt, page_record.halt2, page_record.halt3,
		    page_record.halt4, page_record.preface,
		    page_record.id_preface, (page_record.pwheel > 0),
		    page_record.pwheel, page_record.leng, page_record.leng)
		    ;

	    page_wrdct = divide (page_record.leng + 3, 4, 17, 0) + 2;
	    record_wrdct = record_wrdct - page_wrdct;

	    if (record_wrdct < 0)
	    then
	      do;
	        call ioa_ ("Record length error, ^i", record_wrdct);
	        record_wrdct = -record_wrdct;
	      end;

/*	    if page_record.pad ^= "0"b
/*	    then call ioa_ ("Record screwed up!");*/

	    else if dump_sw
	    then call dump_segment_ (iox_$user_output, page_record_ptr, 0, 0,
		    page_wrdct, format);

	    if page_record.pwheel > 0
	    then substr (wheel_need, page_record.pwheel, 1) = "1"b;

	    if (dump_sw & debug_sw) | ^(table_sw | dump_sw)
	    then
	      do;
do_debug_too:
	        if page_record.preface/* is this a preface? */
	        then
		do;
		  if first_pref_sw	/* first one? */
		  then if skip_pref_sw
				/* be sure its skipped  */
		       then preface = page_record.text;
				/* be sure its used	       */
		       else preface = "";
		end;		/**/
				/* an ID preface? */
	        else if page_record.id_preface
	        then
		do;
		  if first_pref_sw
		  then goto add_string;
		end;

	        else first_pref_sw = "0"b;
				/**/
				/* record text or new preface? */
	        if ^page_record.preface | (page_record.text ^= preface)
	        then
		do;
add_string:			/* writing text online? */
		  if (output_medium = ONLINE) & ^(debug_sw | display_sw)
		  then
		    do;
		      if ^cpwf_sw
		      then
		        do;
			call set_rawo;
				/* pwheel change? */
			if page_record.pwheel > 0
			     & page_record.pwheel ^= mounted_wheel
			then call change_pwheel ((page_record.pwheel));
			call	/* write the text */
			     iox_$put_chars (iox_$user_output,
			     addr (page_record.text), (page_record.leng),
			     code);
				/**/
				/* midpage wait? */
			if page_record.halt4
			then
			  do;
			    call iox_$control (iox_$user_input,
			         "resetread", null (), code);
			    call iox_$get_line (iox_$user_input,
			         addr (stop_bfr), 80, argl, code);
			  end;
			start_page_sw = "0"b;
		        end;	/**/
		    end;

		  else if display_sw
		  then
		    do;
		      output_text_len = output_text_len + page_record.leng;
		      substr (output_text,
			 output_text_len - page_record.leng + 1,
			 page_record.leng) = page_record.text;
		    end;

		  else
		    do;
		      if start_page_sw
				/* at top of page? */
		      then
		        do;
			start_page_sw = "0"b;
				/* record limit for this file? */
			if text_pages = max_outrecs & max_outrecs > 0
			then
			  do;	/* have to cleanup? */
			    if device_cleanup ^= ""
			         & output_medium = ONLINE
			         & ^(debug_sw | display_sw)
			    then
			      do;
			        output_text_len =
				   output_text_len
				   + length (device_cleanup);
			        substr (output_text,
				   output_text_len
				   - length (device_cleanup) + 1,
				   length (device_cleanup)) =
				   device_cleanup;
			      end;

			    call put_out (END);
			    text_pages = 1;
			    output_text_len = 0;
			  end;
			else text_pages = text_pages + 1;

			output_text_len =
			     output_text_len + page_record.leng;
			substr (output_text,
			     output_text_len - page_record.leng + 1,
			     page_record.leng) = page_record.text;
		        end;

		      if output_text_len = 0
		      then call put_out (BEGIN);
		    end;
		end;

/**** dcls */
	        if page_record.preface
	        then preface = page_record.text;
	      end;

	    next_image = page_record.nextref;
	  end image_loop;

	  if (text_pages = max_outrecs)
				/* if record was just filled, ensure  */
	  then first_pref_sw = "1"b;	/*  that prefix included on next one */

	  if table_sw | debug_sw
	  then
	    do;
	      this_page = record_count + pagelist_base;
	      if pagelist.no_front (this_page)
	      then call ioa_ ("^-/* blank front not supplied */");
	      call ioa_ ("^[^/^8i Page: ^;^s^]!^i^-/*^[ BLANK^]^-^[FRONT^]^-"
		 || "^a^[^-CHANGED^] */", debug_sw, record_len,
		 record_count, record.blank, record.front, record.pageid,
		 record.changed);
	      if pagelist.no_back (this_page)
	      then call ioa_ ("^-/* blank back not supplied */");
	    end;

	  if ^table_sw
	  then if file_entry.stop
	       then
	         do;
wait:
		 call sync (reprint);
	         end;
	  if (record_count = file_entry.to.num (ipage))
	  then
	    do;
next_file:
	      ipage = ipage + 1;
	      if (ipage > file_entry.page_sel_ct)
	      then done = "1"b;
	    end;
	end;			/**/
				/* assure the left margin */
/****        call iox_$put_chars (iox_$user_output, addr (CR), 1, code);*/
      end record_loop_2;		/**/
end_file_loop_3:
      if rawo_sw
      then call reset_rawo;

      if output_text_len > 0		/* anything pending on output record */
      then
        do;
	if (device_cleanup ^= "") & (output_medium = ONLINE) & ^debug_sw
	     & ^display_sw
	then
	  do;
	    output_text_len = output_text_len + length (device_cleanup);
	    substr (output_text,
	         output_text_len - length (device_cleanup) + 1,
	         length (device_cleanup)) = device_cleanup;
	  end;

	call put_out (END);
        end;

      if ^cpwf_sw
      then
        do;
	substr (wheel_done, mounted_wheel, 1) = "1"b;
	i = index (wheel_need & ^wheel_done, "1"b);
        end;			/**/

      call close_compout ();

    end file_loop_3;
finish:
    if ^debug_sw & ^display_sw
    then
      do;
        if output_medium ^= ONLINE
        then call ioa_ ("process_compout: Tape complete.");
        else call iox_$put_chars (iox_$user_output, addr (CRLF), 2, code);
      end;

    call clean;
    return;
%page;
af_proc:
  proc (str) returns (char (500) var);

    dcl str	   char (200) var;

    dcl res	   char (500) var;
    dcl setupX	   char (256) var;
    dcl (i, j)	   fixed bin (21);

    i = search (str, "|[");		/* see if any potential AFs	       */
    if (i > 0) & ((output_medium = TAPE) | long_sw)
				/* and do we even care   */
    then
      do;
        res = "";			/* start out clean		       */
        j = 1;
        do while (i ^= 0);
	res = res || substr (str, j, i - 1);
				/* copy in-between stuff    */
	j = j + i - 1;		/* and skip over it		       */
	if (substr (str, j, 1) = "[") /* is it a valid AF call     */
	     | (substr (str, j, 2) = "|[") | (substr (str, j, 3) = "||[")
	then
	  do;			/* yes, go get it expanded	       */
	    call evaluate_af_ (substr (str, j), i2, setupX, code);
	    if (code ^= 0)
	    then
	      do;
	        call com_err_ (code, me, "Evaluating ""^a"".",
		   substr (str, j));
	        error_sw = "1"b;
	      end;
	  end;
	else
	  do;			/* no, just use up a single char     */
	    setupX = substr (str, j, 1);
	    i2 = 1;
	  end;
	res = res || setupX;	/* add the result to the output      */
	j = j + i2;
	i = search (substr (str, j), "|[");
				/* see if there's another   */
	if (i = 0)		/* if not, copy the rest over	       */
	then res = res || substr (str, j);
        end;
      end;
    else
      do;
err_exit:
        res = str;
      end;
    return (res);

  end af_proc;
%page;
build_contents:
  proc;
    contents_l = 0;
    contents = "";

    if (setup ^= "") & (^display_sw | long_sw)
    then contents = contents || setup || CRLF;

    contents = contents || "Directory of files,";

    if (output_medium = TAPE)
    then contents = contents || " on tape,";

    contents = contents || " by file number" || CRLF;
    contents = contents || "   #              --- pageids present ---";

    if contents_tap_sw
    then
      do;
        contents = contents || CRLF;
        contents = contents || "   0       <ASCII information file>";
      end;
    contents = contents || CRLF;	/* end of contents header */

    filno = 0;			/* get file contents info */
    do file_entry_ptr = file_entry_base_ptr (1) repeat (file_entry.link)
         while (file_entry_ptr ^= null ());
      if (file_entry.file ^= "")
      then
        do;
	record_count = 0;
	filno = filno + 1;
	pagelist_base = pagelist.file (filno).from - 1;

	contents = contents || "Document: ";
	contents = contents || before (file_entry.ename, ".compout");
	contents = contents || CRLF;

	do ipage = 1 to file_entry.page_sel_ct;
	  do i = file_entry.from.num (ipage) + pagelist_base
	       to file_entry.to.num (ipage) + pagelist_base;

	    if pagelist.select (i)	/* want this page? */
	    then
	      do;
	        if pagelist.no_front (i)
	        then
		do;
		  contents = contents || "      blank front not supplied";
		  contents = contents || CRLF;
		end;

	        if (record_count = 0)
	        then
		do;
		  contents_l = contents_l + 1;
		  contents = contents || convert (toch_ndx, contents_l);
		end;
	        else contents = contents || "      ";
	        record_count = record_count + 1;
	        if (record_count = max_outrecs)
	        then record_count = 0;
	        if pagelist.blank (i)
	        then contents = contents || "BLANK ";
	        else contents = contents || "      ";
	        if pagelist.front (i)
	        then contents = contents || "FRONT ";
	        else contents = contents || "      ";
	        contents = contents || rtrim (pagelist.id (i));
	        contents = contents || CRLF;
	        if pagelist.no_back (i)
	        then
		do;
		  contents = contents || "      blank back not supplied";
		  contents = contents || CRLF;
		end;
	      end;
	  end;
	end;
        end;

      if debug_sw
      then
        do;			/* show what has been determined     */
	call ioa_ ("^3i ^a (^a)", record_count, file_entry.file,
	     file_entry.ename);
	call ioa_ ("   seq=^i count=^i ^[PGC ^]^[OBV ^]^[SP ^]^[WT ^]",
	     file_entry.seq_no, file_entry.page_count, file_entry.pgc,
	     file_entry.obverse, file_entry.stop, file_entry.wait);
	do i = 1 to file_entry.page_sel_ct;
	  call ioa_ ("^6i fm ""^1a"" ^i ""^a""", i, file_entry.from (i).sign,
	       file_entry.from (i).num, file_entry.from (i).id);
	  call ioa_ ("^6x to ""^1a"" ^i ""^a""", file_entry.to (i).sign,
	       file_entry.to (i).num, file_entry.to (i).id);
	end;
        end;
    end;

  end build_contents;
%page;
change_pwheel:
  proc (wheel);

/* PARAMETERS */

    dcl wheel	   fixed bin;	/* wheel needed */
				/* LOCAL STORAGE */

    dcl change_signal  char (128);

    if nobell_sw
    then change_signal = copy (PADHT, wheel);
    else change_signal = copy (BELHT, wheel);

    call iox_$control (iox_$user_input, "resetread", null (), code);
    call iox_$put_chars (iox_$user_output, addr (change_signal), 2 * wheel,
         code);
    call iox_$get_line (iox_$user_input, addr (stop_bfr), 80, 0, code);
    call iox_$put_chars (iox_$user_output, addr (stop_signal), 5, code);
    call iox_$get_line (iox_$user_input, addr (stop_bfr), 80, 0, code);

  end change_pwheel;
%page;
gather_cons:
  proc (str, where);
    dcl str	   char (*),
        where	   char (*) var;

    dcl (i, j)	   fixed bin;

    i = 1;
    do while (i <= length (str));
    end;

  end gather_cons;
%page;
/*****	PROCESS THE COMMENT STATEMENT IN THE DSM 	*****/
proc_comment:
  proc;				/**/
				/* the Comment statement */
    dcl comment	   char (l_comment) based (comment_ptr);
    dcl comment_ptr	   ptr;
    dcl j		   fixed bin;	/* working index */
    dcl mode_list	   char (256) var;	/**/
				/* available options */
    dcl option	   (9) char (16) var int static options (constant)
		   init ("mode:", "leader:", "setup:", "pack:", "DB:",
		   "blkhdr:", "blktlr:", "file:", "content_file:");
    dcl option_line	   char (200) var;	/* option line from comment */
    dcl option_ndx	   fixed bin;	/* option list index */
    dcl scan_ndx	   fixed bin;	/* comment string scan index */
				/* point to the Comment statement */
    l_comment = fileheader.comment_leng;
    comment_ptr = addr (fileheader.comment);

    if comment_sw			/* just print the Comment? */
    then
      do;
        call ioa_ ("^/  **  From file ^a^/^a", file_entry.file,
	   before (comment, NL || "DB:"));
        return;
      end;

    if debug_sw
    then call ioa_ ("^a", rtrim (rtrim (comment), NL));

    mode_list = "";
    scan_ndx = 1;
scan_comment:			/* scan comment for option keywords */
    do while (scan_ndx < length (comment));
				/* run thru option list */
      do option_ndx = 1 to hbound (option, 1);
        if index (substr (comment, scan_ndx), option (option_ndx)) = 1
        then
	do;			/* found one; step over the keyword */
	  scan_ndx = scan_ndx + length (option (option_ndx));
				/* extract the option 'value' */
	  option_line = before (substr (comment, scan_ndx), NL);
	  goto opt_rtn (option_ndx);	/* go process the option */
	end;
      end;			/**/
				/* no (more) options */
      if mode_arg = ""		/* if taking default mode	       */
	 & scan_ndx = 1		/* and first line is not a keyword,  */
	 & index (comment, TAPE) = 1	/* assume its old style	       */
      then
        do;
	mode = before (comment, NL);
	if debug_sw
	then call ioa_ ("mode(old style)= ^a", mode);
        end;

opt_rtn_end:			/* all opt_rtn (*) return here       */
				/* step over option 'value' */
      j = index (substr (comment, scan_ndx), NL);
      if j = 0			/* if last option */
      then scan_ndx = length (comment);
      else scan_ndx = scan_ndx + j;
    end scan_comment;

    if mode = ""			/* if no mode after all that */
    then
      do;
        if mode_arg ^= ""		/* if not taking the default mode */
        then
	do;
	  if mode_list = ""		/* shoot! none defined in the compout */
	  then mode_list = "..(file defines NONE)";
				/* mode requested not defined */
	  call			/* find out what to do */
	       com_err_ (0, me,
	       "Mode ""^a"" is not defined in file ^a."
	       || "^/^2xThese are defined: ^a^/^2xUse mode ? to see "
	       || "details of these modes.", before (mode_arg, ":"),
	       file_entry.file, substr (mode_list, 3));
	  error_sw = "1"b;
	end;
        else mode = ONLINE;
      end;

/*    if (debug_sw | display_sw) & (display_rtn = "")
/*    then
/*      do;
/*        call com_err_ (0, me, "Display routine not defined in file. ^a",
/*	   file_entry.file);
/*        error_sw = "1"b;
/*      end;			/**/
/* check zero length record */
    if fileheader.recleng = 0
    then
      do;
        call com_err_ (0, me, "File ^a (device ^a) has recleng = 0.",
	   file_entry.file, fileheader.device);
        error_sw = "1"b;
      end;
    else record_bytes = min (record_bytes, fileheader.recleng);

    if (output_medium = TAPE) | (output_medium = PUNCH) | display_sw
    then
      do;
        ii = fileheader.max_pages;
        if (ii = 0)
        then
	do;
	  call com_err_ (0, me, "File ^a (device ^a) has max_pages = 0.",
	       file_entry.file, fileheader.device);
	  error_sw = "1"b;
	end;
        else max_outrecs = min (max_outrecs, ii);
      end;

    return;

opt_rtn (1):			/* mode: */
    dcl temp	   char (32) var;
    if mode_sw			/* just print the modes? */
    then
      do;
        call ioa_ ("^a", option_line);
        goto opt_rtn_end;
      end;

    temp = before (option_line, "=");	/* copy the 1st mode */
    if temp = ""
    then
      do;
        call com_err_ (0, me, "Missing modename in ^a^/^-^a", file_entry.file,
	   option_line);
        error_sw = "1"b;
      end;

    else if ^(display_sw | dump_sw)
    then
      do;
        mode_list = mode_list || ", ";
        mode_list = mode_list || temp;
        i = length (temp) + 1;
        if (mode = "")
        then
	do;
	  if (mode_arg = "") | (temp = mode_arg)
	  then
	    do;
	      mode_name = temp;
	      mode_unproc = option_line;
	      mode = af_proc (after (option_line, "="));
	      output_medium = substr (mode, 1, 4);
	      if debug_sw
	      then call ioa_ ("mode= ^a", mode);
	    end;
	end;
        else if (temp = mode_name) & (mode_unproc ^= option_line)
        then
	do;
	  call com_err_ (0, me, "Mode mismatch:^/   ^a (^a)^/   ^a (^a)",
	       option_line, file_entry.file, mode_unproc,
	       file_entry_base_ptr (1) -> file_entry.file);
	  error_sw = "1"b;
	  return;
	end;
      end;
    goto opt_rtn_end;		/* finished with this case	       */

opt_rtn (2):			/* leader: */
    leader = af_proc (option_line);
    goto opt_rtn_end;		/* finished with this case	       */

opt_rtn (3):			/* setup: */
    if setup_sw
    then call ioa_ ("^a", option_line);
    else if (debug_sw | (output_medium ^= ONLINE) | long_sw)
         & (file_entry_ptr = file_entry_base_ptr (1))
    then
      do;				/* only for first file	       */
        setup = setup || af_proc (option_line);
        setup = setup || CRLF;
      end;
    goto opt_rtn_end;		/* finished with this case	       */

opt_rtn (5):			/* DB: */
    if debug_sw | display_sw		/* either -db or -display was given */
    then
      do;
        call hcs_$make_ptr (codeptr (here),
	   rtrim (fileheader.device) || ".comp_dsm",
	   rtrim (fileheader.device) || ".dvt", const.dvidptr, code);
        if code ^= 0
        then
	do;
	  call com_err_ (code, me, "Making a pointer to ^a$^a",
	       rtrim (fileheader.device) || ".comp_dsm",
	       rtrim (fileheader.device) || ".dvt");
	  error_sw = "1"b;
	end;
        const.devptr = pointer (const.dvidptr, comp_dvid.dvt_r);

/*        call hcs_$make_entry (codeptr (here),
/*	   rtrim (fileheader.device) || "_writer_", "display",
/*	   comp_dvt.displayproc, code);
/*        if code ^= 0
/*        then
/*	do;
/*	  call com_err_ (code, me,
/*	       "Setting comp_dvt.displayproc to ^a_writer_$display",
/*	       rtrim (fileheader.device));
/*	  error_sw = "1"b;
/*	end;*/

/*        call hcs_$make_entry (null (), before (display_rtn, "$"), "init",
/*	   init_proc, code);
/*        if code ^= 0
/*        then
/*	do;
/*	  call com_err_ (code, me, "^a$init", before (display_rtn, "$"));
/*	  error_sw = "1"b;
/*	end;*/
      end;
    goto opt_rtn_end;		/* finished with this case	       */

opt_rtn (8):			/* file: */
    if debug_sw | long_sw | (output_medium ^= ONLINE) & ^(display_sw | dump_sw)
    then
      do;
        setup = setup || af_proc (option_line);
        setup = setup || CRLF;
      end;
    goto opt_rtn_end;		/* finished with this case	       */

    dcl setting	   bit (1);
opt_rtn (9):			/* content_file: */
    if ^display_sw & vol_sw
    then
      do;
        i = 1;
        do while (i < length (option_line));
	if (substr (option_line, i, 1) = "^")
	then
	  do;
	    i = i + 1;
	    setting = "0"b;
	  end;
	else setting = "1"b;
	if (substr (option_line, i, 3) = "seg")
	then
	  do;
	    contents_seg_sw = setting;
	    i = i + 3;
	  end;
	else if (substr (option_line, i, 4) = TAPE)
	then
	  do;
	    contents_tap_sw = setting;
	    i = i + 4;
	  end;
	else
	  do;
	    call com_err_ (0, me, "Invalid content_file option. ^a",
	         option_line);
	    error_sw = "1"b;
	  end;

	if substr (option_line, i, 1) = ","
	then i = i + 1;
        end;
      end;

    goto opt_rtn_end;

opt_rtn (6):			/* blkhdr:*/
    call gather_cons (af_proc (option_line), text_cons (1));
    goto opt_rtn_end;		/* finished with this case	       */
%skip (5);
opt_rtn (7):			/* blktlr: */
    call gather_cons (af_proc (option_line), text_cons (2));
    goto opt_rtn_end;		/* finished with this case	       */
%page;
opt_rtn (4):			/* pack: */
    done = "0"b;
    option_line = af_proc (option_line);
    packi = 1;
    do while (^done);
      pack_ct = pack_ct + 1;
      pack.cct (pack_ct) = 0;
      pack.con (pack_ct) = "0"b;
      it = index ("""cfb", substr (option_line, packi, 1));
      if (it = 0)
      then
        do;
bad_pack:
	call com_err_ (0, me, "Syntax error in pack: statement. ^a",
	     file_entry.file);
	error_sw = "1"b;
	goto done_pack;
        end;
      pack.type (pack_ct) = it;
      if (it = 1)
      then
        do;
con_pack:
	packi = packi + 1;
	if (substr (option_line, packi, 1) ^= """")
	then
	  do;
	    pack.cct (pack_ct) = pack.cct (pack_ct) + 1;
	    if (substr (option_line, packi, 01) = "0")
	    then goto con_pack;
	    if (substr (option_line, packi, 1) ^= "1")
	    then goto bad_pack;
	    substr (pack.con (pack_ct), pack.cct (pack_ct), 1) = "1"b;
	    goto con_pack;
	  end;
        end;
      else
        do;
	packi = packi + 1;
	pack.cct (pack_ct) =
	     index ("123456789", substr (option_line, packi, 1));
	if (pack.cct (pack_ct) = 0)
	then goto bad_pack;
	if (it = 4)
	then pack.cct (pack_ct) = -pack.cct (pack_ct);
        end;
      packi = packi + 1;
      if (substr (option_line, packi, 1) = ";")
      then
        do;
	pack_ct = pack_ct + 1;
	pack.type (pack_ct) = 5;
        end;
      else if (substr (option_line, packi, 1) ^= ",")
      then goto bad_pack;
      packi = packi + 1;
      if (packi > length (option_line))
      then done = "1"b;
    end;
    j = 0;
    do packi = 1 to pack_ct;
      if pack.type (packi) < 3
      then j = j + pack.cct (packi);
    end;
    if (mod (j, 8) ^= 0)
    then
      do;
        call com_err_ (0, me, "pack: length not a multiple of 8",
	   file_entry.file);
        error_sw = "1"b;
      end;
done_pack:
    goto opt_rtn_end;		/* finished with this case	       */

  end proc_comment;
%page;
sync:				/* routine to synchronize printing   */
  proc (redo);			/* with user's paper handling	       */

    dcl redo	   label;		/* transfer label */

    dcl reprint_sw	   bit (1);
    dcl current_modes  char (256);

    reprint_sw = "0"b;

wait:
    call iox_$control (iox_$user_input, "resetread", null (), code);
    call iox_$modes (iox_$user_output, "rawo,rawi", current_modes, code);

    if device_cleanup ^= ""
    then call iox_$put_chars (iox_$user_output,
	    addrel (addr (device_cleanup), 1), length (device_cleanup), code)
	    ;

    call iox_$put_chars (iox_$user_output, addr (stop_signal), 5, code);
    call iox_$get_line (iox_$user_input, addr (stop_bfr), 10, argl, code);
    call iox_$modes (iox_$user_output, current_modes, "", code);

    if argl > 1
    then
      do;
        if substr (stop_bfr, 1, 1) = "q"
        then goto finish;
        if substr (stop_bfr, 1, 1) = "r"
        then
	do;
	  reprint_sw = "1"b;
	  goto wait;
	end;
      end;
    if reprint_sw
    then goto redo;

  end sync;
%page;
/* open a compout file for reading */
open_compout:
  proc returns (bit (1));

    dcl SEQUENTIAL_INPUT
		   fixed bin static options (constant) init (4);
    dcl STREAM_INPUT   fixed bin static options (constant) init (1);

    dcl error_table_$bad_file
		   fixed bin (35) ext static;
    dcl error_table_$improper_data_format
		   fixed bin (35) ext static;

    dcl iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21),
		   fixed bin (35));

    if file_entry.file = ""		/* if this file is to be skipped */
    then return ("0"b);

    call				/* attach and open the file */
         iox_$attach_name ("pco_", input_iocbp, "vfile_ " || file_entry.file,
         null (), code);
    if code = 0
    then call iox_$open (input_iocbp, SEQUENTIAL_INPUT, "0"b, code);
    if code ^= 0
    then
      do;				/* if not a proper structured file */
        if code = error_table_$bad_file
        then
	do;			/* try to open as a stream file */
	  call iox_$open (input_iocbp, STREAM_INPUT, "0"b, code);
	  if code = 0		/* opened OK, try to read it */
	  then
	    do;
	      call iox_$get_chars (input_iocbp, addr (reply_text),
		 length (reply_text), record_len, code);
	      if code = 0		/* read it OK, is it ASCII stuff? */
	      then
	        do;
		if verify (substr (reply_text, 1, record_len), collate ())
		     = 0
		then		/* yep */
		  do;
		    call com_err_ (error_table_$improper_data_format, me,
		         "Appears to be a stream file.^/    ^a",
		         file_entry.file);
		    goto err_return;
		  end;
	        end;
	    end;			/**/
				/* put back what we had	       */
	  code = error_table_$bad_file;
	end;

        call com_err_ (code, me, "Opening ^a", file_entry.file);
        goto err_return;
      end;			/**/
				/* read file header	       */
    call iox_$read_record (input_iocbp, fileheader_ptr, 8192, record_len, code)
         ;
    if code = 0
    then
      do;
        if fileheader.version >= filedata_version_3
        then max_tape_files = max (max_tape_files, fileheader.max_files);

        else if fileheader.version = filedata_version_4
        then page_length = fileheader.page_len;

        else if fileheader.version ^= filedata_version_2
        then code = error_table_$unimplemented_version;
      end;

    if code ^= 0
    then
      do;
        call com_err_ (code, me, "Reading header record.^/    ^a",
	   file_entry.file);

err_return:
        call close_compout ();
        file_entry.file = "";		/* dont want to consider this again  */
        return ("0"b);
      end;

    file_entry.seq_no = -1;
    return ("1"b);

  end open_compout;
%page;
clean:
  proc;

    if rawo_sw
    then call reset_rawo;

    af_data_ptr = null ();
    if (tempsegs (1) ^= null ())
    then call release_temp_segments_ (me, tempsegs, code);

close_compout:
  entry;
    if (input_iocbp ^= null ())
    then
      do;
        call iox_$close (input_iocbp, code);
        call iox_$detach_iocb (input_iocbp, code);
      end;
    if (tape_iocbp ^= null ())
    then
      do;
        call iox_$close (tape_iocbp, code);
        call iox_$detach_iocb (tape_iocbp, code);
      end;
  end clean;
%page;
proc_args:
  proc;				/* process command line args */

/* LOCAL STORAGE */

    dcl ename	   char (32);	/* compout entryname */
    dcl tp	   ptr;
    dcl system_free_p  ptr int static init (null ());
    dcl e_c	   fixed bin;
    dcl e_p	   ptr;
    dcl n_p	   ptr;
    dcl 1 entries	   (e_c) aligned based (e_p),
	2 type	   bit (2) unal,
	2 nnames	   fixed bin (15) unal,
	2 nindex	   fixed bin (17) unal;
    dcl names	   (3) char (32) based (n_p);

    dcl error_table_$badopt
		   fixed bin (35) ext static;

    dcl check_star_name_$entry
		   entry (char (*), fixed bin (35));
    dcl get_system_free_area_
		   entry returns (ptr);
    dcl hcs_$star_	   entry (char (*), char (*), fixed bin (2), ptr,
		   fixed bin, ptr, ptr, fixed bin (35));
				/* this initialzation code is here */
				/* in precognition of the fact that */
				/* proc_args will be called */
				/* recursively to process lines from */
				/* the yet-to-be-implemented control */
				/* file feature */
    if (file_entry_base_ptr (1) = null ())
				/* file feature */
    then file_entry_base_ptr (*), first_p, file_entry_ptr = tempsegs (2);
    else file_entry_base_ptr (2), first_p, file_entry_ptr =
	    addr (file_entry.next);

    file_entry.link = null ();
    file_entry.file = "";
    string (file_entry.sws) = "0"b;
    file_entry.page_sel_ct = 1;
    file_entry.from.num (1) = 0;
    file_entry.from.id (1) = "";
    file_entry.from.sign (1) = POS_REL;
    file_entry.to.num (1) = 0;
    file_entry.to.id (1) = "";
    file_entry.to.sign (1) = NEG_REL;
    string (arg_list.asis) = "0"b;

    do argno = 1 to argct;		/* first process all control args    */
      if index (arg_list.arg (argno), "-") = 1
      then
        do;
next_ctl_arg:			/* copy to automatic */
	keyword = arg_list.arg (argno);
	arg_list.arg (argno) = "";	/* erase it, leaving only paths */

	if keyword = "-block"	/* blocking factor feature	       */
	then
	  do;			/* change # pages/file	       */
	    if (argno = argct)
	    then goto missing;

	    argno = argno + 1;
	    max_records = convert (max_records, arg_list.arg (argno));
	    arg_list.arg (argno) = "";
	  end;			/**/
				/* brief output feature	       */
	else if keyword = "-brief" | keyword = "-bf"
	then
	  do;
	    brief_sw = "1"b;
	    long_sw = "0"b;
	  end;			/**/
				/* printwheel changing feature */
	else if keyword = "-change_printwheel_for_file" | keyword = "-cpwf"
	then cpwf_sw = "1"b;

	else if keyword = "-change_printwheel_for_pages" | keyword = "-cpwp"
	then cpwf_sw = "0"b;	/**/
				/* print Comment: only */
	else if keyword = "-comment"
	then
	  do;
	    comment_sw = "1"b;
	  end;			/**/
				/* control file feature	       */
	else if keyword = "-control_file" | keyword = "-cf"
	then
	  do;
	    if argno = argct	/* must not be last		       */
	    then goto missing;

	    ctl_file_count = ctl_file_count + 1;
	    argno = argno + 1;
	    ctl_file (ctl_file_count) = arg_list.arg (argno);
	    arg_list.arg (argno) = "";
	  end;			/* debugging feature	       */
	else if keyword = "-debug" | keyword = "-db"
	then
	  do;
	    debug_sw = "1"b;
	  end;			/* display mode */
	else if keyword = "-display" | keyword = "-ds"
	then
	  do;
	    display_sw = "1"b;
	  end;			/* dump mode */
	else if keyword = "-dump"
	then
	  do;
	    dump_sw = "1"b;
	  end;			/* page selection feature	       */
	else if keyword = "-from" | keyword = "-fm"
	then
	  do;
	    from_to_ptr = addr (file_entry.from (1));
from_to_rtn:
	    if file_entry.page_sel_ct > 1
	    then
	      do;
	        error_sw = "1"b;
	        call com_err_ (error_table_$inconsistent, me,
		   "^a cannot be mixed with -pages", keyword);
	      end;

	    else
	      do;
	        if (argno = argct)
	        then goto missing;

	        from_to_sw = "1"b;
	        argno = argno + 1;
	        call from_to_proc (1, length (arg_list.arg (argno)));
	        arg_list.arg (argno) = "";
	      end;
	  end;

	else if keyword = "-header" | keyword = "-he"
	then header_sw = "1"b;

	else if keyword = "-noheader" | keyword = "-nhe"
	then header_sw = "0"b;

	else if keyword = "-pathname" | keyword = "-pn"
	then			/* use next arg as name without      */
	  do;			/*   adding .compout	       */
	    if argno = argct	/* no path given? */
	    then goto missing;

	    arg_list.arg (argno) = "";
	    argno = argno + 1;	/* step to path arg */
	    arg_list.asis (argno) = "1"b;
	  end;

	else if keyword = "-mode"
	then
	  do;			/* select non-default mode	       */
	    if (argno = argct)
	    then goto missing;

	    argno = argno + 1;
	    mode_arg = arg_list.arg (argno);

	    if (mode_arg = "dump")
	    then
	      do;
	        dump_sw = "1"b;
	        mode_arg = "";
	      end;

	    else if (mode_arg = "display")
	    then
	      do;
	        display_sw = "1"b;
	        mode_arg = "";
	      end;

	    else if (mode_arg = "comment")
	    then
	      do;
	        comment_sw = "1"b;
	        mode_arg = "";
	      end;

	    else if (mode_arg = "setup")
	    then
	      do;
	        setup_sw = "1"b;
	        mode_arg = "";
	      end;

	    else if (mode_arg = "?")
	    then
	      do;
	        mode_sw = "1"b;
	        mode_arg = "";
	      end;

	    else
	      do;
	        j = (index (mode_arg, " "));
	        if (j = 0)
	        then mode_arg = arg_list.arg (argno);
	        else mode = substr (mode_arg, 1, j);
	      end;

	    arg_list.arg (argno) = "";
	  end;

	else if keyword = "-no_bell" | keyword = "-nob"
	then nobell_sw = "1"b;

	else if keyword = "-pages" | keyword = "-pgs" | keyword = "-page"
	     | keyword = "-pg"
	then
	  do;			/* page selection feature	       */
	    if from_to_sw
	    then
	      do;
	        error_sw = "1"b;
	        call com_err_ (error_table_$inconsistent, me,
		   "-pages cannot be mixed with -from/-to");
	      end;

	    else
	      do;
	        if argno = argct	/* none left or another ctl arg */
		   | index (arg_list.arg (argno + 1), "-") = 1
	        then goto missing;

	        file_entry.page_sel_ct = 0;
				/* reset count for loop */
pages_loop:
	        argno = argno + 1;	/* its another control arg	       */
	        if (substr (arg_list.arg (argno), 1, 1) = "-")
	        then goto next_ctl_arg;

	        i = 1;
	        file_entry.page_sel_ct = file_entry.page_sel_ct + 1;
	        l = index (arg_list.arg (argno), ",");

	        if (l = 0)
	        then l = length (arg_list.arg (argno));
	        else l = l - 1;

	        from_to_ptr =
		   addr (file_entry.from (file_entry.page_sel_ct));
	        call from_to_proc (i, l);
	        file_entry.to (file_entry.page_sel_ct) =
		   file_entry.from (file_entry.page_sel_ct);
	        i = l + 2;
	        l = length (arg_list.arg (argno)) - i + 1;

	        if (l > 0)
	        then
		do;
		  from_to_ptr =
		       addr (file_entry.to (file_entry.page_sel_ct));
		  call from_to_proc (i, l);
		end;

	        arg_list.arg (argno) = "";
	        if (argno < argct)
	        then goto pages_loop;
	      end;
	  end;

	else if keyword = "-pages_changed" | keyword = "-pgc"
	then
	  do;
	    file_entry.pgc = "1"b;
	    if (argno < argct)
	    then if (substr (arg_list.arg (argno + 1), 1, 1) ^= "-")
	         then
		 do;
		   argno = argno + 1;

		   if (arg_list.arg (argno) = "p")
		   then
		     do;
		       file_entry.obverse = "1"b;
		       call ioa_ ("WARNING: pco does not yet support"
			  || " the obverse option");
		     end;

		   else if (arg_list.arg (argno) ^= "s")
		   then
		     do;
		       error_sw = "1"b;
		       call com_err_ (error_table_$inconsistent, me,
			  "Object of ^a is not an allowed value. ^a",
			  keyword, arg_list.arg (argno));
		     end;

		   arg_list.arg (argno) = "";
		 end;
	  end;

	else if keyword = "-stop" | keyword = "-sp"
	then
	  do;
	    if vol_sw
	    then call com_err_ (error_table_$inconsistent, me,
		    "-stop ignored with -volume");
	    else file_entry.stop, file_entry.wait = "1"b;
	  end;

	else if keyword = "-volume"
	then
	  do;
	    if (argno = argct)
	    then
	      do;
missing:
	        error_sw = "1"b;
	        call com_err_ (error_table_$inconsistent, me,
		   "Object of ^a missing.", keyword);
	        return;
	      end;

	    argno = argno + 1;

	    if (volid ^= "")
	    then
	      do;
	        call com_err_ (error_table_$inconsistent, me,
		   "^[-volume not allowed in control file"
		   || "^;duplicate -volume specified", (volid = NOVOL));
	        error_sw = "1"b;
	      end;

	    else
	      do;
	        volid = arg_list.arg (argno);
	        vol_sw = "1"b;
	      end;
	    arg_list.arg (argno) = "";

	    if file_entry.stop
	    then
	      do;
	        call com_err_ (error_table_$inconsistent, me,
		   "-stop ignored with -volume");
	        file_entry.stop = "0"b;
	      end;

	    if file_entry.wait
	    then
	      do;
	        call com_err_ (error_table_$inconsistent, me,
		   "-wait ignored with -volume");
	        file_entry.wait = "0"b;
	      end;

	    if dump_sw
	    then
	      do;
	        call com_err_ (error_table_$inconsistent, me,
		   "-mode dump -volume");
	        volid = "";
	      end;

	    if table_sw
	    then
	      do;
	        call com_err_ (error_table_$inconsistent, me,
		   "-table nullifies -volume");
	        volid = "";
	      end;
	  end;

	else if keyword = "-to"	/* page selection feature */
	then
	  do;
	    from_to_ptr = addr (file_entry.to (1));
	    goto from_to_rtn;
	  end;

	else if keyword = "-table" | keyword = "-tb"
	then
	  do;
	    table_sw = "1"b;
	  end;

	else if keyword = "-wait" | keyword = "-wt"
	then
	  do;
	    if vol_sw
	    then call com_err_ (error_table_$inconsistent, me,
		    "-wait ignored with -volume");
	    else file_entry.wait = "1"b;
	  end;

	else if keyword = "-lg" | keyword = "-long"
	then
	  do;
	    brief_sw = "0"b;
	    long_sw = "1"b;
	  end;

	else
	  do;
	    call com_err_ (error_table_$badopt, me, """^a""", keyword);
	    error_sw = "1"b;
	  end;
        end;
    end;

/* its a file name */
    do argno = 1 to argct;
      if arg_list.arg (argno) ^= ""
      then
        do;
	call expand_pathname_ ((arg_list.arg (argno)), dname, ename, code);
	if code ^= 0
	then
	  do;
	    call com_err_ (code, me, "Expanding path for ^a",
	         arg_list.arg (argno));
	    error_sw = "1"b;
	    return;
	  end;

	if arg_list.asis (argno)
	then ename = rtrim (ename);
	else ename = before (rtrim (ename), ".compout") || ".compout";

	call check_star_name_$entry (ename, code);
				/* check for star name */

	if code = 0		/* 0 = not a star name */
	then call add_linked_file;	/* add a new file to the linked list */

	else
	  do;
	    if (code > 2)
	    then call com_err_ (code, me, "^a", ename);

	    else
	      do;
	        if (system_free_p = null ())
	        then system_free_p = get_system_free_area_ ();
	        call hcs_$star_ (dname, ename, 3, system_free_p, e_c, e_p,
		   n_p, code);
	        if (code ^= 0)
	        then call com_err_ (code, me, "^a>^a", dname, ename);

	        else
		do;
		  do i = 1 to e_c;
		    argct = argct + 1;
		    ename = names (entries (i).nindex);
		    call add_linked_file;
		  end;
		  free entries;
		  free names;
		end;
	      end;
	  end;
        end;
    end;

    if vol_sw & ^display_sw
    then contents_seg_sw = "1"b;

    dcl dname	   char (168);

add_linked_file:
  proc;

    given_file_count = given_file_count + 1;
    if (file_entry.file ^= "")
    then
      do;				/* next entry	       */
        tp, file_entry.link = addr (file_entry.next);
        file_entry_ptr = first_p;	/* make sure the reference to	       */
				/*   file_entry.page_sel_ct in the   */
				/*   next move refers to the one     */
				/*   being moved		       */
        tp -> file_entry = file_entry;	/* copy in all control data	       */
        file_entry_ptr = tp;		/* point to the new entry	       */
        file_entry.link = null ();	/* make sure list ends	       */
      end;

    file_entry.ename = rtrim (ename);	/* record file name		       */
    file_entry.file = rtrim (dname);	/* contruct absolute path	       */
    file_entry.file = file_entry.file || ">";
    file_entry.file = file_entry.file || file_entry.ename;

  end add_linked_file;

from_to_proc:
  proc (beg, len);

    dcl (beg, len)	   fixed bin;

    from_to.id = substr (arg_list.arg (argno), beg, len);
    if (substr (arg_list.arg (argno), beg, len) = "$")
    then
      do;
        from_to.sign = NEG_REL;
        from_to.num = 0;
      end;
    else if (substr (arg_list.arg (argno), beg, 1) = "+")
    then
      do;
        from_to.sign = POS_REL;
        from_to.num =
	   convert (from_to.num,
	   substr (arg_list.arg (argno), beg + 1, len - 1));
      end;
    else if index (substr (arg_list.arg (argno), beg), "$-") = 1
    then
      do;
        from_to.sign = NEG_REL;
        from_to.num =
	   convert (from_to.num,
	   substr (arg_list.arg (argno), beg + 2, len - 2));
      end;
    else if (substr (arg_list.arg (argno), beg, 1) = "!")
    then
      do;
        from_to.sign = ABS;
        from_to.num =
	   convert (from_to.num,
	   substr (arg_list.arg (argno), beg + 1, len - 1));
      end;
    else
      do;
        from_to.sign = SEARCH_ID;
        from_to.num = 0;
      end;
  end from_to_proc;

  end proc_args;
%page;
set_rawo:
  proc;

    if ^rawo_sw
    then
      do;
        call iox_$modes (iox_$user_output, "rawo", "", code);
        if code ^= 0
        then call com_err_ (code, me, "Setting RAWO mode.");
        rawo_sw = "1"b;
      end;

  end set_rawo;

reset_rawo:
  proc;

    call iox_$modes (iox_$user_output, "^rawo", "", code);
				/* leave RAWO mode		       */
    if code ^= 0
    then call com_err_ (code, me, "Resetting RAWO mode.");
    rawo_sw = "0"b;			/* dont want clean_ to try again     */

  end reset_rawo;
%page;
/* This routine handles writing the device string to tape.		       */

put_tape:
  proc (doing);

    dcl doing	   fixed bin;	/* 1-begin 2-end		       */

    dcl ii	   fixed bin (24);
    dcl tp	   ptr;
    dcl tl	   fixed bin (24);
    dcl atd	   char (256) var;
    dcl bp	   ptr;
    dcl bl	   fixed bin (24);
    dcl bi9	   fixed bin;
    dcl bit9	   bit (9);
    dcl bit36	   bit (36) var;
    dcl 1 bs	   (10000) based (bp),
	2 x	   bit (1) unal,	/* must be "0"b, thrown away	       */
	2 d	   bit (8);	/* these bits get on tape	       */
    dcl pack_i	   fixed bin (24);

    goto func (doing);

func (2):
    if (record_bytes < 1) | (record_bytes > 99999)
    then
      do;
        call com_err_ (0, me, "Not 0<record_bytes<99999. ^a", file_entry.file);
        goto finish;
      end;
    vol_file_ct = vol_file_ct + 1;	/* open next file on volume	       */
    bp, tp = page_record_ptr;
    bl, tl = output_text_len;
    if (vol_file_ct = 1) & contents_tap_sw
				/* first file on tape is the	       */
    then
      do;				/*   table-of-contents	       */
        bp = addrel (addr (contents), 1);
        bl = length (contents);
      end;
    if (vol_file_ct > max_tape_files)
    then
      do;
        call com_err_ (0, "Limit of ^a files/tape surpassed. ^a",
	   max_tape_files, file_entry.file);
        goto finish;
      end;
    nnn = vol_file_ct;
    atd = before (mode, " ");
    atd = atd || " ";
    atd = atd || volid;
    atd = atd || after (mode, " ");
    if (vol_file_ct <= contents_l)
    then atd = atd || " -retain all";
    atd = atd || " -ring -create -number ";
    atd = atd || nnn;

    call iox_$attach_name ("pco_tape_", tape_iocbp, (atd), null (), code);
    if code ^= 0
    then
      do;
        call com_err_ (code, me, "Attaching pco_tape_ ^a", atd);
        goto finish;
      end;

    call iox_$open (tape_iocbp, 5, "0"b, code);
    if code ^= 0
    then
      do;
        call com_err_ (code, me, "Opening volume ""^a"" -number ^a", volid,
	   nnn);
        error_sw = "1"b;
      end;

    else
      do;
        if (vol_file_ct > 1 | ^contents_tap_sw) & pack_ct > 0
        then
	do;
(nostrg):
	  substr (output_text, output_text_len + 1, 1) = "";
	  bp = addr (text_c (divide (output_text_len + 4, 4, 24, 0) * 4));
	  pack_i = 0;
	  bl = 0;
	  bit36 = ""b;
	  do i = 1 to output_text_len,
	       output_text_len + 1 repeat (output_text_len + 1)
	       while (length (bit36) > 0);
	    bit9 = unspec (substr (output_text, i, 1));
	    bi9 = 1;
pkd:
	    pack_i = pack_i + 1;
	    goto pk (pack.type (pack_i));
pk (1):
	    bit36 = bit36
	         || substr (pack.con (pack_i), 1, pack.cct (pack_i));
	    goto pkd;
pk (2):
	    bit36 = bit36 || substr (bit9, bi9, pack.cct (pack_i));
pk (4):
pk (3):
	    bi9 = bi9 + pack.cct (pack_i);
	    goto pkd;
pk (5):
	    if (pack_ct = pack_i)
	    then pack_i = 0;
	    do while (length (bit36) >= 8);
	      bl = bl + 1;
	      bs.x (bl) = "0"b;
	      bs.d (bl) = substr (bit36, 1, 8);
	      if (length (bit36) = 8)
	      then bit36 = ""b;
	      else bit36 = substr (bit36, 9);
	    end;
	  end;
	end;
        unspec (substr (bp -> output_text, bl + 1, record_bytes)) = "0"b;
				/* pad out last record	       */
        do ii = 1 to bl by record_bytes;
	call iox_$write_record (tape_iocbp, addr (bp -> text_c (ii)),
	     record_bytes, code);
	if code ^= 0
	then
	  do;
	    call com_err_ (code, me, "Writing volume ""^a"" -number ^a",
	         volid, nnn);
	  end;
        end;
        call iox_$close (tape_iocbp, code);
      end;

    call iox_$detach_iocb (tape_iocbp, code);

    if (vol_file_ct = 1) & contents_tap_sw
    then
      do;
        bp = tp;
        bl = tl;
        goto func (2);
      end;
func (1):
    return;

  end put_tape;
%page;
/* This routine handles the punching of 6-level tape on 8-level specially    */
/*  modified TN300 punch.					       */

put_punch:
  proc (doing);

    dcl doing	   fixed bin;	/* 1-begin 2-end		       */

    dcl i		   fixed bin (24);

    goto func (doing);

func (2):
    call letters ("     > >   " || what || "          ?");
    output_text_len = output_text_len + 2;
    substr (output_text, output_text_len - 1, 1) = "?";
    substr (output_text, output_text_len, 1) = PCHoff;
    do i = 1 to divide (output_text_len + 3, 4, 17, 0);
      word (i) = word (i) | "100100100100"b3;
    end;

    call ioa_ ("(Must be on TN300) Turn transparency ON and hit return.");
    call ioa_ ("When punch stops, turn transparency OFF and hit return.");
    call iox_$get_line (iox_$user_input, addr (keyword), 10, 0, code);
    call iox_$modes (iox_$user_output, "rawo", "", code);
    call iox_$put_chars (iox_$user_output, page_record_ptr, output_text_len,
         code);
    call iox_$modes (iox_$user_output, "^rawo", "", code);
    call iox_$get_line (iox_$user_input, addr (keyword), 10, 0, code);
    call ioa_ ("Punched ^i characters, ^.3f feet", output_text_len,
         dec (output_text_len) / 120);
    return;

func (1):
    substr (output_text, 1, 1) = PCHon; /* put header		       */
    substr (output_text, 2, 1) = "?";
    output_text_len = 2;
    file_entry.seq_no = file_entry.seq_no + 1;
    what = file_entry.ename;
    what = what || "-";
    what = what || ltrim (char (file_entry.seq_no));
    call letters ("       ");
    call letters ((what));
    call letters ("    > >   ");
    call letters ((leader));
    call letters ("      ");
    return;

    dcl PCHon	   char (1) static options (constant) init ("");
    dcl PCHoff	   char (1) static options (constant) init ("");

letters:
  proc (s);

    dcl s		   char (*);

    dcl (i, j)	   fixed bin;

    do i = 1 to length (s);
      j = index (
	 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz1234567890._->~!"
	 , substr (s, i, 1));
      if (j > 26)
      then j = j - 26;
      output_text_len = output_text_len + length (holes (j));
      substr (output_text, output_text_len - length (holes (j)) + 1,
	 length (holes (j))) = holes (j);
    end;

    dcl holes	   (0:42) char (8) var static options (constant)
		   init ("@@@@@",	/*   */
		   "@|J|",	/* A */
		   "@~jjT",	/* B */
		   "@\bb",	/* C */
		   "@~b\",	/* D */
		   "@~jj",	/* E */
		   "@~JJ",	/* F */
		   "@\bjz",	/* G */
		   "@~HH~",	/* H */
		   "@b~b",	/* I */
		   "@``~",	/* J */
		   "@~HTb",	/* K */
		   "@~``",	/* L */
		   "@~DHD~",	/* M */
		   "@~DH~",	/* N */
		   "@~bb~",	/* O */
		   "@~JJD",	/* P */
		   "@\bjRl",	/* Q */
		   "@~JJt",	/* R */
		   "@djjR",	/* S */
		   "@BB~BB",	/* T */
		   "@~`~",	/* U */
		   "@^`^",	/* V */
		   "@~`\`~",	/* W */
		   "@bTHTb",	/* X */
		   "@BDxDB",	/* Y */
		   "@rjfb",	/* Z */
		   "@D~",		/* 1 */
		   "@drjd",	/* 2 */
		   "@RbfZ",	/* 3 */
		   "@NH~H",	/* 4 */
		   "@NjjR",	/* 5 */
		   "@\jjX",	/* 6 */
		   "@BrJF",	/* 7 */
		   "@TjjT",	/* 8 */
		   "@Djj\",	/* 9 */
		   "@\bb\",	/* 0 */
		   "@pp",		/* . */
		   "@````",	/* _ */
		   "@HHHH",	/* - */
		   "@H\~",	/* > */
		   "Wq",		/* noFLASH */
		   "WM");		/* FLASH */
  end letters;
  end put_punch;
    dcl what	   char (44) var;	/* name of what is being worked on   */
%page;
/* This routine handles the -db/-display output of the device string.	       */

put_online:
  proc (doing);

    dcl doing	   fixed bin;	/* 1-begin, 2-end		       */

    dcl db_displ_str   char (4096) var; /* the interpreted string */
    dcl dlen	   fixed bin;
    dcl (i, j)	   fixed bin (24);
    dcl iblk	   fixed bin (24);

    dcl 1 delay	   internal static aligned,
	2 version	   fixed bin init (1),
	2 default	   fixed bin,
	2 values	   like input_delays;
    dcl ESC	   char (1) static options (constant) init ("");
    dcl 1 input_delays aligned,	/* supplied values for delay setting */
	2 vert_nl	   fixed bin,
	2 horz_nl	   float bin,
	2 const_tab  fixed bin,
	2 var_tab	   float bin,
	2 backspace  fixed bin,
	2 vt_ff	   fixed bin;

    dcl iox_$control   entry (ptr, char (*), ptr, fixed bin (35));
    dcl iox_$user_io   ptr ext static;

    if doing = END
    then
      do;
        if iox_$user_output = iox_$user_io
        then
	do;
	  call iox_$control (iox_$user_output, "get_delay", addr (delay),
	       code);
	  input_delays = delay.values;
	  delay.horz_nl = 0.3;
	  call iox_$control (iox_$user_output, "set_delay", addr (delay),
	       code);
	  delay.values = input_delays;/* restore for return */

	  on cleanup
	    call iox_$control (iox_$user_output, "set_delay", addr (delay),
	         code);
	end;

/*        call ioa_ ("^/   **** FILE #^i ****^/", filno);*/
        filno = filno + 1;

        i = 1;
        do while (i <= output_text_len);/* run thru the output record */
				/* grab a chunk */
	dlen = min (output_text_len - i + 1, 2000);

	if dlen = 2000		/* dont split ESC sequences */
	then
	  do;
	    j = index (reverse (substr (output_text, i, 2000)), ESC);
	    dlen = dlen - j;
	  end;

	db_displ_str =
	     comp_util_$display (substr (output_text, i, dlen), dlen, "1"b);
	call iox_$put_chars (iox_$user_output,
	     addr (substr (db_displ_str, 1)), length (db_displ_str), code);

	if code ^= 0
	then
	  do;
	    call com_err_ (code, me, "Writing display output.");
	    if iox_$user_output = iox_$user_io
	    then call iox_$control (iox_$user_output, "set_delay",
		    addr (delay), code);
	    return;
	  end;

	i = i + dlen;
        end;

        if iox_$user_output = iox_$user_io
        then call iox_$control (iox_$user_output, "set_delay", addr (delay),
	        code);
      end;

  end put_online;
%page;
/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/*		       ACTIVE FUNCTION ENTRIES		       */

compout:
  entry;

    call cu_$af_return_arg (nargs, ret_p, ret_l, code);
    if (code = 0)
    then err_out = active_fnc_err_;
    else
      do;
        err_out = com_err_;
        ret_p = null ();
      end;
    if af_data_ptr = null ()
    then
      do;
        call err_out (error_table_$out_of_sequence, "compout");
        return;
      end;
    if (ret_p = null ())
    then call ioa_ ("^a", af_data.compout);
    else ret_v = af_data.compout;
    return;

compask:
  entry;

    call cu_$af_return_arg (nargs, ret_p, ret_l, code);
    if (code = 0)
    then
      do;
        err_out = active_fnc_err_;
      end;
    else
      do;
        err_out = com_err_;
        ret_p = null ();
      end;
    if af_data_ptr = null ()
    then
      do;
        call err_out (error_table_$out_of_sequence, "compask");
        return;
      end;
    do argno = 2 to nargs;
      call cu_$arg_ptr (argno, argp, argl, code);
      i = index (arg, "=");
      if (i = 0)
      then valid_in (argno), valid_out (argno) = arg;
      else
        do;
	valid_in (argno) = before (arg, "=");
	valid_out (argno) = after (arg, "=");
        end;
    end;
    call cu_$arg_ptr (1, argp, argl, code);
    if (code ^= 0)
    then
      do;
        call err_out (code, "compask");
        return;
      end;
    default_ans = "";
    do j = af_data.count to 1 by -1;
      if (arg = af_data.quest (j))
      then
        do;
	default_ans = af_data.ans (j);
	j = 0;
        end;
    end;
    query_info.yes_or_no_sw = "0"b;
    query_info.suppress_name_sw = "1"b;
re_ask:
    call ioa_$nnl ("^a (^a) ", arg, default_ans);
re_get:
    call iox_$get_line (iox_$user_input, addr (reply_text),
         length (reply_text), reply_l, code);
    if (code = error_table_$end_of_info)/* in case called in an exec_com  */
    then goto re_get;
    compans = substr (reply_text, 1, reply_l - 1);
    new_sw = "0"b;
    if (compans = ".")
    then valid_in (1), valid_out (1) = "";
    else if (compans = "")
    then valid_in (1), valid_out (1) = default_ans;
    else
      do;
        valid_in (1), valid_out (1) = compans;
        new_sw = "1"b;
      end;
    if nargs > 1
    then
      do;
        do argno = 2 to nargs;
	if (valid_in (argno) = valid_in (1))
	then
	  do;
	    valid_out (1) = valid_out (argno);
	    goto found_reply;
	  end;
        end;
        call ioa_ ("Please answer ^a^(, ^a^).", valid_list);
        goto re_ask;
found_reply:
      end;
    compans = valid_out (1);
    query_info.yes_or_no_sw = "1"b;
    query_info.suppress_name_sw = "0"b;
    if new_sw
    then
      do;
        af_data.count = af_data.count + 1;
        af_data.quest (af_data.count) = arg;
        af_data.ans (af_data.count) = valid_in (1);
      end;
    if (ret_p = null ())
    then call ioa_ ("^a", compans);
    else
      do;
        if (index (compans, " ") = 0)
        then ret_v = compans;
        else ret_v = """" || compans || """";
      end;
    return;

    dcl dt_sw	   bit (1) int static init ("0"b);
dtn:
  entry;
    dt_sw = "1"b;
    return;
dtf:
  entry;
    dt_sw = "0"b;
    return;

evaluate_af_:
  proc (in_str, in_used, out_str, code);

    dcl in_str	   char (*),	/* str which begins with AF	  [IN] */
        in_used	   fixed bin (21),	/* amount of in_str used up    [OUT] */
        out_str	   char (*) var,	/* result of expansion	 [OUT] */
        code	   fixed bin (35);	/* return code		 [OUT] */

    if (substr (in_str, 1, 1) = "[")
    then af_type = 1;
    else if (substr (in_str, 1, 2) = "|[")
    then af_type = 2;
    else if (substr (in_str, 1, 3) = "||[")
    then af_type = 3;
    else goto brack;
    nest = 1;
    in_used = af_type + 1;
keep_on:
    i = search (substr (in_str, in_used), """[]");
    if (i = 0)
    then
      do;
brack:
        code = error_table_$unbalanced_brackets;
        return;
      end;
    in_used = in_used + i;
    ch = substr (in_str, in_used - 1, 1);
    if (ch = """")
    then
      do;
        i = index (substr (in_str, in_used), """");
        if (i = 0)
        then
	do;
	  code = error_table_$unbalanced_quotes;
	  return;
	end;
        in_used = in_used + i;
        goto keep_on;
      end;
    if (ch = "[")
    then
      do;
        nest = nest + 1;
        goto keep_on;
      end;
    if (ch = "]")
    then
      do;
        nest = nest - 1;
        if (nest > 0)
        then goto keep_on;
      end;
    in_used = in_used - 1;
    call cu_$evaluate_active_string (null (),
         substr (in_str, af_type + 1, in_used - af_type - 1), af_type, out_str,
         code);


    dcl af_type	   fixed bin;
    dcl nest	   fixed bin;
    dcl i		   fixed bin;
    dcl ch	   char (1);
    dcl cu_$evaluate_active_string
		   entry (ptr, char (*), fixed bin, char (*) var,
		   fixed bin (35));
    dcl error_table_$unbalanced_brackets
		   fixed bin (35) ext static;
    dcl error_table_$unbalanced_quotes
		   fixed bin (35) ext static;

  end evaluate_af_;
%page;
    dcl compans	   char (200) var;
    dcl default_ans	   char (200) var;
    dcl cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
    dcl err_out	   entry options (variable) automatic;
    dcl active_fnc_err_
		   entry () options (variable);
    dcl error_table_$out_of_sequence
		   fixed bin (35) ext static;
    dcl cu_$af_return_arg
		   entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
    dcl nargs	   fixed bin;
    dcl new_sw	   bit (1);
    dcl reply_l	   fixed bin (21);
    dcl ret_p	   ptr;
    dcl ret_l	   fixed bin (21);
    dcl ret_v	   char (ret_l) var based (ret_p);
%page;
/*   *  Temp segment usage:					       */
/*   *       record_ptr -> record read from input file		       */
/*   *       |						       */
/*   *  (1)  v___________________________________________~		       */
/*   *							       */
/*   *       file_entry_ptr header_out_ptr page_record_ptr		       */
/*   *       |      |            |	        |			       */
/*   *  (2)  v______v____________v______________v_________~		       */
/*   *							       */
/*   *       contents_ptr						       */
/*   *       |						       */
/*   *  (3)  v___________________________________________~		       */
/*   *							       */
/*   *       pagelist_ptr					       */
/*   *       |						       */
/*   *  (4)  v___________________________________________~		       */
/*   *							       */

/* LOCAL STORAGE */

    dcl text_c	   (output_text_len) char (1) based (page_record_ptr);
				/*  (magtape/papertape)	       */
    dcl file_seq_no	   fixed bin;
    dcl first_p	   ptr;
    dcl format	   bit (11) static options (constant) init ("10001"b);
				/* control for dump_segment_	       */
    dcl (i, l)	   fixed bin;	/* working index		       */
    dcl i2	   fixed bin (21);
    dcl it	   fixed bin (24);
    dcl mode_unproc	   char (200) var;	/* the current mode sans af_proc     */
    dcl mode_name	   char (32) var;
    dcl nnn	   pic "999";
    dcl NL	   char (1) int static options (constant) init ("
");
    dcl NULs	   char (8) static options (constant) init ("");
    dcl packi	   fixed bin;
    dcl stop_bfr	   char (80);	/* buffer to hold users -stop	       */
				/*  option response		       */
				/* OR the .wt input		       */
    dcl str	   char (262144) based;
    dcl this_page	   fixed bin;
    dcl valid_in	   (15) char (64) var;
    dcl valid_list	   (nargs - 1) char (64) var based (addr (valid_in (2)));
    dcl valid_out	   (15) char (64) var;
    dcl word	   (2000) bit (36) based (page_record_ptr);



    dcl 1 pack	   (40),
	2 cct	   fixed bin,	/* number of bits in use	       */
	2 con	   bit (27) unal,	/* constant		       */
	2 type	   fixed bin (8) unal;
				/* 1-literal 2-fwd 3-copy 4-bwd      */
    dcl toch_ndx	   pic "zzz9bb";

    dcl CRLF	   char (2) static options (constant) init ("
");



    dcl error_table_$inconsistent
		   fixed bin (35) ext static;

    dcl hcs_$make_entry
		   entry (ptr, char (*), char (*), entry, fixed bin (35));
    dcl iox_$control   entry (ptr, char (*), ptr, fixed (35));
    dcl iox_$get_line  entry (ptr, ptr, fixed bin (21), fixed bin (21),
		   fixed bin (35));
    dcl iox_$modes	   entry (ptr, char (*), char (*), fixed (35));
    dcl iox_$position  entry options (variable);
    dcl iox_$write_record
		   entry (ptr, ptr, fixed bin (21), fixed bin (35));
    dcl release_temp_segments_
		   entry (char (*), (*) ptr, fixed bin (35));
    dcl expand_pathname_
		   entry (char (*), char (*), char (*), fixed bin (35));


%include comp_dvid;
%include comp_dvt;
%include comp_entries;
%include comp_fntstk;
%include comp_output;
%include comp_page;
%include comp_shared;
%include comp_text;
%include compstat;
%include query_info_;

  end process_compout;




		    xdw_.pl1                        04/23/85  1100.9rew 04/23/85  0911.6     1035549



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* format: style2,ind3,ll80,dclind4,idind16,comcol41,linecom */

/* FUTURE &fileout name ... &filend */

xdw_:
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 " || 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 (1044480) 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
	     do;
	        substr (output, ofe + 1, argl.l (num)) = arg;
	        ofe = ofe + argl.l (num);
	     end;
         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;
	        c32 = ltrim (char (argct));
	        substr (output, ofe + 1, length (c32)) = c32;
	        ofe = ofe + length (c32);
	     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;
	        substr (output, out_len + 1, 1) = "&";
	        out_len = out_len + 1;
	        ifi = ifi + 2;
	     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 || "
");
			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 (1044480) 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;
		 substr (output, ofe + 1, jj) = substr (input, ifi, jj);
		 ifi = ifi + jj;
		 ofe = ofe + 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;
	     substr (output, ofe + 1, argl.l (num)) = arg;
	     ofe = ofe + argl.l (num);
	     if (num ^= j)
	     then
	        do;
		 substr (output, ofe + 1, length (separator)) = separator;
		 ofe = ofe + length (separator);
	        end;
	  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 (1044480) 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 ch60	      char (60) var;
      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;
      substr (output, ofe + 1, 1) = "(";
      ofe = ofe + 1;
      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;
	  substr (output, ofe + 1, i) = substr (input, ifi, i);
	  ofe = ofe + 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):				/* ( */
				/* */
      substr (output, ofe + 1, 1) = "(";
      ofe = ofe + 1;
      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):				/* ) */
				/* */
      substr (output, ofe + 1, 1) = ")";
      ofe = ofe + 1;
      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, ofe - ii), "
");
         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 = ife - ifi + 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;
      ch60 = ltrim (rtrim (rtrim (convert (pic60, val (1)), "0"), "."));
      substr (output, ofe + 1, length (ch60)) = ch60;
      ofe = ofe + length (ch60);
   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 (1044480) 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;
	     substr (output, out_len + 1, i) = substr (input, ifi, i);
	     out_len = out_len + 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 hcs_$initiate_count
		      entry (char (*), char (*), char (*), fixed bin (24),
		      fixed bin (2), ptr, 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
         do;
	  call hcs_$initiate_count (dname, (search_for), "", bc, 0, segptr,
	       ecode);
	  if (segptr ^= null ())
	  then ecode = 0;
         end;
      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;
	        msg = "&" || end_sym || " 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 = 261120;
      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 (1044480) 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 (1044480) 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;
	  substr (output, ofe + 1, i) = substr (input, ifi, i);
	  ofe = ofe + 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;
	  substr (output, ofe + 1, 1) = "^";
	  ofe = ofe + 1;
	  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), "&");
      if (j = 0)
      then goto log_err;
      if (j > 1)
      then
         do;
	  j = j - 1;
	  substr (output, ofe + 1, j) = substr (input, ifi, j);
	  ifi = ifi + j;
	  ofe = ofe + 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 (1044480) 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;
	  substr (output, ofe + 1, i) = substr (input, ifi, i);
	  ofe = ofe + 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):				/* [ */
				/* */
      substr (output, ofe + 1, 1) = "[";
      ofe = ofe + 1;
      ifi = ifi + 1;
      level = level + 1;
      goto loop;

type (3):				/* ] */
				/* */
      substr (output, ofe + 1, 1) = "]";
      ofe = ofe + 1;
      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;

      begin;

         dcl rval	         char (500) var;
         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;
         substr (output, ofe + 1, length (rval)) = rval;
         ofe = ofe + length (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 (1044480) 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;
      substr (output, ofe + 1, 1) = "(";
      ofe, loc (1) = ofe + 1;
      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;
	  substr (output, ofe + 1, i) = substr (input, ifi, i);
	  ofe = ofe + i;
	  ifi = ifi + i;
         end;
      goto type (index ("&(),", inputa (ifi)));

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

type (2):				/* ( */
				/* */
      substr (output, ofe + 1, 1) = "(";
      ofe = ofe + 1;
      ifi = ifi + 1;
      level = level + 1;
      goto loop;

type (3):				/* ) */
				/* */
      substr (output, ofe + 1, 1) = ")";
      ofe = ofe + 1;
      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), "
");
	  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):				/* , */
				/* */
      substr (output, ofe + 1, 1) = ",";
      ofe = ofe + 1;
      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 (1044480) 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;
	  substr (output, ofe + 1, i) = substr (input, ifi, i);
	  ofe = ofe + 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 (1044480) 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 (1044480) 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 (1044480) 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;
	  substr (output, ii + 1, 38) =
	       "4(Invalid &error severity, 4 assumed.) ";
	  ofe = ii + 38;
         end;
      call strip (ifp, ifi, ife);
      if (inputa (ifi) ^= ",")
      then
         do;
	  substr (output, ofe + 1, 39) =
	       "(Missing comma after &error severity.) ";
	  ofe = ofe + 39;
         end;
      else ifi = ifi + 1;
loop:
      i = index (substr (input, ifi), "&");
      if (i = 0)
      then
         do;
	  msg = "&;";
	  call error_missing ("error", begl, ife);
         end;
      if (i > 1)
      then
         do;
	  i = i - 1;
	  substr (output, ofe + 1, i) = substr (input, ifi, i);
	  ofe = ofe + 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 (1044480) 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 (1044480) 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";

/* &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), "&");
      if (i = 0)
      then
         do;
	  msg = "&;";
	  call error_missing ("length", begl, ife);
         end;
      if (i > 1)
      then
         do;
	  i = i - 1;
	  substr (output, ofe + 1, i) = substr (input, ifi, i);
	  ofe = ofe + i;
	  ifi = ifi + i;
         end;
      if (substr (input, ifi, 2) = "&;")
      then
         do;
	  call strip2 (ifp, ifi, ife);
	  ch8 = ofe - ii;
	  ofe = ii;
	  i = index (reverse (ch8), " ") - 1;
	  substr (output, ofe + 1, i) = substr (ch8, 9 - i, i);
	  ofe = ofe + 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 (1044480) 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), "&");
	  if (i = 0)
	  then
	     do;
	        msg = "&;";
	        call error_missing (cmd (which), begl, ife);
	     end;
	  if (i > 1)
	  then
	     do;
	        i = i - 1;
	        substr (output, ofe + 1, i) = substr (input, ifi, i);
	        ofe = ofe + 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 (1044480) 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), "&");
      if (i = 0)
      then
         do;
	  msg = "&;";
	  call error_missing ("quote", begl, ife);
         end;
      if (i > 1)
      then
         do;
	  i = i - 1;
	  substr (output, ofe + 1, i) = substr (input, ifi, i);
	  ofe = ofe + 1;
	  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;
         substr (output, ofe + 1, ii) = substr (argstr, j, ii);
         ofe = ofe + ii;
         j = j + ii;
         if (substr (output, ofe, 1) = """")
         then
	  do;
	     substr (output, ofe + 1, 1) = """";
	     ofe = ofe + 1;
	  end;
         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 (1044480) 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), "&");
      if (i = 0)
      then
         do;
	  msg = "&;";
	  call error_missing ("scan", begl, ife);
         end;
      if (i > 1)
      then
         do;
	  i = i - 1;
	  substr (output, ofe + 1, i) = substr (input, ifi, i);
	  ofe = ofe + 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 (1044480) 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), "&,");
      if (i = 0)
      then
         do;
	  msg = "&;";
	  call error_missing ("substr", begl, ife);
         end;
      if (i > 1)
      then
         do;
	  i = i - 1;
	  substr (output, ofe + 1, i) = substr (input, ifi, i);
	  ofe = ofe + 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;
	     substr (output, ofe + 1, j) = substr (argstr, i);
	     ofe = ofe + j;
	  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 (1044480) 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), "&");
      if (i = 0)
      then
         do;
	  msg = "&;";
	  call error_missing ("unquote", begl, ife);
         end;
      if (i > 1)
      then
         do;
	  i = i - 1;
	  substr (output, ofe + 1, i) = substr (input, ifi, i);
	  ofe = ofe + 1;
	  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 (1044480) 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), "&");
      if (i = 0)
      then
         do;
	  msg = "&;";
	  call error_missing ("usage", begl, ife);
         end;
      if (i > 1)
      then
         do;
	  i = i - 1;
	  substr (output, ofe + 1, i) = substr (input, ifi, i);
	  ofe = ofe + 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);
	     substr (output, ofe + 1, ret_len) = substr (ret_str, 1, ret_len);
	     ofe = ofe + 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;
/*  -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+-  */
/*							       */
/* 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 (1044480) 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), "&""");
         if (i = 0)
         then
	  do;
	     msg = "&""";
	     call error_missing ("""", begl, ife);
	  end;
         i = i - 1;
         substr (output, ofe + 1, i) = substr (input, ifi, i);
         ofe = ofe + i;
         ifi = ifi + i + 2;
         if (substr (input, ifi, 2) ^= "&""")
         then return;
         substr (output, ofe + 1, 2) = "&""";
         ofe = ofe + 2;
         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 (1044480) 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), "&");
      if (i = 0)
      then
         do;
	  msg = "Missing terminator on &";
	  msg = msg || c32;
	  msg = msg || ". ";
	  goto add_identification;
         end;
      if (i > 1)
      then
         do;
	  i = i - 1;
	  substr (output, ofe + 1, i) = substr (input, ifi, i);
	  ofe = ofe + 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 (1044480) 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), "&}");
	     if (jj = 0)
	     then
	        do;
		 msg = "}";
		 call error_missing ("xxx{", begl, ife);
	        end;
	     if (jj > 1)
	     then
	        do;
		 jj = jj - 1;
		 substr (output, ofe + 1, jj) = substr (input, ifi, jj);
		 ifi = ifi + jj;
		 ofe = ofe + 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;
	     substr (output, ofe + 1, array.len (arr_elem)) = arrtext;
	     ofe = ofe + array.len (arr_elem);
	     if (arr_elem ^= limit)
	     then
	        do;
		 substr (output, ofe + 1, length (separator)) = separator;
		 ofe = ofe + length (separator);
	        end;
	  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 (1044480) 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);
	  substr (output, out_len + 1, var.len) = vartext;
	  out_len = out_len + var.len;
         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)
		        ;
	        substr (output, out_len + 1, array.len (arr_elem)) = arrtext;
	        out_len = out_len + array.len (arr_elem);
	        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)
		        ;
	        substr (output, out_len + 1, array.len (arr_elem)) = arrtext;
	        out_len = out_len + array.len (arr_elem);
	        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 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;	/* 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,
	  2 ref	      ptr,	/* 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 (1044480) 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_$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;
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;
dbf:
   entry;
      db_sw = "0"b;
      return;

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

      watchword = watchfor;
      return;

   end;







		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved