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