1 /* ******************************************************
  2    *                                                    *
  3    *                                                    *
  4    * Copyright (c) 1972 by Massachusetts Institute of   *
  5    * Technology and Honeywell Information Systems, Inc. *
  6    *                                                    *
  7    *                                                    *
  8    ****************************************************** */
  9 
 10 menu_:
 11      procedure;
 12           return;
 13 
 14 /* Subroutines for Menu Presentation.  MTB - 493
 15 
 16    James R. Davis January - February 1981
 17 
 18    entries here:
 19 
 20    create
 21    display
 22    get_choice
 23    describe
 24    destroy
 25    list
 26    store
 27    retrieve
 28 
 29 */
 30 
 31 /*
 32    Maintained by Suzanne L. Krupp
 33 
 34    Modified 06/05/81 by Suzanne Krupp to include store_menu and retrieve_menu
 35    entry points.
 36 
 37    Modified 06/29/81 to make store_menu and retrieve_menu entry points use
 38    value segments (so that we can now store more than one menu
 39    per segment.
 40 
 41    Modified 06/29/81 to fix bug in menu_$get_choice where it can't handle a
 42    function_key_data_ptr.
 43 
 44    Modified by BIM July 1981 for to remove the _menu from the names,
 45    fix up the value stuff, and add the delete and list entrypoints.
 46 
 47    Auditing changes BIM October 1981.
 48 
 49    Modified January 1981 by Chris Jones to make menus case-insensitive when possible.
 50 
 51    84-03-15 Davids: Modified call to hcs_$initiate in the LIST procedure
 52    to use the valiables dname and ename which are input to the LIST proc
 53    instead of using P_dname and P_ename which are input to the list entry
 54    which calls the LIST proc. A procedure should use its own parameters.
 55    This answers TR15713.
 56 
 57    84-09-18 Davids: Added calls to window_$sync after all calls to
 58    window_$overwrite_text. These occur in the display_menu entry and in the
 59    get_choice entry. This should prevent the pause that can occur when a menu
 60    is being displayed and the long delay that can occur between the time the
 61    user makes a selection and the time the selection is flaged with an asterix.
 62    Also deleted declared but unreferenced variables.
 63 */
 64 
 65 /* ***** INTERNAL REPRESENTATION OF A MENU ***** */
 66 
 67           declare 1 menu                 aligned based (menu_ptr),
 68                     2 version            char (8) init (MENU_VERSION),
 69                     2 window_requirements,                  /* size of menu */
 70                       3 height           fixed bin,         /* number of lines */
 71                       3 width            fixed bin,
 72                     2 n_options          fixed bin,
 73                     2 flags              unaligned,
 74                       3 case_insensitive bit (1) unal,
 75                       3 mbz1             bit (17) unal,
 76                     2 asterixed_option   fixed bin (17) unal,
 77                                                             /* or zero if none */
 78                     2 option_info        (61),              /* max is 61 */
 79                       3 key              char (1) unal,
 80                       3 pad              bit (27) unal,
 81                       3 line             fixed bin,         /* where to echo */
 82                       3 col              fixed bin,
 83                     2 lines              (lines_alloc refer (menu.height)) unal char (chars_alloc refer (menu.width));
 84 
 85           declare menu_ptr               pointer;
 86           declare menu_segment_ptr       ptr;
 87 
 88           declare MENU_VERSION           char (8) aligned internal static options (constant) init ("menu_v_3");
 89 
 90           declare lines_alloc            fixed bin (21);
 91           declare chars_alloc            fixed bin (21);
 92 
 93 
 94 /* Parameters of the various entries */
 95 
 96           declare (
 97                   P_choices              (*) char (*) varying,
 98                   P_create_sw            bit (1) aligned,
 99                   P_dname                char (*),
100                   P_ename                char (*),
101                   P_menu_name            char (*),
102                   P_headers              (*) char (*) varying,
103                   P_trailers             (*) char (*) varying,
104                   P_format_ptr           pointer,
105                   P_keys                 (*) char (1) unal,
106                   P_areap                pointer,
107                   P_needs_ptr            pointer,
108                   P_menu_ptr             pointer,
109                   P_code                 fixed bin (35),
110                   P_window               pointer,
111                   P_function_key_info_ptr
112                                          pointer,
113                   P_fkeyp                bit (1) aligned,
114                   P_selection            fixed bin,
115                   P_starname             character (*),
116                   P_list_ptr             pointer,
117                   P_mli_version          fixed bin
118                   )                      parameter;
119 
120           declare (
121                   error_table_$unimplemented_version,
122                   error_table_$noentry
123                   )                      fixed bin (35) external static;
124 
125           declare created_sw             bit (1) aligned;
126 
127           declare (addr, copy, currentsize, dimension, divide, hbound, index, length, lbound, max, mod, null, sign)
128                                          builtin;
129 
130           declare add_char_offset_       entry (pointer, fixed bin (21)) returns (pointer) reducible;
131           declare get_system_free_area_  entry () returns (ptr);
132           declare get_user_free_area_    entry () returns (pointer);
133           declare hcs_$initiate          entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr,
134                                          fixed bin (35));
135           declare hcs_$terminate_noname  entry (ptr, fixed bin (35));
136           declare hcs_$make_seg          entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
137           declare value_$init_seg        entry (ptr, fixed bin, ptr, fixed bin (19), fixed bin (35));
138           declare value_$get_data        entry (ptr, bit (36) aligned, char (*), ptr, ptr, fixed bin (18), fixed bin (35))
139                                          ;
140           declare value_$set_data        entry (ptr, bit (36) aligned, char (*), ptr, fixed bin (18), ptr, ptr,
141                                          fixed bin (18), fixed bin (35));
142           declare value_$list_data_names entry (pointer, bit (36) aligned, pointer, pointer, pointer, fixed binary (35));
143 
144 
145           declare cleanup                condition;
146 ^L
147 create_menu:
148 create:
149      entry (P_choices, P_headers, P_trailers, P_format_ptr, P_keys, P_areap, P_needs_ptr, P_menu_ptr, P_code);
150 common_create:
151           begin;
152                declare n_choices              fixed bin;
153                declare (header_ct, menu_ct, trailer_ct)
154                                               fixed bin;    /* lines devoted to each */
155                declare menu_et_$too_few_keys  fixed bin (35) ext static;
156                declare menu_et_$higher_than_max
157                                               fixed bin (35) external static;
158                declare menu_et_$too_many_options
159                                               fixed bin (35) ext static;
160                declare menu_et_$keys_not_unique
161                                               fixed bin (35) ext static;
162 
163                P_code = 0;
164                P_menu_ptr = null ();
165                menu_format_ptr = P_format_ptr;
166                menu_requirements_ptr = P_needs_ptr;
167                n_choices = dimension (P_choices, 1);
168 
169 /* check validity of parms */
170                if menu_format.version ^= menu_format_version_1 | menu_requirements.version ^= menu_requirements_version_1
171                then call ERROR (error_table_$unimplemented_version);
172                if menu_format.pad ^= "0"b
173                then call ERROR (error_table_$unimplemented_version);
174                if n_choices = 0                             /* Perhaps this should be an error? */
175                then ;                                       /* nothing to display */
176                if n_choices > dimension (P_keys, 1)
177                then call ERROR (menu_et_$too_few_keys);
178                if n_choices > hbound (menu.option_info, 1)
179                then call ERROR (menu_et_$too_many_options);
180                if ^all_keys_unique (n_choices)
181                then call ERROR (menu_et_$keys_not_unique);
182 
183 /* parms look good, now calculate size of screen image so we can allocate it */
184                header_ct = sign (length (P_headers (1))) * dimension (P_headers, 1);
185                menu_ct = divide (n_choices, menu_format.n_columns, 17) + sign (mod (n_choices, menu_format.n_columns));
186                trailer_ct = sign (length (P_trailers (1))) * dimension (P_trailers, 1);
187                lines_alloc = header_ct + menu_ct + trailer_ct;
188 
189                if menu_format.max_height > 0
190                then if lines_alloc > menu_format.max_height
191                     then call ERROR (menu_et_$higher_than_max);
192 
193                chars_alloc = menu_format.max_width;
194 
195                begin;
196                     declare based_area             area based (areap);
197                     declare areap                  ptr;
198 
199                     if P_areap ^= null
200                     then areap = P_areap;
201                     else areap = get_system_free_area_ ();
202 
203                     allocate menu in (based_area);
204                end;
205 
206 /* now fill in data structure */
207 
208                menu.version = MENU_VERSION;
209                menu.height = lines_alloc;
210                menu.width = chars_alloc;
211                menu.n_options = n_choices;
212                menu.flags = ""b;
213                menu.case_insensitive = not_mixed_cases (n_choices);
214                menu.asterixed_option = 0;
215 
216                menu.lines (*) = " ";
217                call format_screen ();
218                P_menu_ptr = menu_ptr;
219 
220                call fill_requirements_from_menu ();
221 
222                return;
223 ^L
224 all_keys_unique:
225      procedure (kc) returns (bit (1) aligned);
226           declare kc                     fixed bin parameter;
227                                                             /* how many matter */
228           declare i                      fixed bin;
229           declare (index, substr)        builtin;
230           declare key_overlay            char (kc) defined (P_keys);
231           do i = 1 to kc - 1;
232                if index (substr (key_overlay, kc + 1), P_keys (i)) > 0
233                then return ("0"b);                          /* a match ! */
234           end;
235           return ("1"b);
236      end all_keys_unique;
237 
238 not_mixed_cases:
239      proc (kc) returns (bit (1) unal);
240 
241           dcl     kc                     fixed bin;
242 
243           dcl     key_overlay            char (kc) defined (P_keys);
244           dcl     UPPER_CASE_LETTERS     char (26) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ") internal static options (constant);
245           dcl     LOWER_CASE_LETTERS     char (26) init ("abcdefghijklmnopqrstuvwxyz") internal static options (constant);
246 
247           if (search (key_overlay, UPPER_CASE_LETTERS) = 0) & (search (key_overlay, LOWER_CASE_LETTERS) = 0)
248           then return ("0"b);
249           if (search (key_overlay, UPPER_CASE_LETTERS) ^= 0) & (search (key_overlay, LOWER_CASE_LETTERS) ^= 0)
250           then return ("0"b);
251           return ("1"b);
252 
253      end not_mixed_cases;
254 ^L
255 
256 
257 /* BUILD SCREEN IMAGE:
258 
259    +------------------------------------------------------+ --
260    |_HEADER_ONE___________________________________________| header_ct = 2
261    |_HEADER_TWO___________________________________________| __
262    |_(1)_choice_one_|_(3)_choice_three_|_(4)_choice four__| menu_ct = 2
263    |_(2)_choice_two_|__________________|__________________| __
264    |_TRAILER______________________________________________| trailer_ct = 1
265 
266    <- chars_per_box ->
267 
268    choices are positioned  as evenly as possible:  never more than one extra
269    choice per column.  The portion of the screen devoted to choices begins
270    at the "first_option_char"'th char of the display image (lines).  The
271    choices are divided into "boxes".  If the number of choices is a multiple
272    of the  number of columns, the boxes are an array "n_columns" wide, and
273    choices/n_columns high.  And if there is a remainder R, the first R columns
274    get an extra choice.
275 
276 */
277 
278 format_screen:
279      procedure;
280           declare i                      fixed bin;
281           declare (first_header_line, first_menu_line, first_trailer_line)
282                                          fixed bin;
283           declare chars_per_box          fixed bin;
284           declare first_option_char      fixed bin (21);
285           declare extra                  fixed bin;
286 
287           first_header_line = 1;
288           first_menu_line = first_header_line + header_ct;
289           first_trailer_line = first_menu_line + menu_ct;
290 
291 /* the headers and trailers are easy */
292           do i = 1 to header_ct;
293                menu.lines (first_header_line + i - 1) =
294                     format (P_headers (i), menu_format.center_headers, menu_format.pad_char, menu_format.max_width);
295           end;
296           do i = 1 to trailer_ct;
297                menu.lines (first_trailer_line + i - 1) =
298                     format (P_trailers (i), menu_format.center_trailers, menu_format.pad_char, menu_format.max_width);
299           end;
300 
301           chars_per_box = divide (menu_format.max_width, menu_format.n_columns, 17);
302           extra = mod (menu_format.max_width, menu_format.n_columns);
303           first_option_char = (header_ct * menu.width) + 1;
304 
305 format_boxes:
306           begin;
307                declare 1 boxes                (0:menu_ct - 1) defined (menu.lines) position (first_option_char),
308                          2 row                (0:menu_format.n_columns - 1),
309                            3 constant,
310                              4 lp             char (2) unal,/* " (" */
311                              4 k              char (1) unal,/* key image */
312                              4 rp             char (2) unal,/* ") " */
313                            3 name             char (chars_per_box - 5) unal,
314                          2 pad                char (extra) unal;
315                declare menu_line              fixed bin;
316                declare menu_row               fixed bin;
317 
318                do i = 1 to hbound (P_choices, 1);
319                     menu.option_info (i).key = P_keys (i);
320                     call get_box_coords (i, menu_row, menu_line);
321                     menu.option_info (i).line = first_menu_line + menu_line;
322                     menu.option_info (i).col = 3 + menu_row * chars_per_box;
323 
324                     boxes (menu_line).row (menu_row).lp = " (";
325                     boxes (menu_line).row (menu_row).k = P_keys (i);
326                     boxes (menu_line).row (menu_row).rp = ") ";
327                     boxes (menu_line).row (menu_row).name = P_choices (i);
328                end;
329           end format_boxes;
330           return;
331 
332 get_box_coords:
333      procedure (mi, bx, by);
334           declare mi                     fixed bin parameter;
335                                                             /* input */
336           declare (by, bx)               fixed bin parameter;
337                                                             /* output */
338 
339           by = mod (mi - 1, menu_ct);
340           bx = divide (mi - 1, menu_ct, 17);
341      end get_box_coords;
342 
343 
344 /* This has an implementation limit of 200 chars / line, but
345    surely that is reasonable? - if I use returns (char(*)) I become
346    non-quick */
347 format:
348      procedure (raw, center, padc, ll) returns (char (200) varying);
349           declare raw                    char (*) varying parameter;
350           declare center                 bit (1) unal parameter;
351           declare padc                   char (1) aligned parameter;
352           declare ll                     fixed bin parameter;
353           declare lbuf                   char (200) varying;
354           declare lct                    fixed bin;
355 
356           if ^center
357           then lbuf = raw;
358           else do;
359                     lct = divide (max (0, ll - length (raw)), 2, 17);
360                     lbuf = copy (padc, lct);
361                     lbuf = lbuf || raw;
362                     lbuf = lbuf || copy (padc, lct + mod (lct, 2));
363                end;
364           return (lbuf);
365      end format;
366      end format_screen;
367 
368           end common_create;
369 ^L
370 display_menu:
371 display:
372      entry (P_window, P_menu_ptr, P_code);
373           call setup ();
374           begin;
375 
376                declare window_display_        entry (pointer, (*) char (*) unal, fixed bin (35));
377 
378                call window_display_ (P_window, menu.lines, P_code);
379                if menu.asterixed_option > 0
380                then do;
381                          call cursor_to_option ((menu.asterixed_option));
382                          call window_$overwrite_text (P_window, "*", P_code);
383                     end;
384                call window_$sync (P_window, P_code);
385           end;                                              /* begin block */
386           return;
387 ^L
388 get_choice:
389      entry (P_window, P_menu_ptr, P_function_key_info_ptr, P_fkeyp, P_selection, P_code);
390           call setup ();
391           function_key_data_ptr = P_function_key_info_ptr;
392           if function_key_data_ptr ^= null
393           then if function_key_data.version ^= function_key_data_version_1
394                then call ERROR (error_table_$unimplemented_version);
395 
396           begin;
397                declare c                      char (1);
398                declare cc                     char (1);
399                declare ck                     char (1);
400                declare opx                    fixed bin;    /* index thru options */
401                declare possible               bit (1) aligned;
402                declare fkeyb                  char (32) varying;
403                declare pseq                   char (pseql) based (pseqp);
404                declare pseql                  fixed bin (21);
405                declare pseqp                  ptr;
406 
407                if menu.asterixed_option ^= 0
408                then do;
409                          call cursor_to_option ((menu.asterixed_option));
410                          call window_$overwrite_text (P_window, menu.option_info (menu.asterixed_option).key, P_code);
411                          if P_code ^= 0
412                          then go to RETURN;
413                          call window_$sync (P_window, P_code);
414                          if P_code ^= 0
415                          then go to RETURN;
416                     end;
417 
418                call cursor_to_option (1);
419                do while ("1"b);                             /* until valid key hit */
420                     c = read_a_char ();
421                     if menu.case_insensitive
422                     then cc = upper_case (c);
423                     else cc = c;
424 
425                     do opx = 1 to menu.n_options;
426                          if menu.case_insensitive
427                          then ck = upper_case ((menu.option_info (opx).key));
428                          else ck = menu.option_info (opx).key;
429                          if cc = ck
430                          then do;
431                                    call cursor_to_option (opx);
432                                    P_fkeyp = "0"b;
433                                    P_selection = opx;
434 
435                                    call window_$overwrite_text (P_window, "*", P_code);
436                                    if P_code ^= 0
437                                    then go to RETURN;
438                                    menu.asterixed_option = opx;
439                                    call window_$sync (P_window, P_code);
440                                    go to RETURN;
441 
442 
443                               end;                          /* matching option */
444                     end;                                    /* loop thru options */
445                     if function_key_data_ptr ^= null
446                     then possible = "1"b;                   /* enter loop */
447                     else possible = "0"b;
448                     fkeyb = c;
449                     do while (possible);
450                          possible = "0"b;
451                          do opx = lbound (function_key_data.function_keys, 1)
452                               to hbound (function_key_data.function_keys, 1);
453                               pseql = function_key_data.function_keys (opx, KEY_PLAIN).sequence_length;
454                               pseqp =
455                                    add_char_offset_ (function_key_data.seq_ptr,
456                                    (function_key_data.function_keys (opx, KEY_PLAIN).sequence_index) - 1);
457 
458                               if length (pseq) = length (fkeyb) & pseq = fkeyb
459                               then do;
460                                         P_fkeyp = "1"b;
461                                         P_selection = opx;
462                                         return;
463                                    end;                     /* match - Win */
464                               else if ^possible             /* look for possibles */
465                               then if length (pseq) > length (fkeyb)
466                                                             /* we hope to match if we grow */
467                                    then if index (pseq, fkeyb) = 1
468                                                             /* pseq begins with fkeyb */
469                                         then possible = "1"b;
470                          end;                               /* loop thru f keys */
471                          if possible
472                          then fkeyb = fkeyb || read_a_char ();
473                     end;                                    /* if even one has hopes, keep trying */
474 
475 /* fall out, no match */
476                     call window_$bell (P_window, (0));
477 
478                end;                                         /* loop waiting for good one */
479 
480 read_a_char:
481      procedure returns (char (1));
482           declare ac                     char (1);
483           begin;
484                declare break                  character (1) varying;
485                call window_$get_unechoed_chars (P_window, 1, ac, (0), break, P_code);
486                if P_code ^= 0
487                then goto ERROR_EXIT;
488                if length (break) = 1
489                then ac = break;
490                /*** else ac already has the right thing */
491           end;
492           return (ac);
493      end read_a_char;
494 
495 upper_case:
496      proc (c) returns (char (1));
497 
498           dcl     c                      char (1);
499 
500           if (rank (c) < rank ("a")) | (rank (c) > rank ("z"))
501           then return (c);
502           else return (byte (rank (c) - (rank ("a") - rank ("A"))));
503 
504      end upper_case;
505           end;                                              /* begin block */
506 ^L
507 store_menu:
508 store:
509      entry (P_dname, P_ename, P_menu_name, P_create_sw, P_menu_ptr, P_code);
510 
511           call setup ();
512           menu_segment_ptr = null;
513           created_sw = "0"b;
514           on cleanup call term_menu ();
515 
516           call hcs_$initiate (P_dname, P_ename, "", 0, 1, menu_segment_ptr, P_code);
517           if P_code = error_table_$noentry & P_create_sw
518           then do;
519                     created_sw = "1"b;
520                     call hcs_$make_seg (P_dname, P_ename, "", RW_ACCESS_BIN, menu_segment_ptr, P_code);
521                     if menu_segment_ptr = null
522                     then go to SEG_ERR;
523                     call value_$init_seg (menu_segment_ptr, 0, null, 0, P_code);
524                     if P_code ^= 0
525                     then go to SEG_ERR;
526 
527                end;
528 
529           if menu_segment_ptr = null
530           then go to SEG_ERR;
531 
532           menu.asterixed_option = 0;
533 
534           call value_$set_data (menu_segment_ptr, "01"b, value_name (P_menu_name), P_menu_ptr, currentsize (menu), null,
535                null, (0), P_code);
536 
537           if P_code = 0                                     /* don't let term_menu delete new segment */
538           then created_sw = "0"b;                           /* if we succeeded */
539           call term_menu ();
540 
541           return;
542 
543 
544 delete_menu:
545 delete:
546      entry (P_dname, P_ename, P_menu_name, P_code);
547 
548           P_code = 0;
549           created_sw = "0"b;
550           on cleanup call term_menu;
551           call hcs_$initiate (P_dname, P_ename, "", 0, 1, menu_segment_ptr, P_code);
552           if menu_segment_ptr = null
553           then go to SEG_ERR;
554 
555 /* Should be changed to use delete_data as soon as that exists */
556 /* since that will give us an error if the value isn't there to delete */
557 
558           call value_$set_data (menu_segment_ptr, "01"b, value_name (P_menu_name), null, 0, null, null, (0), P_code);
559                                                             /* Null ptr deletes value */
560           call term_menu ();
561           return;
562 
563 retrieve_menu:
564 retrieve:
565      entry (P_dname, P_ename, P_menu_name, P_areap, P_menu_ptr, P_code);
566 
567           P_code = 0;
568           P_menu_ptr = null;
569           menu_segment_ptr = null;
570           created_sw = "0"b;
571           on cleanup call term_menu ();
572 
573           call hcs_$initiate (P_dname, P_ename, "", 0, 1, menu_segment_ptr, P_code);
574           if menu_segment_ptr = null
575           then go to SEG_ERR;
576 
577           begin;
578 
579                declare areap                  ptr;
580 
581                if P_areap = null
582                then areap = get_user_free_area_ ();
583                else areap = P_areap;
584 
585                call value_$get_data (menu_segment_ptr, "01"b, value_name (P_menu_name), areap, menu_ptr, (0), P_code);
586                if P_code ^= 0
587                then go to SEG_ERR;
588 
589           end;                                              /* begin */
590 
591 
592           if menu.version ^= MENU_VERSION
593           then do;
594                     P_code = error_table_$unimplemented_version;
595                     go to SEG_ERR;
596                end;
597 
598           P_menu_ptr = menu_ptr;
599           call term_menu ();
600 
601           return;
602 
603 
604 SEG_ERR:
605           call term_menu ();
606 
607           go to ERROR_EXIT;
608 
609 list_menus:
610 list:
611      entry (P_dname, P_ename, P_starname, P_areap, P_mli_version, P_list_ptr, P_code);
612 
613 
614           if P_mli_version ^= menu_list_info_version_1
615           then do;
616                     P_code = error_table_$unimplemented_version;
617                     return;
618                end;
619 
620           call LIST (P_dname, P_ename, P_starname, P_areap, P_list_ptr, P_code);
621           return;
622 
623 LIST:
624      procedure (dname, ename, starname, area_ptr, list_ptr, code);
625           declare (dname, ename, starname)
626                                          character (*);
627           declare area_ptr               pointer;
628           declare list_ptr               pointer;
629           declare (i, listx, vlistx)     fixed bin (21);
630           declare code                   fixed bin (35);
631           declare auto_area_ptr          pointer;
632           declare the_general_area       area based (auto_area_ptr);
633 
634           if area_ptr = null ()
635           then auto_area_ptr = get_user_free_area_ ();
636           else auto_area_ptr = area_ptr;
637 
638           code = 0;
639 
640           list_ptr, menu_segment_ptr, menu_list_info_ptr, match_info_ptr, value_list_info_ptr = null ();
641 
642           on cleanup
643                begin;
644                     if menu_list_info_ptr ^= null
645                     then free menu_list_info;
646                     if match_info_ptr ^= null
647                     then free match_info;
648                     if value_list_info_ptr ^= null
649                     then free value_list_info;
650                     if menu_segment_ptr ^= null
651                     then call hcs_$terminate_noname (menu_segment_ptr, (0));
652                end;
653 
654           call hcs_$initiate (dname, ename, "", 0, 1, menu_segment_ptr, code);
655           if menu_segment_ptr = null
656           then go to SEG_ERR;
657 
658           alloc_name_count = 1;
659           alloc_max_name_len = length (value_name (starname));
660           allocate match_info;
661 
662           match_info.version = match_info_version_1;
663           match_info.name_array (1).exclude_sw = "0"b;
664           match_info.name_array (1).regexp_sw = "0"b;
665           match_info.name_array (1).pad = ""b;
666           match_info.name_array (1).name = value_name (starname);
667 
668           call value_$list_data_names (menu_segment_ptr, "01"b, match_info_ptr, get_system_free_area_ (),
669                value_list_info_ptr, code);
670           free match_info;
671           if code ^= 0
672           then return;
673 
674 
675           menu_list_n_names = value_list_info.pair_count;
676           menu_list_name_string_length =
677                sum (value_list_info.name_len) - (value_list_info.pair_count * length (".menu_"));
678 
679           allocate menu_list_info in (the_general_area);
680 
681           menu_list_info.version = menu_list_info_version_1;
682 
683           listx = 1;
684           do i = 1 to value_list_info.pair_count;
685                menu_list_info.position (i) = listx;
686                menu_list_info.length (i) = value_list_info.name_len (i) - length (".menu_");
687 
688                vlistx = value_list_info.name_index (i);
689 
690                substr (menu_list_info.name_string, listx, menu_list_info.length (i)) =
691                     substr (value_list_info.chars, vlistx, menu_list_info.length (i));
692                listx = listx + menu_list_info.length (i);
693           end;
694 
695           list_ptr = addr (menu_list_info);
696           free value_list_info;
697           call hcs_$terminate_noname (menu_segment_ptr, (0));
698      end LIST;
699 
700 /* This is called whenever we leave store_menu or retrieve_menu.
701    It terminates the null refname. */
702 
703 term_menu:
704      procedure ();
705 
706           declare hcs_$terminate_noname  entry (ptr, fixed bin (35));
707           declare delete_$ptr            entry (pointer, bit (6), character (*), fixed binary (35));
708 
709           if menu_segment_ptr ^= null
710           then if created_sw
711                then call delete_$ptr (menu_segment_ptr, "100101"b, "", (0));
712                else call hcs_$terminate_noname (menu_segment_ptr, (0));
713 
714      end term_menu;
715 
716 value_name:
717      procedure (name) returns (character (*));
718           declare name                   character (*);
719 
720           return (rtrim (name) || ".menu_");                /* user may not add the suffix themselves */
721      end value_name;
722 ^L
723 describe_menu:
724 describe:
725      entry (P_menu_ptr, P_needs_ptr, P_code);
726 
727           call setup ();
728           menu_requirements_ptr = P_needs_ptr;
729           if menu_requirements.version ^= menu_requirements_version_1
730           then do;
731                     P_code = error_table_$unimplemented_version;
732                     return;
733                end;
734 
735           call fill_requirements_from_menu ();
736           return;
737 
738 
739 fill_requirements_from_menu:
740      procedure ();
741 
742           menu_requirements.lines_needed = menu.height;
743           menu_requirements.width_needed = menu.width;
744           menu_requirements.n_options = menu.n_options;
745      end fill_requirements_from_menu;
746 
747 
748 
749 destroy_menu:
750 destroy:
751      entry (P_menu_ptr, P_code);
752           call setup ();
753           free menu_ptr -> menu;
754           return;
755 
756 
757 
758 setup:
759      procedure ();
760           P_code = 0;
761           if P_menu_ptr -> menu.version ^= MENU_VERSION
762           then call ERROR (error_table_$unimplemented_version);
763           menu_ptr = P_menu_ptr;
764      end setup;
765 
766 
767 cursor_to_option:
768      procedure (e);
769           declare e                      fixed bin parameter;
770           call window_$position_cursor (P_window, menu.option_info (e).line, menu.option_info (e).col, P_code);
771           if P_code ^= 0
772           then goto ERROR_EXIT;
773 
774      end cursor_to_option;
775 
776 
777 ERROR:
778      procedure (code);
779           declare code                   fixed bin (35) parameter;
780           P_code = code;
781           goto ERROR_EXIT;
782      end ERROR;
783 
784 RETURN:
785 ERROR_EXIT:
786           return;
787 ^L
788 %include menu_dcls;
789 %include window_dcls;
790 %include function_key_data;
791 %include access_mode_values;
792 %include value_structures;
793 %include menu_list_info;
794      end menu_;