1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117 wioctl_:
118 procedure;
119
120 declare (
121 (Old_modes, New_modes, Order)
122 character (*),
123 Code fixed bin (35),
124 Iocb_ptr pointer,
125 Info_ptr pointer
126 ) parameter;
127
128 declare temp_ptr pointer;
129 ^L
130
131 declare mode_string_$parse entry (character (*), pointer, pointer, fixed binary (35));
132
133 declare ioa_$rsnnl entry () options (variable);
134 declare pathname_ entry (char (*), char (*)) returns (char (168));
135 declare requote_string_ entry (char (*)) returns (char (*));
136 declare window_io_iox_$reset_more_entry
137 entry (pointer);
138
139 declare target_iocbp pointer;
140 declare modex fixed bin;
141 declare force_mode bit (1) aligned;
142 declare binding_index fixed bin;
143
144 declare 1 auto_capabilities_info
145 aligned like capabilities_info;
146
147 declare 1 desk_info aligned like tc_desk_window_info;
148
149 declare (
150 video_et_$bad_window_id,
151 video_et_$overlapping_more_responses,
152 video_et_$window_too_big,
153 video_et_$no_more_handler_in_use,
154 error_table_$bad_subr_arg,
155 error_table_$bad_mode_value,
156 error_table_$inconsistent,
157 error_table_$null_info_ptr,
158 error_table_$invalid_array_size
159 ) external static fixed bin (35);
160 declare error_table_$bad_mode fixed bin (35) ext static;
161 declare error_table_$unimplemented_version
162 fixed bin (35) ext static;
163
164 declare (addr, bin, byte, clock, codeptr, copy, hbound, index, lbound, length, max, null, rank, rtrim, search, string,
165 substr, translate, unspec)
166 builtin;
167 dcl cleanup condition;
168 dcl SPACE char (1) static options (constant) init (" ");
169 dcl DEL char (1) static options (constant) init ("^?");
170 dcl WHITE_SPACE char (5) int static options (constant) initial
171
172 ("^M
173 ^K^L");
174
175
176 dcl 1 special_chars_old aligned based,
177 2 nl_seq aligned like c_chars_old,
178 2 cr_seq aligned like c_chars_old,
179 2 bs_seq aligned like c_chars_old,
180 2 tab_seq aligned like c_chars_old,
181 2 vt_seq aligned like c_chars_old,
182 2 ff_seq aligned like c_chars_old,
183 2 printer_on aligned like c_chars_old,
184 2 printer_off aligned like c_chars_old,
185 2 red_ribbon_shift aligned like c_chars_old,
186 2 black_ribbon_shift aligned like c_chars_old,
187 2 end_of_page aligned like c_chars_old,
188 2 escape_length fixed bin,
189 2 not_edited_escapes (sc_escape_len refer (special_chars_old.escape_length)) like c_chars_old,
190
191 2 edited_escapes (sc_escape_len refer (special_chars_old.escape_length)) like c_chars_old,
192
193 2 input_escapes aligned,
194 3 len fixed bin (8) unaligned,
195 3 str char (sc_input_escape_len refer (special_chars_old.input_escapes.len)) unaligned,
196
197 2 input_results aligned,
198 3 pad bit (9) unaligned,
199 3 str char (sc_input_escape_len refer (special_chars_old.input_escapes.len)) unaligned;
200
201
202
203 dcl 1 c_chars_old based (c_chars_ptr) aligned,
204 2 count fixed bin (8) unaligned,
205 2 chars (3) char (1) unaligned;
206
207 dcl 1 special_chars_struc_old
208 aligned based,
209 2 version fixed bin,
210 2 default fixed bin,
211 2 special_chars,
212
213
214 3 nl_seq aligned like c_chars_old,
215 3 cr_seq aligned like c_chars_old,
216 3 bs_seq aligned like c_chars_old,
217 3 tab_seq aligned like c_chars_old,
218 3 vt_seq aligned like c_chars_old,
219 3 ff_seq aligned like c_chars_old,
220 3 printer_on aligned like c_chars_old,
221 3 printer_off aligned like c_chars_old,
222 3 red_ribbon_shift aligned like c_chars_old,
223 3 black_ribbon_shift
224 aligned like c_chars_old,
225 3 end_of_page aligned like c_chars_old,
226 3 escape_length fixed bin,
227 3 not_edited_escapes
228 (sc_escape_len refer (special_chars_struc_old.escape_length)) like c_chars_old,
229
230 3 edited_escapes (sc_escape_len refer (special_chars_struc_old.escape_length)) like c_chars_old,
231
232 3 input_escapes aligned,
233 4 len fixed bin (8) unaligned,
234 4 str char (sc_input_escape_len refer (special_chars_struc_old.input_escapes.len)) unaligned,
235
236 3 input_results aligned,
237 4 pad bit (9) unaligned,
238 4 str char (sc_input_escape_len refer (special_chars_struc_old.input_escapes.len)) unaligned;
239
240 %page;
241
242 modes:
243 entry (Iocb_ptr, New_modes, Old_modes, Code);
244
245 call setup;
246
247 Old_modes = "";
248 call ioa_$rsnnl (
249 "more_mode=^[scroll^;clear^;wrap^;fold^],^[^^^]more,ll=^d,pl=^d,^[^^^]vertsp,^[^^^]can,^[^^^]erkl,^[^^^]esc,^[^^^]rawo,^[^^^]red,^[^^^]ctl_char,^[^^^]edited",
250 Old_modes, (0), attach_data.more_mode, ^attach_data.more_processing, attach_data.current.columns,
251 attach_data.current.rows, ^attach_data.flags.vertsp, ^attach_data.flags.can, ^attach_data.flags.erkl,
252 ^attach_data.flags.esc, ^attach_data.flags.rawo, ^attach_data.flags.red, ^attach_data.flags.ctl_char,
253 ^attach_data.flags.edited);
254
255 if New_modes = "" then
256 return;
257 call mode_string_$parse (New_modes, get_system_free_area_ (), mode_string_info_ptr, Code);
258 if Code ^= 0 then
259 return;
260
261 force_mode = "0"b;
262 do modex = 1 to hbound (mode_string_info.modes, 1);
263 call set_mode (mode_string_info.modes (modex));
264 end;
265
266 mode_error_return:
267 free mode_string_info;
268
269 return;
270 ^L
271
272 set_mode:
273 procedure (mv);
274 dcl 1 mv aligned like mode_value;
275
276 if mv.mode_name = "force" then
277 force_mode = mode_value_boolean ();
278
279 else if mv.mode_name = "more_mode" then do;
280 if ^mv.char_valuep then
281 goto BAD_TYPE;
282
283 if mv.char_value = "scroll" | mv.char_value = "line_count" then do;
284 auto_capabilities_info.version = capabilities_info_version_1;
285 call iox_$control (Iocb_ptr, "get_capabilities", addr (auto_capabilities_info), Code);
286 if Code ^= 0 then
287 return;
288 if ^auto_capabilities_info.scroll_region then
289 go to BAD_VALUE;
290 attach_data.more_mode = MORE_MODE_SCROLL;
291 end;
292 else if mv.char_value = "wrap" then
293 attach_data.more_mode = MORE_MODE_WRAP;
294 else if mv.char_value = "clear" then
295 attach_data.more_mode = MORE_MODE_CLEAR;
296 else if mv.char_value = "fold" then
297 attach_data.more_mode = MORE_MODE_FOLD;
298 else goto BAD_TYPE;
299 end;
300 else if mv.mode_name = "more" then
301 attach_data.more_processing = mode_value_boolean ();
302 else if mv.mode_name = "debug" then
303 attach_data.debug = mode_value_boolean ();
304
305 else if mv.mode_name = "ll" then
306 if mv.numeric_value ^= attach_data.current.columns then
307 go to BAD_VALUE;
308 else ;
309
310 else if mv.mode_name = "pl" then
311 if mv.numeric_value ^= attach_data.current.rows then
312 go to BAD_VALUE;
313 else ;
314
315 else if mv.mode_name = "vertsp" then
316 attach_data.flags.vertsp = mode_value_boolean ();
317 else if mv.mode_name = "can" then
318 attach_data.can = mode_value_boolean ();
319
320
321 else if mv.mode_name = "erkl" then do;
322 attach_data.erkl = mode_value_boolean ();
323 call set_break_table (attach_data.erase_char, attach_data.erkl);
324 call set_break_table (attach_data.kill_char, attach_data.erkl);
325 end;
326
327 else if mv.mode_name = "esc" then do;
328 attach_data.esc = mode_value_boolean ();
329 call set_break_table (attach_data.input_escape_char, attach_data.esc);
330 end;
331
332 else if mv.mode_name = "rawo" then
333 begin;
334 declare saved_r bit (1);
335 saved_r = attach_data.rawo;
336 attach_data.rawo = mode_value_boolean ();
337 if ^saved_r & attach_data.rawo & attach_data.cursor_valid then do;
338 attach_data.row_at_rawo = attach_data.line;
339 attach_data.col_at_rawo = attach_data.col;
340 end;
341 else if saved_r & ^attach_data.rawo then do;
342 attach_data.line = attach_data.row_at_rawo;
343 attach_data.col = attach_data.col_at_rawo;
344 attach_data.cursor_valid = "1"b;
345 end;
346 end;
347
348 else if mv.mode_name = "red" then
349 attach_data.red = mode_value_boolean ();
350 else if mv.mode_name = "ctl_char" then
351 attach_data.ctl_char = mode_value_boolean ();
352 else if mv.mode_name = "edited" then
353 attach_data.edited = mode_value_boolean ();
354
355
356 else if ^force_mode then do;
357 Code = error_table_$bad_mode;
358
359
360 go to mode_error_return;
361 end;
362
363 return;
364
365
366
367 mode_value_boolean:
368 procedure returns (bit (1) aligned);
369 if ^mv.boolean_valuep then
370 goto BAD_TYPE;
371 return (mv.boolean_value);
372
373 mode_value_char:
374 entry returns (char (32) varying);
375 if ^mv.char_valuep then
376 goto BAD_TYPE;
377 return (rtrim (mv.char_value));
378
379 mode_value_numeric:
380 entry returns (fixed bin (35));
381 if ^mv.numeric_valuep then
382 goto BAD_TYPE;
383 return (mv.numeric_value);
384
385 end;
386 BAD_TYPE:
387 BAD_VALUE:
388 Code = error_table_$bad_mode_value;
389 goto mode_error_return;
390 end set_mode;
391 ^L
392 control:
393 entry (Iocb_ptr, Order, Info_ptr, Code);
394 call setup;
395
396 if Order = "reset_more" then
397 call window_io_iox_$reset_more_entry (Iocb_ptr);
398
399 else if Order = "send_buffered_output" then
400 call window_$sync (Iocb_ptr, Code);
401
402 else if Order = "printer_off" then
403 attach_data.suppress_echo = "1"b;
404 else if Order = "printer_on" then
405 attach_data.suppress_echo = "0"b;
406
407 else if Order = "get_terminal_iocb_ptr" then
408 Info_ptr = target_iocbp;
409
410 else if Order = "get_window_iocb_ptr" then
411 Info_ptr = Iocb_ptr -> actual_iocb_ptr;
412
413 else if Order = "get_capabilities" then do;
414 call check_null ();
415 call iox_$control (target_iocbp, Order, Info_ptr, Code);
416 if Code ^= 0 then
417 return;
418
419
420 if Info_ptr -> capabilities_info.columns ^= attach_data.current.columns then do;
421
422 Info_ptr -> capabilities_info.scroll_region = "0"b;
423 Info_ptr -> capabilities_info.insert_chars = "1"b;
424
425 Info_ptr -> capabilities_info.insert_mode = "1"b;
426
427 Info_ptr -> capabilities_info.delete_chars = "1"b;
428 end;
429
430 Info_ptr -> capabilities_info.columns = attach_data.current.columns;
431 Info_ptr -> capabilities_info.rows = attach_data.current.rows;
432 return;
433 end;
434
435 else if Order = "get_window_info" then do;
436 call check_null ();
437 window_position_info_ptr = Info_ptr;
438 call require_version (window_position_info.version, window_position_info_version_1);
439 window_position_info.height = attach_data.current.rows;
440 window_position_info.width = attach_data.current.columns;
441 window_position_info.origin.column = attach_data.column_origin;
442 window_position_info.origin.line = attach_data.line_origin;
443 end;
444
445 else if Order = "set_window_info" then do;
446 call check_null ();
447 window_position_info_ptr = Info_ptr;
448 call require_version (window_position_info.version, window_position_info_version_1);
449
450 auto_capabilities_info.version = capabilities_info_version_1;
451 call iox_$control (target_iocbp, "get_capabilities", addr (auto_capabilities_info), Code);
452 if Code ^= 0 then
453 return;
454
455
456
457
458
459
460 Code = video_et_$window_too_big;
461
462 if (window_position_info.origin.line > auto_capabilities_info.screensize.rows)
463 | (window_position_info.origin.line < 1) then
464 return;
465
466 if window_position_info.extent.height < 1 then
467 return;
468
469 if (window_position_info.origin.line + window_position_info.extent.height - 1)
470 > auto_capabilities_info.screensize.rows then
471 return;
472
473 if window_position_info.origin.column = 0 then
474 window_position_info.origin.column = 1;
475
476 if window_position_info.origin.column < 1
477 | window_position_info.origin.column > auto_capabilities_info.screensize.columns then
478 return;
479
480 if window_position_info.extent.width > auto_capabilities_info.screensize.columns then
481 return;
482
483 if window_position_info.extent.width = 0 then
484 window_position_info.extent.width = auto_capabilities_info.screensize.columns;
485
486 Code = 0;
487
488 desk_info.window_id = attach_data.window_id;
489 desk_info.first_row = window_position_info.origin.line;
490 desk_info.n_rows = window_position_info.extent.height;
491 desk_info.first_column = window_position_info.origin.column;
492 desk_info.n_columns = window_position_info.extent.width;
493
494 call iox_$control (target_iocbp, "resize_window", addr (desk_info), Code);
495
496 if Code = video_et_$bad_window_id then do;
497 call iox_$control (target_iocbp, "check_out_window", addr (desk_info), (0));
498 desk_info.window_iocb_ptr = Iocb_ptr -> iocb.actual_iocb_ptr;
499 call iox_$control (target_iocbp, "check_in_window", addr (desk_info), Code);
500 if Code = 0 then
501 attach_data.window_id = desk_info.window_id;
502 end;
503 if Code ^= 0 then
504 return;
505
506
507 if attach_data.window_image_ptr ^= null () then
508 free window_image in (attach_data_area);
509
510 rearrange_window:
511 begin;
512 declare origin_change fixed bin;
513 declare bottom_line_change fixed bin;
514 declare old_origin fixed bin;
515 declare old_bottom_line fixed bin;
516 declare new_bottom_line fixed bin;
517
518 declare saved_ignore_status bit (1) aligned;
519
520 declare cleanup condition;
521
522 saved_ignore_status = attach_data.ignore_status;
523
524 on cleanup attach_data.ignore_status = saved_ignore_status;
525 attach_data.ignore_status = "1"b;
526
527 string (attach_data.status) = ""b;
528 attach_data.status_pending = "0"b;
529
530 origin_change = attach_data.current.line_origin - window_position_info.line;
531
532 old_origin = attach_data.current.line_origin;
533
534 new_bottom_line = window_position_info.line + window_position_info.height - 1;
535 old_bottom_line = old_origin + attach_data.current.rows - 1;
536
537 bottom_line_change = new_bottom_line - old_bottom_line;
538
539 attach_data.current.rows = window_position_info.height;
540 attach_data.line_origin = window_position_info.line;
541
542 attach_data.current.columns = window_position_info.width;
543 attach_data.column_origin = window_position_info.column;
544
545 if ^(((attach_data.current.line_origin >= old_origin)
546
547 & (attach_data.current.line_origin <= new_bottom_line))
548
549 | ((new_bottom_line >= old_origin)
550 & (new_bottom_line <= old_bottom_line)))
551
552 then do;
553 call window_$position_cursor (Iocb_ptr, (1), (1), (0));
554 call window_io_iox_$reset_more_entry (Iocb_ptr);
555 end;
556
557 else do;
558
559 if attach_data.line > attach_data.current.rows then
560 call window_$position_cursor (Iocb_ptr, attach_data.current.rows, (1), (0));
561 else if origin_change > 0 then
562 call window_$change_line (Iocb_ptr, attach_data.line + origin_change, (0));
563
564
565 end;
566
567 attach_data.ignore_status = saved_ignore_status;
568 end rearrange_window;
569
570 call ioa_$rsnnl ("window_io_ ^a -first_line ^i -n_lines ^i -first_column ^i -n_columns ^i",
571 attach_data.attach_description, (0), attach_data.target_iocb_ptr -> iocb.name,
572 attach_data.line_origin, attach_data.current.rows, attach_data.column_origin,
573 attach_data.current.columns);
574
575 attach_data.status_pending = "0"b;
576 string (attach_data.status) = ""b;
577
578 if attach_data.async_count > 0 then do;
579 attach_data.status_pending = "1"b;
580 attach_data.status.screen_invalid = "1"b;
581 end;
582
583
584 allocate window_image in (attach_data_area);
585
586 if ^(attach_data.more_mode = MORE_MODE_SCROLL) then
587 return;
588
589 auto_capabilities_info.version = capabilities_info_version_1;
590 call iox_$control (Iocb_ptr, "get_capabilities", addr (auto_capabilities_info), Code);
591
592 if Code ^= 0 then
593 return;
594 if ^auto_capabilities_info.scroll_region then
595 attach_data.more_mode = MORE_MODE_WRAP;
596
597 return;
598 end;
599
600 else if Order = "get_editing_chars" then do;
601 call check_null ();
602 editing_chars_ptr = Info_ptr;
603 call require_version (editing_chars.version, editing_chars_version_3);
604 editing_chars.erase = attach_data.erase_char;
605 editing_chars.kill = attach_data.kill_char;
606 end;
607
608 else if Order = "set_editing_chars" then do;
609 call check_null ();
610 editing_chars_ptr = Info_ptr;
611 call require_version (editing_chars.version, editing_chars_version_3);
612 if index (WHITE_SPACE, editing_chars.erase) ^= 0 | index (WHITE_SPACE, editing_chars.kill) ^= 0
613 | editing_chars.erase = editing_chars.kill then
614 Code = error_table_$inconsistent;
615
616 else do;
617
618 begin;
619 dcl 1 lekbi aligned like line_editor_key_binding_info based (sekbi.key_binding_info_ptr);
620 dcl 1 sekbi aligned like set_editor_key_bindings_info;
621
622 sekbi.version = set_editor_key_bindings_info_version_1;
623 sekbi.update = "1"b;
624 sekbi.replace = "0"b;
625 sekbi.mbz = (34)"0"b;
626 sekbi.key_binding_info_ptr = null ();
627 line_editor_binding_count = 4;
628 line_editor_longest_sequence = 1;
629
630 on cleanup
631 begin;
632 if sekbi.key_binding_info_ptr ^= null () then
633 free lekbi in (attach_data_area);
634 end;
635 allocate lekbi in (attach_data_area);
636
637 lekbi.version = line_editor_key_binding_info_version_3;
638
639
640 lekbi.binding_count = 0;
641
642
643
644
645
646 if editing_chars.erase ^= SPACE & editing_chars.kill ^= SPACE then do;
647 lekbi.binding_count = lekbi.binding_count + 4;
648
649
650
651
652
653 if (attach_data.erase_char >= SPACE) & (attach_data.erase_char < DEL) then
654 lekbi.bindings (lekbi.binding_count - 3).action = SELF_INSERT;
655 else lekbi.bindings (lekbi.binding_count - 3).action = UNDEFINED;
656 lekbi.bindings (lekbi.binding_count - 3).sequence = attach_data.erase_char;
657
658 lekbi.bindings (lekbi.binding_count - 1).action = BACKWARD_DELETE_CHARACTER;
659 lekbi.bindings (lekbi.binding_count - 1).sequence = editing_chars.erase;
660
661 attach_data.erase_char = editing_chars.erase;
662
663 if (attach_data.kill_char >= SPACE) & (attach_data.kill_char < DEL) then
664 lekbi.bindings (lekbi.binding_count - 2).action = SELF_INSERT;
665 else lekbi.bindings (lekbi.binding_count - 2).action = UNDEFINED;
666 lekbi.bindings (lekbi.binding_count - 2).sequence = attach_data.kill_char;
667
668 lekbi.bindings (lekbi.binding_count).action = KILL_TO_BEGINNING_OF_LINE;
669 lekbi.bindings (lekbi.binding_count).sequence = editing_chars.kill;
670
671 attach_data.kill_char = editing_chars.kill;
672
673
674
675 end;
676
677 else if editing_chars.erase ^= SPACE then do;
678 lekbi.binding_count = lekbi.binding_count + 2;
679
680
681
682
683
684 if (attach_data.erase_char >= SPACE) & (attach_data.erase_char < DEL) then
685 lekbi.bindings (lekbi.binding_count - 1).action = SELF_INSERT;
686 else lekbi.bindings (lekbi.binding_count - 1).action = UNDEFINED;
687 lekbi.bindings (lekbi.binding_count - 1).sequence = attach_data.erase_char;
688
689 lekbi.bindings (lekbi.binding_count).action = BACKWARD_DELETE_CHARACTER;
690 lekbi.bindings (lekbi.binding_count).sequence = editing_chars.erase;
691
692 attach_data.erase_char = editing_chars.erase;
693 end;
694
695 else if editing_chars.kill ^= SPACE then do;
696 lekbi.binding_count = lekbi.binding_count + 2;
697
698
699
700
701
702 if (attach_data.kill_char >= SPACE) & (attach_data.kill_char < DEL) then
703 lekbi.bindings (lekbi.binding_count - 1).action = SELF_INSERT;
704 else lekbi.bindings (lekbi.binding_count - 1).action = UNDEFINED;
705 lekbi.bindings (lekbi.binding_count - 1).sequence = attach_data.kill_char;
706
707 lekbi.bindings (lekbi.binding_count).action = KILL_TO_BEGINNING_OF_LINE;
708 lekbi.bindings (lekbi.binding_count).sequence = editing_chars.kill;
709
710 attach_data.kill_char = editing_chars.kill;
711 end;
712
713
714 lekbi.name (*), lekbi.description (*), lekbi.info_dir (*), lekbi.info_entry (*) = "";
715
716 call iox_$control (Iocb_ptr, "set_editor_key_bindings", addr (sekbi), Code);
717
718 temp_ptr = sekbi.key_binding_info_ptr;
719 sekbi.key_binding_info_ptr = null ();
720 free temp_ptr -> lekbi;
721 end;
722 end;
723 end;
724
725 else if Order = "get_more_responses" then do;
726 call check_null ();
727 more_responses_info_ptr = Info_ptr;
728 call require_version (more_responses_info.version, more_responses_info_version_1);
729 more_responses_info.n_yeses = attach_data.n_yeses;
730 more_responses_info.n_noes = attach_data.n_noes;
731 more_responses_info.yeses = attach_data.more_yeses;
732 more_responses_info.noes = attach_data.more_noes;
733 end;
734
735 else if Order = "set_more_responses" then do;
736 call check_null ();
737 more_responses_info_ptr = Info_ptr;
738 call require_version (more_responses_info.version, more_responses_info_version_1);
739 if search (substr (more_responses_info.yeses, 1, more_responses_info.n_yeses),
740 substr (more_responses_info.noes, 1, more_responses_info.n_noes)) > 0 then
741 Code = video_et_$overlapping_more_responses;
742 else do;
743 attach_data.n_yeses = more_responses_info.n_yeses;
744 attach_data.n_noes = more_responses_info.n_noes;
745 attach_data.more_yeses = more_responses_info.yeses;
746 attach_data.more_noes = more_responses_info.noes;
747 end;
748 end;
749
750 else if Order = "get_window_status" then do;
751 call check_null ();
752 window_status_info_ptr = Info_ptr;
753 call require_version (window_status_info.version, window_status_version_1);
754 string (window_status_info.status_string) = string (attach_data.status);
755 string (attach_data.status) = "0"b;
756 attach_data.status_pending = "0"b;
757 return;
758 end;
759
760 else if Order = "set_window_status"
761 then do;
762 call check_null ();
763 window_status_info_ptr = Info_ptr;
764 call require_version (window_status_info.version, window_status_version_1);
765 string (attach_data.status) = string (attach_data.status) | string (window_status_info.status_string);
766 attach_data.status_pending = "1"b;
767 end;
768
769 else if Order = "start" then
770 call iox_$control (target_iocbp, "start", null (), (0));
771
772 else if Order = "set_break_table" then do;
773 call check_null ();
774 break_table_ptr = Info_ptr;
775 call require_version (break_table_info.version, break_table_info_version_1);
776 attach_data.breaks = string (break_table_info.breaks);
777 end;
778 else if Order = "get_break_table" then do;
779 call check_null ();
780 break_table_ptr = Info_ptr;
781 call require_version (break_table_info.version, break_table_info_version_1);
782 string (break_table_info.breaks) = attach_data.breaks;
783 end;
784
785 else if Order = "set_more_handler" then do;
786 call check_null ();
787 more_handler_info_ptr = Info_ptr;
788 call require_version (more_handler_info.version, more_handler_info_version_3);
789
790
791 if attach_data.more_handler_in_use then do;
792 more_handler_info.old_more_handler = attach_data.more_handler;
793 more_handler_info.old_handler_valid = "1"b;
794 end;
795 else more_handler_info.old_handler_valid = "0"b;
796
797
798 attach_data.more_handler = more_handler_info.more_handler;
799 attach_data.more_handler_in_use = "1"b;
800 end;
801
802 else if Order = "get_more_handler" then do;
803 call check_null ();
804 more_handler_info_ptr = Info_ptr;
805 call require_version (more_handler_info.version, more_handler_info_version_3);
806 if ^attach_data.more_handler_in_use then do;
807 Code = video_et_$no_more_handler_in_use;
808 return;
809 end;
810 more_handler_info.more_handler = attach_data.more_handler;
811 more_handler_info.old_handler_valid = "0"b;
812 return;
813 end;
814
815 else if Order = "reset_more_handler" then
816 attach_data.more_handler_in_use = "0"b;
817
818 else if Order = "set_token_characters" then do;
819 call check_null ();
820 token_characters_info_ptr = Info_ptr;
821 call require_version_str (token_characters_info.version, token_characters_info_version_1);
822 attach_data.token_characters = token_characters_info.token_characters;
823 attach_data.token_character_count = token_characters_info.token_character_count;
824 end;
825
826 else if Order = "get_token_characters" then do;
827 call check_null ();
828 token_characters_info_ptr = Info_ptr;
829 call require_version_str (token_characters_info.version, token_characters_info_version_1);
830 token_characters_info.token_characters = attach_data.token_characters;
831 token_characters_info.token_character_count = attach_data.token_character_count;
832 end;
833
834 else if Order = "set_more_prompt" then do;
835 call check_null ();
836 more_prompt_info_ptr = Info_ptr;
837 call require_version_str (more_prompt_info.version, more_prompt_info_version_1);
838 attach_data.more_prompt = more_prompt_info.more_prompt;
839 end;
840
841 else if Order = "get_more_prompt" then do;
842 call check_null ();
843 more_prompt_info_ptr = Info_ptr;
844 call require_version_str (more_prompt_info.version, more_prompt_info_version_1);
845 more_prompt_info.more_prompt = attach_data.more_prompt;
846 end;
847
848 else if Order = "set_editor_key_bindings" then do;
849 call check_null ();
850 set_editor_key_bindings_info_ptr = Info_ptr;
851
852 dcl line_editor_key_binding_info_version_2
853 char (8) int static options (constant) init ("lekbi002");
854
855 if set_editor_key_bindings_info.version = line_editor_key_binding_info_version_2
856 | set_editor_key_bindings_info.version = line_editor_key_binding_info_version_3 then
857 call update_key_bindings (set_editor_key_bindings_info_ptr);
858 else if set_editor_key_bindings_info.version ^= set_editor_key_bindings_info_version_1 then
859 call error_exit (error_table_$unimplemented_version);
860 else if set_editor_key_bindings_info.replace = set_editor_key_bindings_info.update
861
862 then
863 call error_exit (error_table_$bad_subr_arg);
864 else if set_editor_key_bindings_info.update then
865 call update_key_bindings (set_editor_key_bindings_info.key_binding_info_ptr);
866 else
867 do;
868 temp_ptr = attach_data.dispatch_table_ptr;
869 attach_data.dispatch_table_ptr = set_editor_key_bindings_info.key_binding_info_ptr;
870 free temp_ptr -> dispatch_table in (attach_data_area);
871 end;
872 end;
873
874 else if Order = "get_editor_key_bindings" then do;
875 call check_null ();
876 get_editor_key_bindings_info_ptr = Info_ptr;
877
878 call require_version_str (get_editor_key_bindings_info.version, get_editor_key_bindings_info_version_1);
879 call require_mbz (get_editor_key_bindings_info.flags.mbz);
880
881 if get_editor_key_bindings_info.entire_state then
882 call make_key_bindings_copy (get_editor_key_bindings_info.entire_state_ptr);
883
884 else do;
885 line_editor_key_binding_info_ptr = get_editor_key_bindings_info.key_binding_info_ptr;
886 if line_editor_key_binding_info_ptr = null () then do;
887 call error_exit (error_table_$null_info_ptr);
888 end;
889 call require_version_str (line_editor_key_binding_info.version,
890 line_editor_key_binding_info_version_3);
891
892 dcl bad_prefix condition;
893 on bad_prefix
894 call error_exit (error_table_$bad_subr_arg);
895
896
897 do binding_index = 1 to line_editor_key_binding_info.binding_count;
898 call get_key_binding (line_editor_key_binding_info.sequence (binding_index),
899 line_editor_key_binding_info.action (binding_index),
900 line_editor_key_binding_info.numarg_action (binding_index),
901 line_editor_key_binding_info.editor_routine (binding_index),
902 line_editor_key_binding_info.name (binding_index),
903 line_editor_key_binding_info.description (binding_index),
904 line_editor_key_binding_info.info_path (binding_index));
905 end;
906 end;
907
908 return;
909 end;
910
911 else if Order = "get_output_conversion" then do;
912 dcl 1 cts aligned like cv_trans_struc based (cts_ptr);
913 dcl cts_ptr ptr;
914 call check_null ();
915 cts_ptr = Info_ptr;
916 if ^(cts.version = 1 | cts.version = CV_TRANS_VERSION)
917
918 then do;
919 Code = error_table_$unimplemented_version;
920 return;
921 end;
922 begin;
923 dcl index fixed bin;
924 do index = 0 to CV_TRANS_SIZE (cts.version);
925 cts.cv_trans.value (index) = attach_data.output_cv_ptr -> cv_trans.value (index);
926 end;
927 end;
928 end;
929
930 else if Order = "set_output_conversion" then do;
931 call check_null ();
932 cts_ptr = Info_ptr;
933 if ^(cts.version = 1 | cts.version = CV_TRANS_VERSION)
934
935 then do;
936 Code = error_table_$unimplemented_version;
937 return;
938 end;
939 if cts.default = 1 then
940 do;
941 call iox_$control (target_iocbp, "get_output_conversion", cts_ptr, Code);
942 if Code ^= 0 then
943 return;
944 end;
945 attach_data.output_cv_ptr -> cv_trans.value (*) = OUTPUT_CONVERT_OCTAL;
946
947 begin;
948 dcl index fixed bin;
949 do index = 0 to CV_TRANS_SIZE (cts.version);
950 attach_data.output_cv_ptr -> cv_trans.value (index) = cts.cv_trans.value (index);
951 end;
952 end;
953
954 begin;
955 dcl cv_trans_idx fixed bin;
956 dcl conversion_type fixed bin;
957
958
959 do cv_trans_idx = 0 to 127;
960 substr (attach_data.conversion_tct_table, cv_trans_idx + 1, 1) =
961 byte (attach_data.output_cv_ptr -> cv_trans.value (cv_trans_idx));
962 end;
963
964
965 do cv_trans_idx = 128 to 255;
966 conversion_type = attach_data.output_cv_ptr -> cv_trans.value (cv_trans_idx);
967 if conversion_type = OUTPUT_CONVERT_ORDINARY
968
969 then
970 substr (attach_data.conversion_tct_table, cv_trans_idx + 1, 1) =
971 byte (OUTPUT_CONVERT_OCTAL);
972 else substr (attach_data.conversion_tct_table, cv_trans_idx + 1, 1) = byte (conversion_type);
973 end;
974
975
976 substr (attach_data.conversion_tct_table, 257, 256) = copy (byte (OUTPUT_CONVERT_OCTAL), 256);
977 end;
978
979 end;
980
981 else if Order = "get_special" then do;
982 dcl 1 gsi aligned like get_special_info_struc based (Info_ptr);
983 dcl gsi_area area based (gsi.area_ptr);
984
985 dcl 1 gsi_old aligned based (Info_ptr),
986 2 area_ptr pointer,
987 2 table_ptr pointer;
988 dcl gsi_area_old area based (gsi_old.area_ptr);
989
990 call check_null ();
991 sc_escape_len = attach_data.special_ptr -> special_chars.escape_length;
992 sc_input_escape_len = attach_data.special_ptr -> special_chars.input_escapes.len;
993 if gsi.version = SPECIAL_INFO_STRUCT_VERSION_1 then do;
994 allocate special_chars_struc set (gsi.table_ptr) in (gsi_area);
995 gsi.table_ptr -> special_chars_struc.version = SPECIAL_VERSION_2;
996 addr (gsi.table_ptr -> special_chars_struc.special_chars) -> special_chars =
997 attach_data.special_ptr -> special_chars;
998 end;
999 else do;
1000 allocate special_chars_struc_old set (gsi_old.table_ptr) in (gsi_area_old);
1001 gsi_old.table_ptr -> special_chars_struc_old.version = SPECIAL_VERSION;
1002 call copy_new_to_old_special_table;
1003 if Code ^= 0 then do;
1004 free gsi_old.table_ptr -> special_chars_struc_old;
1005 gsi_old.table_ptr = null;
1006 end;
1007 end;
1008 end;
1009
1010 else if Order = "set_special" then do;
1011 dcl 1 scs aligned like special_chars_struc based (scs_ptr);
1012 dcl scs_ptr ptr;
1013 call check_null ();
1014 scs_ptr = Info_ptr;
1015
1016
1017
1018 if scs.version ^= SPECIAL_VERSION & scs.version ^= SPECIAL_VERSION_2
1019 & scs.version ^= editing_chars_version_2 then do;
1020 call error_exit (error_table_$unimplemented_version);
1021 end;
1022 on cleanup goto FREE_SCS;
1023 if scs.default = 1 then do;
1024 begin;
1025 dcl 1 auto_gsi like get_special_info_struc;
1026 auto_gsi.version = SPECIAL_INFO_STRUCT_VERSION_1;
1027 auto_gsi.area_ptr = get_system_free_area_ ();
1028 call iox_$control (target_iocbp, "get_special", addr (auto_gsi), Code);
1029 if Code ^= 0 then
1030 return;
1031 scs_ptr = auto_gsi.table_ptr;
1032 end;
1033 end;
1034 sc_escape_len = scs.special_chars.escape_length;
1035 sc_input_escape_len = scs.special_chars.input_escapes.len;
1036 allocate special_chars set (temp_ptr);
1037 if scs.version = SPECIAL_VERSION_2 then
1038 temp_ptr -> special_chars = addr (scs.special_chars) -> special_chars;
1039 else call copy_old_to_new_special_table;
1040 free attach_data.special_ptr -> special_chars;
1041 attach_data.special_ptr = temp_ptr;
1042 FREE_SCS:
1043 if scs_ptr ^= Info_ptr
1044 then
1045 free scs;
1046 end;
1047
1048 else if Order = "read_status" then
1049 call read_status ();
1050
1051 else if (Order = "io_call") | (Order = "io_call_af") then
1052 call process_io_call (Iocb_ptr, Order, Info_ptr, Code);
1053
1054 else if Order = "set_audit_iocb_ptr" then
1055 attach_data.auditor_iocb_ptr = Info_ptr;
1056
1057 else if Order = "get_audit_iocb_ptr" then
1058 Info_ptr = attach_data.auditor_iocb_ptr;
1059
1060
1061 else call iox_$control (target_iocbp, Order, Info_ptr, Code);
1062
1063 return;
1064 ^L
1065 update_key_bindings:
1066 proc (a_info_ptr);
1067
1068 dcl a_info_ptr ptr parameter;
1069
1070 line_editor_key_binding_info_ptr = a_info_ptr;
1071
1072 if line_editor_key_binding_info.version = line_editor_key_binding_info_version_3 then do;
1073
1074
1075 do binding_index = 1 to line_editor_key_binding_info.binding_count;
1076 if length (line_editor_key_binding_info.sequence (binding_index)) = 0 then do;
1077 call error_exit (error_table_$bad_subr_arg);
1078 end;
1079
1080 if (line_editor_key_binding_info.action (binding_index) < EXTERNAL_ROUTINE)
1081 | (line_editor_key_binding_info.action (binding_index) > HIGHEST_BUILTIN_ROUTINE_VALUE) then do;
1082 call error_exit (error_table_$bad_subr_arg);
1083 end;
1084
1085 if (line_editor_key_binding_info.numarg_action (binding_index) < 0
1086 | line_editor_key_binding_info.numarg_action (binding_index) > HIGHEST_NUMARG_ACTION_VALUE)
1087 & ^(line_editor_key_binding_info.action (binding_index) = EXTERNAL_ROUTINE) then do;
1088 call error_exit (error_table_$bad_subr_arg);
1089 end;
1090
1091 end;
1092
1093
1094 do binding_index = 1 to line_editor_key_binding_info.binding_count;
1095 call set_key_binding (line_editor_key_binding_info.sequence (binding_index),
1096 line_editor_key_binding_info.action (binding_index),
1097 line_editor_key_binding_info.numarg_action (binding_index),
1098 line_editor_key_binding_info.editor_routine (binding_index),
1099 line_editor_key_binding_info.name (binding_index),
1100 line_editor_key_binding_info.description (binding_index),
1101 line_editor_key_binding_info.info_path (binding_index));
1102 end;
1103 end;
1104
1105 else if line_editor_key_binding_info.version = line_editor_key_binding_info_version_2 then do;
1106 dcl 1 v2lekbi aligned based (line_editor_key_binding_info_ptr),
1107 2 version char (8),
1108 2 binding_count fixed bin,
1109 2 longest_sequence fixed bin,
1110 2 bindings (line_editor_binding_count refer (v2lekbi.binding_count)),
1111 3 sequence char (line_editor_longest_sequence refer (v2lekbi.longest_sequence)) varying,
1112 3 action fixed bin,
1113 3 numarg_action fixed binary,
1114 3 editor_routine entry (pointer, fixed bin (35));
1115 dcl 1 blank_info_path like line_editor_key_binding_info.info_path;
1116
1117 do binding_index = 1 to v2lekbi.binding_count;
1118 if length (v2lekbi.sequence (binding_index)) = 0 then do;
1119 call error_exit (error_table_$bad_subr_arg);
1120 end;
1121
1122 if (v2lekbi.action (binding_index) < EXTERNAL_ROUTINE)
1123 | (v2lekbi.action (binding_index) > HIGHEST_BUILTIN_ROUTINE_VALUE) then do;
1124 call error_exit (error_table_$bad_subr_arg);
1125 end;
1126
1127 if (v2lekbi.numarg_action (binding_index) < 0
1128 | v2lekbi.numarg_action (binding_index) > HIGHEST_NUMARG_ACTION_VALUE)
1129 & ^(v2lekbi.action (binding_index) = EXTERNAL_ROUTINE) then do;
1130 call error_exit (error_table_$bad_subr_arg);
1131 end;
1132
1133 end;
1134
1135 blank_info_path.info_dir, blank_info_path.info_entry = "";
1136
1137
1138 do binding_index = 1 to v2lekbi.binding_count;
1139 call set_key_binding (v2lekbi.sequence (binding_index), v2lekbi.action (binding_index),
1140 v2lekbi.numarg_action (binding_index), v2lekbi.editor_routine (binding_index), "", "",
1141 blank_info_path);
1142 end;
1143 end;
1144
1145 else call error_exit (error_table_$unimplemented_version);
1146
1147 return;
1148 end update_key_bindings;
1149 ^L
1150 set_key_binding:
1151 procedure (sequence, action, numarg_action, editor_routine, name, description, info_path);
1152
1153 dcl sequence char (*) varying;
1154 dcl action fixed bin;
1155 dcl numarg_action fixed bin;
1156 dcl editor_routine entry (ptr, fixed bin (35));
1157 dcl (name, description) char (*) varying aligned parameter;
1158 dcl 1 info_path like line_editor_key_binding_info.info_path parameter;
1159
1160 dcl char char (1) aligned;
1161 dcl char_fix fixed bin (9);
1162 dcl char_index fixed bin;
1163 dcl old_ptr pointer;
1164 dcl new_ptr pointer;
1165
1166 dcl window_io_iox_$free_dispatch_tables
1167 entry (ptr);
1168
1169 dcl PREFIX fixed bin static options (constant) init (-1);
1170
1171 char = substr (sequence, 1, 1);
1172
1173
1174
1175 if (action = SELF_INSERT) & (length (sequence) = 1) & (char >= SPACE) & (char < DEL) then
1176 call set_break_table (char, "0"b);
1177 else call set_break_table (char, "1"b);
1178
1179 old_ptr = attach_data.dispatch_table_ptr;
1180
1181
1182 do char_index = 1 to length (sequence) - 1;
1183 char_fix = rank (substr (sequence, char_index, 1));
1184
1185
1186 if old_ptr -> dispatch_table.key (char_fix).type >= 0 then do;
1187 allocate dispatch_table set (new_ptr);
1188 new_ptr -> dispatch_table.key (*).type = UNDEFINED;
1189
1190 old_ptr -> dispatch_table.key (char_fix).next_table = new_ptr;
1191 old_ptr -> dispatch_table.key (char_fix).type = PREFIX;
1192 end;
1193 old_ptr = old_ptr -> dispatch_table.key (char_fix).next_table;
1194 end;
1195
1196 char_fix = rank (substr (sequence, length (sequence), 1));
1197
1198
1199 if old_ptr -> dispatch_table.key (char_fix).type = PREFIX then
1200 call window_io_iox_$free_dispatch_tables (old_ptr -> dispatch_table.key (char_fix).next_table);
1201
1202
1203 old_ptr -> dispatch_table.key (char_fix).type = action;
1204
1205 if action = EXTERNAL_ROUTINE then do;
1206 old_ptr -> dispatch_table.key (char_fix).routine = editor_routine;
1207 old_ptr -> dispatch_table.key (char_fix).numarg_action = numarg_action;
1208 end;
1209 old_ptr -> dispatch_table.key (char_fix).name = name;
1210 old_ptr -> dispatch_table.key (char_fix).description = description;
1211 old_ptr -> dispatch_table.key (char_fix).info_path = info_path;
1212
1213 return;
1214 ^L
1215 get_key_binding:
1216 entry (sequence, action, numarg_action, editor_routine, name, description, info_path);
1217
1218 old_ptr = attach_data.dispatch_table_ptr;
1219
1220 do char_index = 1 to length (sequence) - 1;
1221 char_fix = rank (substr (sequence, char_index, 1));
1222
1223
1224 if old_ptr -> dispatch_table.key (char_fix).type >= 0 then
1225 signal bad_prefix;
1226
1227 old_ptr = old_ptr -> dispatch_table.key (char_fix).next_table;
1228 end;
1229
1230 char_fix = rank (substr (sequence, length (sequence), 1));
1231 action = old_ptr -> dispatch_table.key (char_fix).type;
1232
1233 if action = EXTERNAL_ROUTINE then do;
1234 editor_routine = old_ptr -> dispatch_table.key (char_fix).routine;
1235 numarg_action = old_ptr -> dispatch_table.key (char_fix).numarg_action;
1236 end;
1237 if length (old_ptr -> dispatch_table.key (char_fix).name) = 0 then
1238 name = builtin_routine_names (max (action, lbound (builtin_routine_names, 1)));
1239 else name = old_ptr -> dispatch_table.key (char_fix).name;
1240 if length (old_ptr -> dispatch_table.key (char_fix).description) = 0 then
1241 description = builtin_descriptions (max (action, lbound (builtin_descriptions, 1)));
1242 else description = old_ptr -> dispatch_table.key (char_fix).description;
1243 if old_ptr -> dispatch_table.key (char_fix).info_entry = "" then do;
1244 if action = EXTERNAL_ROUTINE then do;
1245 info_path.info_entry = "";
1246 info_path.info_dir = "";
1247 end;
1248 else do;
1249 info_path.info_entry = BUILTIN_INFO_ENTRY;
1250 info_path.info_dir = BUILTIN_INFO_DIR;
1251 end;
1252 end;
1253 else info_path = old_ptr -> dispatch_table.key (char_fix).info_path;
1254
1255 return;
1256
1257 end set_key_binding;
1258 ^L
1259 make_key_bindings_copy:
1260 procedure (new_ptr);
1261
1262 dcl new_ptr ptr;
1263
1264 call copy_dispatch_table (attach_data.dispatch_table_ptr, new_ptr);
1265 return;
1266
1267 copy_dispatch_table:
1268 procedure (old_ptr, new_ptr);
1269
1270 dcl (old_ptr, new_ptr) ptr;
1271
1272 dcl key_num fixed bin;
1273
1274 allocate dispatch_table in (attach_data_area) set (new_ptr);
1275 new_ptr -> dispatch_table = old_ptr -> dispatch_table;
1276 do key_num = lbound (old_ptr -> dispatch_table.key, 1) to hbound (old_ptr -> dispatch_table.key, 1);
1277 if old_ptr -> dispatch_table.key (key_num).type < 0 then
1278 call copy_dispatch_table (old_ptr -> dispatch_table.key (key_num).next_table,
1279 new_ptr -> dispatch_table.key (key_num).next_table);
1280 end;
1281
1282 return;
1283
1284 end copy_dispatch_table;
1285
1286 end make_key_bindings_copy;
1287 ^L
1288 process_io_call:
1289 procedure (io_call_iocb, io_call_order, io_call_infop, code);
1290
1291 dcl io_call_iocb pointer parameter;
1292 dcl io_call_order char (*) parameter;
1293 dcl code fixed bin (35) parameter;
1294
1295 %include io_call_info;
1296
1297 dcl iocb_ptr pointer;
1298 dcl order char (32);
1299 dcl caller char (32);
1300 dcl called_as_af bit (1);
1301 dcl i fixed bin;
1302 dcl arg_index fixed bin;
1303 dcl entry_name char (65);
1304
1305 dcl 1 MHI aligned like more_handler_info;
1306 dcl 1 MRI aligned like more_responses_info;
1307 dcl 1 MPI aligned like more_prompt_info;
1308 dcl 1 TCI aligned like token_characters_info;
1309 dcl 1 WSI aligned like window_status_info;
1310 dcl 1 EC aligned like editing_chars;
1311
1312 dcl error_table_$wrong_no_of_args
1313 fixed bin (35) external;
1314 dcl error_table_$undefined_order_request
1315 fixed bin (35) external;
1316 dcl error_table_$noarg fixed bin (35) external;
1317 dcl error_table_$bad_arg fixed bin (35) external;
1318 dcl error_table_$badopt fixed bin (35) external;
1319
1320 dcl cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry);
1321
1322 code = 0;
1323
1324 iocb_ptr = io_call_iocb -> iocb.actual_iocb_ptr;
1325
1326 if io_call_order = "io_call" then
1327 called_as_af = "0"b;
1328 else do;
1329 called_as_af = "1"b;
1330 io_call_af_ret = "";
1331 end;
1332
1333 order = io_call_info.order_name;
1334 caller = io_call_info.caller_name;
1335
1336 if order = "set_more_handler" then do;
1337 if io_call_info.nargs = 0 then do;
1338 call io_call_info.error (0, "", "usage: io_call control window_switch set_more_handler more_handler");
1339 return;
1340 end;
1341 if io_call_info.nargs > 1 then do;
1342 call io_call_info
1343 .
1344 error (error_table_$wrong_no_of_args, caller, "Only one more handler name may be specified. ^a",
1345 order);
1346 return;
1347 end;
1348
1349 MHI.version = more_handler_info_version_3;
1350 MHI.more_handler = cv_entry_ ((io_call_info.args (1)), codeptr (process_io_call), code);
1351 if code ^= 0 then do;
1352 call io_call_info
1353 .
1354 error (code, caller, "Could not covert ""^a"" to an entry value. ^a", io_call_info.args (1),
1355 order);
1356 code = 0;
1357 return;
1358 end;
1359 call iox_$control (iocb_ptr, order, addr (MHI), code);
1360 if code ^= 0 then
1361 call io_call_info.error (code, caller, "While setting more handler. ^a", order);
1362 code = 0;
1363 return;
1364 end;
1365
1366 else if order = "get_more_handler" then do;
1367 call io_call_require_no_args ();
1368 MHI.version = more_handler_info_version_3;
1369 call iox_$control (iocb_ptr, order, addr (MHI), code);
1370 if code ^= 0 & code ^= video_et_$no_more_handler_in_use then do;
1371 call io_call_info.error (code, caller, "While getting more handler. ^a", order);
1372 code = 0;
1373 return;
1374 end;
1375 if code = video_et_$no_more_handler_in_use then do;
1376 if called_as_af then
1377 call ioa_$rsnnl ("NONE", io_call_af_ret, (0));
1378 else call io_call_info.report ("No more handler in use.");
1379 code = 0;
1380 return;
1381 end;
1382 call entry_var_to_string (MHI.more_handler, entry_name, code);
1383 if code ^= 0 then do;
1384 call io_call_info.error (code, caller, "While getting name of more handler. ^a", order);
1385 code = 0;
1386 return;
1387 end;
1388 if called_as_af then
1389 call ioa_$rsnnl ("^a", io_call_af_ret, (0), rtrim (entry_name));
1390 else call io_call_info.report ("More handler: ^a", rtrim (entry_name));
1391 return;
1392 end;
1393
1394 else if order = "set_more_responses" then do;
1395 if io_call_info.nargs = 0 then do;
1396 call io_call_info
1397 .
1398 error (0, "",
1399 "usage: io_call control window_switch set_more_responses yes_responses no_responses");
1400 return;
1401 end;
1402 if io_call_info.nargs < 2 then do;
1403 call io_call_info
1404 .
1405 error (error_table_$wrong_no_of_args, caller, "Both yes and no responses must be specified. ^a",
1406 order);
1407 return;
1408 end;
1409 if io_call_info.nargs > 2 then do;
1410 call io_call_info
1411 .
1412 error (error_table_$wrong_no_of_args, caller,
1413 "Only one yes response string and one no response string may be specified. ^a", order);
1414 return;
1415 end;
1416 MRI.version = more_responses_info_version_1;
1417 MRI.n_yeses = length (io_call_info.args (1));
1418 MRI.yeses = io_call_info.args (1);
1419 MRI.n_noes = length (io_call_info.args (2));
1420 MRI.noes = io_call_info.args (2);
1421 call iox_$control (iocb_ptr, order, addr (MRI), code);
1422 if code ^= 0 then
1423 call io_call_info.error (code, caller, "While setting more responses. ^a", order);
1424 code = 0;
1425 return;
1426 end;
1427
1428 else if order = "get_more_responses" then do;
1429 call io_call_require_no_args ();
1430 MRI.version = more_responses_info_version_1;
1431 call iox_$control (iocb_ptr, order, addr (MRI), code);
1432 if code ^= 0 then do;
1433 call io_call_info.error (code, caller, "While getting more repsonses. ^a", order);
1434 code = 0;
1435 return;
1436 end;
1437 if called_as_af then
1438 call ioa_$rsnnl ("^a ^a", io_call_af_ret, (0), substr (MRI.yeses, 1, MRI.n_yeses),
1439 substr (MRI.noes, 1, MRI.n_noes));
1440 else do;
1441 dcl (yeses, noes) char (255) varying init ("");
1442 do i = 1 to max (MRI.n_yeses, MRI.n_noes);
1443 if i <= MRI.n_yeses then
1444 yeses = yeses || flat_rep (substr (MRI.yeses, i, i + 1)) || " ";
1445 if i <= MRI.n_noes then
1446 noes = noes || flat_rep (substr (MRI.noes, i, i + 1)) || " ";
1447 end;
1448 call io_call_info
1449 .
1450 report ("Yes Response^[s^]: ""^a"" No Response^[s^]: ""^a""", MRI.n_yeses > 1, yeses,
1451 MRI.n_noes > 1, noes);
1452 end;
1453 return;
1454 end;
1455
1456 else if order = "set_more_prompt" then do;
1457 if io_call_info.nargs = 0 then do;
1458 call io_call_info.error (0, "", "usage: io_call control window_switch set_more_prompt prompt_string");
1459 return;
1460 end;
1461 if io_call_info.nargs > 1 then do;
1462 call io_call_info
1463 .
1464 error (error_table_$wrong_no_of_args, caller, "Only one more prompt string may be specified. ^a",
1465 order);
1466 return;
1467 end;
1468 MPI.version = more_prompt_info_version_1;
1469 MPI.more_prompt = io_call_info.args (1);
1470 call iox_$control (iocb_ptr, order, addr (MPI), code);
1471 if code ^= 0 then
1472 call io_call_info.error (code, caller, "While setting more prompt. ^a", order);
1473 code = 0;
1474 return;
1475 end;
1476
1477 else if order = "get_more_prompt" then do;
1478 call io_call_require_no_args ();
1479 MPI.version = more_prompt_info_version_1;
1480 call iox_$control (iocb_ptr, order, addr (MPI), code);
1481 if code ^= 0 then do;
1482 call io_call_info.error (code, caller, "While getting more prompt. ^a", order);
1483 code = 0;
1484 return;
1485 end;
1486 if called_as_af then
1487 call ioa_$rsnnl ("^a", io_call_af_ret, (0), MPI.more_prompt);
1488 else call io_call_info.report ("More prompt: ""^a""", MPI.more_prompt);
1489 return;
1490 end;
1491
1492
1493 else if order = "set_editor_key_bindings" then do;
1494 if io_call_info.nargs = 0 then do;
1495 binding_usage:
1496 call io_call_info
1497 .
1498 error (0, "",
1499 "usage: io_call control window_switch set_editor_key_bindings character_sequence1 {editor_routine1} {control_args_1} ... {character_sequenceN {editor_routineN} {control_argsN}}"
1500 );
1501 return;
1502 end;
1503
1504
1505
1506
1507
1508 line_editor_binding_count = 0;
1509 line_editor_longest_sequence = 0;
1510
1511 call count_key_binding_args (1 , line_editor_binding_count, line_editor_longest_sequence);
1512
1513 if line_editor_binding_count = 0 | line_editor_longest_sequence = 0 then
1514 goto binding_usage;
1515
1516 allocate line_editor_key_binding_info set (line_editor_key_binding_info_ptr);
1517 on cleanup free line_editor_key_binding_info;
1518
1519 line_editor_key_binding_info.version = line_editor_key_binding_info_version_3;
1520
1521
1522
1523
1524 call process_key_bindings (1 , 1 );
1525
1526 call iox_$control (iocb_ptr, order, line_editor_key_binding_info_ptr, code);
1527 revert cleanup;
1528 free line_editor_key_binding_info;
1529 if code ^= 0 then
1530 call io_call_info.error (code, caller, "While setting key bindings. ^a", order);
1531 code = 0;
1532 return;
1533 end;
1534
1535 else if order = "get_editor_key_bindings" then do;
1536 if io_call_info.nargs ^= 1 then do;
1537 call io_call_info
1538 .
1539 error (0, "", "usage: io_call control window_switch get_editor_key_bindings character_sequence");
1540 call error_exit (Code);
1541 end;
1542 begin;
1543 dcl 1 gekbi aligned like get_editor_key_bindings_info;
1544 dcl 1 lekbi aligned like line_editor_key_binding_info based (gekbi.key_binding_info_ptr);
1545
1546 gekbi.version = get_editor_key_bindings_info_version_1;
1547 string (gekbi.flags) = ""b;
1548 gekbi.key_binding_info_ptr = null ();
1549 line_editor_binding_count = 1;
1550 line_editor_longest_sequence = length (io_call_info.args (1));
1551 on cleanup
1552 begin;
1553 if gekbi.key_binding_info_ptr = null () then
1554 free line_editor_key_binding_info in (attach_data_area);
1555 end;
1556 allocate lekbi in (attach_data_area);
1557
1558 lekbi.version = line_editor_key_binding_info_version_3;
1559 lekbi.sequence (1) = io_call_info.args (1);
1560
1561 call iox_$control (iocb_ptr, order, addr (gekbi), code);
1562 if code ^= 0 then do;
1563 call io_call_info
1564 .
1565 error (code, caller, "Getting the binding of ^a. ^a",
1566 requote_string_ ((io_call_info.args (1))), order);
1567 return;
1568 end;
1569
1570 dcl routine_pathname char (256);
1571 if lekbi.action (1) = EXTERNAL_ROUTINE then do;
1572 call entry_var_to_string (lekbi.editor_routine (1), routine_pathname, code);
1573 if code ^= 0 then
1574 return;
1575 end;
1576
1577 Note
1578
1579
1580 if called_as_af then do;
1581 if lekbi.action (1) = EXTERNAL_ROUTINE then
1582 call ioa_$rsnnl ("^a ^a -numarg_action ^a -name ^a -description ^a ^[-info_pathname ^a]",
1583 io_call_af_ret, (0), requote_string_ ((lekbi.sequence (1))),
1584 requote_string_ (rtrim (routine_pathname)),
1585 numarg_action_names (lekbi.numarg_action (1)),
1586 requote_string_ (rtrim (lekbi.name (1))),
1587 requote_string_ (rtrim (lekbi.description (1))),
1588 (lekbi.info_entry (1) ^= "") ,
1589 requote_string_ (rtrim (pathname_ (lekbi.info_dir (1), lekbi.info_entry (1)))));
1590 else if lekbi.action (1) > EXTERNAL_ROUTINE then
1591
1592 call ioa_$rsnnl ("^a -builtin ^a -description ^a^[ -info_pathname ^a^]", io_call_af_ret,
1593 (0), lekbi.sequence (1), builtin_routine_names (lekbi.action (1)),
1594 requote_string_ (rtrim (lekbi.description (1))),
1595 (lekbi.info_entry (1) ^= "") ,
1596 requote_string_ (rtrim (pathname_ (lekbi.info_dir (1), lekbi.info_entry (1)))));
1597 else
1598 call ioa_$rsnnl ("^a -name PREFIX -description ^a", io_call_af_ret, (0),
1599 requote_string_ ((lekbi.sequence (1))),
1600 requote_string_ (rtrim (lekbi.description (1))));
1601 end;
1602
1603 else call io_call_info
1604 .
1605 report (
1606 "Sequence: ^a^/ ^[Num-arg action: ^a^/ Procedure: ^a^/ ^;^2s^]Name: ^a^/ Description: ^a^[^/ Info path: ^a^]",
1607 flat_rep_string (lekbi.sequence (1)), (lekbi.action (1) = EXTERNAL_ROUTINE),
1608 numarg_action_names (lekbi.numarg_action (1)), routine_pathname, lekbi.name (1),
1609 lekbi.description (1), (lekbi.info_entry (1) ^= "") ,
1610 pathname_ (lekbi.info_dir (1), lekbi.info_entry (1)));
1611
1612 revert cleanup;
1613 free lekbi in (attach_data_area);
1614 end;
1615 code = 0;
1616 return;
1617 end;
1618
1619 else if order = "set_token_characters" then do;
1620 if io_call_info.nargs = 0 then do;
1621 call io_call_info
1622 .
1623 error (0, "", "usage: io_call control window_switch set_token_characters token_character_string")
1624 ;
1625 return;
1626 end;
1627 if io_call_info.nargs > 1 then do;
1628 call io_call_info
1629 .
1630 error (error_table_$wrong_no_of_args, caller,
1631 "Only one string of token characters may be specified. ^a", order);
1632 return;
1633 end;
1634
1635 TCI.version = token_characters_info_version_1;
1636 TCI.token_character_count = length (io_call_info.args (1));
1637 TCI.token_characters = io_call_info.args (1);
1638
1639 call iox_$control (iocb_ptr, order, addr (TCI), code);
1640 if code ^= 0 then
1641 call io_call_info.error (code, caller, "While setting token characters. ^a", order);
1642 code = 0;
1643 return;
1644 end;
1645
1646 else if order = "get_token_characters" then do;
1647 call io_call_require_no_args ();
1648 TCI.version = token_characters_info_version_1;
1649 call iox_$control (iocb_ptr, order, addr (TCI), code);
1650 if code ^= 0 then do;
1651 call io_call_info.error (code, caller, "While getting token characters. ^a", order);
1652 code = 0;
1653 return;
1654 end;
1655 if called_as_af then
1656 io_call_af_ret = substr (TCI.token_characters, 1, TCI.token_character_count);
1657 else call io_call_info.report ("^a", substr (TCI.token_characters, 1, TCI.token_character_count));
1658 return;
1659 end;
1660
1661 else if order = "get_window_status" then do;
1662 call io_call_require_no_args ();
1663 WSI.version = window_status_version_1;
1664 call iox_$control (iocb_ptr, order, addr (WSI), code);
1665 if code ^= 0 then do;
1666 call io_call_info.error (code, caller, "While getting window status. ^a", order);
1667 code = 0;
1668 return;
1669 end;
1670 if called_as_af then do;
1671 if (WSI.status_string = ""b) then
1672 io_call_af_ret = "NONE";
1673 else call ioa_$rsnnl ("^[SCREEN_INVALID ^]^[ASYNC_CHANGE ^]^[TTP_CHANGE ^]^[RECONNECTION^]",
1674 io_call_af_ret, (0), (WSI.status_string & W_STATUS_SCREEN_INVALID),
1675 (WSI.status_string & W_STATUS_ASYNC_EVENT), (WSI.status_string & W_STATUS_TTP_CHANGE),
1676 (WSI.status_string & W_STATUS_RECONNECTION));
1677 end;
1678 else call io_call_info
1679 .
1680 report (
1681 "There was ^[no ^]^[screen_invalid ^]^[async_change ^]^[ttp_change ^]^[reconnection ^]status pending for the window.",
1682 (WSI.status_string = ""b), (WSI.status_string & W_STATUS_SCREEN_INVALID),
1683 (WSI.status_string & W_STATUS_ASYNC_EVENT), (WSI.status_string & W_STATUS_TTP_CHANGE),
1684 (WSI.status_string & W_STATUS_RECONNECTION));
1685 return;
1686 end;
1687
1688 else if order = "set_window_status" then do;
1689 if io_call_info.nargs = 0 then do;
1690 call io_call_info
1691 .error (0, "", "usage: io control window_switch set_window_status status_key_1 {status_key_2}");
1692 return;
1693 end;
1694 WSI.version = window_status_version_1;
1695 do arg_index = 1 to io_call_info.nargs;
1696 if io_call_info.args (arg_index) = "screen_invalid" then
1697 WSI.status_string = WSI.status_string | W_STATUS_SCREEN_INVALID;
1698 else if io_call_info.args (arg_index) = "asynchronous_change"
1699 | io_call_info.args (arg_index) = "async_change" then
1700 WSI.status_string = WSI.status_string | W_STATUS_ASYNC_EVENT;
1701 else if io_call_info.args (arg_index) = "terminal_type_change"
1702 | io_call_info.args (arg_index) = "ttp_change" then
1703 WSI.status_string = WSI.status_string | W_STATUS_TTP_CHANGE;
1704 else if io_call_info.args (arg_index) = "reconnection" then
1705 WSI.status_string = WSI.status_string | W_STATUS_RECONNECTION;
1706 else do;
1707 call io_call_info
1708 .
1709 error (error_table_$bad_arg, caller,
1710 "Only screen_invalid or asynchronous_change is allowed, not ""^a."" ^a",
1711 io_call_info.args (arg_index), order);
1712 return;
1713 end;
1714 end;
1715 call iox_$control (iocb_ptr, order, addr (WSI), code);
1716 return;
1717 end;
1718
1719
1720
1721
1722 else if order = "set_editing_chars" then do;
1723 if io_call_info.nargs = 0 then do;
1724 call io_call_info
1725 .error (0, "", "usage: io_call control window_switch set_editing_chars erase_kill_characters");
1726 return;
1727 end;
1728 if io_call_info.nargs > 1 then do;
1729 call io_call_info
1730 .
1731 error (error_table_$wrong_no_of_args, caller,
1732 "Only one set of editing characters may be specified. ^a", order);
1733 return;
1734 end;
1735 if length (io_call_info.args (1)) < 2 then do;
1736 call io_call_info
1737 .
1738 error (error_table_$bad_arg, caller, "Both erase and kill characters must be specified. ^a",
1739 order);
1740 return;
1741 end;
1742 if length (io_call_info.args (1)) > 3 then do;
1743 call io_call_info
1744 .
1745 error (error_table_$bad_arg, caller,
1746 "Only one erase character, one kill character and one redisplay character may be specified. ^a",
1747 order);
1748 return;
1749 end;
1750 EC.erase = substr (io_call_info.args (1), 1, 1);
1751 EC.kill = substr (io_call_info.args (1), 2, 1);
1752 if length (io_call_info.args (1)) = 3 then do;
1753 EC.version = editing_chars_version_3;
1754 EC.redisplay = substr (io_call_info.args (1), 3, 1);
1755 end;
1756 else do;
1757 EC.version = editing_chars_version_2;
1758 EC.redisplay = "";
1759 end;
1760
1761 call iox_$control (iocb_ptr, order, addr (EC), code);
1762 if code ^= 0 then
1763 call io_call_info.error (code, caller, "While setting editing characters. ^a", order);
1764 return;
1765 end;
1766
1767 else if order = "get_editing_chars" then do;
1768 call io_call_require_no_args ();
1769 EC.version = editing_chars_version_3;
1770 call iox_$control (iocb_ptr, order, addr (EC), code);
1771 if code ^= 0 then
1772 return;
1773 if called_as_af then
1774 call ioa_$rsnnl ("^a^a^a", io_call_af_ret, (0), EC.erase, EC.kill, EC.redisplay);
1775 else call io_call_info
1776 .
1777 report ("Erase: ^a, Kill: ^a, Redisplay: ^a", flat_rep (EC.erase), flat_rep (EC.kill),
1778 flat_rep (EC.redisplay));
1779 return;
1780 end;
1781
1782 code = error_table_$undefined_order_request;
1783 return;
1784
1785 io_call_require_no_args:
1786 procedure;
1787
1788 if io_call_info.nargs ^= 0 then do;
1789 call io_call_info
1790 .
1791 error (error_table_$wrong_no_of_args, caller, "No arguments are allowed for the ^a order.",
1792 order);
1793 call error_exit (Code);
1794 end;
1795 end io_call_require_no_args;
1796 ^L
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808 count_key_binding_args:
1809 procedure (arg_index, binding_count, longest_key_sequence);
1810
1811 dcl arg_index fixed bin,
1812 binding_count fixed bin,
1813 longest_key_sequence fixed bin;
1814
1815 dcl ctl_arg_flag bit (1);
1816
1817 do while (arg_index <= io_call_info.nargs);
1818
1819 if arg_index = io_call_info.nargs then do;
1820 if index (io_call_info.args (arg_index), "-") = 1 then
1821 return;
1822 call io_call_info
1823 .
1824 error (error_table_$noarg, caller,
1825 "Editor routine for character sequence ""^a"" must be specified.",
1826 io_call_info.args (arg_index));
1827 call error_exit (Code);
1828 end;
1829
1830 longest_key_sequence = max (length (io_call_info.args (arg_index)), longest_key_sequence);
1831 binding_count = binding_count + 1;
1832
1833 arg_index = arg_index + 1;
1834
1835 if index (io_call_info.args (arg_index), "-") ^= 1 then
1836 arg_index = arg_index + 1;
1837
1838
1839
1840
1841 if arg_index <= io_call_info.nargs then
1842 if index (io_call_info.args (arg_index), "-") = 1 then do;
1843 ctl_arg_flag = "1"b;
1844 do while (ctl_arg_flag);
1845 arg_index = arg_index + 2;
1846 if arg_index < io_call_info.nargs then
1847 ctl_arg_flag = (index (io_call_info.args (arg_index), "-") = 1);
1848 else ctl_arg_flag = "0"b;
1849 end;
1850 end;
1851
1852 end;
1853
1854 return;
1855
1856 end count_key_binding_args;
1857 ^L
1858
1859
1860 process_key_bindings:
1861 procedure (arg_index, binding_index);
1862
1863 dcl arg_index fixed bin;
1864 dcl binding_index fixed bin;
1865
1866 dcl 1 flags aligned,
1867 2 builtin_given unaligned bit (1),
1868 2 external_given unaligned bit (1),
1869 2 numarg_action_given
1870 unaligned bit (1);
1871
1872 do while (arg_index <= io_call_info.nargs);
1873
1874 unspec (flags) = ""b;
1875
1876
1877 line_editor_key_binding_info.sequence (binding_index) = io_call_info.args (arg_index);
1878
1879
1880 line_editor_key_binding_info.name, line_editor_key_binding_info.description,
1881 line_editor_key_binding_info.info_dir, line_editor_key_binding_info.info_entry = "";
1882
1883 arg_index = arg_index + 1;
1884
1885 if index (io_call_info.args (arg_index), "-") ^= 1 then do;
1886 line_editor_key_binding_info.action (binding_index) = EXTERNAL_ROUTINE;
1887
1888 line_editor_key_binding_info.editor_routine (binding_index) =
1889 cv_entry_ ((io_call_info.args (arg_index)), codeptr (process_io_call), code);
1890 if code ^= 0 then do;
1891 call io_call_info
1892 .
1893 error (code, caller, "Could not convert ""^a"" to an entry value. ^a",
1894 io_call_info.args (arg_index), order);
1895 code = 0;
1896 call error_exit (Code);
1897 end;
1898 external_given = "1"b;
1899 builtin_given = "0"b;
1900 arg_index = arg_index + 1;
1901 end;
1902
1903 if arg_index <= io_call_info.nargs then
1904 if index (io_call_info.args (arg_index), "-") = 1 then
1905
1906 call process_control_args (arg_index, binding_index);
1907
1908 if ^(builtin_given | external_given) then do;
1909 call io_call_info
1910 .
1911 error (error_table_$noarg, caller,
1912 "Editor routine for character sequence ""^a"" must be specified. ^a",
1913 line_editor_key_binding_info.sequence (binding_index), order);
1914 call error_exit (Code);
1915 end;
1916
1917 if builtin_given & numarg_action_given then do;
1918 call io_call_info
1919 .
1920 error (error_table_$inconsistent, caller,
1921 "Numarg action may not be specified for builtin routines. ^a", order);
1922 call error_exit (Code);
1923 end;
1924
1925 if ^numarg_action_given & external_given then
1926 line_editor_key_binding_info.numarg_action (binding_index) = PASS;
1927
1928 binding_index = binding_index + 1;
1929
1930 end;
1931
1932 return;
1933 ^L
1934
1935
1936
1937 process_control_args:
1938 procedure (arg_index, binding_index);
1939
1940 dcl arg_index fixed bin;
1941 dcl binding_index fixed bin;
1942 dcl builtin_index fixed bin;
1943 dcl numarg_index fixed bin;
1944 dcl arg char (arg_len) varying based (arg_ptr);
1945 dcl next_arg char (next_arg_len) varying based (next_arg_ptr);
1946 dcl (arg_len, next_arg_len)
1947 fixed bin (21);
1948 dcl (arg_ptr, next_arg_ptr)
1949 ptr;
1950 dcl found bit (1);
1951
1952 dcl uppercase char (26) static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
1953 dcl lowercase char (26) static options (constant) init ("abcdefghijklmnopqrstuvwxyz");
1954 dcl expand_pathname_$add_suffix
1955 entry (char (*), char (*), char (*), char (*), fixed bin (35));
1956
1957 do while (arg_index <= io_call_info.nargs);
1958
1959 arg_ptr = addr (io_call_info.args (arg_index));
1960 arg_len = length (io_call_info.args (arg_index));
1961
1962 if index (arg, "-") ^= 1 then
1963 return;
1964
1965 if ^(arg = "-builtin" | arg = "-external" | arg = "-numarg_action" | arg = "-name"
1966 | arg = "-description" | arg = "-info_pathname") then do;
1967 call io_call_info.error (error_table_$badopt, caller, "^a. ^a", arg, order);
1968 call error_exit (Code);
1969 end;
1970
1971 if arg_index = io_call_info.nargs then do;
1972 call io_call_info
1973 .error (error_table_$noarg, caller, """^a"" requires an argument. ^a", arg, order);
1974 call error_exit (Code);
1975 end;
1976
1977 next_arg_ptr = addr (io_call_info.args (arg_index + 1));
1978 next_arg_len = length (io_call_info.args (arg_index + 1));
1979
1980 if arg = "-external" then do;
1981 line_editor_key_binding_info.action (binding_index) = EXTERNAL_ROUTINE;
1982
1983 line_editor_key_binding_info.editor_routine (binding_index) =
1984 cv_entry_ ((next_arg), codeptr (process_io_call), code);
1985 if code ^= 0 then do;
1986 call io_call_info
1987 .
1988 error (code, caller, "Could not convert ""^a"" to an entry value. ^a", next_arg,
1989 order);
1990 code = 0;
1991 call error_exit (Code);
1992 end;
1993 external_given = "1"b;
1994 builtin_given = "0"b;
1995 end;
1996
1997
1998
1999
2000
2001 if arg = "-builtin" then do;
2002 begin;
2003 dcl next_arg_uppercase char (next_arg_len);
2004 found = "0"b;
2005 next_arg_uppercase = translate (next_arg, uppercase, lowercase);
2006 do builtin_index = 1 to HIGHEST_BUILTIN_ROUTINE_VALUE while (^found);
2007 if builtin_routine_names (builtin_index) = next_arg_uppercase then
2008 found = "1"b;
2009 end;
2010 end;
2011 if ^found then do;
2012 call io_call_info
2013 .
2014 error (error_table_$bad_arg, caller,
2015 """^a"" is not a builtin editor function. ^a", next_arg, order);
2016 call error_exit (Code);
2017 end;
2018 line_editor_key_binding_info.action (binding_index) = builtin_index - 1;
2019
2020 builtin_given = "1"b;
2021 external_given = "0"b;
2022 end;
2023
2024 else if arg = "-numarg_action" then do;
2025 begin;
2026 dcl next_arg_uppercase char (next_arg_len);
2027 found = "0"b;
2028 next_arg_uppercase = translate (next_arg, uppercase, lowercase);
2029 do numarg_index = 0 to HIGHEST_NUMARG_ACTION_VALUE while (^found);
2030 if numarg_action_names (numarg_index) = next_arg_uppercase then
2031 found = "1"b;
2032 end;
2033 end;
2034 if ^found then do;
2035 call io_call_info
2036 .
2037 error (error_table_$bad_arg, caller, """^a"" is not a valid numarg action. ^a",
2038 next_arg, order);
2039 call error_exit (Code);
2040 end;
2041 line_editor_key_binding_info.numarg_action (binding_index) = numarg_index - 1;
2042
2043 numarg_action_given = "1"b;
2044 end;
2045
2046 else if arg = "-name" then
2047 line_editor_key_binding_info.name (binding_index) = next_arg;
2048 else if arg = "-description" then
2049 line_editor_key_binding_info.description (binding_index) = next_arg;
2050 else if arg = "-info_pathname" then do;
2051 call expand_pathname_$add_suffix ((next_arg), "info",
2052 line_editor_key_binding_info.info_dir (binding_index),
2053 line_editor_key_binding_info.info_entry (binding_index), code);
2054 if code ^= 0 then do;
2055 call io_call_info.error (code, caller, "The pathname ""^a"". ^a", next_arg, order);
2056 call error_exit (Code);
2057 end;
2058 end;
2059
2060 arg_index = arg_index + 2;
2061
2062
2063 end;
2064
2065 return;
2066
2067 end process_control_args;
2068
2069 end process_key_bindings;
2070
2071 end process_io_call;
2072 ^L
2073 require_version:
2074 proc (version_found, latest);
2075
2076 dcl version_found fixed bin parameter;
2077 dcl latest fixed bin parameter;
2078
2079 if version_found ^= latest & version_found ^= editing_chars_version_2 then do;
2080 call error_exit (error_table_$unimplemented_version);
2081 end;
2082
2083 end require_version;
2084
2085 require_version_str:
2086 proc (version_found, latest);
2087
2088 dcl version_found char (8) aligned;
2089 dcl latest char (8);
2090
2091 if version_found ^= latest then do;
2092 call error_exit (error_table_$unimplemented_version);
2093 end;
2094
2095 end require_version_str;
2096
2097 check_null:
2098 procedure;
2099 if Info_ptr = null () then do;
2100 call error_exit (error_table_$null_info_ptr);
2101 end;
2102 end check_null;
2103
2104 require_mbz:
2105 proc (bit_string);
2106
2107 dcl bit_string bit (*);
2108
2109 if bit_string ^= ""b then do;
2110 call error_exit (error_table_$bad_subr_arg);
2111 end;
2112 end require_mbz;
2113
2114 setup:
2115 procedure;
2116 attach_data_ptr = Iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
2117 Code = 0;
2118 target_iocbp = attach_data.target_iocb_ptr;
2119 end setup;
2120
2121 always_breaks:
2122 procedure (c) returns (bit (1) aligned) reducible;
2123 dcl c char (1) aligned parameter;
2124 return (rank (c) <= 31 | c = byte (bin ("177"b3)) );
2125 end always_breaks;
2126
2127 set_break_table:
2128 proc (c, flag);
2129
2130 dcl c char (1) aligned;
2131 dcl flag bit (1) unaligned;
2132
2133 if (rank (c) >= lbound (line_editor_breaks_array, 1)) & (rank (c) <= hbound (line_editor_breaks_array, 1)) then
2134 line_editor_breaks_array (rank (c)) = always_breaks (c) | flag;
2135
2136 end set_break_table;
2137
2138
2139
2140
2141 flat_rep:
2142 procedure (c) returns (char (32) varying) reducible;
2143
2144 dcl c character (1);
2145
2146 if c = byte (bin ("015"b3)) then
2147 return ("RETURN");
2148 if c = byte (bin ("033"b3)) then
2149 return ("ESC");
2150 if c < " " then
2151 return ("^" || byte (rank (c) + rank ("@")));
2152 if c = " " then
2153 return ("SPACE");
2154 if c = byte (bin ("177"b3)) then
2155 return ("DEL");
2156 return (c);
2157
2158 end flat_rep;
2159
2160 flat_rep_string:
2161 proc (P_string) returns (char (*)) reducible;
2162
2163 dcl P_string char (*) varying;
2164
2165 dcl char_idx fixed bin (21);
2166
2167 if length (P_string) = 0 then
2168 return ("");
2169
2170 begin;
2171 dcl flat_string char (7 * length (P_string)) varying init ("");
2172
2173 do char_idx = 1 to length (P_string) - 1;
2174 flat_string = flat_string || flat_rep (substr (P_string, char_idx, 1)) || " ";
2175 end;
2176 flat_string = flat_string || flat_rep (substr (P_string, length (P_string), 1));
2177 return ((flat_string));
2178 end;
2179
2180 end flat_rep_string;
2181 ^L
2182
2183
2184
2185
2186 entry_var_to_string:
2187 procedure (routine, entry_string, code);
2188
2189 dcl routine entry;
2190 dcl entry_string char (*);
2191 dcl code fixed bin (35);
2192
2193 dcl seg_name char (32);
2194 dcl entry_point_name char (32);
2195
2196 dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
2197 dcl get_entry_name_ entry (ptr, char (*), fixed bin (18), char (8) aligned, fixed bin (35));
2198
2199 dcl 1 entry_variable aligned based,
2200 2 code_ptr ptr,
2201 2 env_ptr ptr;
2202
2203 call hcs_$fs_get_path_name (addr (routine) -> entry_variable.code_ptr, "", (0), seg_name, code);
2204 if code ^= 0 then
2205 return;
2206
2207 call get_entry_name_ (addr (routine) -> entry_variable.code_ptr, entry_point_name, (0), "", code);
2208 if code ^= 0 then
2209 return;
2210
2211 entry_string = rtrim (seg_name) || "$" || rtrim (entry_point_name);
2212
2213 return;
2214
2215 end entry_var_to_string;
2216 ^L
2217
2218
2219
2220
2221
2222
2223
2224 read_status:
2225 proc ();
2226
2227 %include tc_operations_;
2228
2229 %include tty_read_status_info;
2230
2231 dcl 1 rqrs aligned like request_read_status;
2232
2233
2234 rqrs.sentinel = REQUEST_SENTINEL;
2235 rqrs.window_id = attach_data.window_id;
2236 rqrs.request_id = clock ();
2237 rqrs.operation = OP_READ_STATUS;
2238 rqrs.row = attach_data.current.line_origin;
2239 rqrs.col = attach_data.current.column_origin; note
2240 string (rqrs.flags) = ""b;
2241
2242 call iox_$control (target_iocbp, "window_operation", addr (rqrs), Code);
2243 if Code ^= 0 then
2244 return;
2245
2246 Info_ptr -> tty_read_status_info.event_channel = rqrs.event_channel;
2247 Info_ptr -> tty_read_status_info.input_pending = rqrs.returned_length > 0;
2248
2249 return;
2250
2251 end read_status;
2252
2253 error_exit:
2254 proc (a_code);
2255
2256 dcl a_code fixed bin (35) parameter;
2257
2258 Code = a_code;
2259 go to error_return;
2260
2261 end error_exit;
2262
2263 error_return:
2264 return;
2265 %page;
2266 copy_new_to_old_special_table:
2267 proc;
2268
2269
2270
2271
2272
2273 dcl i fixed bin;
2274 dcl old_max_length fixed bin;
2275
2276 Code = 0;
2277 old_max_length = hbound (gsi_old.table_ptr -> special_chars_struc_old.nl_seq.chars, 1);
2278
2279 if attach_data.special_ptr -> special_chars.nl_seq.count > old_max_length then
2280 go to bad_special;
2281 addr (gsi_old.table_ptr -> special_chars_struc_old.nl_seq) -> c_chars_old =
2282 addr (attach_data.special_ptr -> special_chars.nl_seq) -> c_chars_old;
2283 if attach_data.special_ptr -> special_chars.cr_seq.count > old_max_length then
2284 go to bad_special;
2285 addr (gsi_old.table_ptr -> special_chars_struc_old.cr_seq) -> c_chars_old =
2286 addr (attach_data.special_ptr -> special_chars.cr_seq) -> c_chars_old;
2287 if attach_data.special_ptr -> special_chars.bs_seq.count > old_max_length then
2288 go to bad_special;
2289 addr (gsi_old.table_ptr -> special_chars_struc_old.bs_seq) -> c_chars_old =
2290 addr (attach_data.special_ptr -> special_chars.bs_seq) -> c_chars_old;
2291 if attach_data.special_ptr -> special_chars.tab_seq.count > old_max_length then
2292 go to bad_special;
2293 addr (gsi_old.table_ptr -> special_chars_struc_old.tab_seq) -> c_chars_old =
2294 addr (attach_data.special_ptr -> special_chars.tab_seq) -> c_chars_old;
2295 if attach_data.special_ptr -> special_chars.vt_seq.count > old_max_length then
2296 go to bad_special;
2297 addr (gsi_old.table_ptr -> special_chars_struc_old.vt_seq) -> c_chars_old =
2298 addr (attach_data.special_ptr -> special_chars.vt_seq) -> c_chars_old;
2299 if attach_data.special_ptr -> special_chars.ff_seq.count > old_max_length then
2300 go to bad_special;
2301 addr (gsi_old.table_ptr -> special_chars_struc_old.ff_seq) -> c_chars_old =
2302 addr (attach_data.special_ptr -> special_chars.ff_seq) -> c_chars_old;
2303 if attach_data.special_ptr -> special_chars.printer_on.count > old_max_length then
2304 go to bad_special;
2305 addr (gsi_old.table_ptr -> special_chars_struc_old.printer_on) -> c_chars_old =
2306 addr (attach_data.special_ptr -> special_chars.printer_on) -> c_chars_old;
2307 if attach_data.special_ptr -> special_chars.printer_off.count > old_max_length then
2308 go to bad_special;
2309 addr (gsi_old.table_ptr -> special_chars_struc_old.printer_off) -> c_chars_old =
2310 addr (attach_data.special_ptr -> special_chars.printer_off) -> c_chars_old;
2311 if attach_data.special_ptr -> special_chars.red_ribbon_shift.count > old_max_length then
2312 go to bad_special;
2313 addr (gsi_old.table_ptr -> special_chars_struc_old.red_ribbon_shift) -> c_chars_old =
2314 addr (attach_data.special_ptr -> special_chars.red_ribbon_shift) -> c_chars_old;
2315 if attach_data.special_ptr -> special_chars.black_ribbon_shift.count > old_max_length then
2316 go to bad_special;
2317 addr (gsi_old.table_ptr -> special_chars_struc_old.black_ribbon_shift) -> c_chars_old =
2318 addr (attach_data.special_ptr -> special_chars.black_ribbon_shift) -> c_chars_old;
2319 if attach_data.special_ptr -> special_chars.end_of_page.count > old_max_length then
2320 go to bad_special;
2321 addr (gsi_old.table_ptr -> special_chars_struc_old.end_of_page) -> c_chars_old =
2322 addr (attach_data.special_ptr -> special_chars.end_of_page) -> c_chars_old;
2323 gsi_old.table_ptr -> special_chars_struc_old.escape_length =
2324 attach_data.special_ptr -> special_chars.escape_length;
2325 do i = 1 to attach_data.special_ptr -> special_chars.escape_length;
2326 if attach_data.special_ptr -> special_chars.not_edited_escapes (i).count > old_max_length then
2327 go to bad_special;
2328 addr (gsi_old.table_ptr -> special_chars_struc_old.not_edited_escapes (i)) -> c_chars_old =
2329 addr (attach_data.special_ptr -> special_chars.not_edited_escapes (i)) -> c_chars_old;
2330 if attach_data.special_ptr -> special_chars.edited_escapes (i).count > old_max_length then
2331 go to bad_special;
2332 addr (gsi_old.table_ptr -> special_chars_struc_old.edited_escapes (i)) -> c_chars_old =
2333 addr (attach_data.special_ptr -> special_chars.edited_escapes (i)) -> c_chars_old;
2334 end;
2335 gsi_old.table_ptr -> special_chars_struc_old.input_escapes =
2336 attach_data.special_ptr -> special_chars.input_escapes;
2337 gsi_old.table_ptr -> special_chars_struc_old.input_results =
2338 attach_data.special_ptr -> special_chars.input_results;
2339
2340 return;
2341
2342 bad_special:
2343 Code = error_table_$invalid_array_size;
2344 return;
2345
2346 end copy_new_to_old_special_table;
2347 %page;
2348 copy_old_to_new_special_table:
2349 proc;
2350
2351
2352
2353
2354 dcl i fixed bin;
2355
2356 addr (temp_ptr -> special_chars.nl_seq) -> c_chars_old =
2357 addr (addr (scs.special_chars) -> special_chars_old.nl_seq) -> c_chars_old;
2358 addr (temp_ptr -> special_chars.cr_seq) -> c_chars_old =
2359 addr (addr (scs.special_chars) -> special_chars_old.cr_seq) -> c_chars_old;
2360 addr (temp_ptr -> special_chars.bs_seq) -> c_chars_old =
2361 addr (addr (scs.special_chars) -> special_chars_old.bs_seq) -> c_chars_old;
2362 addr (temp_ptr -> special_chars.tab_seq) -> c_chars_old =
2363 addr (addr (scs.special_chars) -> special_chars_old.tab_seq) -> c_chars_old;
2364 addr (temp_ptr -> special_chars.vt_seq) -> c_chars_old =
2365 addr (addr (scs.special_chars) -> special_chars_old.vt_seq) -> c_chars_old;
2366 addr (temp_ptr -> special_chars.ff_seq) -> c_chars_old =
2367 addr (addr (scs.special_chars) -> special_chars_old.ff_seq) -> c_chars_old;
2368 addr (temp_ptr -> special_chars.printer_on) -> c_chars_old =
2369 addr (addr (scs.special_chars) -> special_chars_old.printer_on) -> c_chars_old;
2370 addr (temp_ptr -> special_chars.printer_off) -> c_chars_old =
2371 addr (addr (scs.special_chars) -> special_chars_old.printer_off) -> c_chars_old;
2372 addr (temp_ptr -> special_chars.red_ribbon_shift) -> c_chars_old =
2373 addr (addr (scs.special_chars) -> special_chars_old.red_ribbon_shift) -> c_chars_old;
2374 addr (temp_ptr -> special_chars.black_ribbon_shift) -> c_chars_old =
2375 addr (addr (scs.special_chars) -> special_chars_old.black_ribbon_shift) -> c_chars_old;
2376 addr (temp_ptr -> special_chars.end_of_page) -> c_chars_old =
2377 addr (addr (scs.special_chars) -> special_chars_old.end_of_page) -> c_chars_old;
2378 temp_ptr -> special_chars.escape_length = addr (scs.special_chars) -> special_chars_old.escape_length;
2379 do i = 1 to attach_data.special_ptr -> special_chars.escape_length;
2380 addr (temp_ptr -> special_chars.not_edited_escapes (i)) -> c_chars_old =
2381 addr (addr (scs.special_chars) -> special_chars_old.not_edited_escapes (i)) -> c_chars_old;
2382 addr (temp_ptr -> special_chars.edited_escapes (i)) -> c_chars_old =
2383 addr (addr (scs.special_chars) -> special_chars_old.edited_escapes (i)) -> c_chars_old;
2384 end;
2385 temp_ptr -> special_chars.input_escapes = addr (scs.special_chars) -> special_chars_struc_old.input_escapes;
2386 temp_ptr -> special_chars.input_results = addr (scs.special_chars) -> special_chars_struc_old.input_results;
2387
2388 return;
2389
2390 end copy_old_to_new_special_table;
2391 %page;
2392 %include window_io_attach_data_;
2393 %include window_control_info;
2394 %page;
2395 %include iocb;
2396 %page;
2397 %include tc_desk_info_;
2398 %page;
2399 %include tty_editing_chars;
2400 %page;
2401 %include tty_convert;
2402 %page;
2403 %include iox_dcls;
2404 %page;
2405 %include mode_string_info;
2406 %page;
2407 %include window_dcls;
2408 %page;
2409 %include terminal_type_data;
2410 %page;
2411 %include terminal_info;
2412
2413 end wioctl_;
2414