1 /****^  ******************************************************
  2         *                                                    *
  3         * Copyright, (C) Honeywell Bull Inc., 1987           *
  4         *                                                    *
  5         * Copyright (c) 1972 by Massachusetts Institute of   *
  6         * Technology and Honeywell Information Systems, Inc. *
  7         *                                                    *
  8         ****************************************************** */
  9 
 10 /* Command interface for video */
 11 /* format: style4,delnl,insnl,indattr,ifthen,dclind9 */
 12 /* Benson I. Margulies, too late in the summer of 1981 */
 13 /* Modified by Chris Jones, 29 October 1981, to handle "undocumented" keys
 14    and control args. */
 15 /* Modified by Jon A. Rochlis, 14 June 1983, to add supported_terminal and
 16    video_invoked keywords. */
 17 /* Modified by JR, 1 October 1983, to add support for partial screen width
 18    windows. */
 19 /* Modified by JR, 28 June 1984, to add get_window_width, since I forgot about
 20    it in October. */
 21 /* Modified by C. Marker 6 September 1984, to add -line_speed. */
 22 
 23 wdc:
 24 window_call:
 25      procedure options (variable);
 26 
 27 declare  cu_$arg_list_ptr       entry returns (ptr);
 28 declare  arg_list_ptr           pointer;
 29 
 30           arg_list_ptr = cu_$arg_list_ptr ();
 31 
 32           begin;                                            /* to allow some useful declarations */
 33 
 34 declare  1 irep                 (window_call_data_$n_ctl_args) aligned,
 35            2 allowed            bit (1) aligned,
 36            2 required           bit (1) aligned,
 37            2 found              bit (1) aligned,
 38            2 argument           fixed bin,
 39            2 arg                aligned,                    /* if there was a following key */
 40              3 value            fixed bin,
 41              3 ptr              pointer unaligned,
 42              3 length           fixed bin (21);
 43 
 44 
 45 declare  key                    character (32);
 46 declare  keyx                   fixed bin (21);
 47 
 48 declare  1 this_f               aligned like function based (this_f_ptr);
 49 declare  this_f_ptr             pointer;
 50 
 51 
 52 declare  argument_ptr           pointer;
 53 declare  argument_length        fixed bin (21);
 54 declare  argument               character (argument_length) based (argument_ptr);
 55 
 56 declare  rs_ptr                 pointer;
 57 declare  rs_length              fixed bin (21);
 58 declare  return_string          character (rs_length) varying based (rs_ptr);
 59 
 60 declare  save_argument          character (32);
 61 
 62 declare  this_is_an_af          bit (1) aligned;
 63 declare  error_reporter         entry options (variable) variable;
 64 declare  n_arguments            fixed bin;
 65 declare  iocb_ptr               pointer;
 66 declare  code                   fixed bin (35);
 67 declare  (ctlx, argx)           fixed bin;
 68 
 69 declare  ME                     character (32) init ("window_call") internal static options (constant);
 70 
 71 declare  com_err_               entry () options (variable);
 72 declare  active_fnc_err_        entry () options (variable);
 73 declare  requote_string_        entry (character (*)) returns (character (*));
 74 
 75 declare  cu_$af_return_arg_rel  entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
 76 declare  cu_$arg_ptr_rel        entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
 77 declare  cv_dec_check_          entry (character (*), fixed binary (35)) returns (fixed binary (35));
 78 declare  ioa_                   entry () options (variable);
 79 
 80 declare  video_utils_$turn_on_login_channel
 81                                 entry (fixed binary (35), character (*));
 82 declare  video_utils_$turn_off_login_channel
 83                                 entry (fixed binary (35));
 84 
 85 declare  (
 86          error_table_$nodescr,
 87          error_table_$not_act_fnc,
 88          error_table_$noarg,
 89          error_table_$bad_arg,
 90          error_table_$badopt,
 91          error_table_$active_function,
 92          error_table_$bad_conversion,
 93          video_et_$wsys_invoked,
 94          video_et_$wsys_not_invoked
 95          )                      ext static fixed bin (35);
 96 
 97 declare  video_data_$terminal_iocb
 98                                 pointer external;
 99 
100 declare  (addr, character, length, ltrim, null, substr, translate)
101                                 builtin;
102 %page;
103 %include window_dcls;
104 %include window_control_info;
105 %include iox_dcls;
106 %include iox_modes;
107 %page;
108 /* Someday ... */
109 ^L
110 
111                call cu_$af_return_arg_rel (n_arguments, rs_ptr, rs_length, code, arg_list_ptr);
112 
113                if n_arguments = 0 | code = error_table_$nodescr then do;
114                                                             /* was called as AF, no args */
115                     if code = 0 then
116                          call active_fnc_err_ (0, ME, "Usage: window_call call KEY ARGUMENTS.");
117                     else call com_err_ (0, ME, "Usage: window_call KEY ARGUMENTS.");
118                     go to RETURN;
119                end;
120 
121                if code = error_table_$not_act_fnc then do;
122                     this_is_an_af = "0"b;
123                     error_reporter = com_err_;
124                end;
125 
126                else do;                                     /* Code MUST be 0, by contract */
127                     this_is_an_af = "1"b;
128                     error_reporter = active_fnc_err_;
129                end;
130 
131                wcd_functions_ptr = addr (window_call_data_$functions);
132                wcd_names_ptr = addr (window_call_data_$names);
133                wcd_string_ptr = addr (window_call_data_$string);
134                wcd_ctl_args_ptr = addr (window_call_data_$ctl_args);
135 
136                call cu_$arg_ptr_rel (1, argument_ptr, argument_length, (0), arg_list_ptr);
137 
138                if character (argument, 1) = "-" then do;
139                     call error_reporter (error_table_$noarg, ME, "The function keyword must be the first argument.");
140                     go to RETURN;
141                end;
142 
143                do keyx = 1 to window_call_data_$n_keys while (argument ^= "");
144                     if argument = window_call_data_names (keyx).long | argument = window_call_data_names (keyx).short
145                          | argument = window_call_data_names (keyx).undocumented_long
146                          | argument = window_call_data_names (keyx).undocumented_short then
147                          go to HAVE_KEYX;
148                end;
149 
150                call ERROR_REPORTER (error_table_$badopt, ME, "Unrecognized key ""^a"".", argument);
151                go to RETURN;
152 
153 HAVE_KEYX:
154                key = window_call_data_names (keyx).long;
155                this_f_ptr = addr (window_call_data_functions (keyx));
156 
157                if this_is_an_af & ^this_f.af_allowed then do;
158                     call active_fnc_err_ (error_table_$active_function, ME);
159                     go to RETURN;
160                end;
161 
162 /* Now we are ready to parse for this_f */
163 
164                irep.found (*) = "0"b;
165                irep.arg (*).ptr = null;
166                irep.arg (*).length = 0;
167                irep = this_f.args, by name;                 /* pick up flags */
168                irep = window_call_data_ctl_args, by name;
169 
170 main_argument_loop:
171                do argx = 2 to n_arguments;
172                     call cu_$arg_ptr_rel (argx, argument_ptr, argument_length, (0), arg_list_ptr);
173 
174 /* first see if its a control argument. It has to be, we have no
175    positionals */
176 
177                     if character (argument, 1) ^= "-" | length (argument) < 2 then do;
178                          call ERROR_REPORTER (error_table_$badopt, ME, "The argument ^a is out of place.", argument);
179                          go to RETURN;
180                     end;
181 
182 /* Now, is it a control argument we
183    (1) recognize at all, and
184    (2) allow for this key? */
185 
186                     do ctlx = 1 to window_call_data_$n_ctl_args;
187                          if (substr (argument, 2) = window_call_data_ctl_args (ctlx).name.long
188                               | substr (argument, 2) = window_call_data_ctl_args (ctlx).name.undocumented_long
189                               | substr (argument, 2) = window_call_data_ctl_args (ctlx).name.short
190                               | substr (argument, 2) = window_call_data_ctl_args (ctlx).name.undocumented_short)
191                               & irep (ctlx).allowed then
192                               go to HAVE_CTLX;
193                     end;
194 
195 /* Unrecognized */
196 
197                     call ERROR_REPORTER (error_table_$badopt, ME, "^a.", argument);
198                     go to RETURN;
199 
200 HAVE_CTLX:
201                     irep (ctlx).found = "1"b;
202 
203                     if irep (ctlx).argument ^= A_NONE then do;
204                                                             /* trailing parameter dept */
205                          argx = argx + 1;
206                          save_argument = argument;
207                          if argx > n_arguments then do;
208 NOARG:
209                               call ERROR_REPORTER (error_table_$noarg, ME,
210                                    "Control argument ^a requires a ^[^s^;numeric^;string^] parameter.", save_argument,
211                                    irep (ctlx).argument);
212                               go to RETURN;
213                          end;
214 
215                          call cu_$arg_ptr_rel (argx, argument_ptr, argument_length, (0), arg_list_ptr);
216 
217                          if irep (ctlx).argument = A_NUMBER then do;
218                               irep (ctlx).value = cv_dec_check_ (argument, code);
219                               if code ^= 0 then do;
220 
221                                    if character (argument, 1) = "-" then
222                                         go to NOARG;
223 
224                                    if code <= length (argument) then
225                                         call ERROR_REPORTER (error_table_$bad_conversion, ME,
226                                              "Converting ^a to an integer.", argument);
227                                    else call ERROR_REPORTER (code, ME, "Converting ^a to an integer.", argument);
228                                    go to RETURN;
229                               end;
230                          end;
231                          else do;
232                               irep (ctlx).ptr = argument_ptr;
233                               irep (ctlx).length = argument_length;
234                          end;
235                     end;
236                end main_argument_loop;
237 
238 /* Last Parse Step. Make sure all the requirements were met */
239 
240 
241                do ctlx = 1 to window_call_data_$n_ctl_args;
242                     if irep (ctlx).required & ^irep (ctlx).found then do;
243 USAGE:
244                          call ERROR_REPORTER (error_table_$noarg, ME, "Usage: window_call ^a ^a.", key,
245                               substr (window_call_data_string, this_f.usage.index, this_f.usage.length));
246                          go to RETURN;
247                     end;
248                end;
249 
250 /* Here Endeth the Parse. */
251 ^L
252 
253 /* Here come the semantics. One action routine for each function. */
254 
255                go to DO_IT (keyx);                          /* we trust keyx */
256 
257 /* The order of these must match the order they are generated
258    in window_call_data_. A perfect job for pl1_macro, but thats
259    too much hair for now. Anyway, we would have to carry constants
260    invented in one program into another. */
261 
262 DO_IT (1):                                                  /* clear window */
263                call get_iocb;                               /* use -io_switch or user_i/o */
264                call window_$clear_window (iocb_ptr, code);
265                go to CHECK_RETURN;
266 
267 DO_IT (2):                                                  /* Bell */
268                call get_iocb;
269                call window_$bell (iocb_ptr, code);
270                go to CHECK_RETURN;
271 
272 DO_IT (3):                                                  /* Clear Region */
273                call get_iocb;
274 
275                if ^irep (C_COLUMN).found then
276                     irep (C_COLUMN).value = 1;
277                if ^irep (C_N_COLUMNS).found then do;
278                     call get_window_info;
279                     irep (C_N_COLUMNS).value = window_info.width - irep (C_COLUMN).value + 1;
280                end;
281                call window_$clear_region (iocb_ptr, irep (C_LINE).value, irep (C_COLUMN).value, irep (C_N_LINES).value,
282                     irep (C_N_COLUMNS).value, code);
283                go to CHECK_RETURN;
284 
285 DO_IT (4):                                                  /* Clear to end of line */
286                call get_iocb;
287                call window_$clear_to_end_of_line (iocb_ptr, code);
288                go to CHECK_RETURN;
289 
290 DO_IT (5):
291                call get_iocb;
292                call window_$clear_to_end_of_window (iocb_ptr, code);
293                go to CHECK_RETURN;
294 
295 DO_IT (6):
296                call get_iocb;
297                call window_$delete_chars (iocb_ptr, irep (C_COUNT).value, code);
298                go to CHECK_RETURN;
299 
300 DO_IT (7):                                                  /* Get Position */
301                begin;
302 declare  (l, c)                 fixed bin;
303 
304                     call get_iocb;
305                     call window_$get_cursor_position (iocb_ptr, l, c, code);
306                     if code ^= 0 then
307                          go to CHECK_RETURN;
308 
309                     if this_is_an_af then
310                          return_string = ltrim (character (l)) || " " || ltrim (character (c));
311                     else call ioa_ ("Line = ^d; Column = ^d.", l, c);
312                     go to RETURN;
313                end;
314 ^L
315 
316 DO_IT (8):                                                  /* Get echoed chars */
317                call get ("1"b);                             /* Does not return */
318 
319 DO_IT (9):                                                  /* Get unechoed */
320                call get ("0"b);
321 
322 DO_IT (10):                                                 /* insert_text */
323                call get_iocb;
324 declare  text                   character (irep (C_STRING).length) based (irep (C_STRING).ptr);
325 
326 
327                call window_$insert_text (iocb_ptr, text, code);
328                go to CHECK_RETURN;
329 
330 DO_IT (11):                                                 /* Overwrite_text */
331                call get_iocb;
332                call window_$overwrite_text (iocb_ptr, text, code);
333                go to CHECK_RETURN;
334 
335 DO_IT (12):                                                 /* position cursor */
336                call get_iocb;
337                call window_$position_cursor (iocb_ptr, irep (C_LINE).value, irep (C_COLUMN).value, code);
338                go to CHECK_RETURN;
339 
340 
341 DO_IT (13):                                                 /* position cursor rel */
342                call get_iocb;
343                call window_$position_cursor_rel (iocb_ptr, irep (C_LINE).value, irep (C_COLUMN).value, code);
344                go to CHECK_RETURN;
345 
346 
347 DO_IT (14):                                                 /* Scroll Region */
348                call get_iocb;
349                if ^irep (C_LINE).found then
350                     irep (C_LINE).value = 1;
351 
352                if ^irep (C_N_LINES).found then do;
353                     call get_window_info;
354                     irep (C_N_LINES).value = window_info.height - irep (C_LINE).value + 1;
355                end;
356 
357                call window_$scroll_region (iocb_ptr, irep (C_LINE).value, irep (C_N_LINES).value, irep (C_COUNT).value,
358                     code);
359                go to CHECK_RETURN;
360 
361 DO_IT (15):                                                 /* SYNC */
362                call get_iocb;
363                call window_$sync (iocb_ptr, code);
364                go to CHECK_RETURN;
365 
366 DO_IT (16):                                                 /* Write Sync Read */
367                begin;
368 declare  buffer                 character (irep (C_COUNT).value);
369 declare  break                  character (1) varying;
370 declare  n_read                 fixed bin (21);
371 declare  prompt                 character (irep (C_STRING).length) based (irep (C_STRING).ptr);
372 
373                     call get_iocb;
374                     call window_$write_sync_read (iocb_ptr, prompt, length (buffer), buffer, n_read, break, code);
375                     if code ^= 0 then
376                          go to CHECK_RETURN;
377 
378                     begin;
379 declare  read                   character (n_read) defined (buffer) position (1);
380                          if this_is_an_af then
381                               return_string = requote_string_ (read) || " " || requote_string_ ((break));
382                          else call ioa_ ("Read = ^a; Break = ^a.", requote_string_ (read), requote_string_ ((break)));
383                     end;                                    /* inner begin */
384                end;                                         /* outer begin */
385                go to RETURN;
386 
387 /* INVOKE */
388 
389 DO_IT (17):
390                if video_data_$terminal_iocb ^= null () then do;
391                     call ERROR_REPORTER (video_et_$wsys_invoked, ME);
392                     go to RETURN;
393                end;
394 
395                begin options (non_quick);
396 declare  reason                 character (512);
397 declare  line_speed             fixed bin;
398 
399                     if irep (C_LINE_SPEED).found then do; /* we have line speed */
400                          line_speed = irep (C_LINE_SPEED).value;
401                          if line_speed < 0 then do;
402                               call ERROR_REPORTER (error_table_$bad_arg, ME, "^a", "Negative value not allowed for line speed.");
403                               go to RETURN;
404                          end;
405                     end;
406 
407                     call video_utils_$turn_on_login_channel (code, reason);
408                     if code ^= 0 then do;
409                          call ERROR_REPORTER (code, ME, "^a", reason);
410                          go to RETURN;
411                     end;
412 
413                     if irep (C_LINE_SPEED).found then do; /* we have line speed */
414                          call iox_$control (video_data_$terminal_iocb, "set_line_speed", addr (line_speed), code);
415                          if code ^= 0 then
416                               go to CHECK_RETURN;
417                     end;
418 
419                     go to RETURN;
420                end;
421 
422 /*  REVOKE */
423 
424 DO_IT (18):
425                call video_utils_$turn_off_login_channel ((0));
426                go to RETURN;
427 
428 /* CREATE */
429 
430 DO_IT (19):
431                begin options (non_quick);
432 declare  wiocbp                 pointer;
433 declare  1 wpi                  aligned like window_position_info;
434 declare  switch_name            character (irep (C_SWITCH).length) based (irep (C_SWITCH).ptr);
435 
436                     call iox_$find_iocb (switch_name, wiocbp, code);
437                     if code ^= 0 then
438                          go to CHECK_RETURN;
439 
440                     wpi.version = window_position_info_version_1;
441                     if irep (C_LINE).found then
442                          wpi.origin.line = irep (C_LINE).value;
443                     else wpi.origin.line = 1;
444 
445                     if irep (C_N_LINES).found then
446                          wpi.extent.height = irep (C_N_LINES).value;
447                     else wpi.extent.height = 0;
448 
449                     if irep (C_COLUMN).found then
450                          wpi.origin.column = irep (C_COLUMN).value;
451                     else wpi.origin.column = 0;
452 
453                     if irep (C_N_COLUMNS).found then
454                          wpi.extent.width = irep (C_N_COLUMNS).value;
455                     else wpi.extent.width = 0;
456 
457                     call window_$create (video_data_$terminal_iocb, addr (wpi), wiocbp, code);
458                     if code ^= 0 then
459                          go to CHECK_RETURN;
460                     return;
461 
462                end;
463 
464 DO_IT (20):
465                call get_iocb;           /* Delete Window */
466 
467                call window_$destroy (iocb_ptr, code);
468                if code ^= 0 then
469                     go to CHECK_RETURN;
470                return;                                      /* Change Window */
471 
472 DO_IT (21):
473                call get_iocb;
474                call get_window_info;
475 
476 /* Life is more complicated with partial width windows.  One can now change
477    widths as well as heights ... up until this point, one had to specify
478    at least one of C_LINE/C_N_LINES, now one must specify one of those *or*
479    one of C_COLUMN/C_N_COLUMNS. */
480 
481                if ^(irep (C_LINE).found | irep (C_N_LINES).found |
482                     irep (C_COLUMN).found  | irep (C_N_COLUMNS).found)
483                     then go to USAGE;
484 
485                if irep (C_LINE).found then
486                     window_info.origin.line = irep (C_LINE).value;
487 
488                if irep (C_N_LINES).found then
489                     window_info.height = irep (C_N_LINES).value;
490                else do; /* use rest of screen */
491                     call get_capabilities (video_data_$terminal_iocb);
492                     if window_info.origin.line + window_info.height - 1 > ci.rows then
493                          window_info.height = ci.rows - window_info.origin.line + 1;
494                end;
495 
496                if irep (C_COLUMN).found then
497                     window_info.origin.column = irep (C_COLUMN).value;
498 
499                if irep (C_N_COLUMNS).found then
500                     window_info.width = irep (C_N_COLUMNS).value;
501                else do; /* use rest of screen */
502                     call get_capabilities (video_data_$terminal_iocb);
503                     if window_info.origin.column + window_info.width - 1 > ci.columns then
504                          window_info.width = ci.columns - window_info.origin.column + 1;
505                end;
506 
507                call iox_$control (iocb_ptr, "set_window_info", addr (window_info), code);
508                go to CHECK_RETURN;
509 
510 DO_IT (22):                                                 /* get first line */
511                call get_iocb;
512                call get_window_info;
513                if this_is_an_af then
514                     return_string = ltrim (character (window_info.origin.line));
515                else call ioa_ ("First line = ^d.", window_info.origin.line);
516                go to RETURN;
517 
518 DO_IT (23):                                                 /* get n lines */
519                call get_iocb;
520                call get_window_info;
521 
522                if this_is_an_af then
523                     return_string = ltrim (character (window_info.height));
524                else call ioa_ ("Height = ^d.", window_info.height);
525                go to RETURN;
526 
527 DO_IT (24):                                                 /* get n columns */
528                call get_iocb;
529                call get_window_info;
530 
531                if this_is_an_af then
532                     return_string = ltrim (character (window_info.width));
533                else call ioa_ ("Width = ^d.", window_info.width);
534                go to RETURN;
535 ^L
536 %include terminal_capabilities;
537 declare  1 ci                   aligned like capabilities_info;
538 
539 DO_IT (25):                                                 /* get_terminal_height */
540                call get_capabilities (video_data_$terminal_iocb);
541                if this_is_an_af then
542                     return_string = ltrim (character (ci.screensize.rows));
543                else call ioa_ ("Terminal Height = ^d rows.", ci.screensize.rows);
544                go to RETURN;
545 
546 DO_IT (26):                                                 /* get terminal width */
547                call get_capabilities (video_data_$terminal_iocb);
548                if this_is_an_af then
549                     return_string = ltrim (character (ci.screensize.columns));
550                else call ioa_ ("Terminal Width = ^d columns.", ci.screensize.columns);
551                go to RETURN;
552 
553 DO_IT (27):                                                 /* Get one (but always block) */
554                call get_iocb;
555                begin;
556 declare  one                    character (1) varying;
557 
558                     call window_$get_one_unechoed_char (iocb_ptr, one, "1"b, code);
559                     if code ^= 0 then
560                          go to CHECK_RETURN;
561 
562                     if this_is_an_af then
563                          return_string = requote_string_ ((one));
564                     else call ioa_ ("Char = ""^a""", one);
565                     return;
566                end;
567 
568 DO_IT(28):               /* supported terminal */
569 
570 %include terminal_info;
571 
572 dcl 1 ti like terminal_info;
573 
574 dcl supported_ttp bit(1);
575 dcl ttp_length fixed binary,
576     ttp_ptr pointer;
577 dcl ttp char (ttp_length) based (ttp_ptr);
578 
579 dcl ttt_info_$video_info entry (char(*), fixed bin, ptr, ptr, fixed bin(35));
580 dcl error_table_$no_table fixed bin(35) ext static;
581 
582 dcl     uppercase              char (26) static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
583 dcl     lowercase              char (26) static options (constant) init ("abcdefghijklmnopqrstuvwxyz");
584 
585                if irep(C_TERMINAL_TYPE).found then
586                          do;  /* user gave us a terminal type */
587                               ttp_length = irep(C_TERMINAL_TYPE).length;
588                               ttp_ptr = irep(C_TERMINAL_TYPE).ptr;
589                          end;
590                     else
591                          do; /* user didn't give us one, let's get the current type */
592                               ti.version = 1;
593                               call iox_$control(iox_$user_io, "terminal_info", addr(ti), code);
594                               if code ^= 0 then goto CHECK_RETURN;
595                               ttp_length = length(ti.term_type);
596                               ttp_ptr = addr(ti.term_type);
597                          end;
598 
599                ttp = translate(ttp, uppercase, lowercase); /* ttt_info_ is case sensitive */
600                call ttt_info_$video_info (ttp, (0), null(), null(), code);
601 
602                if code ^= 0 & code ^= error_table_$no_table then goto CHECK_RETURN;
603                if code = error_table_$no_table then supported_ttp = "0"b;
604                               else supported_ttp = "1"b;
605 
606                if this_is_an_af then
607                          if supported_ttp then return_string = "true"; else return_string = "false";
608                     else
609                          call ioa_ ("The ^a terminal type is ^[not ^]supported by the video system.", ttp, ^supported_ttp);
610                goto RETURN;
611 
612 DO_IT(29):          /* video invoked? */
613 
614 dcl video_invoked bit(1);
615 
616                video_invoked = video_data_$terminal_iocb ^= null();
617 
618                if this_is_an_af then
619                          if video_invoked then return_string = "true"; else return_string = "false";
620                     else
621                          call ioa_ ("The video system has ^[not ^]been invoked.", ^video_invoked);
622                goto RETURN;
623 ^L
624 get_capabilities:
625      procedure (iocb_ptr);
626 
627 declare  iocb_ptr               ptr;
628 
629           ci.version = capabilities_info_version_1;
630           call iox_$control (iocb_ptr, "get_capabilities", addr (ci), code);
631           if code ^= 0 then
632                go to CHECK_RETURN;
633      end get_capabilities;
634 
635 get:
636      procedure (echo_flag);
637 declare  break                  character (1) varying;
638 declare  buffer                 character (irep (C_COUNT).value);
639 declare  echo_flag              bit (1) aligned;
640 declare  n_read                 fixed bin (21);
641 
642           call get_iocb;
643 
644           if echo_flag then
645                call window_$get_echoed_chars (iocb_ptr, length (buffer), buffer, n_read, break, code);
646           else call window_$get_unechoed_chars (iocb_ptr, length (buffer), buffer, n_read, break, code);
647           if code ^= 0 then
648                go to CHECK_RETURN;
649 
650           begin;
651 declare  read                   character (n_read) defined (buffer) pos (1);
652 
653                if this_is_an_af then
654                     return_string = requote_string_ (read) || " " || requote_string_ ((break));
655                else call ioa_ ("Read = ^a, Break = ^a.", requote_string_ (read), requote_string_ ((break)));
656           end;
657           go to RETURN;
658      end get;
659 
660 get_iocb:
661      procedure;
662 
663           if ^irep (C_SWITCH).found then
664                iocb_ptr = iox_$user_io;
665           else begin;
666 declare  switch_name            character (irep (C_SWITCH).length) based (irep (C_SWITCH).ptr);
667 
668                call iox_$look_iocb (switch_name, iocb_ptr, code);
669                if code ^= 0 then
670                     go to CHECK_RETURN;
671           end;
672      end get_iocb;
673 ^L
674 
675 declare  1 window_info          aligned like window_position_info;
676 
677 get_window_info:
678      procedure;
679 
680           window_info.version = window_position_info_version_1;
681           call iox_$control (iocb_ptr, "get_window_info", addr (window_info), code);
682           if code ^= 0 then
683                go to CHECK_RETURN;
684      end get_window_info;
685 
686 CHECK_RETURN:
687                if code ^= 0 then
688                     call ERROR_REPORTER (code, ME, "(^a)", key);
689                go to RETURN;
690 
691 ERROR_REPORTER:
692      procedure options (variable, support);
693 
694 declare  code                   fixed bin (35) based (code_ptr);
695 declare  code_ptr               pointer;
696 declare  error_table_$undefined_order_request
697                                 fixed bin (35) ext static;
698 declare  cu_$arg_ptr            entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
699 declare  cu_$generate_call      entry (entry, ptr);
700 
701           call cu_$arg_ptr (1, code_ptr, (0), (0));         /* assume we are called with at least one */
702           if code = error_table_$undefined_order_request then
703                cu_$arg_list_ptr () -> arg_list.arg_ptrs (1) = addr (video_et_$wsys_not_invoked);
704           call cu_$generate_call (error_reporter, cu_$arg_list_ptr ());
705 
706 %include arg_list;
707 
708      end ERROR_REPORTER;
709 
710           end;                                              /* The begin block */
711 RETURN:
712           return;
713 
714 %page;
715 %include window_call_info_;
716 
717      end window_call;