



		    cb_menu_.alm                    06/09/82  1345.4rew 06/09/82  1345.2       10278



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
" Transfer vector for the COBOL menu interfaces (which are themselves little
" more than transfers).
"
" Written April 1982 by Chris Jones

	name	cb_menu_

	macro	transfer
	segdef	&1
&1:	getlp
	tra	&2
	&end

	transfer	create,fc_menu_create$cobol_create
	transfer	delete,fc_menu_value_seg_man$delete
	transfer	describe,fc_menu_video$cobol_describe
	transfer	destroy,fc_menu_create$destroy
	transfer	display,fc_menu_video$display
	transfer	get_choice,fc_menu_video$get_choice
	transfer	init2,fc_menu_utils$init2		" init1 is an alm program in another module
	transfer	list,fc_menu_value_seg_man$list
	transfer	retrieve,fc_menu_value_seg_man$retrieve
	transfer	store,fc_menu_value_seg_man$store
	transfer	terminate,fc_menu_utils$terminate

" init1 is handled specially

	segdef	init1
init1:	getlp
	tra	fc_menu_init1$fc_menu_init1

	end




		    cb_window_.alm                  06/09/82  1345.4rew 06/09/82  1345.1        6282



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
" Transfer vector for the COBOL window interfaces (which are themselves little
" more than transfers).
"
" Written April 1982 by Chris Jones

	name	cb_window_

	macro	transfer
	segdef	&1
&1:	getlp
	tra	&2
	&end

	transfer	change,fc_menu_window$change
	transfer	clear_window,fc_menu_window$clear_window
	transfer	create,fc_menu_window$create
	transfer	destroy,fc_menu_window$destroy

	end




		    fc_menu_create.pl1              06/09/82  1345.4rew 06/09/82  1345.1      100728



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/*
   This program is part of the wrapper used by FORTRAN and COBOL programs to access the menu system.
   It exists because the menu_ subroutines make use of data types which have no counterparts in FORTRAN and/or COBOL.
*/
/* Written March to April 1982 by Chris Jones */
/* format: style4,delnl,insnl,indattr,ifthen,declareind10,dclind10 */
fc_menu_create:
     proc;

	signal condition (bad_call_);			/* not a true entrypoint */
	return;

/* Parameters */

dcl	p_choices		   (*) char (*) parameter;	/* (Input) the options the menu will have */
dcl	1 p_choices_struc	   parameter aligned,	/* ...same, for COBOL */
	  2 choices	   (*) char (*) unal;
dcl	p_code		   fixed bin (35) parameter;	/* (Output) status code */
dcl	p_headers		   (*) char (*) parameter;	/* (Input) menu headers */
dcl	1 p_headers_struc	   parameter aligned,
	  2 headers	   (*) char (*) unal;
dcl	p_keys		   (*) char (1) parameter;	/* (Input) the selection keys */
dcl	1 p_keys_struc	   parameter aligned,
	  2 keys		   (*) char (1) unal;
dcl	p_menu_format_array	   (6) fixed bin parameter;	/* (Input) various menu formatting parameters */
dcl	1 p_menu_format_struc  aligned parameter,	/* (Input) ditto, for COBOL programs */
	  2 version	   fixed bin,
	  2 constraints,
	    3 max_width	   fixed bin,
	    3 max_height	   fixed bin,
	  2 n_columns	   fixed bin,
	  2 flags		   unal,
	    3 center_headers   pic "9",
	    3 center_trailers  pic "9",
	  2 pad_char	   char (1) unal;
dcl	p_menu_id		   fixed bin (35) parameter;	/* (Output) how a menu is identified */
dcl	p_menu_needs_array	   (3) fixed bin parameter;	/* (Output) describes size of created menu */
dcl	1 p_menu_needs_struc   aligned parameter,	/* ...for COBOL programs */
	  2 lines_needed	   fixed bin (35),
	  2 width_needed	   fixed bin (35),
	  2 n_options	   fixed bin (35);
dcl	p_menu_ptr	   ptr;			/* (Input) an unpacked menu_id */
dcl	p_pad_char	   char (1) parameter;	/* (Input) character used for padding */
dcl	p_trailers	   (*) char (*) parameter;	/* (Input) menu trailers */
dcl	1 p_trailers_struc	   parameter aligned,
	  2 trailers	   (*) char (*) unal;

/* Automatic storage */

dcl	1 auto_menu_format	   like menu_format;
dcl	1 auto_menu_requirements
			   like menu_requirements;
dcl	fortran_entry	   bit (1) aligned;		/* "1"b if called from a FORTRAN program */
dcl	menu_id_ptr	   ptr;			/* used to redefine p_menu_id */
dcl	menu_ptr		   ptr;			/* used in calls to the menu_ subroutines */

/* Based variables */

dcl	THE_AREA		   area based (get_system_free_area_ ());
dcl	menu_array	   (fc_menu_data_$menu_array_size) ptr based (fc_menu_data_$menu_array_ptr);
						/* array of menus we are managing */
dcl	packed_menu_ptr	   ptr unal based (menu_id_ptr);
						/* overlays the fixed bin (35) which is the menu_id */

/* Static storage and constants */

dcl	MENU_ARRAY_SIZE_INCREMENT
			   fixed bin init (5) static options (constant);

/* The following constants are used as indices into the arrays a FORTRAN program passes in in lieu of structures. */

dcl	VERSION		   fixed bin init (1) static options (constant);
dcl	MAX_WIDTH		   fixed bin init (2) static options (constant);
dcl	MAX_HEIGHT	   fixed bin init (3) static options (constant);
dcl	N_COLUMNS		   fixed bin init (4) static options (constant);
dcl	CENTER_HEADERS	   fixed bin init (5) static options (constant);
dcl	CENTER_TRAILERS	   fixed bin init (6) static options (constant);

dcl	LINES_NEEDED	   fixed bin init (1) static options (constant);
dcl	WIDTH_NEEDED	   fixed bin init (2) static options (constant);
dcl	N_OPTIONS		   fixed bin init (3) static options (constant);

/* External entries and variables */

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

dcl	fc_menu_data_$initialized
			   bit (1) aligned external static;
dcl	fc_menu_data_$menu_array_ptr
			   ptr external static;
dcl	fc_menu_data_$menu_array_size
			   fixed bin external static;

dcl	get_system_free_area_  entry () returns (ptr);

/* Conditions and builtins */

dcl	(bad_call_)	   condition;

dcl	(addr, hbound, lbound, length, null, rtrim)
			   builtin;

/* Entries to create a menu */

fortran_create:
     entry (p_choices, p_headers, p_trailers, p_pad_char, p_menu_format_array, p_keys, p_menu_needs_array, p_menu_id,
	p_code);

	call must_have_initialized;
	fortran_entry = "1"b;
	auto_menu_format.version = p_menu_format_array (VERSION);
	auto_menu_format.max_width = p_menu_format_array (MAX_WIDTH);
	auto_menu_format.max_height = p_menu_format_array (MAX_HEIGHT);
	auto_menu_format.n_columns = p_menu_format_array (N_COLUMNS);
	auto_menu_format.center_headers = (p_menu_format_array (CENTER_HEADERS) ^= 0);
	auto_menu_format.center_trailers = (p_menu_format_array (CENTER_TRAILERS) ^= 0);
	auto_menu_format.pad_char = p_pad_char;
	call create_the_menu (p_choices, p_headers, p_trailers, p_keys);
	return;

/* The COBOL version of this entry point */

cobol_create:
     entry (p_choices_struc, p_headers_struc, p_trailers_struc, p_menu_format_struc, p_keys_struc, p_menu_needs_struc,
	p_menu_id, p_code);

	call must_have_initialized;
	fortran_entry = "0"b;
	auto_menu_format.version = p_menu_format_struc.version;
	auto_menu_format.max_width = p_menu_format_struc.max_width;
	auto_menu_format.max_height = p_menu_format_struc.max_height;
	auto_menu_format.n_columns = p_menu_format_struc.n_columns;
	auto_menu_format.center_headers = (p_menu_format_struc.center_headers ^= 0);
	auto_menu_format.center_trailers = (p_menu_format_struc.center_trailers ^= 0);
	auto_menu_format.pad_char = p_menu_format_struc.pad_char;
	call create_the_menu ((p_choices_struc.choices), (p_headers_struc.headers), (p_trailers_struc.trailers),
	     (p_keys_struc.keys));
	return;

create_the_menu:
     proc (arg_choices, arg_headers, arg_trailers, arg_keys);

dcl	arg_choices	   (*) char (*) parameter;
dcl	arg_headers	   (*) char (*) parameter;
dcl	arg_keys		   (*) char (1) parameter;
dcl	arg_trailers	   (*) char (*) parameter;

dcl	array_idx		   fixed bin;
dcl	choices		   (lbound (arg_choices, 1):hbound (arg_choices, 1))
			   char (length (arg_choices (hbound (arg_choices, 1)))) varying;
dcl	headers		   (lbound (arg_headers, 1):hbound (arg_headers, 1))
			   char (length (arg_headers (hbound (arg_headers, 1)))) varying;
dcl	keys		   (lbound (arg_keys, 1):hbound (arg_keys, 1)) char (1) unal;
dcl	trailers		   (lbound (arg_trailers, 1):hbound (arg_trailers, 1))
			   char (length (arg_trailers (hbound (arg_trailers, 1)))) varying;

/* Copy all of the arguments into the right kind of structure */

	do array_idx = lbound (arg_choices, 1) to hbound (arg_choices, 1);
	     choices (array_idx) = rtrim (arg_choices (array_idx));
	end;
	do array_idx = lbound (arg_headers, 1) to hbound (arg_headers, 1);
	     headers (array_idx) = rtrim (arg_headers (array_idx));
	end;
	do array_idx = lbound (arg_trailers, 1) to hbound (arg_trailers, 1);
	     trailers (array_idx) = rtrim (arg_trailers (array_idx));
	end;
	do array_idx = lbound (arg_keys, 1) to hbound (arg_keys, 1);
	     keys (array_idx) = arg_keys (array_idx);
	end;

	auto_menu_requirements.version = menu_requirements_version_1;
	auto_menu_format.pad = ""b;

/* Create the menu, and copy back the returned items */

	call menu_$create (choices, headers, trailers, addr (auto_menu_format), keys, null (),
	     addr (auto_menu_requirements), menu_ptr, p_code);
	if fortran_entry then do;
	     p_menu_needs_array (LINES_NEEDED) = auto_menu_requirements.lines_needed;
	     p_menu_needs_array (WIDTH_NEEDED) = auto_menu_requirements.width_needed;
	     p_menu_needs_array (N_OPTIONS) = auto_menu_requirements.n_options;
	end;
	else do;
	     p_menu_needs_struc.lines_needed = auto_menu_requirements.lines_needed;
	     p_menu_needs_struc.width_needed = auto_menu_requirements.width_needed;
	     p_menu_needs_struc.n_options = auto_menu_requirements.n_options;
	end;
	menu_id_ptr = addr (p_menu_id);
	packed_menu_ptr = menu_ptr;			/* sets menu_id */

	call add_to_menu_array_proc (menu_ptr);		/* remember we created it */

     end create_the_menu;

/* Entry to destroy a previously created menu */

destroy:
     entry (p_menu_id, p_code);

	call must_have_initialized;
	menu_id_ptr = addr (p_menu_id);
	menu_ptr = packed_menu_ptr;
	call remove_from_menu_array (menu_ptr);
	call menu_$destroy (menu_ptr, p_code);
	packed_menu_ptr = menu_ptr;
	return;

add_to_menu_array:
     entry (p_menu_ptr);

	call add_to_menu_array_proc (p_menu_ptr);
	return;

/* Routine to add a newly created menu to the array of menus we will destroy on termination of this package.
   This routine handles the case of growing the menu_array if necessary. */

add_to_menu_array_proc:
     proc (menu_ptr);

dcl	menu_ptr		   ptr;			/* the id to add to the array */

dcl	menu_array_idx	   fixed bin;		/* index into menu_array */

	do menu_array_idx = 1 to fc_menu_data_$menu_array_size while (menu_array (menu_array_idx) ^= null ());
	end;
	if menu_array_idx > fc_menu_data_$menu_array_size then do;
						/* must grow menu_array */

	     begin;				/* so we can define some tricky arrays */

dcl	new_menu_array_end_ptr ptr;
dcl	old_menu_array_ptr	   ptr;
dcl	old_menu_array_size	   fixed bin;

dcl	old_menu_array	   (old_menu_array_size) ptr based (old_menu_array_ptr);
dcl	menu_array_beginning   (old_menu_array_size) ptr based (fc_menu_data_$menu_array_ptr);
dcl	menu_array_end	   (MENU_ARRAY_SIZE_INCREMENT) ptr based (new_menu_array_end_ptr);

		old_menu_array_ptr = fc_menu_data_$menu_array_ptr;
						/* save so we can access after creating new one */
		old_menu_array_size = fc_menu_data_$menu_array_size;
		menu_array_idx = fc_menu_data_$menu_array_size + 1;
						/* this is where the new free slot will be */

		fc_menu_data_$menu_array_size = fc_menu_data_$menu_array_size + MENU_ARRAY_SIZE_INCREMENT;
		allocate menu_array in (THE_AREA) set (fc_menu_data_$menu_array_ptr);
		new_menu_array_end_ptr = addr (menu_array (menu_array_idx));
		menu_array_beginning (*) = old_menu_array (*);
						/* copy all the old values */
		free old_menu_array;		/* all done with this now */
		menu_array_end (*) = null ();
	     end;					/* the begin */
	end;					/* the do */

	menu_array (menu_array_idx) = menu_ptr;

     end add_to_menu_array_proc;

remove_from_menu_array:
     proc (menu_ptr);

dcl	menu_ptr		   ptr;

dcl	menu_array_idx	   fixed bin;

	do menu_array_idx = 1 to fc_menu_data_$menu_array_size while (menu_array (menu_array_idx) ^= menu_ptr);
	end;

	if menu_array_idx <= fc_menu_data_$menu_array_size then
	     if menu_array (menu_array_idx) = menu_ptr then
		menu_array (menu_array_idx) = null ();

     end remove_from_menu_array;

must_have_initialized:
     proc;

	if ^fc_menu_data_$initialized then
	     goto HAVE_NOT_INITIALIZED;

     end must_have_initialized;

HAVE_NOT_INITIALIZED:
	p_code = error_table_$out_of_sequence;
	return;

%include menu_dcls;

     end fc_menu_create;




		    fc_menu_data_.cds               09/11/84  1517.7rew 09/04/84  1523.8       31131



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* Internal data for use by the COBOL and FORTRAN wrappers to the menu system. */
/* Created 29 March 1982 by Chris Jones */
/* format: style4,delnl,insnl,indattr,ifthen,declareind10,dclind10 */
fc_menu_data_:
     procedure options (variable);

dcl	1 fc_menu_data	   aligned,		/* per process data */
	  2 initialized	   bit (1),		/* on=>the pointer and length are valid */
	  2 menu_array_size	   fixed bin,		/* number of slots in menu_array */
	  2 menu_array_ptr	   ptr,			/* pointer the the array of menus */
	  2 window_array_size  fixed bin,		/* number of slots in window_array */
	  2 window_array_ptr   ptr,			/* pointer to the array of windows */
	  2 already_video	   bit (1) aligned,		/* set if the video system was already on */
	  2 auto_window	   bit (1) aligned,		/* set if we're managing the menu window automatically */
	  2 have_user_io_info  bit (1) aligned,		/* set if user_io_window_info is valid */
	  2 original_cleanup_handler
			   ptr,			/* points to cleanup handler we've subsumed */
	  2 auto_window_iocbp  ptr,			/* pointer to the automatic menu window */
	  2 user_io_window_info
			   like window_position_info, /* where the user_i/o window started */
	  2 auto_window_info   like window_position_info; /* where the automatic menu window is */

dcl	1 cds_data	   like cds_args;		/* args to create_data_segment_ */

dcl	code		   fixed bin (35);		/* status code */

dcl	FC_MENU_DATA_	   char (16) static options (constant) init ("fc_menu_data_");
						/* the name of the data segment we're creating */

dcl	com_err_		   entry () options (variable);
dcl	create_data_segment_   entry (ptr, fixed bin (35));

dcl	(addr, currentsize, null, string, unspec)
			   builtin;

/* Initialize the data to known values. */

	fc_menu_data.initialized = "0"b;
	fc_menu_data.menu_array_size = 0;
	fc_menu_data.menu_array_ptr = null ();
	fc_menu_data.window_array_size = 0;
	fc_menu_data.window_array_ptr = null ();
	fc_menu_data.already_video = "0"b;
	fc_menu_data.auto_window = "0"b;
	fc_menu_data.have_user_io_info = "0"b;
	fc_menu_data.auto_window_iocbp = null ();
	fc_menu_data.original_cleanup_handler = null ();
	unspec (fc_menu_data.user_io_window_info) = "0"b;
	unspec (fc_menu_data.auto_window_info) = "0"b;
	fc_menu_data.user_io_window_info.version = window_position_info_version_1;
	fc_menu_data.auto_window_info.version = window_position_info_version_1;

/* Initialize the create_data_segment_ args. */

	cds_data.sections (1).p = null ();
	cds_data.sections (1).len = 0;
	cds_data.sections (1).struct_name = "";
	cds_data.sections (2).p = addr (fc_menu_data);
	cds_data.sections (2).len = currentsize (fc_menu_data);
	cds_data.sections (2).struct_name = "fc_menu_data";

	cds_data.seg_name = FC_MENU_DATA_;

	cds_data.num_exclude_names = 0;
	cds_data.exclude_array_ptr = null ();

	string (cds_data.switches) = "0"b;
	cds_data.switches.have_static = "1"b;
	cds_data.switches.separate_static = "1"b;

	call create_data_segment_ (addr (cds_data), code);
	if code ^= 0 then
	     call com_err_ (code, FC_MENU_DATA_);

	return;
%page;
%include cds_args;
%page;
%include window_control_info;

     end fc_menu_data_;




		    fc_menu_init1.alm               11/05/86  1235.1r w 11/04/86  1038.3       30267



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
" This routine is used by the FORTRAN and COBOL menu interface routines to
" attach a cleanup handler to their caller's stack (sneaky, no?).  If there
" already is a cleanup handler attached to the stack, it is subsumed and ours
" is attached anyway.  However, the subsumed one will be called by the one we
" attach.
"
" Written April 1982 by Chris Jones
"
	include	stack_header
	include	stack_frame
	include	on_unit

cleanup_name:
	aci	"cleanup"
	equ	cleanup_length,7

	entry	fc_menu_init1

fc_menu_init1:
	lda	stack_frame.condition_bit,dl
	cana	sp|stack_frame.flag_word		" see if any conditions are enabled
	tze	establish_handler			" -> none were set

" Unfortunately, at least one condition handler exists.  We loop thru them,
" looking for "cleanup".  Hopefully, we won't find one (stay tuned for details
" if we do...).

	ldx0	sp|stack_frame.on_unit_rel_ptrs	" relative to this stack frame
check_for_cleanup:
	tze	establish_handler			" -> no handlers left
	epp2	sp|on_unit.name,x0			" pointer to the on unit name
	lda	sp|on_unit.size,x0			" length of the on unit name
	cmpc	(),(pr,rl),fill(040)		" is this a cleanup handler?
	desc9a	cleanup_name,cleanup_length
	desc9a	pr2|0,al
	tze	found_cleanup_handler		" -> yes
	ldx0	sp|on_unit.next,x0			" offset to next on unit
	tra	check_for_cleanup			" keep looking
"
" Come here if there already is a cleanup handler on this frame.  Remember what
" it is so that the terminate routine can call it.
"
" x0 is the offset into the stack frame of the on unit.
"
found_cleanup_handler:
	epp2	sp|on_unit.body,x0*
	spri2	fc_menu_data_$original_cleanup_handler
"
"	fall thru...
"
" Here we call establish_cleanup_proc_ to actually establish the handler.  Note
" that establish_cleanup_proc_ attaches its handler to its CALLER's stack frame.
" Notice also that we haven't pushed a frame, so we are running on our caller's
" frame.  Thus, when we call establish_cleanup_proc_, the handler will get
" attached to our caller's frame, and when establish_cleanup_proc_ returns, it
" returns not to us, but to our caller.
"
establish_handler:
"
" The first thing we do is extend the stack by 16 words to make room for the
" argument list.  This code was cribbed from condition_.alm.
"
	lda	ap|0				" see if this is a pl1 frame
	eppap	sb|stack_header.stack_end_ptr,*	" remember where it was
	eax0	16				" the increment we are extending the stack by
	adlx0	sb|stack_header.stack_end_ptr+1	" add in offset part of stack_end
	stx0	sb|stack_header.stack_end_ptr+1	" put it back
	stx0	sp|stack_frame.next_sp+1		" reset current frame's idea of end
	cana	=o14,dl				" Z<>0 => pl1 frame
	tze	build_arg_list
	stx0	sp|5				" record growth in pl1 frame
build_arg_list:
	ora	2,du				" 1 argument
	sta	ap|0
	stz	ap|1				" no descriptors
	epp2	fc_menu_utils$terminate
	spri2	ap|4				" the argument
	epp2	ap|4
	spri2	ap|2				" the pointer to it
"
" Now (at last), call and have the handler attached.
"
	lda	=o400000,du
	sta	fc_menu_data_$initialized
	tra	establish_cleanup_proc_$establish_cleanup_proc_
"
"	there is no return...
"
	end




		    fc_menu_utils.pl1               09/11/84  1517.7rew 09/04/84  1524.3       66546



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/*
   This program invokes and revokes the FORTRAN/COBOL menu subsystem.
*/
/* Written March to April 1982 by Chris Jones */
/* format: style4,delnl,insnl,indattr,ifthen,declareind10,dclind10 */
fc_menu_utils:
     proc;

	signal condition (bad_call_);			/* not a true entrypoint */
	return;

/* Parameters */

dcl	p_code		   fixed bin (35) parameter;	/* (Output) status code */
dcl	p_user_window_columns  fixed bin (35) parameter;	/* (Output) width of user_i/o window after init */
dcl	p_user_window_id	   fixed bin (35) parameter;	/* (Output) id of user_i/o window after init */
dcl	p_user_window_lines	   fixed bin (35) parameter;	/* (Output) height of user_i/o window after init */
dcl	p_usage_mode	   fixed bin parameter;	/* (Input) whether windows are to be managed automatically */

/* Automatic variables */

dcl	1 entry_overlay	   aligned,
	  2 codeptr	   ptr,
	  2 envptr	   ptr;
dcl	entry_variable	   entry variable options (variable);

/* Based variables */

dcl	THE_AREA		   area based (get_system_free_area_ ());
dcl	menu_array	   (fc_menu_data_$menu_array_size) ptr based (fc_menu_data_$menu_array_ptr);
						/* array of menus we are managing */
dcl	window_array	   (fc_menu_data_$window_array_size) ptr based (fc_menu_data_$window_array_ptr);
						/* array of windows we've created */


/* Static storage and constants */

dcl	DEFAULT_MENU_ARRAY_SIZE
			   fixed bin init (5) static options (constant);
dcl	DEFAULT_WINDOW_ARRAY_SIZE
			   fixed bin init (3) static options (constant);

/* External entries and variables */

dcl	error_table_$bad_arg   fixed bin (35) ext static;
dcl	error_table_$out_of_sequence
			   fixed bin (35) ext static;

dcl	fc_menu_data_$already_video
			   bit (1) aligned external static;
dcl	fc_menu_data_$auto_window
			   bit (1) aligned external static;
dcl	fc_menu_data_$have_user_io_info
			   bit (1) aligned external static;
dcl	fc_menu_data_$initialized
			   bit (1) aligned external static;
dcl	fc_menu_data_$menu_array_ptr
			   ptr external static;
dcl	fc_menu_data_$menu_array_size
			   fixed bin external static;
dcl	fc_menu_data_$original_cleanup_handler
			   ptr external static;
dcl	1 fc_menu_data_$user_io_window_info
			   aligned like window_position_info external static;
dcl	fc_menu_data_$window_array_ptr
			   ptr external static;
dcl	fc_menu_data_$window_array_size
			   fixed bin external static;

dcl	iox_$user_io	   ptr ext static;

dcl	video_data_$terminal_iocb
			   ptr external static;

dcl	get_system_free_area_  entry () returns (ptr);
dcl	iox_$control	   entry (ptr, char (*), ptr, fixed bin (35));
dcl	iox_$destroy_iocb	   entry (ptr, fixed bin (35));
dcl	video_utils_$turn_off_login_channel
			   entry (fixed bin (35));
dcl	video_utils_$turn_on_login_channel
			   entry (fixed bin (35), char (*));

/* Conditions and builtins */

dcl	(bad_call_)	   condition;

dcl	(addr, null, unspec)   builtin;

/* Routine to do the real initialization (the cleanup handler has been attached by init1 */

init2:
     entry (p_usage_mode, p_user_window_lines, p_user_window_columns, p_user_window_id, p_code);

	if ^fc_menu_data_$initialized then do;
	     p_code = error_table_$out_of_sequence;
	     return;
	end;
	if (p_usage_mode ^= 0) & (p_usage_mode ^= 1) then do;
	     p_code = error_table_$bad_arg;
	     return;
	end;
	fc_menu_data_$auto_window = (p_usage_mode = 0);

/* Allocate the array, set the pointer and length */

	fc_menu_data_$menu_array_size = DEFAULT_MENU_ARRAY_SIZE;
	allocate menu_array in (THE_AREA) set (fc_menu_data_$menu_array_ptr);
	menu_array (*) = null ();
	fc_menu_data_$window_array_size = DEFAULT_WINDOW_ARRAY_SIZE;
	allocate window_array in (THE_AREA) set (fc_menu_data_$window_array_ptr);
	window_array (*) = null ();

/* Now set up the video system.  If the video system is already invoked, leave it as is, and only manage the
   area of the display currently covered by user_i/o.  Otherwise, invoke the video system and use the whole display. */

	fc_menu_data_$already_video = (video_data_$terminal_iocb ^= null ());
	if ^fc_menu_data_$already_video then do;
	     call video_utils_$turn_on_login_channel (p_code, "");
	     if p_code ^= 0 then do;
		call terminate_proc;
		return;
	     end;
	end;
	call iox_$control (iox_$user_io, "get_window_info", addr (fc_menu_data_$user_io_window_info), p_code);
	if p_code ^= 0 then do;
	     call terminate_proc;
	     return;
	end;
	fc_menu_data_$have_user_io_info = "1"b;

	p_user_window_lines = fc_menu_data_$user_io_window_info.height;
	p_user_window_columns = fc_menu_data_$user_io_window_info.width;
	p_user_window_id = pack_ptr (iox_$user_io);
	return;

/* entry which cleans up */

terminate:
     entry;

	call terminate_proc;
	return;

/* routine to do the termination and cleanup stuff */
/* This routine must be very careful as it can be called at any time (including in the middle of the init call). */

terminate_proc:
     proc;

dcl	menu_array_idx	   fixed bin;
dcl	window_array_idx	   fixed bin;

	if ^fc_menu_data_$initialized then
	     return;				/* nothing to do, nowhere to report an error */

/* Free the menu_array variables */

	if fc_menu_data_$menu_array_ptr ^= null () then do;
	     do menu_array_idx = 1 to fc_menu_data_$menu_array_size;
		if menu_array (menu_array_idx) ^= null () then do;
		     call menu_$destroy (menu_array (menu_array_idx), (0));
		end;
	     end;
	     free menu_array;
	     fc_menu_data_$menu_array_ptr = null ();
	     fc_menu_data_$menu_array_size = 0;
	end;

/* Restore the terminal attachments */

	if fc_menu_data_$already_video then do;
	     if fc_menu_data_$have_user_io_info then do;

/* Destroy any windows we've created */

		if fc_menu_data_$window_array_ptr ^= null () then do;
		     do window_array_idx = 1 to fc_menu_data_$window_array_size;
			if window_array (window_array_idx) ^= null () then do;
			     call window_$destroy (window_array (window_array_idx), (0));
			     call iox_$destroy_iocb (window_array (window_array_idx), (0));
			     window_array (window_array_idx) = null ();
			end;
		     end;
		     free window_array;
		     fc_menu_data_$window_array_ptr = null ();
		     fc_menu_data_$window_array_size = 0;
		end;

		call iox_$control (iox_$user_io, "set_window_info", addr (fc_menu_data_$user_io_window_info), (0));
		fc_menu_data_$have_user_io_info = "0"b;
	     end;
	end;
	else call video_utils_$turn_off_login_channel ((0));

	if fc_menu_data_$original_cleanup_handler ^= null () then do;
	     entry_overlay.codeptr = fc_menu_data_$original_cleanup_handler;
	     entry_overlay.envptr = null ();
	     unspec (entry_variable) = unspec (entry_overlay);
	     call entry_variable;
	     fc_menu_data_$original_cleanup_handler = null ();
	end;

	fc_menu_data_$initialized = "0"b;

     end terminate_proc;

pack_ptr:
     proc (p) returns (fixed bin (35));

dcl	p		   ptr;

dcl	pp		   ptr unal;
dcl	ptr_as_integer	   fixed bin (35) based;

	pp = p;
	return (addr (pp) -> ptr_as_integer);

     end pack_ptr;

%include window_control_info;
%page;
%include window_dcls;
%page;
%include menu_dcls;

     end fc_menu_utils;




		    fc_menu_value_seg_man.pl1       06/09/82  1345.4rew 06/09/82  1345.1       40707



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/*
   FORTRAN/COBOL menu interface value segment manipulation routines
*/
/* Written April 1982 by Chris Jones */
/* format: style4,delnl,insnl,indattr,ifthen,declareind10,dclind10 */
fc_menu_value_seg_man:
     proc;

	signal condition (bad_call_);			/* not a true entrypoint */
	return;

/* Parameters */

dcl	p_code		   fixed bin (35) parameter;	/* (Output) status code */
dcl	p_count		   fixed bin (35) parameter;	/* (Output) number of names matching p_match_string */
dcl	p_create_seg	   fixed bin parameter;	/* (Input) whether or not to create the value seg */
dcl	p_dir_name	   char (*) parameter;	/* (Input) directory in which the value segment lives */
dcl	p_entry_name	   char (*) parameter;	/* (Input) entry name of the value segment */
dcl	p_match_string	   char (*) parameter;	/* (Input) star name used to match menu names */
dcl	p_menu_id		   fixed bin (35) parameter;	/* (Output) how a menu is identified */
dcl	p_menu_name	   char (*) parameter;	/* (Input) name of the menu being stored or retrieved */
dcl	p_names		   (*) char (*) parameter;	/* (Output) names which match p_match_string */

/* Automatic storage */

dcl	menu_id_ptr	   ptr;			/* used to redefine p_menu_id */
dcl	menu_ptr		   ptr;			/* used in calls to the menu_ subroutines */

/* Based variables */

dcl	packed_menu_ptr	   ptr unal based (menu_id_ptr);
						/* overlays the fixed bin (35) which is the menu_id */

/* External entries and variables */

dcl	error_table_$bad_arg   fixed bin (35) ext static;
dcl	error_table_$out_of_sequence
			   fixed bin (35) ext static;
dcl	error_table_$smallarg  fixed bin (35) ext static;

dcl	fc_menu_data_$initialized
			   bit (1) aligned external static;

dcl	fc_menu_create$add_to_menu_array
			   entry (ptr);

/* Conditions and builtins */

dcl	(bad_call_)	   condition;

dcl	(addr, dim, lbound, min, null, substr)
			   builtin;

/* Entry to store a menu object in a value segment. */

store:
     entry (p_dir_name, p_entry_name, p_menu_name, p_create_seg, p_menu_id, p_code);

	call must_have_initialized;
	if (p_create_seg ^= 0) & (p_create_seg ^= 1) then do;
	     p_code = error_table_$bad_arg;
	     return;
	end;
	menu_id_ptr = addr (p_menu_id);
	menu_ptr = packed_menu_ptr;			/* unpack the pointer */
	call menu_$store (p_dir_name, p_entry_name, p_menu_name, (p_create_seg = 1), menu_ptr, p_code);
	return;

/* Entry to retrieve a menu from a value segment. */

retrieve:
     entry (p_dir_name, p_entry_name, p_menu_name, p_menu_id, p_code);

	call must_have_initialized;
	menu_id_ptr = addr (p_menu_id);
	call menu_$retrieve (p_dir_name, p_entry_name, p_menu_name, null (), menu_ptr, p_code);
	if p_code = 0 then do;
	     call fc_menu_create$add_to_menu_array (menu_ptr);
	     packed_menu_ptr = menu_ptr;
	end;
	return;

/* Entry to delete a stored menu object from a value segment.  This is simply a pass-through to the menu_ subr. */

delete:
     entry (p_dir_name, p_entry_name, p_menu_name, p_code);

	call must_have_initialized;
	call menu_$delete (p_dir_name, p_entry_name, p_menu_name, p_code);
	return;

/* Entry to return a list of menu names stored in a value segment. */

list:
     entry (p_dir_name, p_entry_name, p_match_string, p_count, p_names, p_code);

dcl	names_idx		   fixed bin;

	call must_have_initialized;
	call menu_$list (p_dir_name, p_entry_name, p_match_string, null (), menu_list_info_version_1,
	     menu_list_info_ptr, p_code);

/* Copy the names into the provided array */

	if p_code = 0 then do;
	     p_count = menu_list_info.n_names;
	     do names_idx = 1 to min (menu_list_info.n_names, dim (p_names, 1));
		p_names (lbound (p_names, 1) + names_idx - 1) =
		     substr (menu_list_info.name_string, menu_list_info.position (names_idx),
		     menu_list_info.length (names_idx));
	     end;
	     if menu_list_info.n_names > dim (p_names, 1) then
		p_code = error_table_$smallarg;
	     free menu_list_info;
	end;
	return;

must_have_initialized:
     proc;

	if ^fc_menu_data_$initialized then
	     goto HAVE_NOT_INITIALIZED;

     end must_have_initialized;

HAVE_NOT_INITIALIZED:
	p_code = error_table_$out_of_sequence;
	return;

%include menu_dcls;
%page;
%include menu_list_info;

     end fc_menu_value_seg_man;




		    fc_menu_video.pl1               09/11/84  1517.7r   09/11/84  1459.7      124290



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/*
   This program is the FORTRAN/COBOL menu displayer, getter of choices, etc.
*/
/*
   Written April 1982 by Chris Jones

   84-03-12 Davids: Added code to set the mbz field to 0 and the width field
   to the value of fc_menu_data$user_io_window_info.width in the 
   auto_user_io_info structure. This structure is used to resize the user_io
   window after the menu window is created. The width of the window was
   some small random number. I expect that the problem was not noticed
   before because it is only recently that partial width windows were
   implemented in the video system.

   Added code to ckeck fkey_ptr after call to ttt_info_$function_key_data.
   If pointer is null then the aalternate function key sequences are used.
   Removed the code that checks for a non-zero error code being returned
   there is no reason to return with an error code if we can continue with the
   alternate set. Also added code to check the number of the highest function
   key on the terminal with the number of the highest function key needed. If
   the terminal cannot cover the needed key the alternate set of function keys
   are used. The original code allowed for a subscript out-of-bounds if the
   application needed more function keys then the terminal had.

   84-09-11 Rochlis: changed auto_user_io_info.mbz to be auto_user_io_info.column
   so this module will compile with the MR11 Video System.
*/
   
/* format: style4,delnl,insnl,indattr,ifthen,declareind10,dclind10 */
fc_menu_video:
     proc;

	signal condition (bad_call_);			/* not a true entrypoint */
	return;

/* Parameters */

dcl	p_code		   fixed bin (35) parameter;	/* (Output) status code */
dcl	p_fkey		   fixed bin (35) parameter;	/* (Output) non zero if a function key was hit */
dcl	p_function_key_info	   char (*) parameter;	/* (Input) substitutes for function keys */
dcl	p_menu_id		   fixed bin (35) parameter;	/* (Output) how a menu is identified */
dcl	p_menu_needs_array	   (3) fixed bin parameter;	/* (Output) describes size of created menu */
dcl	1 p_menu_needs_struc   parameter aligned,	/* (Output) ditto, for COBOL programs */
	  2 lines_needed	   fixed bin,
	  2 width_needed	   fixed bin,
	  2 n_options	   fixed bin;
dcl	p_selection	   fixed bin parameter;	/* (Output) number of the choice */
dcl	p_window_id	   fixed bin (35) parameter;	/* (Input) the windowiocb ptr packed */

/* Automatic storage */

dcl	1 auto_menu_requirements
			   like menu_requirements;
dcl	1 auto_user_io_info	   like window_position_info;
dcl	fkey		   bit (1) aligned;		/* set if a function key was hit */
dcl	fkey_ptr		   ptr;			/* points to the function key info */
dcl	fkey_sequence_length   fixed bin;		/* length of ersatz function key string */
dcl	fkey_sequence_ptr	   ptr;			/* pointer to same */
dcl	fortran_entry	   bit (1) aligned;		/* distinguishes which kind of program called us */
dcl	fx		   fixed bin;		/* index for function key info */
dcl	menu_ptr		   ptr;			/* used in calls to the menu_ subroutines */
dcl	window_ptr	   ptr;			/* used in calls to the window_ and menu_ subroutines */

/* Based variables */

dcl	fkey_sequence	   char (fkey_sequence_length) based (fkey_sequence_ptr);
dcl	window_array	   (fc_menu_data_$window_array_size) ptr based (fc_menu_data_$window_array_ptr);
						/* array of windows we've created */

/* Static storage and constants */

dcl	AUTO_WINDOW_IDX	   fixed bin init (1) static options (constant);

dcl	LINES_NEEDED	   fixed bin init (1) static options (constant);
dcl	WIDTH_NEEDED	   fixed bin init (2) static options (constant);
dcl	N_OPTIONS		   fixed bin init (3) static options (constant);

/* External entries and variables */

dcl	error_table_$no_table  fixed bin (35) ext static;
dcl	error_table_$out_of_sequence
			   fixed bin (35) ext static;

dcl	fc_menu_data_$auto_window
			   bit (1) aligned external static;
dcl	1 fc_menu_data_$auto_window_info
			   aligned like window_position_info external static;
dcl	fc_menu_data_$auto_window_iocbp
			   ptr external static;
dcl	fc_menu_data_$initialized
			   bit (1) aligned external static;
dcl	1 fc_menu_data_$user_io_window_info
			   aligned like window_position_info external static;
dcl	fc_menu_data_$window_array_ptr
			   ptr external static;
dcl	fc_menu_data_$window_array_size
			   fixed bin external static;

dcl	iox_$user_io	   ptr ext static;

dcl	video_data_$terminal_iocb
			   ptr external static;

dcl	fc_menu_window$add_to_window_array
			   entry (ptr);
dcl	iox_$control	   entry (ptr, char (*), ptr, fixed bin (35));
dcl	iox_$find_iocb	   entry (char (*), ptr, fixed bin (35));
dcl	ttt_info_$function_key_data
			   entry (char (*), ptr, ptr, fixed bin (35));
dcl	unique_chars_	   entry (bit (*)) returns (char (15));
dcl	window_$clear_window   entry (ptr, fixed bin (35));
dcl	window_$create	   entry (ptr, ptr, ptr, fixed bin (35));

/* Conditions and builtins */

dcl	(bad_call_, cleanup)   condition;

dcl	(addr, byte, length, null, rtrim, substr)
			   builtin;

/* Entry which returns information about a menu */

fortran_describe:
     entry (p_menu_id, p_menu_needs_array, p_code);

	fortran_entry = "1"b;
	goto describe_common;

cobol_describe:
     entry (p_menu_id, p_menu_needs_struc, p_code);

	fortran_entry = "0"b;

describe_common:
	call must_have_initialized;
	menu_ptr = unpack_ptr (p_menu_id);
	auto_menu_requirements.version = menu_requirements_version_1;
	call menu_$describe (menu_ptr, addr (auto_menu_requirements), p_code);
	if fortran_entry then do;
	     p_menu_needs_array (LINES_NEEDED) = auto_menu_requirements.lines_needed;
	     p_menu_needs_array (WIDTH_NEEDED) = auto_menu_requirements.width_needed;
	     p_menu_needs_array (N_OPTIONS) = auto_menu_requirements.n_options;
	end;
	else do;
	     p_menu_needs_struc.lines_needed = auto_menu_requirements.lines_needed;
	     p_menu_needs_struc.width_needed = auto_menu_requirements.width_needed;
	     p_menu_needs_struc.n_options = auto_menu_requirements.n_options;
	end;
	return;

/* Entry to display a given menu.  If the user has specified she wants to have us manage the menu window,
   make sure it's big enough (creating it if necessary). */

display:
     entry (p_window_id, p_menu_id, p_code);

	call must_have_initialized;
	menu_ptr = unpack_ptr (p_menu_id);
	if fc_menu_data_$auto_window then do;		/* we manage the menu window */
	     auto_menu_requirements.version = menu_requirements_version_1;
	     call menu_$describe (menu_ptr, addr (auto_menu_requirements), p_code);
						/* find out how big a window we need */
	     if p_code ^= 0 then
		return;

/* If we don't have the menu window created yet, create it. */

	     if window_array (AUTO_WINDOW_IDX) = null () then do;
		call iox_$find_iocb ("fc_menu_." || unique_chars_ (""b), fc_menu_data_$auto_window_iocbp, p_code);
		if p_code ^= 0 then
		     return;
		fc_menu_data_$auto_window_info.line = fc_menu_data_$user_io_window_info.line;
						/* start at the top of the user_i/o window */
		fc_menu_data_$auto_window_info.height = 0;
		call window_$create (video_data_$terminal_iocb, addr (fc_menu_data_$auto_window_info),
		     fc_menu_data_$auto_window_iocbp, p_code);
		if p_code ^= 0 then
		     return;
		call fc_menu_window$add_to_window_array (fc_menu_data_$auto_window_iocbp);
	     end;

/* Ensure the auto window is big enough. */
	     if auto_menu_requirements.lines_needed > fc_menu_data_$auto_window_info.height then do;
		fc_menu_data_$auto_window_info.height = auto_menu_requirements.lines_needed;
		call iox_$control (fc_menu_data_$auto_window_iocbp, "set_window_info",
		     addr (fc_menu_data_$auto_window_info), p_code);
		if p_code ^= 0 then
		     return;

/* Shrink the user_i/o window now. */

		auto_user_io_info.version = window_position_info_version_1;
                    auto_user_io_info.column = 0;
		auto_user_io_info.line =
		     fc_menu_data_$user_io_window_info.line + fc_menu_data_$auto_window_info.height;
                    auto_user_io_info.width = fc_menu_data_$user_io_window_info.width;
		auto_user_io_info.height =
		     fc_menu_data_$user_io_window_info.height - fc_menu_data_$auto_window_info.height;
		call iox_$control (iox_$user_io, "set_window_info", addr (auto_user_io_info), p_code);
		if p_code ^= 0 then
		     return;
		call window_$clear_window (iox_$user_io, p_code);
		if p_code ^= 0 then
		     return;
	     end;
	     window_ptr = fc_menu_data_$auto_window_iocbp;
	end;
	else window_ptr = unpack_ptr (p_window_id);

/* Now, display the menu */

	call menu_$display (window_ptr, menu_ptr, p_code);
	return;

/* Entry to get a choice from a displayed menu. */


get_choice:
     entry (p_window_id, p_menu_id, p_function_key_info, p_fkey, p_selection, p_code);

	call must_have_initialized;

/* See if we have to fake function keys. */

	if p_function_key_info = "" then
	     fkey_ptr = null ();			/* no function keys needed */
	else do;					/* we've got to check */
	     fkey_ptr = null ();
	     fkey_sequence_ptr = null ();

	     on cleanup call cleanup_get_choice;

	     call ttt_info_$function_key_data (get_term_type_name (), null (), fkey_ptr, p_code);

	     if fkey_ptr = null () /* if function key data could not be */
               then do;              /* gotten - don't report error just make it */
		fkey_ptr = make_function_key_info (p_function_key_info);
		goto GOT_FUNCTION_KEY_INFO;
		end;

	     if fkey_ptr -> function_key_data.highest < length (rtrim (p_function_key_info)) - 1
	     then do; /* At least 1 Fkey has an index larger than the terminals's Fkeys */
		fkey_ptr = make_function_key_info (p_function_key_info);
		goto GOT_FUNCTION_KEY_INFO;
		end;

/* Loop through the function keys looking for any missing ones */

	     do fx = 0 to length (rtrim (p_function_key_info)) - 1;
		if (substr (p_function_key_info, fx + 1) ^= " ")
		     & (fkey_ptr -> function_key_data.function_keys.sequence_length (fx, KEY_PLAIN) = 0) then do;
						/* we're missing one we need */
		     free fkey_ptr -> function_key_data;
		     fkey_ptr = null ();
		     fkey_ptr = make_function_key_info (p_function_key_info);
		     goto GOT_FUNCTION_KEY_INFO;
		end;
	     end;
	end;
GOT_FUNCTION_KEY_INFO:
	menu_ptr = unpack_ptr (p_menu_id);
	if fc_menu_data_$auto_window then
	     window_ptr = fc_menu_data_$auto_window_iocbp;
	else window_ptr = unpack_ptr (p_window_id);
	call iox_$control (iox_$user_io, "reset_more", null (), (0));
	call menu_$get_choice (window_ptr, menu_ptr, fkey_ptr, fkey, p_selection, p_code);
	if fkey then
	     p_fkey = 1;
	else p_fkey = 0;

ERROR_RETURN:
	call cleanup_get_choice;
	return;

cleanup_get_choice:
     proc;

	if fkey_ptr ^= null () then do;
	     free fkey_ptr -> function_key_data;
	     fkey_ptr = null ();
	end;
	if fkey_sequence_ptr ^= null () then do;
	     free fkey_sequence;
	     fkey_sequence_ptr = null ();
	end;

     end cleanup_get_choice;

unpack_ptr:
     proc (ptr_as_integer) returns (ptr);

dcl	ptr_as_integer	   fixed bin (35);

dcl	packed_ptr	   ptr unal based (addr (ptr_as_integer));

	return (packed_ptr);

     end unpack_ptr;

get_term_type_name:
     procedure () returns (char (32));
declare	1 ti		   aligned like terminal_info;

	ti.version = terminal_info_version;
	call iox_$control (iox_$user_io, "terminal_info", addr (ti), p_code);
	if p_code ^= 0 then
	     goto ERROR_RETURN;
	return (ti.term_type);

     end get_term_type_name;

make_function_key_info:
     procedure (string) returns (pointer);
declare	string		   char (*);
declare	i		   fixed bin;

	function_key_data_highest = length (rtrim (string)) - 1;
	allocate function_key_data set (fkey_ptr);
	fkey_sequence_length = 2 * length (rtrim (string));
	allocate fkey_sequence set (fkey_sequence_ptr);
	fkey_ptr -> function_key_data.version = function_key_data_version_1;
	fkey_ptr -> function_key_data.highest = function_key_data_highest;
	fkey_ptr -> function_key_data.sequence.seq_ptr = addr (fkey_sequence);
	fkey_ptr -> function_key_data.sequence.seq_len = length (fkey_sequence);
	fkey_ptr -> function_key_data.home.sequence_index (*) = 0;
	fkey_ptr -> function_key_data.home.sequence_length (*) = 0;
	fkey_ptr -> function_key_data.left.sequence_index (*) = 0;
	fkey_ptr -> function_key_data.left.sequence_length (*) = 0;
	fkey_ptr -> function_key_data.up.sequence_index (*) = 0;
	fkey_ptr -> function_key_data.up.sequence_length (*) = 0;
	fkey_ptr -> function_key_data.right.sequence_index (*) = 0;
	fkey_ptr -> function_key_data.right.sequence_length (*) = 0;
	fkey_ptr -> function_key_data.down.sequence_index (*) = 0;
	fkey_ptr -> function_key_data.down.sequence_length (*) = 0;
	fkey_ptr -> function_key_data.function_keys.sequence_index (*, *) = 0;
	fkey_ptr -> function_key_data.function_keys.sequence_length (*, *) = 0;
	do i = 0 to length (rtrim (string)) - 1;
	     if substr (string, i + 1, 1) ^= " " then do;
		substr (fkey_sequence, i * 2 + 1, 2) = byte (27) || substr (string, i + 1, 1);
		fkey_ptr -> function_key_data.function_keys.sequence_index (i, KEY_PLAIN) = i * 2 + 1;
		fkey_ptr -> function_key_data.function_keys.sequence_length (i, KEY_PLAIN) = 2;
	     end;
	end;

	return (fkey_ptr);

     end make_function_key_info;

must_have_initialized:
     proc;

	if ^fc_menu_data_$initialized then
	     goto HAVE_NOT_INITIALIZED;

     end must_have_initialized;

HAVE_NOT_INITIALIZED:
	p_code = error_table_$out_of_sequence;
	return;

%include menu_dcls;
%page;
%include window_control_info;
%page;
%include function_key_data;
%page;
%include terminal_info;

     end fc_menu_video;




		    fc_menu_window.pl1              09/11/84  1517.7rew 09/11/84  1448.7       76122



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/*
   This is the FORTRAN/COBOL interface to the window system.  It is a very primitive interface, consisting
   only of those entries absolutely necessary for the operation of the menu subroutines.  These are
   create, destroy, and change.
*/
/* Written April 1982 by Chris Jones */
/* Modified 20 August 1984 by Jon A. Rochlis for MR11 video. Changes the
   reference window_position_info.mbz to window_position_info.column */

/* format: style4,delnl,insnl,indattr,ifthen,declareind10,dclind10 */
fc_menu_window:
     proc;

	signal bad_call_;				/* not a true entrypoint */
	return;

/* Parameters */

dcl	p_code		   fixed bin (35) parameter;	/* (Output) standard status code */
dcl	p_first_line	   fixed bin (35) parameter;	/* (Input) where the window is to start */
dcl	p_height		   fixed bin (35) parameter;	/* (Input) how high the window is to be */
dcl	p_switch_name	   char (*) parameter;	/* (Input) name of the switch the window is attached to */
dcl	p_window_id	   fixed bin (35) parameter;	/* (Input/Output) how a window is identified */
dcl	p_window_ptr	   ptr parameter;		/* (Input) used to add a window to the array */

/* Automatic variables */

dcl	1 auto_window_info	   like window_position_info;
dcl	window_iocb_ptr	   ptr;

/* Based variables */

dcl	THE_AREA		   area based (get_system_free_area_ ());
dcl	window_array	   (fc_menu_data_$window_array_size) ptr based (fc_menu_data_$window_array_ptr);

/* Constants */

dcl	WINDOW_ARRAY_SIZE_INCREMENT
			   fixed bin static init (3) options (constant);
						/* External variables and entries */

dcl	get_system_free_area_  entry () returns (ptr);
dcl	iox_$control	   entry (ptr, char (*), ptr, fixed bin (35));
dcl	iox_$find_iocb	   entry (char (*), ptr, fixed bin (35));
dcl	window_$clear_window   entry (ptr, fixed bin (35));
dcl	window_$create	   entry (ptr, ptr, ptr, fixed bin (35));
dcl	window_$destroy	   entry (ptr, fixed bin (35));

dcl	error_table_$no_operation
			   fixed bin (35) ext static;
dcl	error_table_$out_of_sequence
			   fixed bin (35) ext static;
dcl	video_et_$overlaps_screen_edge
			   fixed bin (35) ext static;

dcl	fc_menu_data_$auto_window
			   bit (1) aligned ext static;
dcl	fc_menu_data_$initialized
			   bit (1) aligned ext static;
dcl	1 fc_menu_data_$user_io_window_info
			   like window_position_info ext static aligned;
dcl	fc_menu_data_$window_array_ptr
			   ptr ext static;
dcl	fc_menu_data_$window_array_size
			   fixed bin ext static;
dcl	video_data_$terminal_iocb
			   ptr ext static;

/* Builtins and conditions */

dcl	(addr, null)	   builtin;

dcl	(bad_call_)	   condition;

create:
     entry (p_first_line, p_height, p_switch_name, p_window_id, p_code);

	call must_have_initialized;
	call validate_origin_and_height;
	call iox_$find_iocb (p_switch_name, window_iocb_ptr, p_code);
	if p_code ^= 0 then
	     return;
	auto_window_info.version = window_position_info_version_1;
	auto_window_info.column = 0;
	auto_window_info.line = fc_menu_data_$user_io_window_info.line + p_first_line - 1;
	auto_window_info.width = 0;			/* not used currently */
	auto_window_info.height = p_height;
	call window_$create (video_data_$terminal_iocb, addr (auto_window_info), window_iocb_ptr, p_code);
	if p_code ^= 0 then
	     return;
	call add_to_window_array_proc (window_iocb_ptr);
	p_window_id = pack_ptr (window_iocb_ptr);	/* pack the pointer into an integer */
	return;

/* Entry to destroy a previously created window. */

destroy:
     entry (p_window_id, p_code);

	call must_have_initialized;
	window_iocb_ptr = unpack_ptr (p_window_id);
	call remove_from_window_array (window_iocb_ptr);
	call window_$destroy (window_iocb_ptr, p_code);
	if p_code = 0 then
	     p_window_id = 0;
	return;

/* Entry to change the size and/or position of a window. */
change:
     entry (p_window_id, p_first_line, p_height, p_code);

	call must_have_initialized;
	call validate_origin_and_height;
	window_iocb_ptr = unpack_ptr (p_window_id);
	auto_window_info.version = window_position_info_version_1;
	auto_window_info.column = 0;
	auto_window_info.line = fc_menu_data_$user_io_window_info.line + p_first_line - 1;
	auto_window_info.width = 0;			/* not used currently */
	auto_window_info.height = p_height;
	call iox_$control (window_iocb_ptr, "set_window_info", addr (auto_window_info), p_code);
	return;

clear_window:
     entry (p_window_id, p_code);

	window_iocb_ptr = unpack_ptr (p_window_id);
	call window_$clear_window (window_iocb_ptr, p_code);
	return;

add_to_window_array:
     entry (p_window_ptr);

	call add_to_window_array_proc (p_window_ptr);
	return;

/* Routine to add a newly created window to the array of windows we will destroy on termination of this package.
   This routine handles the case of growing the window_array if necessary. */

add_to_window_array_proc:
     proc (window_ptr);

dcl	window_ptr	   ptr;			/* the id to add to the array */

dcl	window_array_idx	   fixed bin;		/* index into window_array */

	do window_array_idx = 1 to fc_menu_data_$window_array_size while (window_array (window_array_idx) ^= null ());
	end;
	if window_array_idx > fc_menu_data_$window_array_size then do;
						/* must grow window_array */

	     begin;				/* so we can define some tricky arrays */

dcl	new_window_array_end_ptr
			   ptr;
dcl	old_window_array_ptr   ptr;
dcl	old_window_array_size  fixed bin;

dcl	old_window_array	   (old_window_array_size) ptr based (old_window_array_ptr);
dcl	window_array_beginning (old_window_array_size) ptr based (fc_menu_data_$window_array_ptr);
dcl	window_array_end	   (WINDOW_ARRAY_SIZE_INCREMENT) ptr based (new_window_array_end_ptr);

		old_window_array_ptr = fc_menu_data_$window_array_ptr;
						/* save so we can access after creating new one */
		old_window_array_size = fc_menu_data_$window_array_size;
		window_array_idx = fc_menu_data_$window_array_size + 1;
						/* this is where the new free slot will be */

		fc_menu_data_$window_array_size = fc_menu_data_$window_array_size + WINDOW_ARRAY_SIZE_INCREMENT;
		allocate window_array in (THE_AREA) set (fc_menu_data_$window_array_ptr);
		new_window_array_end_ptr = addr (window_array (window_array_idx));
		window_array_beginning (*) = old_window_array (*);
						/* copy all the old values */
		free old_window_array;		/* all done with this now */
		window_array_end (*) = null ();
	     end;					/* the begin */
	end;					/* the do */

	window_array (window_array_idx) = window_ptr;

     end add_to_window_array_proc;

remove_from_window_array:
     proc (window_ptr);

dcl	window_ptr	   ptr;

dcl	window_array_idx	   fixed bin;

	do window_array_idx = 1 to fc_menu_data_$window_array_size
	     while (window_array (window_array_idx) ^= window_ptr);
	end;

	if window_array_idx <= fc_menu_data_$window_array_size then
	     if window_array (window_array_idx) = window_ptr then
		window_array (window_array_idx) = null ();

     end remove_from_window_array;

pack_ptr:
     proc (p) returns (fixed bin (35));

dcl	p		   ptr;

dcl	pp		   ptr unal based;
dcl	ptr_as_integer	   fixed bin (35);

	addr (ptr_as_integer) -> pp = p;
	return (ptr_as_integer);

     end pack_ptr;

unpack_ptr:
     proc (pp) returns (ptr);

dcl	pp		   fixed bin (35);

dcl	packed_ptr	   ptr unal based (addr (pp));

	return (packed_ptr);

     end unpack_ptr;

/* Routine to make sure we've initialized, and to make sure we aren't being called if automatic windows were specified */
must_have_initialized:
     proc;

	if ^fc_menu_data_$initialized then
	     goto HAVE_NOT_INITIALIZED;
	if fc_menu_data_$auto_window then
	     goto ILLEGAL_WINDOW_OPERATION;

     end must_have_initialized;

HAVE_NOT_INITIALIZED:
	p_code = error_table_$out_of_sequence;
	return;

ILLEGAL_WINDOW_OPERATION:
	p_code = error_table_$no_operation;
	return;

validate_origin_and_height:
     proc;

	if (p_first_line < 1)
	     | (p_first_line + p_height
	     > fc_menu_data_$user_io_window_info.line + fc_menu_data_$user_io_window_info.height) then
	     goto ILLEGAL_WINDOW_SIZE;
     end validate_origin_and_height;

ILLEGAL_WINDOW_SIZE:
	p_code = video_et_$overlaps_screen_edge;
	return;

%include window_control_info;

     end fc_menu_window;




		    ft_menu_.alm                    06/09/82  1345.4rew 06/09/82  1345.1       10332



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
" Transfer vector for the FORTRAN menu interfaces (which are themselves little
" more than transfers).
"
" Written April 1982 by Chris Jones

	name	ft_menu_

	macro	transfer
	segdef	&1
&1:	getlp
	tra	&2
	&end

	transfer	create,fc_menu_create$fortran_create
	transfer	delete,fc_menu_value_seg_man$delete
	transfer	describe,fc_menu_video$fortran_describe
	transfer	destroy,fc_menu_create$destroy
	transfer	display,fc_menu_video$display
	transfer	get_choice,fc_menu_video$get_choice
	transfer	init2,fc_menu_utils$init2		" init1 is an alm program in another module
	transfer	list,fc_menu_value_seg_man$list
	transfer	retrieve,fc_menu_value_seg_man$retrieve
	transfer	store,fc_menu_value_seg_man$store
	transfer	terminate,fc_menu_utils$terminate

" init1 is handled specially

	segdef	init1
init1:	getlp
	tra	fc_menu_init1$fc_menu_init1

	end




		    ft_window_.alm                  06/09/82  1345.4rew 06/09/82  1345.1        6300



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
" Transfer vector for the FORTRAN window interfaces (which are themselves little
" more than transfers).
"
" Written April 1982 by Chris Jones

	name	ft_window_

	macro	transfer
	segdef	&1
&1:	getlp
	tra	&2
	&end

	transfer	change,fc_menu_window$change
	transfer	clear_window,fc_menu_window$clear_window
	transfer	create,fc_menu_window$create
	transfer	destroy,fc_menu_window$destroy

	end




		    menu_.pl1                       04/09/85  1714.1r w 04/08/85  1129.0      215541



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

menu_:
     procedure;
	return;

/* Subroutines for Menu Presentation.  MTB - 493

   James R. Davis January - February 1981

   entries here:

   create
   display
   get_choice
   describe
   destroy
   list
   store
   retrieve

*/

/*
   Maintained by Suzanne L. Krupp

   Modified 06/05/81 by Suzanne Krupp to include store_menu and retrieve_menu
   entry points.

   Modified 06/29/81 to make store_menu and retrieve_menu entry points use
   value segments (so that we can now store more than one menu
   per segment.

   Modified 06/29/81 to fix bug in menu_$get_choice where it can't handle a
   function_key_data_ptr.

   Modified by BIM July 1981 for to remove the _menu from the names,
   fix up the value stuff, and add the delete and list entrypoints.

   Auditing changes BIM October 1981.

   Modified January 1981 by Chris Jones to make menus case-insensitive when possible.

   84-03-15 Davids: Modified call to hcs_$initiate in the LIST procedure
   to use the valiables dname and ename which are input to the LIST proc
   instead of using P_dname and P_ename which are input to the list entry
   which calls the LIST proc. A procedure should use its own parameters.
   This answers TR15713.

   84-09-18 Davids: Added calls to window_$sync after all calls to
   window_$overwrite_text. These occur in the display_menu entry and in the
   get_choice entry. This should prevent the pause that can occur when a menu
   is being displayed and the long delay that can occur between the time the
   user makes a selection and the time the selection is flaged with an asterix.
   Also deleted declared but unreferenced variables.
*/

/* ***** INTERNAL REPRESENTATION OF A MENU ***** */

	declare 1 menu		 aligned based (menu_ptr),
		2 version		 char (8) init (MENU_VERSION),
		2 window_requirements,		/* size of menu */
		  3 height	 fixed bin,	/* number of lines */
		  3 width		 fixed bin,
		2 n_options	 fixed bin,
		2 flags		 unaligned,
		  3 case_insensitive bit (1) unal,
		  3 mbz1		 bit (17) unal,
		2 asterixed_option	 fixed bin (17) unal,
						/* or zero if none */
		2 option_info	 (61),		/* max is 61 */
		  3 key		 char (1) unal,
		  3 pad		 bit (27) unal,
		  3 line		 fixed bin,	/* where to echo */
		  3 col		 fixed bin,
		2 lines		 (lines_alloc refer (menu.height)) unal char (chars_alloc refer (menu.width));

	declare menu_ptr		 pointer;
	declare menu_segment_ptr	 ptr;

	declare MENU_VERSION	 char (8) aligned internal static options (constant) init ("menu_v_3");

	declare lines_alloc		 fixed bin (21);
	declare chars_alloc		 fixed bin (21);


/* Parameters of the various entries */

	declare (
	        P_choices		 (*) char (*) varying,
	        P_create_sw		 bit (1) aligned,
	        P_dname		 char (*),
	        P_ename		 char (*),
	        P_menu_name		 char (*),
	        P_headers		 (*) char (*) varying,
	        P_trailers		 (*) char (*) varying,
	        P_format_ptr	 pointer,
	        P_keys		 (*) char (1) unal,
	        P_areap		 pointer,
	        P_needs_ptr		 pointer,
	        P_menu_ptr		 pointer,
	        P_code		 fixed bin (35),
	        P_window		 pointer,
	        P_function_key_info_ptr
				 pointer,
	        P_fkeyp		 bit (1) aligned,
	        P_selection		 fixed bin,
	        P_starname		 character (*),
	        P_list_ptr		 pointer,
	        P_mli_version	 fixed bin
	        )			 parameter;

	declare (
	        error_table_$unimplemented_version,
	        error_table_$noentry
	        )			 fixed bin (35) external static;

	declare created_sw		 bit (1) aligned;

	declare (addr, copy, currentsize, dimension, divide, hbound, index, length, lbound, max, mod, null, sign)
				 builtin;

	declare add_char_offset_	 entry (pointer, fixed bin (21)) returns (pointer) reducible;
	declare get_system_free_area_	 entry () returns (ptr);
	declare get_user_free_area_	 entry () returns (pointer);
	declare hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr,
				 fixed bin (35));
	declare hcs_$terminate_noname	 entry (ptr, fixed bin (35));
	declare hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
	declare value_$init_seg	 entry (ptr, fixed bin, ptr, fixed bin (19), fixed bin (35));
	declare value_$get_data	 entry (ptr, bit (36) aligned, char (*), ptr, ptr, fixed bin (18), fixed bin (35))
				 ;
	declare value_$set_data	 entry (ptr, bit (36) aligned, char (*), ptr, fixed bin (18), ptr, ptr,
				 fixed bin (18), fixed bin (35));
	declare value_$list_data_names entry (pointer, bit (36) aligned, pointer, pointer, pointer, fixed binary (35));


	declare cleanup		 condition;

create_menu:
create:
     entry (P_choices, P_headers, P_trailers, P_format_ptr, P_keys, P_areap, P_needs_ptr, P_menu_ptr, P_code);
common_create:
	begin;
	     declare n_choices	      fixed bin;
	     declare (header_ct, menu_ct, trailer_ct)
				      fixed bin;	/* lines devoted to each */
	     declare menu_et_$too_few_keys  fixed bin (35) ext static;
	     declare menu_et_$higher_than_max
				      fixed bin (35) external static;
	     declare menu_et_$too_many_options
				      fixed bin (35) ext static;
	     declare menu_et_$keys_not_unique
				      fixed bin (35) ext static;

	     P_code = 0;
	     P_menu_ptr = null ();
	     menu_format_ptr = P_format_ptr;
	     menu_requirements_ptr = P_needs_ptr;
	     n_choices = dimension (P_choices, 1);

/* check validity of parms */
	     if menu_format.version ^= menu_format_version_1 | menu_requirements.version ^= menu_requirements_version_1
	     then call ERROR (error_table_$unimplemented_version);
	     if menu_format.pad ^= "0"b
	     then call ERROR (error_table_$unimplemented_version);
	     if n_choices = 0			/* Perhaps this should be an error? */
	     then ;				/* nothing to display */
	     if n_choices > dimension (P_keys, 1)
	     then call ERROR (menu_et_$too_few_keys);
	     if n_choices > hbound (menu.option_info, 1)
	     then call ERROR (menu_et_$too_many_options);
	     if ^all_keys_unique (n_choices)
	     then call ERROR (menu_et_$keys_not_unique);

/* parms look good, now calculate size of screen image so we can allocate it */
	     header_ct = sign (length (P_headers (1))) * dimension (P_headers, 1);
	     menu_ct = divide (n_choices, menu_format.n_columns, 17) + sign (mod (n_choices, menu_format.n_columns));
	     trailer_ct = sign (length (P_trailers (1))) * dimension (P_trailers, 1);
	     lines_alloc = header_ct + menu_ct + trailer_ct;

	     if menu_format.max_height > 0
	     then if lines_alloc > menu_format.max_height
		then call ERROR (menu_et_$higher_than_max);

	     chars_alloc = menu_format.max_width;

	     begin;
		declare based_area		 area based (areap);
		declare areap		 ptr;

		if P_areap ^= null
		then areap = P_areap;
		else areap = get_system_free_area_ ();

		allocate menu in (based_area);
	     end;

/* now fill in data structure */

	     menu.version = MENU_VERSION;
	     menu.height = lines_alloc;
	     menu.width = chars_alloc;
	     menu.n_options = n_choices;
	     menu.flags = ""b;
	     menu.case_insensitive = not_mixed_cases (n_choices);
	     menu.asterixed_option = 0;

	     menu.lines (*) = " ";
	     call format_screen ();
	     P_menu_ptr = menu_ptr;

	     call fill_requirements_from_menu ();

	     return;

all_keys_unique:
     procedure (kc) returns (bit (1) aligned);
	declare kc		 fixed bin parameter;
						/* how many matter */
	declare i			 fixed bin;
	declare (index, substr)	 builtin;
	declare key_overlay		 char (kc) defined (P_keys);
	do i = 1 to kc - 1;
	     if index (substr (key_overlay, kc + 1), P_keys (i)) > 0
	     then return ("0"b);			/* a match ! */
	end;
	return ("1"b);
     end all_keys_unique;

not_mixed_cases:
     proc (kc) returns (bit (1) unal);

	dcl     kc		 fixed bin;

	dcl     key_overlay		 char (kc) defined (P_keys);
	dcl     UPPER_CASE_LETTERS	 char (26) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ") internal static options (constant);
	dcl     LOWER_CASE_LETTERS	 char (26) init ("abcdefghijklmnopqrstuvwxyz") internal static options (constant);

	if (search (key_overlay, UPPER_CASE_LETTERS) = 0) & (search (key_overlay, LOWER_CASE_LETTERS) = 0)
	then return ("0"b);
	if (search (key_overlay, UPPER_CASE_LETTERS) ^= 0) & (search (key_overlay, LOWER_CASE_LETTERS) ^= 0)
	then return ("0"b);
	return ("1"b);

     end not_mixed_cases;



/* BUILD SCREEN IMAGE:

   +------------------------------------------------------+ --
   |_HEADER_ONE___________________________________________| header_ct = 2
   |_HEADER_TWO___________________________________________| __
   |_(1)_choice_one_|_(3)_choice_three_|_(4)_choice four__| menu_ct = 2
   |_(2)_choice_two_|__________________|__________________| __
   |_TRAILER______________________________________________| trailer_ct = 1

   <- chars_per_box ->

   choices are positioned  as evenly as possible:  never more than one extra
   choice per column.  The portion of the screen devoted to choices begins
   at the "first_option_char"'th char of the display image (lines).  The
   choices are divided into "boxes".  If the number of choices is a multiple
   of the  number of columns, the boxes are an array "n_columns" wide, and
   choices/n_columns high.  And if there is a remainder R, the first R columns
   get an extra choice.

*/

format_screen:
     procedure;
	declare i			 fixed bin;
	declare (first_header_line, first_menu_line, first_trailer_line)
				 fixed bin;
	declare chars_per_box	 fixed bin;
	declare first_option_char	 fixed bin (21);
	declare extra		 fixed bin;

	first_header_line = 1;
	first_menu_line = first_header_line + header_ct;
	first_trailer_line = first_menu_line + menu_ct;

/* the headers and trailers are easy */
	do i = 1 to header_ct;
	     menu.lines (first_header_line + i - 1) =
		format (P_headers (i), menu_format.center_headers, menu_format.pad_char, menu_format.max_width);
	end;
	do i = 1 to trailer_ct;
	     menu.lines (first_trailer_line + i - 1) =
		format (P_trailers (i), menu_format.center_trailers, menu_format.pad_char, menu_format.max_width);
	end;

	chars_per_box = divide (menu_format.max_width, menu_format.n_columns, 17);
	extra = mod (menu_format.max_width, menu_format.n_columns);
	first_option_char = (header_ct * menu.width) + 1;

format_boxes:
	begin;
	     declare 1 boxes	      (0:menu_ct - 1) defined (menu.lines) position (first_option_char),
		     2 row	      (0:menu_format.n_columns - 1),
		       3 constant,
		         4 lp	      char (2) unal,/* " (" */
		         4 k	      char (1) unal,/* key image */
		         4 rp	      char (2) unal,/* ") " */
		       3 name	      char (chars_per_box - 5) unal,
		     2 pad	      char (extra) unal;
	     declare menu_line	      fixed bin;
	     declare menu_row	      fixed bin;

	     do i = 1 to hbound (P_choices, 1);
		menu.option_info (i).key = P_keys (i);
		call get_box_coords (i, menu_row, menu_line);
		menu.option_info (i).line = first_menu_line + menu_line;
		menu.option_info (i).col = 3 + menu_row * chars_per_box;

		boxes (menu_line).row (menu_row).lp = " (";
		boxes (menu_line).row (menu_row).k = P_keys (i);
		boxes (menu_line).row (menu_row).rp = ") ";
		boxes (menu_line).row (menu_row).name = P_choices (i);
	     end;
	end format_boxes;
	return;

get_box_coords:
     procedure (mi, bx, by);
	declare mi		 fixed bin parameter;
						/* input */
	declare (by, bx)		 fixed bin parameter;
						/* output */

	by = mod (mi - 1, menu_ct);
	bx = divide (mi - 1, menu_ct, 17);
     end get_box_coords;


/* This has an implementation limit of 200 chars / line, but
   surely that is reasonable? - if I use returns (char(*)) I become
   non-quick */
format:
     procedure (raw, center, padc, ll) returns (char (200) varying);
	declare raw		 char (*) varying parameter;
	declare center		 bit (1) unal parameter;
	declare padc		 char (1) aligned parameter;
	declare ll		 fixed bin parameter;
	declare lbuf		 char (200) varying;
	declare lct		 fixed bin;

	if ^center
	then lbuf = raw;
	else do;
		lct = divide (max (0, ll - length (raw)), 2, 17);
		lbuf = copy (padc, lct);
		lbuf = lbuf || raw;
		lbuf = lbuf || copy (padc, lct + mod (lct, 2));
	     end;
	return (lbuf);
     end format;
     end format_screen;

	end common_create;

display_menu:
display:
     entry (P_window, P_menu_ptr, P_code);
	call setup ();
	begin;

	     declare window_display_	      entry (pointer, (*) char (*) unal, fixed bin (35));

	     call window_display_ (P_window, menu.lines, P_code);
	     if menu.asterixed_option > 0
	     then do;
		     call cursor_to_option ((menu.asterixed_option));
		     call window_$overwrite_text (P_window, "*", P_code);
		end;
	     call window_$sync (P_window, P_code);
	end;					/* begin block */
	return;

get_choice:
     entry (P_window, P_menu_ptr, P_function_key_info_ptr, P_fkeyp, P_selection, P_code);
	call setup ();
	function_key_data_ptr = P_function_key_info_ptr;
	if function_key_data_ptr ^= null
	then if function_key_data.version ^= function_key_data_version_1
	     then call ERROR (error_table_$unimplemented_version);

	begin;
	     declare c		      char (1);
	     declare cc		      char (1);
	     declare ck		      char (1);
	     declare opx		      fixed bin;	/* index thru options */
	     declare possible	      bit (1) aligned;
	     declare fkeyb		      char (32) varying;
	     declare pseq		      char (pseql) based (pseqp);
	     declare pseql		      fixed bin (21);
	     declare pseqp		      ptr;

	     if menu.asterixed_option ^= 0
	     then do;
		     call cursor_to_option ((menu.asterixed_option));
		     call window_$overwrite_text (P_window, menu.option_info (menu.asterixed_option).key, P_code);
		     if P_code ^= 0
		     then go to RETURN;
		     call window_$sync (P_window, P_code);
		     if P_code ^= 0
		     then go to RETURN;
		end;

	     call cursor_to_option (1);
	     do while ("1"b);			/* until valid key hit */
		c = read_a_char ();
		if menu.case_insensitive
		then cc = upper_case (c);
		else cc = c;

		do opx = 1 to menu.n_options;
		     if menu.case_insensitive
		     then ck = upper_case ((menu.option_info (opx).key));
		     else ck = menu.option_info (opx).key;
		     if cc = ck
		     then do;
			     call cursor_to_option (opx);
			     P_fkeyp = "0"b;
			     P_selection = opx;

			     call window_$overwrite_text (P_window, "*", P_code);
			     if P_code ^= 0
			     then go to RETURN;
			     menu.asterixed_option = opx;
			     call window_$sync (P_window, P_code);
			     go to RETURN;


			end;			/* matching option */
		end;				/* loop thru options */
		if function_key_data_ptr ^= null
		then possible = "1"b;		/* enter loop */
		else possible = "0"b;
		fkeyb = c;
		do while (possible);
		     possible = "0"b;
		     do opx = lbound (function_key_data.function_keys, 1)
			to hbound (function_key_data.function_keys, 1);
			pseql = function_key_data.function_keys (opx, KEY_PLAIN).sequence_length;
			pseqp =
			     add_char_offset_ (function_key_data.seq_ptr,
			     (function_key_data.function_keys (opx, KEY_PLAIN).sequence_index) - 1);

			if length (pseq) = length (fkeyb) & pseq = fkeyb
			then do;
				P_fkeyp = "1"b;
				P_selection = opx;
				return;
			     end;			/* match - Win */
			else if ^possible		/* look for possibles */
			then if length (pseq) > length (fkeyb)
						/* we hope to match if we grow */
			     then if index (pseq, fkeyb) = 1
						/* pseq begins with fkeyb */
				then possible = "1"b;
		     end;				/* loop thru f keys */
		     if possible
		     then fkeyb = fkeyb || read_a_char ();
		end;				/* if even one has hopes, keep trying */

/* fall out, no match */
		call window_$bell (P_window, (0));

	     end;					/* loop waiting for good one */

read_a_char:
     procedure returns (char (1));
	declare ac		 char (1);
	begin;
	     declare break		      character (1) varying;
	     call window_$get_unechoed_chars (P_window, 1, ac, (0), break, P_code);
	     if P_code ^= 0
	     then goto ERROR_EXIT;
	     if length (break) = 1
	     then ac = break;
	     /*** else ac already has the right thing */
	end;
	return (ac);
     end read_a_char;

upper_case:
     proc (c) returns (char (1));

	dcl     c			 char (1);

	if (rank (c) < rank ("a")) | (rank (c) > rank ("z"))
	then return (c);
	else return (byte (rank (c) - (rank ("a") - rank ("A"))));

     end upper_case;
	end;					/* begin block */

store_menu:
store:
     entry (P_dname, P_ename, P_menu_name, P_create_sw, P_menu_ptr, P_code);

	call setup ();
	menu_segment_ptr = null;
	created_sw = "0"b;
	on cleanup call term_menu ();

	call hcs_$initiate (P_dname, P_ename, "", 0, 1, menu_segment_ptr, P_code);
	if P_code = error_table_$noentry & P_create_sw
	then do;
		created_sw = "1"b;
		call hcs_$make_seg (P_dname, P_ename, "", RW_ACCESS_BIN, menu_segment_ptr, P_code);
		if menu_segment_ptr = null
		then go to SEG_ERR;
		call value_$init_seg (menu_segment_ptr, 0, null, 0, P_code);
		if P_code ^= 0
		then go to SEG_ERR;

	     end;

	if menu_segment_ptr = null
	then go to SEG_ERR;

	menu.asterixed_option = 0;

	call value_$set_data (menu_segment_ptr, "01"b, value_name (P_menu_name), P_menu_ptr, currentsize (menu), null,
	     null, (0), P_code);

	if P_code = 0				/* don't let term_menu delete new segment */
	then created_sw = "0"b;			/* if we succeeded */
	call term_menu ();

	return;


delete_menu:
delete:
     entry (P_dname, P_ename, P_menu_name, P_code);

	P_code = 0;
	created_sw = "0"b;
	on cleanup call term_menu;
	call hcs_$initiate (P_dname, P_ename, "", 0, 1, menu_segment_ptr, P_code);
	if menu_segment_ptr = null
	then go to SEG_ERR;

/* Should be changed to use delete_data as soon as that exists */
/* since that will give us an error if the value isn't there to delete */

	call value_$set_data (menu_segment_ptr, "01"b, value_name (P_menu_name), null, 0, null, null, (0), P_code);
						/* Null ptr deletes value */
	call term_menu ();
	return;

retrieve_menu:
retrieve:
     entry (P_dname, P_ename, P_menu_name, P_areap, P_menu_ptr, P_code);

	P_code = 0;
	P_menu_ptr = null;
	menu_segment_ptr = null;
	created_sw = "0"b;
	on cleanup call term_menu ();

	call hcs_$initiate (P_dname, P_ename, "", 0, 1, menu_segment_ptr, P_code);
	if menu_segment_ptr = null
	then go to SEG_ERR;

	begin;

	     declare areap		      ptr;

	     if P_areap = null
	     then areap = get_user_free_area_ ();
	     else areap = P_areap;

	     call value_$get_data (menu_segment_ptr, "01"b, value_name (P_menu_name), areap, menu_ptr, (0), P_code);
	     if P_code ^= 0
	     then go to SEG_ERR;

	end;					/* begin */


	if menu.version ^= MENU_VERSION
	then do;
		P_code = error_table_$unimplemented_version;
		go to SEG_ERR;
	     end;

	P_menu_ptr = menu_ptr;
	call term_menu ();

	return;


SEG_ERR:
	call term_menu ();

	go to ERROR_EXIT;

list_menus:
list:
     entry (P_dname, P_ename, P_starname, P_areap, P_mli_version, P_list_ptr, P_code);


	if P_mli_version ^= menu_list_info_version_1
	then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	call LIST (P_dname, P_ename, P_starname, P_areap, P_list_ptr, P_code);
	return;

LIST:
     procedure (dname, ename, starname, area_ptr, list_ptr, code);
	declare (dname, ename, starname)
				 character (*);
	declare area_ptr		 pointer;
	declare list_ptr		 pointer;
	declare (i, listx, vlistx)	 fixed bin (21);
	declare code		 fixed bin (35);
	declare auto_area_ptr	 pointer;
	declare the_general_area	 area based (auto_area_ptr);

	if area_ptr = null ()
	then auto_area_ptr = get_user_free_area_ ();
	else auto_area_ptr = area_ptr;

	code = 0;

	list_ptr, menu_segment_ptr, menu_list_info_ptr, match_info_ptr, value_list_info_ptr = null ();

	on cleanup
	     begin;
		if menu_list_info_ptr ^= null
		then free menu_list_info;
		if match_info_ptr ^= null
		then free match_info;
		if value_list_info_ptr ^= null
		then free value_list_info;
		if menu_segment_ptr ^= null
		then call hcs_$terminate_noname (menu_segment_ptr, (0));
	     end;

	call hcs_$initiate (dname, ename, "", 0, 1, menu_segment_ptr, code);
	if menu_segment_ptr = null
	then go to SEG_ERR;

	alloc_name_count = 1;
	alloc_max_name_len = length (value_name (starname));
	allocate match_info;

	match_info.version = match_info_version_1;
	match_info.name_array (1).exclude_sw = "0"b;
	match_info.name_array (1).regexp_sw = "0"b;
	match_info.name_array (1).pad = ""b;
	match_info.name_array (1).name = value_name (starname);

	call value_$list_data_names (menu_segment_ptr, "01"b, match_info_ptr, get_system_free_area_ (),
	     value_list_info_ptr, code);
	free match_info;
	if code ^= 0
	then return;


	menu_list_n_names = value_list_info.pair_count;
	menu_list_name_string_length =
	     sum (value_list_info.name_len) - (value_list_info.pair_count * length (".menu_"));

	allocate menu_list_info in (the_general_area);

	menu_list_info.version = menu_list_info_version_1;

	listx = 1;
	do i = 1 to value_list_info.pair_count;
	     menu_list_info.position (i) = listx;
	     menu_list_info.length (i) = value_list_info.name_len (i) - length (".menu_");

	     vlistx = value_list_info.name_index (i);

	     substr (menu_list_info.name_string, listx, menu_list_info.length (i)) =
		substr (value_list_info.chars, vlistx, menu_list_info.length (i));
	     listx = listx + menu_list_info.length (i);
	end;

	list_ptr = addr (menu_list_info);
	free value_list_info;
	call hcs_$terminate_noname (menu_segment_ptr, (0));
     end LIST;

/* This is called whenever we leave store_menu or retrieve_menu.
   It terminates the null refname. */

term_menu:
     procedure ();

	declare hcs_$terminate_noname	 entry (ptr, fixed bin (35));
	declare delete_$ptr		 entry (pointer, bit (6), character (*), fixed binary (35));

	if menu_segment_ptr ^= null
	then if created_sw
	     then call delete_$ptr (menu_segment_ptr, "100101"b, "", (0));
	     else call hcs_$terminate_noname (menu_segment_ptr, (0));

     end term_menu;

value_name:
     procedure (name) returns (character (*));
	declare name		 character (*);

	return (rtrim (name) || ".menu_");		/* user may not add the suffix themselves */
     end value_name;

describe_menu:
describe:
     entry (P_menu_ptr, P_needs_ptr, P_code);

	call setup ();
	menu_requirements_ptr = P_needs_ptr;
	if menu_requirements.version ^= menu_requirements_version_1
	then do;
		P_code = error_table_$unimplemented_version;
		return;
	     end;

	call fill_requirements_from_menu ();
	return;


fill_requirements_from_menu:
     procedure ();

	menu_requirements.lines_needed = menu.height;
	menu_requirements.width_needed = menu.width;
	menu_requirements.n_options = menu.n_options;
     end fill_requirements_from_menu;



destroy_menu:
destroy:
     entry (P_menu_ptr, P_code);
	call setup ();
	free menu_ptr -> menu;
	return;



setup:
     procedure ();
	P_code = 0;
	if P_menu_ptr -> menu.version ^= MENU_VERSION
	then call ERROR (error_table_$unimplemented_version);
	menu_ptr = P_menu_ptr;
     end setup;


cursor_to_option:
     procedure (e);
	declare e			 fixed bin parameter;
	call window_$position_cursor (P_window, menu.option_info (e).line, menu.option_info (e).col, P_code);
	if P_code ^= 0
	then goto ERROR_EXIT;

     end cursor_to_option;


ERROR:
     procedure (code);
	declare code		 fixed bin (35) parameter;
	P_code = code;
	goto ERROR_EXIT;
     end ERROR;

RETURN:
ERROR_EXIT:
	return;

%include menu_dcls;
%include window_dcls;
%include function_key_data;
%include access_mode_values;
%include value_structures;
%include menu_list_info;
     end menu_;




		    menu_create.pl1                 07/17/90  1544.4rew 07/17/90  1543.3      249759



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



/****^  HISTORY COMMENTS:
  1) change(90-05-16,Kallstrom), approve(90-05-16,MCR8176),
     audit(90-06-21,Blackmore), install(90-07-17,MR12.4-1022):
     fixed menu_get_choice so that the -dfkeys string is not used when the
     number of characters in the string is the same as the number of function
     keys defined for the terminal type.
                                                   END HISTORY COMMENTS */


/* format: style2 */

menu_create:
     procedure options (variable);			/* COMMAND */

/* The menu commands from MTB 494
   menu_create, menu_display, menu_get_choice, menu_describe

   James R. Davis 21 Jan 81
*/

/* Maintained by Suzanne Krupp.

   Modified 06/08/81 by Suzanne Krupp to use menu_$store_menu and
     menu_$retrieve menu to store retrieve menus from segments.

   Modified 06/30/81 by Suzanne Krupp to change maximum allowed options
     from 35 to 61.

  Modified July 1981 BIM for cleanup to store/retrieve, list, delete.

  Audit changes October 1981 BIM.

  Modified November 1981 MRJ to fake function key data when not found in TTT
                             and to add control arg to specify options selectors.

  Modified 10 February 1982 by Chris Jones to initialize dfkey_string_len.

  84-03-12 Davids: Modified argument processing of menu_describe entry to
  allow more robust handling. You can now specify any combination of
  -width, -height, and -count and things will work. There is no longer
  any "knowledge" of how many arguments should be present. This fixes
  TR phx15650
*/

	declare get_system_free_area_	 entry () returns (ptr);
	declare requote_string_	 entry (character (*)) returns (character (*));


	declare arg		 char (al) based (ap);
	declare al		 fixed bin (21);
	declare ap		 ptr;
	declare alp		 ptr;		/* to arg list */
	declare code		 fixed bin (35);
	declare nargs		 fixed bin;
	declare af_value		 char (afl) varying based (afp);
	declare afl		 fixed bin (21);
	declare afp		 ptr;
	declare active		 bit (1) aligned;
	declare complain		 entry variable options (variable);
	declare answer		 char (3) var;
	declare myname		 char (32);
	declare pathname_present	 bit (1);
	declare swname_present	 bit (1);
	declare brief		 bit (1);
	declare valid_args		 fixed bin;
	declare pathname		 char (168);	/* MENU seg path */
	declare dirname		 char (168);	/* MENU seg dir */
	declare ename		 char (32);	/* MENU seg entryname */

	declare 1 auto_query_info	 like query_info;

	declare menu_namep		 ptr;
	declare menu_name_len	 fixed bin;
	declare menu_name		 char (menu_name_len) based (menu_namep);

	declare iocbp		 ptr;
	declare menu_ptr		 ptr;

	declare SUFFIX		 char (5) internal static options (constant) init ("value");

	declare (
	        error_table_$active_function,
	        error_table_$bad_conversion,
	        error_table_$badopt,
	        error_table_$bigarg,
	        error_table_$noarg,
	        error_table_$noentry,
	        error_table_$too_many_args
	        )			 fixed bin (35) ext static;


	declare (addr, empty, max, null, rtrim, size)
				 builtin;

	call set_flavor_of_command ("menu_create", "0"b);

menu_create_block:
	begin;
	     declare 1 mf		      aligned like menu_format;
	     declare 1 auto_menu_requirements
				      aligned like menu_requirements;

	     declare (n_choices, n_headers, n_trailers)
				      fixed bin;
	     declare max_choice_len	      fixed bin (21);
	     declare max_line_len	      fixed bin (21);

	     declare (keep_trying, create)  bit (1) aligned;

	     declare command_query_	      entry () options (variable);

	     declare option_keys_ptr	      pointer;
	     declare option_keys_len	      fixed bin (21);
	     declare option_keys	      (option_keys_len) char (1) unal based (option_keys_ptr);

	     if nargs < 2
	     then goto USAGE;

	     dirname, ename, pathname = "";
	     pathname_present, brief, create = "0"b;
	     call get_menu_name ();

	     call scan_controls ();
	     n_choices = max (n_choices, 1);
	     n_headers = max (n_headers, 1);
	     n_trailers = max (n_trailers, 1);
	     begin;
		declare argx		 fixed bin;
		declare choices		 (n_choices) char (max_choice_len) varying;
		declare headers		 (n_headers) char (max_line_len) varying;
		declare trailers		 (n_trailers) char (max_line_len) varying;
		declare (choicex, headerx, trailerx)
					 fixed bin;

		choicex, headerx, trailerx = 0;
		choices (*), headers (*), trailers (*) = "";
		do argx = 2 to nargs;
		     call arg_getter (argx, ap, al, (0));
		     if arg = "-option" | arg = "-opt"
		     then call snarf (choicex, choices);
		     else if arg = "-header" | arg = "-he"
		     then call snarf (headerx, headers);
		     else if arg = "-trailer" | arg = "-tr"
		     then call snarf (trailerx, trailers);
		end;

		auto_menu_requirements.version = menu_requirements_version_1;
						/* create starts out false, so we can query */

		call menu_$create (choices, headers, trailers, addr (mf), option_keys, null,
		     addr (auto_menu_requirements), menu_ptr, code);
		if code ^= 0
		then call gen_err (code, "Could not create the menu object.");

		if ^pathname_present
		then call get_default_vseg_path ();

		keep_trying = "1"b;
		answer = "";
		do while (keep_trying);
		     call menu_$store (dirname, ename, menu_name, create, menu_ptr, code);
		     if code = error_table_$noentry
		     then do;
			     if brief
			     then answer = "yes";
			     else do;
				     call get_query_info (code);
				     call command_query_ (addr (auto_query_info), answer, myname,
					"Segment not found: ^a.  Do you wish to create it?", pathname);
				end;
			     if answer = "yes"
			     then do;
				     keep_trying = "1"b;
				     create = "1"b;
				end;
			     else call gen_err (code, rtrim (pathname));
			end;
		     else if code ^= 0
		     then call gen_err (code, "Trying to store " || menu_name || " in " || pathname || " .");
		     else keep_trying = "0"b;
		end;				/* do while */

		return;


snarf:
     procedure (ix, larr);
	declare ix		 fixed bin parameter;
						/* I/O index into array */
	declare larr		 (*) char (*) varying parameter;
						/* I/O array of lines */
	ix = ix + 1;
	argx = argx + 1;
	call arg_getter (argx, ap, al, (0));
	larr (ix) = arg;
     end snarf;

	     end;					/* non quick begin block */

/* Internal Procedures for create follow */



/* look thru the command args, count headers, trailers, and options, and set format */
scan_controls:
     procedure ();
	declare argx		 fixed bin;
	declare get_line_length_$switch
				 entry (ptr, fixed bin (35)) returns (fixed bin);

	max_choice_len, max_line_len = 0;
	n_choices, n_headers, n_trailers = 0;

/* defaults */
	option_keys_ptr = addr (MENU_OPTION_KEYS);
	option_keys_len = hbound (MENU_OPTION_KEYS, 1);
	mf.version = menu_format_version_1;
	mf.max_width = get_line_length_$switch ((null ()), code);
	if code ^= 0
	then do;
		code = 0;
		mf.max_width = 80;			/* new get_line_length_ isnt in yet */
	     end;

	mf.max_height = 0;
	mf.n_columns = 1;
	mf.flags = "0"b;
	mf.pad_char = " ";

	do argx = 2 to nargs;
	     call arg_getter (argx, ap, al, (0));

	     if arg = "-header" | arg = "-he"
	     then call accumulate (n_headers, max_line_len);
	     else if arg = "-trailer" | arg = "-tr"
	     then call accumulate (n_trailers, max_line_len);
	     else if arg = "-option" | arg = "-opt"
	     then call accumulate (n_choices, max_choice_len);

	     else if arg = "-columns" | arg = "-col"
	     then mf.n_columns = get_next_arg_num ();

	     else if arg = "-center_headers" | arg = "-ceh"
	     then mf.center_headers = "1"b;
	     else if arg = "-no_center_headers" | arg = "-nceh"
	     then mf.center_headers = "0"b;
	     else if arg = "-center_trailers" | arg = "-cet"
	     then mf.center_trailers = "1"b;
	     else if arg = "-no_center_trailers" | arg = "-ncet"
	     then mf.center_trailers = "0"b;
	     else if arg = "-line_length" | arg = "-ll"
	     then mf.max_width = get_next_arg_num ();
	     else if arg = "-pad"
	     then mf.pad_char = get_next_arg_char ();
	     else if arg = "-pathname" | arg = "-pn"
	     then do;
		     pathname_present = "1"b;
		     call get_next_arg ();
		     call get_menu_seg_info ();
		end;
	     else if arg = "-brief" | arg = "-bf"
	     then brief = "1"b;
	     else if arg = "-option_keys" | arg = "-okeys"
	     then do;
		     call get_next_arg ();
		     option_keys_ptr = addr (arg);
		     option_keys_len = length (arg);
		end;
	     else do;
		     call complain (error_table_$badopt, myname, "^a", arg);
		     goto ERROR_EXIT;
		end;
	end;					/* control arg loop */

	return;


accumulate:
     procedure (count, maxlen);
	declare count		 fixed bin parameter;
						/* input/output */
	declare maxlen		 fixed bin (21) parameter;
						/* input/output */
	call get_next_arg ();
	count = count + 1;				/* found another */
	maxlen = max (maxlen, al);
     end accumulate;


get_next_arg_num:
     procedure returns (fixed bin);
	declare x			 fixed bin (35);
	declare cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));
	declare nscode		 fixed bin (35);

	call get_next_arg ();
	x = cv_dec_check_ (arg, nscode);
	if nscode ^= 0
	then do;
		call complain (error_table_$bad_conversion, myname, "Not a decimal number: ^a.", arg);
		goto ERROR_EXIT;
	     end;

	return (x);
     end get_next_arg_num;

get_next_arg_char:
     procedure returns (char (1) aligned);
	declare c			 char (1) aligned;
	call get_next_arg ();
	if al > 1
	then do;
		call complain (error_table_$bigarg, myname, "The pad argument must be  a single character.");
		goto ERROR_EXIT;
	     end;
	c = arg;
	return (c);
     end get_next_arg_char;

get_next_arg:
     procedure ();
	if argx = nargs
	then goto MISSING;
	argx = argx + 1;
	call arg_getter (argx, ap, al, (0));
     end get_next_arg;
     end scan_controls;


MISSING:
	     call complain (error_table_$noarg, myname, "missing arg after ^a.", arg);
	     goto ERROR_EXIT;
	end menu_create_block;

menu_get_choice:
     entry options (variable);			/* COMMAND/AF */
	call set_flavor_of_command ("menu_get_choice", "1"b);

get_menu_choice_begin:
	begin;
	     declare funk		      ptr;	/* to function key info */
	     declare funky_area	      area (512);	/*  where to allocate funk info */
						/* like this we don't have to free, and we know the data is small */
	     declare dfkey_string_ptr	      ptr;
	     declare dfkey_string_len	      fixed bin (21);
	     declare dfkey_string	      char (dfkey_string_len) based (dfkey_string_ptr) unal;
	     declare fkey		      bit (1) aligned;
	     declare keyno		      fixed bin;
	     declare argx		      fixed bin;

	     pathname_present, swname_present = "0"b;
	     funk, dfkey_string_ptr = null ();
	     dfkey_string_len = 0;
	     call get_menu_name ();

	     do argx = 2 to nargs;
		call arg_getter (argx, ap, al, code);
		if code ^= 0
		then call gen_err (code, "");
		if arg = "-pathname" | arg = "-pn"
		then do;
			call get_next_choice_arg ();
			call get_menu_seg_info ();
			pathname_present = "1"b;
		     end;
		else if arg = "-io_switch" | arg = "-is"
		then do;
			call get_next_choice_arg ();
			call get_switch ();
			swname_present = "1"b;
		     end;
		else if arg = "-function_keys" | arg = "-fkeys"
		then do;
			call get_next_choice_arg ();
			funk = make_function_key_info (arg);
		     end;
		else if arg = "-default_function_keys" | arg = "-dfkeys"
		then do;
			call get_next_choice_arg ();
			dfkey_string_ptr = addr (arg);
			dfkey_string_len = length (arg);
		     end;
		else go to BAD_OPT;
	     end;

	     if ^swname_present
	     then iocbp = iox_$user_io;		/* we do output on *'s */
	     if ^pathname_present
	     then call get_default_vseg_path ();

	     call lookup_menu ();

	     if funk = null ()
	     then funk = get_function_key_info ();

	     call menu_$get_choice (iocbp, menu_ptr, funk, fkey, keyno, code);
	     if code ^= 0
	     then goto USAGE;

	     call result (key_str ());
	     return;


/* internal procedures for get_menu_choice */

get_next_choice_arg:
     proc ();

	argx = argx + 1;
	call arg_getter (argx, ap, al, code);
	if code ^= 0
	then call gen_err (code, "");

     end get_next_choice_arg;

key_str:
     procedure () returns (char (8) aligned);
	declare s			 char (8) aligned;
	declare ioa_$rsnnl		 entry () options (variable);
	call ioa_$rsnnl ("^[F^]^d", s, (0), fkey, keyno);
	return (s);
     end key_str;


get_function_key_info:
     procedure () returns (pointer);
	declare f			 ptr;
	declare fx		 fixed bin;
	declare ttt_info_$function_key_data
				 entry (char (*), ptr, ptr, fixed bin (35));
	declare error_table_$no_table	 fixed bin (35) ext static;
	funky_area = empty ();

	call ttt_info_$function_key_data (get_term_type_name (), addr (funky_area), f, code);
	if code = error_table_$no_table
	then do;
		code = 0;
		if dfkey_string_ptr = null ()
		then f = make_function_key_info ("0123456789");
		else f = make_function_key_info (dfkey_string);
	     end;
	else if code ^= 0
	then do;
		call complain (code, myname, "Getting function key data.");
		goto ERROR_EXIT;
	     end;
	else do;
		if dfkey_string_ptr ^= null () & f -> function_key_data.highest + 1 < dfkey_string_len
		then f = make_function_key_info (dfkey_string);
		else do;				/* make sure all required function keys are present */
			do fx = 1 to dfkey_string_len;
			     if (substr (dfkey_string, fx, 1) ^= " ")
				& (f -> function_key_data.function_keys.sequence_length (fx - 1, KEY_PLAIN) = 0)
			     then do;
				     f = make_function_key_info (dfkey_string);
				     goto GOT_FUNCTION_KEY_INFO;
				end;
			end;
		     end;
	     end;
GOT_FUNCTION_KEY_INFO:
	return (f);


get_term_type_name:
     procedure () returns (char (32));
	declare 1 ti		 aligned like terminal_info;

	ti.version = terminal_info_version;
	call iox_$control (iox_$user_io, "terminal_info", addr (ti), code);
	if code ^= 0
	then do;
		call complain (code, myname, "Getting terminal type.");
		goto ERROR_EXIT;
	     end;
	return (ti.term_type);
     end get_term_type_name;
     end get_function_key_info;


make_function_key_info:
     procedure (string) returns (pointer);
	declare string		 char (*);
	declare sequence		 char (2 * length (string)) based (sequence_ptr);
	declare sequence_ptr	 pointer;
	declare i			 fixed bin;

	function_key_data_highest = length (string) - 1;
	allocate function_key_data in (funky_area);
	allocate sequence in (funky_area);
	function_key_data.version = function_key_data_version_1;
	function_key_data.highest = function_key_data_highest;
	function_key_data.sequence.seq_ptr = addr (sequence);
	function_key_data.sequence.seq_len = length (sequence);
	function_key_data.home.sequence_index (*) = 0;
	function_key_data.home.sequence_length (*) = 0;
	function_key_data.left.sequence_index (*) = 0;
	function_key_data.left.sequence_length (*) = 0;
	function_key_data.up.sequence_index (*) = 0;
	function_key_data.up.sequence_length (*) = 0;
	function_key_data.right.sequence_index (*) = 0;
	function_key_data.right.sequence_length (*) = 0;
	function_key_data.down.sequence_index (*) = 0;
	function_key_data.down.sequence_length (*) = 0;
	function_key_data.function_keys.sequence_index (*, *) = 0;
	function_key_data.function_keys.sequence_length (*, *) = 0;
	do i = 0 to length (string) - 1;
	     if substr (string, i + 1, 1) ^= " "
	     then do;
		     substr (sequence, i * 2 + 1, 2) = byte (27) || substr (string, i + 1, 1);
		     function_key_data.function_keys.sequence_index (i, KEY_PLAIN) = i * 2 + 1;
		     function_key_data.function_keys.sequence_length (i, KEY_PLAIN) = 2;
		end;
	end;

	return (addr (function_key_data));

     end make_function_key_info;

	end get_menu_choice_begin;

menu_display:
     entry options (variable);
	call set_flavor_of_command ("menu_display", "0"b);

menu_display_begin:
	begin;

	     declare argx		      fixed bin;

	     pathname_present, swname_present = "0"b;
	     call get_menu_name ();

	     do argx = 2 to nargs;
		call arg_getter (argx, ap, al, code);
		if code ^= 0
		then call gen_err (code, "");
		if arg = "-pathname" | arg = "-pn"
		then do;
			call get_next_display_arg ();
			call get_menu_seg_info ();
			pathname_present = "1"b;
		     end;
		else if arg = "-io_switch" | arg = "-is"
		then do;
			call get_next_display_arg ();
			call get_switch ();
			swname_present = "1"b;
		     end;
		else go to BAD_OPT;
	     end;

	     if ^swname_present
	     then iocbp = iox_$user_output;
	     if ^pathname_present
	     then call get_default_vseg_path ();

	     call lookup_menu ();

	     call menu_$display (iocbp, menu_ptr, code);
	     if code ^= 0
	     then call gen_err (code, menu_name);

	     return;

get_next_display_arg:
     proc ();

	argx = argx + 1;
	call arg_getter (argx, ap, al, code);
	if code ^= 0
	then call gen_err (code, "");

     end get_next_display_arg;

	end menu_display_begin;

menu_describe:
     entry options (variable);
	call set_flavor_of_command ("menu_describe", "1"b);

menu_describe_begin:
	begin;

	     declare 1 mr		      aligned like menu_requirements;
	     declare ioa_		      entry () options (variable);
	     declare argx		      fixed bin;
	     dcl	   width_flag	      bit (1);
	     dcl	   height_flag	      bit (1);
	     dcl	   count_flag	      bit (1);

	     width_flag = "0"b;
	     height_flag = "0"b;
	     count_flag = "0"b;
	     pathname_present = "0"b;
	     call get_menu_name ();

	     do argx = 2 to nargs;
		call arg_getter (argx, ap, al, code);
		if code ^= 0
		then call gen_err (code, "");
		if arg = "-pathname" | arg = "-pn"
		then do;
			call get_next_desc_arg ();
			call get_menu_seg_info ();
			pathname_present = "1"b;
		     end;
		else if arg = "-width"
		then width_flag = "1"b;
		else if arg = "-height"
		then height_flag = "1"b;
		else if arg = "-count" | arg = "-ct"
		then count_flag = "1"b;
		else go to BAD_OPT;
	     end;

	     if ^pathname_present
	     then call get_default_vseg_path ();

	     call lookup_menu ();

	     if active
	     then do;
		     if (width_flag & height_flag) | (width_flag & count_flag) | (height_flag & count_flag)
		     then code = error_table_$too_many_args;
		     if ^(width_flag | height_flag | count_flag)
		     then code = error_table_$noarg;
		end;
	     if code ^= 0
	     then goto USAGE;

	     mr.version = menu_requirements_version_1;
	     call menu_$describe (menu_ptr, addr (mr), code);
	     if code ^= 0
	     then goto USAGE;
	     if ^active
	     then do;
		     if ^width_flag & ^height_flag & ^count_flag
						/* no flags set - print everything */
		     then call ioa_ ("Height: ^d;  Width: ^d;  ^d Option^[s^]", mr.n_options, mr.width_needed,
			     mr.n_options, (mr.n_options > 1));
		     else call ioa_ ("^[Height: ^d;  ^;^s^]^[Width: ^d;  ^;^s^]^[^d Option^[s^]^;^s^s^]", height_flag,
			     mr.n_options, width_flag, mr.width_needed, count_flag, mr.n_options,
			     (mr.n_options > 1));
		end;
	     else do;
		     if width_flag
		     then call describe ("-width");
		     else if height_flag
		     then call describe ("-height");
		     else call describe ("-count");
		end;
	     return;


describe:
     procedure (which);
	declare which		 char (*) parameter;
	declare v			 char (8) aligned;
	declare n			 fixed bin;
	declare (char, ltrim, rtrim)	 builtin;

	if which = "-width"
	then n = mr.width_needed;
	else if which = "-height"
	then n = mr.lines_needed;
	else if which = "-count" | which = "-ct"
	then n = mr.n_options;
	else goto BAD_OPT;
	v = rtrim (ltrim (char (n)));
	call result (v);
     end describe;

get_next_desc_arg:
     proc ();

	argx = argx + 1;
	call arg_getter (argx, ap, al, code);
	if code ^= 0
	then call gen_err (code, "");

     end get_next_desc_arg;

	end menu_describe_begin;
	return;

menu_list:
     entry options (variable);

	call set_flavor_of_command ("menu_list", "1"b);

menu_list_begin:
	begin;
	     declare ioa_		      entry () options (variable);
%include menu_list_info;
	     declare argx		      fixed bin;
	     declare starname	      character (128);
	     declare starname_present	      bit (1);

	     starname_present = "0"b;
	     pathname_present = "0"b;

	     if nargs > 0
	     then do argx = 1 to nargs;
		     call arg_getter (argx, ap, al, (0));
		     if character (arg, 1) = "-"
		     then do;
			     if arg = "-pathname" | arg = "-pn"
			     then do;
				     call get_next_list_arg;
				     call get_menu_seg_info;
				     pathname_present = "1"b;
				end;
			     else go to BAD_OPT;
			end;
		     else do;
			     if starname_present
			     then call gen_err (error_table_$too_many_args, "Only one starname may be given.");
			     starname = arg;
			     starname_present = "1"b;
			end;
		end;

	     if ^starname_present
	     then starname = "**";

	     if ^pathname_present
	     then call get_default_vseg_path;

	     menu_list_info_ptr = null ();
	     call menu_$list (dirname, ename, starname, get_system_free_area_ (), menu_list_info_version_1,
		menu_list_info_ptr, code);

	     if code ^= 0
	     then call gen_err (code, "");
	     if active
	     then af_value = "";

	     do argx = 1 to menu_list_info.n_names;
		begin;
		     declare name		      character (menu_list_info.names (argx).length)
					      defined (menu_list_info.name_string)
					      position (menu_list_info.names (argx).position);
		     if active
		     then af_value = af_value || requote_string_ (name) || " ";
		     else call ioa_ ("^a", name);

		end;
	     end;
	     if active
	     then af_value = rtrim (af_value);

get_next_list_arg:
     procedure;

	if argx = nargs
	then call gen_err (error_table_$noarg, "No pathname supplied with -pathname.");
	argx = argx + 1;
	call arg_getter (argx, ap, al, (0));
     end get_next_list_arg;

	end menu_list_begin;

	return;

menu_delete:
     entry options (variable);

	call set_flavor_of_command ("menu_delete", "0"b);

menu_delete_begin:
	begin;

	     declare argx		      fixed bin;
	     pathname_present = "0"b;

	     call get_menu_name ();

	     do argx = 2 to nargs;
		call arg_getter (argx, ap, al, (0));

		if arg = "-pathname" | arg = "-pn"
		then do;
			call get_next_delete_arg ();
			call get_menu_seg_info ();
			pathname_present = "1"b;
		     end;
		else go to BAD_OPT;
	     end;

	     if ^pathname_present
	     then call get_default_vseg_path;

	     call menu_$delete (dirname, ename, menu_name, code);
	     if code ^= 0
	     then call gen_err (code, "Could not delete menu " || menu_name || " from segment " || pathname);


get_next_delete_arg:
     procedure;
	if argx = nargs
	then call gen_err (error_table_$noarg, "");

	argx = argx + 1;

	call arg_getter (argx, ap, al, (0));
     end get_next_delete_arg;

	end menu_delete_begin;
	return;


/* COMMON UTILITIES FOR THE VARIOUS COMMANDS AND ACTIVE FUNCTIONS */

/* This procedure finds a menu in a menu segment. */

lookup_menu:
     procedure ();

	call menu_$retrieve (dirname, ename, menu_name, null, menu_ptr, code);
	if code ^= 0
	then call gen_err (code, "Looking up menu:  " || menu_name || " in " || pathname);

     end lookup_menu;

get_menu_name:
     proc ();

	call arg_getter (1, ap, al, code);
	if code ^= 0
	then call gen_err (code, "");
	menu_namep = ap;
	menu_name_len = al;

     end get_menu_name;

/* This one assumes that first arg is PATH of menu, and finds it.
   It may be OK for the seg not to exist (if we will create it).
   Sets GLOBAL variables for directory, etc.

*/
get_menu_seg_info:
     procedure ();
	declare expand_pathname_$add_suffix
				 entry (character (*), character (*), character (*), character (*),
				 fixed binary (35));

	call expand_pathname_$add_suffix (arg, SUFFIX, dirname, ename, code);
	if code ^= 0
	then call gen_err (code, arg);
	pathname = rtrim (dirname) || ">" || rtrim (ename);

     end get_menu_seg_info;



get_switch:
     procedure ();

	call iox_$look_iocb (arg, iocbp, code);
	if code ^= 0
	then call gen_err (code, "Looking for switch:  " || arg);

     end get_switch;

result:
     procedure (v);
	declare v			 char (8) aligned parameter;
	declare ioa_		 entry () options (variable);
	if active
	then af_value = v;
	else call ioa_ ("^a", v);
     end result;


set_flavor_of_command:
     procedure (name, active_ok);

/* This MUST be quick, or it will get the wrong arg list.
   In Hoc Signo Ursus
*/
	declare name		 char (*) parameter;
	declare active_ok		 bit (1) aligned parameter;

	declare active_fnc_err_	 entry () options (variable);
	declare com_err_		 entry () options (variable);
	declare cu_$arg_list_ptr	 entry (pointer);
	declare cu_$af_return_arg	 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	declare error_table_$not_act_fnc
				 fixed bin (35) ext static;

	myname = name;
	call cu_$arg_list_ptr (alp);
	call cu_$af_return_arg (nargs, afp, afl, code);
	if code = 0
	then do;
		active = "1"b;
		complain = active_fnc_err_;

		if ^active_ok
		then code = error_table_$active_function;
		if code ^= 0
		then goto USAGE;
	     end;
	else if code = error_table_$not_act_fnc
	then do;
		code = 0;
		active = "0"b;
		complain = com_err_;
		afp = null ();
	     end;
	else do;
		call com_err_ (code, myname);
		goto ERROR_EXIT;
	     end;
     end set_flavor_of_command;


arg_getter:
     procedure (argn, argp, argl, acode);
	declare argn		 fixed bin parameter;
	declare argp		 pointer parameter;
	declare argl		 fixed bin (21) parameter;
	declare acode		 fixed bin (35) parameter;
	declare cu_$af_arg_ptr_rel	 entry (fixed bin, ptr, fixed bin (21), fixed bin (35), pointer);
	declare cu_$arg_ptr_rel	 entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
	if active
	then call cu_$af_arg_ptr_rel (argn, argp, argl, acode, alp);
	else call cu_$arg_ptr_rel (argn, argp, argl, acode, alp);
     end arg_getter;


get_default_vseg_path:
     proc ();

	declare user_info_		 entry (char (*), char (*), char (*));
	declare user_info_$homedir	 entry (char (*));

	declare person_id		 char (22);

	call user_info_ (person_id, "", "");
	call user_info_$homedir (dirname);
	ename = rtrim (person_id) || ".value";
	pathname = rtrim (dirname) || ">" || ename;

     end get_default_vseg_path;


get_query_info:
     proc (code);

	declare code		 fixed bin (35);

	auto_query_info.version = query_info_version_5;
	auto_query_info.yes_or_no_sw = "1"b;
	auto_query_info.suppress_name_sw = "0"b;
	auto_query_info.suppress_spacing = "0"b;
	auto_query_info.cp_escape_control = "00"b;
	auto_query_info.status_code = code;
	auto_query_info.query_code = 0;
	auto_query_info.question_iocbp = null;
	auto_query_info.answer_iocbp = null;
	auto_query_info.repeat_time = 0;
	auto_query_info.explanation_ptr = null;
	auto_query_info.explanation_len = 0;

     end get_query_info;


gen_err:
     procedure (a_code, a_str);

	declare a_code		 fixed bin (35);
	declare a_str		 char (*);

	call complain (code, myname, "^a", a_str);
	go to ERROR_EXIT;

     end gen_err;

USAGE:
	call complain (code, myname, "Usage: ^a MENU {-control_args}", myname);
	go to ERROR_EXIT;

BAD_OPT:
	call complain (error_table_$badopt, myname, "^a", arg);
	goto ERROR_EXIT;

ERROR_EXIT:
	return;

%include menu_dcls;
%include iox_dcls;
%include terminal_info;
%include access_mode_values;
%include query_info;
%include function_key_data;
     end menu_create;




		    menu_et_.alm                    11/05/86  1235.1r w 11/04/86  1038.4        7731



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

"
"  Error Table for the Menu Software
"
"  James R Davis February 1981
"
	include	et_macros
	et	menu_et_

	ec	too_many_options,manyopt,(A menu can contain at most 61 choices.)
	ec	too_few_keys,few_keys,(There are fewer keys than choices.)

	ec	keys_not_unique,key_dup,(Each key must be unique.)

	ec	higher_than_max,too_high,(The menu will not fit within the specified maximum height.)
	
	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
