1
2
3
4
5
6
7
8
9
10
11
12 TECO:
13 teco:
14 procedure;
15
16 goto declarations;
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 ^L
102
103
104 declare (cleanup, fixedoverflow, program_interrupt, teco_abort) condition;
105
106
107
108 declare (addr, bit, convert, copy, divide, fixed, hbound, index, lbound, length, max, min, multiply, null, reverse,
109 search, substr, unspec, verify) builtin;
110
111
112
113 declare EO_X_common_return label variable;
114 declare get_character_fail_handler label variable;
115 declare (arg_address, b1, b2, command_line_address, file_address, io_char_address, p) pointer;
116 declare 1 error_structure aligned,
117 2 error_message char (8),
118 2 nl char (1);
119 declare cvb picture "(11)-9";
120 declare string char (12);
121 declare (backup_flag, immediate_interrupt_ok, no_ES_flag, no_number, match, program_interrupt_flag, search_successful,
122 trace_flag, trace_flag_copy) bit (1) aligned;
123 declare my_id bit (36) aligned;
124 declare (current_character, delimiter, io_char) char (1) aligned;
125 declare search_chars char (2) aligned;
126 declare (Q_register_pushdown_level, arg_length, command_level) fixed bin (17);
127 declare arg1_stack (0:20) fixed bin (17);
128 declare colon_stack (0:20) fixed bin (17);
129 declare command_char_stack (0:20) fixed bin (17);
130 declare command_iteration_stack (0:20) fixed bin (17);
131 declare command_length_stack (0:20) fixed bin (17);
132 declare command_seg_stack (0:20) fixed bin (17);
133 declare macro_entry fixed bin (17);
134 declare num_arg_stack (0:20) fixed bin (17);
135 declare pushdown_Q_register_seg_number (1:20) fixed bin (17);
136 declare pushdown_Q_register_value (1:20) fixed bin (17);
137 declare arg (0:2) fixed bin (24);
138 declare (backup_command_line_1_char, base_iteration_level, colon_X_save_command_level, colon_flag, tag_char_number,
139 command_char_number, command_line_length, count, current_Q_register_number, current_expression, current_sign,
140 dot1, dot2, end_buffer, i, iteration_level, return_iteration_level, j, max_seg_size, max_dot1, min_dot2, n1, n2,
141 num_arg, number, octal_number, paren_level, start, read_count, search_answer, iteration_answer, search_length,
142 skip_count, temp_dot, which_operator) fixed bin (24);
143 declare expression_stack (1:20) fixed bin (24);
144 declare operator_stack (1:20) fixed bin (24);
145 declare sign_stack (1:20) fixed bin (24);
146 declare error_code fixed bin (35);
147 declare 1 iteration (1:20) aligned,
148 2 begin fixed bin (24),
149 2 end fixed bin (24),
150 2 count fixed bin (24),
151 2 begin_tag fixed bin (24),
152 2 errset bit (1);
153 declare 1 temp_seg_info structure aligned,
154 2 Q_register_value (32:127) fixed bin (24),
155 2 Q_register_seg_number (32:127) fixed bin (17),
156 2 temp_seg_address (-100:100) pointer,
157 2 temp_seg_usage_count (-100:100) fixed bin (17);
158
159
160
161 declare argument based (arg_address) char (arg_length);
162 declare current_Q_register based (current_Q_register_address) aligned char (current_Q_register_value);
163 declare file based (file_address) aligned char (count);
164 declare quoted_string based (quoted_string_address) aligned char (quoted_string_length);
165 declare buffer1 based (b1) aligned char (dot1);
166 declare buffer2 based (b2) aligned char (end_buffer);
167 declare command_line based (command_line_address) aligned char (command_line_length);
168
169
170
171 declare assign_temp_seg_id_ entry (char (*) aligned, bit (36) aligned, fixed bin (35));
172 declare com_err_ entry options (variable);
173 declare cu_$arg_count entry () returns (fixed bin (17));
174 declare cu_$arg_ptr entry (fixed bin (17), pointer, fixed bin (17), fixed bin (35));
175 declare cu_$cp entry (pointer, fixed bin (24), fixed bin (35));
176 declare cu_$ptr_call entry options (variable);
177 declare cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed binary (24));
178 declare find_command_$fc_no_message entry (pointer, fixed bin (24), pointer, fixed bin (35));
179 declare get_seg_ptr_ entry (char (*) aligned, bit (6) aligned, fixed bin (24), pointer, fixed bin (35));
180 declare get_temp_seg_ entry (bit (36) aligned, bit (5) aligned, pointer, fixed bin (35));
181 declare (
182 ioa_,
183 ioa_$rsnnl
184 ) entry options (variable);
185 declare iox_$get_chars entry (pointer, pointer, fixed bin (24), fixed bin (24), fixed bin (35));
186 declare iox_$get_line entry (pointer, pointer, fixed bin (24), fixed bin (24), fixed bin (35));
187 declare iox_$put_chars entry (pointer, pointer, fixed bin (24), fixed bin (35));
188 declare release_seg_ptr_ entry (pointer, fixed bin (17), fixed bin (35));
189 declare release_temp_segs_all_ entry (bit (36) aligned, fixed bin (35));
190 declare search_file_
191 entry (pointer, fixed bin (24), fixed bin (24), pointer, fixed bin (24), fixed bin (24), fixed bin (24),
192 fixed bin (24), fixed bin (24));
193 declare teco_backup_file_ entry (char (*) aligned);
194 declare teco_error entry (char (*) aligned);
195 declare teco_get_macro_ entry (char (*) aligned, pointer, fixed bin (24), fixed bin (35));
196
197
198
199 declare current_Q_register_seg_number fixed bin (17) defined (Q_register_seg_number (current_Q_register_number));
200 declare current_Q_register_value fixed bin (24) defined (Q_register_value (current_Q_register_number));
201 declare current_Q_register_address pointer defined (temp_seg_address (current_Q_register_seg_number));
202 declare current_Q_register_usage_count fixed bin (17) defined (temp_seg_usage_count (current_Q_register_seg_number));
203 declare quoted_string_seg_number fixed bin (17) defined (Q_register_seg_number (34));
204 declare quoted_string_length fixed bin (24) defined (Q_register_value (34));
205 declare quoted_string_address pointer defined (temp_seg_address (Q_register_seg_number (34)));
206 declare arg1 defined (arg (1)) fixed bin (24);
207 declare arg2 defined (arg (2)) fixed bin (24);
208
209
210
211 declare error_table_$too_many_args fixed bin (35) ext static;
212 declare sys_info$max_seg_size external static fixed bin (24);
213 declare iox_$user_input external static pointer;
214 declare iox_$user_output external static pointer;
215
216
217
218 declare new_line_char int static options (constant) char (1) aligned initial ("
219 ");
220 declare blanks int static options (constant) char (12) aligned initial ("");
221 declare white_space int static options (constant) char (2) aligned initial (" ");
222
223 declare start_up_name int static options (constant) char (8) aligned initial ("start_up");
224 declare char_0_code int static options (constant) fixed bin (09) initial (000110000b);
225 declare dummy_Q_register_number int static options (constant) fixed bin (17) initial (127);
226 declare number_reserved_temp_segs int static options (constant) fixed bin (17) initial (2);
227 declare quoted_string_Q_register_number int static options (constant) fixed bin (17) initial (34);
228 declare radix int static options (constant) fixed bin (17) initial (10);
229 declare max_positive_integer int static options (constant) fixed bin (35)
230 initial (11111111111111111111111111111111111b);
231 declare rwa_access int static options (constant) bit (5) aligned initial ("01011"b);
232 declare r_access int static options (constant) bit (6) aligned initial ("010000"b);
233 declare rwac_access int static options (constant) bit (6) aligned initial ("010111"b);
234 declare program_name int static options (constant) char (4) aligned initial ("teco");
235
236
237
238 declare signature_length int static fixed bin (24) init (3);
239 declare signature int static char (8) aligned initial ("N^HZ");
240 declare error_mode int static char (4) aligned initial ("shor");
241
242 %include cp_active_string_types;
243 ^L
244 teco_error_mode:
245 entry (new_error_mode);
246 dcl new_error_mode char (*) unal;
247 error_mode = new_error_mode;
248 return;
249
250
251
252 set_prompt:
253 entry;
254
255 call cu_$arg_ptr (1, arg_address, arg_length, error_code);
256 if error_code = 0
257 then do;
258 signature = argument;
259 signature_length = min (length (argument), length (signature));
260 end;
261 else do;
262 signature = "N^HZ";
263 signature_length = 3;
264 end;
265 return;
266
267 teco_no_ES:
268 entry;
269 no_ES_flag = "1"b;
270 macro_entry = 0;
271 goto no_ES_declarations;
272
273 abort:
274 ABORT:
275 entry;
276 signal teco_abort;
277
278 macro:
279 entry;
280 no_ES_flag = "0"b;
281 macro_entry = 1;
282 goto no_ES_declarations;
283
284 declarations:
285 no_ES_flag = "0"b;
286 macro_entry = 0;
287
288 no_ES_declarations:
289 command_level = 0;
290 Q_register_pushdown_level = 0;
291 io_char_address = addr (io_char);
292 error_structure.nl = new_line_char;
293 unspec (temp_seg_info) = ""b;
294 temp_seg_address (*) = null;
295
296 max_seg_size = sys_info$max_seg_size * 4;
297 read_count = cu_$arg_count ();
298
299
300
301 if read_count - macro_entry > hbound (pushdown_Q_register_value, 1) - 1
302 then do;
303 call com_err_ (error_table_$too_many_args, program_name, "Maximum number of arguments is ^d.",
304 hbound (pushdown_Q_register_value, 1) - 1);
305 return;
306 end;
307
308 call assign_temp_seg_id_ (program_name, my_id, error_code);
309 if error_code ^= 0
310 then do;
311 call com_err_ (error_code, program_name, "temporary_segment_id");
312 return;
313 end;
314 on cleanup call release_bufs;
315 do i = 0 to number_reserved_temp_segs + (read_count - macro_entry) + 1;
316 call get_temp_seg_ (my_id, rwa_access, p, error_code);
317 if error_code ^= 0
318 then do;
319 call com_err_ (error_code, program_name, "temporary segment number ^d", (i));
320 goto EQ;
321 end;
322 temp_seg_address (i) = p;
323 end;
324 command_line_address = temp_seg_address (0);
325 Q_register_pushdown_level = (read_count - macro_entry) + 1;
326 pushdown_Q_register_seg_number (Q_register_pushdown_level) = 0;
327 pushdown_Q_register_value (Q_register_pushdown_level) = (read_count - macro_entry);
328 do i = 1 to read_count - macro_entry;
329 call cu_$arg_ptr (read_count - i + 1, arg_address, arg_length, error_code);
330 temp_seg_address (i + 3) -> argument = arg_address -> argument;
331 temp_seg_usage_count (i + 3) = 1;
332 pushdown_Q_register_value (i) = arg_length;
333 pushdown_Q_register_seg_number (i) = i + 3;
334 end;
335 command_seg_stack (0) = -1;
336 temp_seg_usage_count (-1) = 1;
337 temp_seg_address (-1) = command_line_address;
338 quoted_string_seg_number = 3;
339 temp_seg_usage_count (3) = 1;
340 n1, n2 = 0;
341 b1 = null;
342 dot1, dot2, end_buffer = 0;
343 max_dot1, min_dot2 = 0;
344 base_iteration_level = 0;
345 paren_level = 0;
346 trace_flag, trace_flag_copy = "0"b;
347 command_char_number, command_line_length, backup_command_line_1_char = 0;
348 search_answer = 0;
349 iteration_level = 0;
350 immediate_interrupt_ok = "1"b;
351 num_arg = 0;
352 colon_flag = 0;
353 which_operator = -1;
354 program_interrupt_flag = "0"b;
355 on program_interrupt
356 begin;
357 if immediate_interrupt_ok
358 then goto command_abort;
359 else program_interrupt_flag = "1"b;
360 end;
361 on teco_abort goto command_abort;
362 current_Q_register_number = quoted_string_Q_register_number;
363
364 if macro_entry = 0
365 then do;
366 quoted_string_length = length (start_up_name);
367 quoted_string = start_up_name;
368 end;
369 else do;
370 call cu_$arg_ptr (1, arg_address, arg_length, error_code);
371 if error_code ^= 0
372 then do;
373 call com_err_ (error_code, program_name);
374 goto EQ;
375 end;
376 quoted_string_length = arg_length;
377 quoted_string = arg_address -> argument;
378 end;
379 goto EM_have_name;
380 ^L
381 command_abort:
382 program_interrupt_flag = "0"b;
383 immediate_interrupt_ok = "0"b;
384 do while (command_level > 0);
385 call unwind_command_level;
386 end;
387 base_iteration_level, iteration_level = 0;
388 paren_level = 0;
389 command_line_length, backup_command_line_1_char = 0;
390 if macro_entry ^= 0
391 then do;
392 call com_err_ (0, program_name, "Command aborted.");
393 goto EQ;
394 end;
395 trace_flag = trace_flag_copy;
396 command_complete:
397 COMMAND (36):
398 COMMAND (10):
399 num_arg = 0;
400 command_return_value:
401 colon_flag = 0;
402 if num_arg = 0
403 then
404 new_arg:
405 which_operator = -1;
406 else
407 arg_loop:
408 which_operator = 0;
409 M_return:
410 if program_interrupt_flag
411 then goto command_abort;
412 immediate_interrupt_ok = "1"b;
413 get_character_fail_handler = command_string_completed;
414 get_number:
415 current_sign = 0;
416 number = 0;
417 no_number = "0"b;
418 COMMAND_PREFIX (1):
419 COMMAND_PREFIX (24):
420 continue_scan:
421 call get_character;
422 goto COMMAND_PREFIX (index (" (:?0123456789-.zZqQ%bB ", current_character));
423 ^L
424 COMMAND_PREFIX (0):
425 if current_sign = 0
426 then if which_operator < 0
427 then goto check_command;
428 else if which_operator = 0
429 then goto check_operator;
430 number = 1;
431 no_number = "1"b;
432 backup_com_line:
433 backup_command_line_1_char = 1;
434
435
436 got_number:
437 COMMAND_PREFIX (22):
438 COMMAND_PREFIX (23): Note
439 if current_sign < 0
440 then number = -number;
441 goto OPERATOR (which_operator);
442 ^L
443 command_string_completed:
444 if iteration_level ^= 0
445 then goto unfinished_iteration;
446 if paren_level ^= 0
447 then goto unbalanced_parentheses;
448 macro_entry = 0;
449
450 if signature_length > 0
451 then call WRITE (addr (signature), 0, signature_length);
452 do while (Q_register_pushdown_level ^= 0);
453 Q_register_pushdown_level = Q_register_pushdown_level - 1;
454 temp_seg_usage_count (pushdown_Q_register_seg_number (Q_register_pushdown_level + 1)) =
455 temp_seg_usage_count (pushdown_Q_register_seg_number (Q_register_pushdown_level + 1)) - 1;
456 end;
457 command_line_length = 0;
458 command_char_number = 0;
459 search_answer = 0;
460 call read_line;
461 go to command_complete;
462 ^L
463 COMMAND_PREFIX (15):
464 if which_operator = 0
465 then goto COMMAND_PREFIX (0);
466 current_sign = -current_sign;
467 if current_sign = 0
468 then current_sign = -1;
469 goto continue_scan;
470
471
472 COMMAND (43):
473 current_sign = 1;
474 goto continue_scan;
475
476
477 COMMAND_PREFIX (5):
478 COMMAND_PREFIX (6):
479 COMMAND_PREFIX (7):
480 COMMAND_PREFIX (8):
481 COMMAND_PREFIX (9):
482 COMMAND_PREFIX (10):
483 COMMAND_PREFIX (11):
484 COMMAND_PREFIX (12):
485 COMMAND_PREFIX (13):
486 COMMAND_PREFIX (14):
487 octal_number = 0;
488 do i = fixed (unspec (io_char), 9, 0) - char_0_code repeat (fixed (unspec (io_char), 9, 0) - char_0_code)
489 while (i >= 0 & i < radix);
490 number = multiply (number, radix, 15, 0) + i;
491 octal_number = octal_number * 8 + i;
492 call get_character;
493 end;
494 if current_character ^= "."
495 then goto backup_com_line;
496 number = octal_number;
497 goto got_number;
498
499
500 COMMAND_PREFIX (16):
501 number = dot1;
502 goto got_number;
503
504
505 COMMAND_PREFIX (17):
506 COMMAND_PREFIX (18):
507 number = dot1 + end_buffer - dot2;
508 goto got_number;
509
510
511 COMMAND_PREFIX (19):
512 COMMAND_PREFIX (20):
513 current_Q_register_number = get_Q_register_number ();
514 number = current_Q_register_value;
515 goto got_number;
516
517
518 COMMAND_PREFIX (21):
519 current_Q_register_number = get_Q_register_number ();
520 if current_Q_register_seg_number ^= 0
521 then goto percent_cant_increment;
522 current_Q_register_value, number = current_Q_register_value + 1;
523 goto got_number;
524
525
526 COMMAND_PREFIX (3):
527 colon_flag = 1;
528 goto continue_scan;
529 ^L
530 COMMAND_PREFIX (4):
531 trace_flag = "1"b;
532 get_character_fail_handler = question_mark_alone;
533 call get_character;
534 if current_character = "?"
535 then trace_flag = "0"b;
536 else backup_command_line_1_char = 1;
537 question_mark_alone:
538 trace_flag_copy = trace_flag;
539 get_character_fail_handler = command_string_completed;
540 goto continue_scan;
541 ^L
542 OPERATOR (-1):
543 which_operator = 0;
544 two_commas:
545 if num_arg >= hbound (arg, 1)
546 then goto too_many_args;
547 num_arg = num_arg + 1;
548 current_expression = number;
549 goto arg_loop;
550 OPERATOR (0):
551 OPERATOR (1):
552 current_expression = current_expression + number;
553 goto arg_loop;
554
555
556 OPERATOR (2):
557 current_expression = current_expression - number;
558 goto arg_loop;
559
560
561 OPERATOR (3):
562 if no_number
563 then goto missing_right_operand;
564 current_expression = current_expression * number;
565 goto arg_loop;
566
567
568 OPERATOR (4):
569 if no_number
570 then goto missing_right_operand;
571 current_expression = divide (current_expression, number, 15, 0);
572 goto arg_loop;
573
574
575 OPERATOR (5):
576 if no_number
577 then goto missing_right_operand;
578 unspec (current_expression) = unspec (current_expression) & unspec (number);
579 goto arg_loop;
580
581
582 OPERATOR (6):
583 if no_number
584 then goto missing_right_operand;
585 unspec (current_expression) = unspec (current_expression) | unspec (number);
586 goto arg_loop;
587 ^L
588 COMMAND_PREFIX (2):
589 if paren_level >= hbound (expression_stack, 1)
590 then goto parenthesis_overflow;
591 operator_stack (paren_level + 1) = which_operator;
592 sign_stack (paren_level + 1) = current_sign;
593 expression_stack (paren_level + 1) = current_expression;
594 num_arg_stack (paren_level + 1) = num_arg;
595 colon_stack (paren_level + 1) = colon_flag;
596 arg1_stack (paren_level + 1) = arg1;
597 paren_level = paren_level + 1;
598 goto command_complete;
599
600
601 COMMAND (41):
602 if paren_level = 0
603 then goto unbalanced_parentheses;
604 if num_arg >= 2
605 then goto strange_parentheses;
606 paren_level = paren_level - 1;
607 number = arg1;
608 which_operator = operator_stack (paren_level + 1);
609 current_sign = sign_stack (paren_level + 1);
610 current_expression = expression_stack (paren_level + 1);
611 arg1 = arg1_stack (paren_level + 1);
612 colon_flag = colon_stack (paren_level + 1);
613 i = num_arg;
614 num_arg = num_arg_stack (paren_level + 1);
615 if i = 0
616 then goto get_number;
617 goto got_number;
618
619
620 check_operator:
621 which_operator = index ("+-*/&|", current_character);
622 if which_operator ^= 0
623 then goto get_number;
624
625 check_command:
626 arg (num_arg) = current_expression;
627 goto COMMAND (fixed (unspec (current_character) & "001111111"b, 9));
628
629
630 COMMAND (44):
631 if which_operator >= 0
632 then goto new_arg;
633 number = 0;
634 goto two_commas;
635
636
637 COMMAND (61):
638 if colon_flag = 1
639 then call ioa_ ("^v(^o^x^)", num_arg, arg1, arg2);
640 else call ioa_ ("^v(^d^x^)", num_arg, arg1, arg2);
641 goto command_complete;
642 ^L
643 COMMAND (60):
644 tag_char_number = 0;
645 iteration_common:
646 if num_arg >= 2
647 then goto too_many_args;
648 if num_arg = 0
649 then arg1 = max_positive_integer;
650 if arg1 < 0
651 then goto bad_negative_argument;
652 if iteration_level >= hbound (iteration.count, 1)
653 then goto iteration_overflow;
654 iteration.errset (iteration_level + 1) = (colon_flag ^= 0);
655 iteration.begin_tag (iteration_level + 1) = tag_char_number;
656 if arg1 = 0
657 then do;
658 call skip ("<>");
659 goto iteration_done;
660 end;
661 iteration_level = iteration_level + 1;
662 iteration.begin (iteration_level) = command_char_number;
663 iteration.end (iteration_level) = -1;
664 iteration.count (iteration_level) = arg1;
665 goto command_complete;
666
667
668
669 COMMAND (62):
670 if num_arg ^= 0
671 then goto too_many_args;
672 if iteration_level = base_iteration_level
673 then goto iteration_underflow;
674 iteration.count (iteration_level) = iteration.count (iteration_level) - 1;
675 if iteration.count (iteration_level) ^= 0
676 then do;
677 iteration.end (iteration_level) = command_char_number;
678 command_char_number = iteration.begin (iteration_level);
679 goto command_complete;
680 end;
681 iteration_level = iteration_level - 1;
682 iteration_done:
683 iteration_answer = -1;
684 get_out_of_iteration:
685 if iteration.errset (iteration_level + 1) | iteration.begin_tag (iteration_level + 1) ^= 0
686 then do;
687 num_arg = 1;
688 current_expression = iteration_answer;
689 goto command_return_value;
690 end;
691 else goto command_complete;
692
693
694 COMMAND (59):
695 if num_arg >= 2
696 then goto too_many_args;
697 if iteration_level = 0
698 then goto semi_colon_out_of_iteration;
699 if num_arg = 0
700 then arg1 = search_answer;
701 if colon_flag = 0
702 then if arg1 < 0
703 then goto command_complete;
704 else ;
705 else if arg1 >= 0
706 then goto command_complete;
707 call unwind_iteration (iteration_level - 1);
708 goto iteration_done;
709 ^L
710 COMMAND (34):
711 if num_arg >= 3
712 then goto too_many_args;
713 if num_arg = 1
714 then arg2 = 0;
715 get_character_fail_handler = missing_double_quote_command;
716 call get_character;
717 goto QUOTE_COMMAND (index ("cCeEgGlLnNmM", current_character));
718
719
720 QUOTE_COMMAND (1):
721 QUOTE_COMMAND (2):
722 if num_arg = 0
723 then goto too_few_args;
724 if num_arg = 2
725 then goto too_many_args;
726 unspec (io_char) = bit (fixed (arg1, 9, 0));
727 if io_char >= "a"
728 then if io_char <= "z"
729 then goto command_complete;
730 if io_char >= "A"
731 then if io_char <= "Z"
732 then goto command_complete;
733 if io_char >= "0"
734 then if io_char <= "9"
735 then goto command_complete;
736 if io_char = "_"
737 then goto command_complete;
738 if io_char = "$"
739 then goto command_complete;
740 if io_char = "."
741 then goto command_complete;
742 goto quote_skip;
743
744 QUOTE_COMMAND (3):
745 QUOTE_COMMAND (4):
746 if num_arg = 0
747 then goto too_few_args;
748 if arg1 = arg2
749 then goto command_complete;
750 else goto quote_skip;
751
752 QUOTE_COMMAND (5):
753 QUOTE_COMMAND (6):
754 if num_arg = 0
755 then goto too_few_args;
756 if arg1 > arg2
757 then goto command_complete;
758 else goto quote_skip;
759
760 QUOTE_COMMAND (7):
761 QUOTE_COMMAND (8):
762 if num_arg = 0
763 then goto too_few_args;
764 if arg1 < arg2
765 then goto command_complete;
766 else goto quote_skip;
767
768 QUOTE_COMMAND (9):
769 QUOTE_COMMAND (10):
770 if num_arg = 0
771 then goto too_few_args;
772 if arg1 ^= arg2
773 then goto command_complete;
774 else goto quote_skip;
775
776
777 QUOTE_COMMAND (11):
778 QUOTE_COMMAND (12):
779 if num_arg ^= 0
780 then goto too_many_args;
781 call get_quoted_string;
782 if end_buffer - dot2 < quoted_string_length
783 then match = "0"b;
784 else match = quoted_string = substr (buffer2, dot2 + 1, quoted_string_length);
785 if colon_flag ^= 0
786 then match = ^match;
787 if match
788 then goto command_complete;
789 else goto quote_skip;
790
791
792
793 quote_skip:
794 call skip ("""'");
795 goto command_complete;
796
797
798 COMMAND (39):
799 if colon_flag = 1
800 then goto quote_skip;
801 goto command_complete;
802
803
804 COMMAND (33):
805 call skip_with_trace ("!!");
806 goto command_complete;
807
808
809 COMMAND (91):
810 if Q_register_pushdown_level >= hbound (pushdown_Q_register_value, 1)
811 then goto Q_register_pushdown_overflow;
812 current_Q_register_number = get_Q_register_number ();
813 pushdown_Q_register_value (Q_register_pushdown_level + 1) = current_Q_register_value;
814 pushdown_Q_register_seg_number (Q_register_pushdown_level + 1) = current_Q_register_seg_number;
815 immediate_interrupt_ok = "0"b;
816 if current_Q_register_seg_number ^= 0
817 then current_Q_register_usage_count = current_Q_register_usage_count + 1;
818 Q_register_pushdown_level = Q_register_pushdown_level + 1;
819 goto command_complete;
820
821
822 COMMAND (93):
823 if Q_register_pushdown_level = 0
824 then goto Q_register_pushdown_underflow;
825 current_Q_register_number = get_Q_register_number ();
826 i = current_Q_register_seg_number;
827 immediate_interrupt_ok = "0"b;
828 Q_register_pushdown_level = Q_register_pushdown_level - 1;
829 current_Q_register_value = pushdown_Q_register_value (Q_register_pushdown_level + 1);
830 current_Q_register_seg_number = pushdown_Q_register_seg_number (Q_register_pushdown_level + 1);
831 if i ^= 0
832 then temp_seg_usage_count (i) = temp_seg_usage_count (i) - 1;
833 goto command_complete;
834 ^L
835 COMMAND (65):
836 COMMAND (97):
837 if num_arg >= 2
838 then goto too_many_args;
839 if num_arg = 0
840 then goto unimplemented_feature;
841 if arg1 > 0
842 then do;
843 i = dot2 + arg1 - 1;
844 if i >= end_buffer
845 then goto A_1_arg_beyond_Z;
846 io_char = substr (buffer2, i + 1, 1);
847 end;
848 else do;
849 i = dot1 + arg1 - 1;
850 if i < 0
851 then goto A_1_arg_before_0;
852 io_char = substr (buffer1, i + 1, 1);
853 end;
854 current_expression = fixed (unspec (io_char), 9, 0);
855 num_arg = 1;
856 goto command_return_value;
857
858
859 COMMAND (67):
860 COMMAND (99):
861 if num_arg = 0
862 then arg1 = 1;
863 C_check:
864 if num_arg > 1
865 then goto too_many_args;
866 call move_dot (arg1, (colon_flag ^= 0));
867 goto command_complete;
868
869
870 COMMAND (68):
871 COMMAND (100):
872 if num_arg = 0
873 then arg1 = 1;
874 if num_arg >= 2
875 then goto too_many_args;
876 call delete_chars (min (dot1, dot1 + arg1), max (dot2, dot2 + arg1));
877 goto command_complete;
878 ^L
879 COMMAND (69):
880 COMMAND (101):
881 get_character_fail_handler = EXTERNAL_COMMAND (0);
882 call get_character;
883 goto EXTERNAL_COMMAND (index ("oOiImMcCaAsSbBgGqQ", current_character));
884
885
886 EXTERNAL_COMMAND (9):
887 EXTERNAL_COMMAND (10):
888 dcl ret_string char (10000) varying based (current_Q_register_address),
889 cu_$evaluate_active_string entry (ptr, char (*), fixed bin, char (*) var, fixed bin (35));
890
891 current_Q_register_number = get_Q_register_number ();
892 call get_quoted_string;
893 call allocate_Q_register_have_number (current_Q_register_number);
894
895 ret_string = "";
896 begin;
897 dcl quoted_string_unal char (quoted_string_length) based (quoted_string_address);
898 call cu_$evaluate_active_string (null (), quoted_string_unal, NORMAL_ACTIVE_STRING, ret_string, error_code)
899 ;
900 end;
901 if error_code ^= 0
902 then do;
903 call com_err_ (error_code, program_name, """^a""", quoted_string);
904 goto command_abort;
905 end;
906
907 current_Q_register_value = length (ret_string);
908
909 current_Q_register = copy (ret_string, 1);
910 goto command_complete;
911
912
913 EXTERNAL_COMMAND (13):
914 EXTERNAL_COMMAND (14):
915 backup_flag = "1"b;
916 goto EO_EB_common;
917
918
919 EXTERNAL_COMMAND (7):
920 EXTERNAL_COMMAND (8):
921 call get_quoted_string;
922 call cu_$cp (quoted_string_address, quoted_string_length, error_code);
923 goto command_complete;
924
925 EXTERNAL_COMMAND (15):
926 EXTERNAL_COMMAND (16):
927 goto unimplemented_feature;
928 ^L
929 EXTERNAL_COMMAND (3):
930 EXTERNAL_COMMAND (4):
931 if num_arg ^= 0
932 then goto too_many_args;
933 num_arg = colon_flag;
934 call get_quoted_string;
935 call get_seg_ptr_ (quoted_string, r_access, read_count, file_address, error_code);
936 if error_code ^= 0
937 then if colon_flag = 1
938 then do;
939 current_expression = 0;
940 goto command_return_value;
941 end;
942 else goto file_error;
943 count = divide (read_count + 8, 9, 17, 0);
944
945 if dot1 + end_buffer - dot2 > 0
946 then do;
947 call add_chars (file_address, count);
948 call close_file (file_address);
949 end;
950 else do;
951 immediate_interrupt_ok = "0"b;
952 b1, b2 = file_address;
953 n1, n2 = 0;
954 dot1, dot2, end_buffer, max_dot1 = count;
955 min_dot2 = 0;
956 end;
957 if colon_flag = 1
958 then do;
959 current_expression = -1;
960 goto command_return_value;
961 end;
962 else goto command_complete;
963
964
965 EXTERNAL_COMMAND (5):
966 EXTERNAL_COMMAND (6):
967 call get_quoted_string;
968 EM_have_name:
969 call teco_get_macro_ (quoted_string, file_address, read_count, error_code);
970 if error_code ^= 0
971 then goto EM_macro_not_found;
972 j = 0;
973 do i = -1 to lbound (temp_seg_address, 1) by -1;
974 if temp_seg_address (i) = file_address
975 then goto EM_have_slot;
976
977 if j = 0
978 then if temp_seg_usage_count (i) = 0
979 then j = i;
980 end;
981 if j = 0
982 then goto EM_no_slot;
983 i = j;
984
985 EM_have_slot:
986 temp_seg_address (i) = file_address;
987 current_Q_register_number = dummy_Q_register_number;
988 Q_register_value (dummy_Q_register_number) = read_count;
989 Q_register_seg_number (dummy_Q_register_number) = i;
990 goto M_have_reg;
991 ^L
992 EXTERNAL_COMMAND (1):
993 EXTERNAL_COMMAND (2):
994 backup_flag = "0"b;
995 EO_EB_common:
996 if num_arg >= 3
997 then goto too_many_args;
998 do;
999 call get_quoted_string;
1000 if backup_flag
1001 then call teco_backup_file_ (quoted_string);
1002 call get_seg_ptr_ (quoted_string, rwac_access, read_count, file_address, error_code);
1003 if file_address = null
1004 then goto file_error;
1005 end;
1006 immediate_interrupt_ok = "0"b;
1007 if b1 = file_address
1008 then call copy_source;
1009 start = 1;
1010 EO_X_common_return = EO_close_file;
1011 if num_arg ^= 0
1012 then goto EO_X_common;
1013 else do;
1014 arg1 = 0;
1015 count = dot1 + end_buffer - dot2;
1016 goto EO_X_around_dot;
1017 end;
1018 EO_close_file:
1019 call release_seg_ptr_ (file_address, 9 * count, error_code);
1020 if error_code ^= 0
1021 then goto file_error;
1022 goto command_complete;
1023 ^L
1024 EO_X_common:
1025 if num_arg < 2
1026 then if arg1 >= 1
1027 then do;
1028 call find_line_forward;
1029 arg1 = dot1;
1030 goto EO_X_after_dot;
1031 end;
1032 else do;
1033 call find_line_reverse;
1034 arg1 = temp_dot;
1035 count = dot1 - temp_dot;
1036 goto EO_X_before_dot;
1037 end;
1038 else do;
1039 if arg1 < 0
1040 then arg1 = 0;
1041 if arg2 > dot1 + end_buffer - dot2
1042 then arg2 = dot1 + end_buffer - dot2;
1043 count = arg2 - arg1;
1044 if count < 0
1045 then goto args_wrong_order;
1046 if start + count > max_seg_size
1047 then goto dot_beyond_Z;
1048 if dot1 >= arg2
1049 then
1050 EO_X_before_dot:
1051 do;
1052 if count ^= 0
1053 then substr (file, start, count) = substr (buffer1, arg1 + 1, count);
1054 goto EO_X_common_return;
1055 end;
1056 if arg1 >= dot1
1057 then
1058 EO_X_after_dot:
1059 do;
1060 if count ^= 0
1061 then substr (file, start, count) = substr (buffer2, (arg1 + dot2 - dot1) + 1, count);
1062 goto EO_X_common_return;
1063 end;
1064 else
1065 EO_X_around_dot:
1066 do;
1067 i = dot1 - arg1;
1068 if i ^= 0
1069 then substr (file, start, i) = substr (buffer1, arg1 + 1, i);
1070 j = count - i;
1071 if j ^= 0
1072 then substr (file, i + start, j) = substr (buffer2, dot2 + 1, j);
1073 goto EO_X_common_return;
1074 end;
1075 end;
1076 ^L
1077 EQ:
1078 EXTERNAL_COMMAND (17):
1079 EXTERNAL_COMMAND (18):
1080 if trace_flag
1081 then do;
1082 io_char = new_line_char;
1083 call WRITE (io_char_address, 0, 1);
1084 end;
1085 call release_bufs;
1086 return;
1087
1088 release_bufs:
1089 procedure;
1090 immediate_interrupt_ok = "0"b;
1091 call release_temp_segs_all_ (my_id, error_code);
1092 if error_code ^= 0
1093 then call com_err_ (error_code, program_name, "trying to release temporary segments");
1094 if n1 = 0 & b1 ^= null
1095 then call release_seg_ptr_ (b1, -1, error_code);
1096 end release_bufs;
1097
1098
1099 EXTERNAL_COMMAND (11):
1100 EXTERNAL_COMMAND (12):
1101 if no_ES_flag
1102 then goto unimplemented_feature;
1103 if num_arg <= 0
1104 then arg1 = max_positive_integer;
1105 if num_arg <= 1
1106 then arg2 = max_positive_integer;
1107 current_Q_register_number = get_Q_register_number ();
1108 if current_Q_register_seg_number = 0
1109 then goto ES_numeric_Q;
1110 call get_quoted_string;
1111 call find_command_$fc_no_message (quoted_string_address, quoted_string_length, file_address, error_code);
1112 if error_code ^= 0
1113 then go to ES_subroutine_not_found;
1114 current_expression = 0;
1115 call cu_$ptr_call (file_address, current_Q_register, arg1, arg2, current_expression);
1116 num_arg = 1;
1117 goto command_return_value;
1118 ^L
1119 COMMAND (70):
1120 COMMAND (102):
1121 get_character_fail_handler = F_COMMAND (0);
1122 call get_character;
1123 goto F_COMMAND (index ("<;", current_character));
1124
1125
1126 F_COMMAND (1):
1127 call get_character;
1128 do while (index (white_space, current_character) ^= 0);
1129 call get_character;
1130 end;
1131 if current_character ^= "!"
1132 then goto F_COMMAND (0);
1133 tag_char_number = command_char_number;
1134 call skip_with_trace ("!!");
1135 goto iteration_common;
1136
1137
1138 F_COMMAND (2):
1139 if num_arg > 1
1140 then goto too_many_args;
1141 if num_arg < 1
1142 then goto too_few_args;
1143 call get_quoted_string;
1144 if iteration_level = 0
1145 then goto semi_colon_out_of_iteration;
1146 do return_iteration_level = iteration_level by -1 to 1;
1147 do while (return_iteration_level <= base_iteration_level);
1148 call unwind_command_level;
1149 end;
1150 if iteration.begin_tag (return_iteration_level) ^= 0
1151 then if quoted_string
1152 =
1153 substr (command_line, iteration.begin_tag (return_iteration_level) + 1,
1154 iteration.begin (return_iteration_level) - 1 - iteration.begin_tag (return_iteration_level))
1155 then do;
1156 call unwind_iteration (return_iteration_level - 1);
1157 iteration_answer = arg1;
1158 goto get_out_of_iteration;
1159 end;
1160 end;
1161 goto label_not_found;
1162 ^L
1163 COMMAND (71):
1164 COMMAND (103):
1165 if num_arg ^= 0
1166 then goto too_many_args;
1167 current_Q_register_number = get_Q_register_number ();
1168 if current_Q_register_seg_number ^= 0
1169 then do;
1170 call add_chars (current_Q_register_address, current_Q_register_value);
1171 goto command_complete;
1172 end;
1173 else do;
1174 num_arg = 1;
1175 arg1 = current_Q_register_value;
1176 goto backslash;
1177 end;
1178
1179
1180 COMMAND (72):
1181 COMMAND (104):
1182 if num_arg ^= 0
1183 then goto too_many_args;
1184 arg1 = 0;
1185 current_expression = dot1 + end_buffer - dot2;
1186 num_arg = 2;
1187 goto command_return_value;
1188 ^L
1189 COMMAND (73):
1190 COMMAND (105):
1191 if num_arg >= 2
1192 then goto too_many_args;
1193 if colon_flag = 0
1194 then do;
1195 if num_arg = 0
1196 then do;
1197 call get_quoted_string;
1198 call add_chars (quoted_string_address, quoted_string_length);
1199 goto command_complete;
1200 end;
1201 else do;
1202 unspec (io_char) = bit (fixed (arg1, 9, 0));
1203 call add_chars (io_char_address, 1);
1204 goto command_complete;
1205 end;
1206 end;
1207 else do;
1208 current_Q_register_number = get_Q_register_number ();
1209 if num_arg = 0
1210 then do;
1211 call get_quoted_string;
1212 immediate_interrupt_ok = "0"b;
1213 temp_seg_usage_count (quoted_string_seg_number) = temp_seg_usage_count (quoted_string_seg_number) + 1;
1214 i = current_Q_register_seg_number;
1215 current_Q_register_seg_number = quoted_string_seg_number;
1216 current_Q_register_value = quoted_string_length;
1217 if i ^= 0
1218 then temp_seg_usage_count (i) = temp_seg_usage_count (i) - 1;
1219 goto command_complete;
1220 end;
1221 else do;
1222 immediate_interrupt_ok = "0"b;
1223 call allocate_Q_register_have_number (current_Q_register_number);
1224 unspec (substr (current_Q_register_address -> file, 1, 1)) = bit (fixed (arg1, 9, 0));
1225 current_Q_register_value = 1;
1226 goto command_complete;
1227 end;
1228 end;
1229
1230
1231 COMMAND (74):
1232 COMMAND (106):
1233 if num_arg = 0
1234 then arg1 = 0;
1235 arg1 = arg1 - dot1;
1236 goto C_check;
1237 ^L
1238 COMMAND (75):
1239 COMMAND (107):
1240 if num_arg > 2
1241 then goto too_many_args;
1242 if num_arg < 2
1243 then do;
1244 if num_arg = 0
1245 then arg1 = 1;
1246 if arg1 > 0
1247 then do;
1248 call must_find_line_forward;
1249 call delete_chars (dot1, temp_dot);
1250 goto command_complete;
1251 end;
1252 else do;
1253 call must_find_line_reverse;
1254 call delete_chars (temp_dot, dot2);
1255 goto command_complete;
1256 end;
1257 end;
1258 if arg1 > arg2
1259 then goto args_wrong_order;
1260 call move_dot_forward (arg1 - dot1);
1261 call move_dot_backward (arg2 - dot1);
1262 call delete_chars (arg1, dot2 + arg2 - dot1);
1263 goto command_complete;
1264
1265
1266 COMMAND (76):
1267 COMMAND (108):
1268 if num_arg > 1
1269 then goto too_many_args;
1270 if num_arg = 0
1271 then arg1 = 1;
1272 if arg1 > 0
1273 then do;
1274 call must_find_line_forward;
1275 call move_dot_forward (count - colon_flag);
1276 end;
1277 else do;
1278 call must_find_line_reverse;
1279 call move_dot_backward (temp_dot - dot1 - colon_flag);
1280 end;
1281 goto command_complete;
1282 ^L
1283 COMMAND (77):
1284 COMMAND (109):
1285 current_Q_register_number = get_Q_register_number ();
1286 if current_Q_register_seg_number = 0
1287 then goto M_numeric_Q_register;
1288 M_have_reg:
1289 if (command_level ^= 0 & command_char_number = command_line_length) | colon_flag ^= 0
1290 then do;
1291 call revert_command_level;
1292 goto M_get_new_line;
1293 end;
1294 if command_level >= hbound (command_char_stack, 1)
1295 then goto command_level_overflow;
1296 command_char_stack (command_level) = command_char_number;
1297 command_length_stack (command_level) = command_line_length;
1298 command_iteration_stack (command_level) = base_iteration_level;
1299 M_get_new_line:
1300 command_seg_stack (command_level + 1) = current_Q_register_seg_number;
1301 immediate_interrupt_ok = "0"b;
1302 command_line_length = current_Q_register_value;
1303 current_Q_register_usage_count = current_Q_register_usage_count + 1;
1304 command_line_address = current_Q_register_address;
1305 command_char_number = 0;
1306 base_iteration_level = iteration_level;
1307 command_level = command_level + 1;
1308 goto M_return;
1309 ^L
1310 COMMAND (78):
1311 COMMAND (110):
1312 if num_arg = 0
1313 then arg1 = 1;
1314 if num_arg > 2
1315 then goto too_many_args;
1316 if num_arg = 2
1317 then do;
1318 if arg1 <= 0 | arg2 < 0
1319 then goto unimplemented_feature;
1320 call find_line_forward;
1321 arg1 = arg2;
1322 arg2 = temp_dot;
1323 end;
1324 else if arg1 >= 0
1325 then arg2 = end_buffer;
1326 else goto unimplemented_feature;
1327 num_arg = colon_flag;
1328 call get_quoted_string;
1329 if quoted_string_length = 0
1330 then goto command_complete;
1331 if arg1 = 0
1332 then goto command_complete;
1333 temp_dot = dot2;
1334 i = quoted_string_length;
1335 if n1 ^= n2
1336 then if dot1 > 0
1337 then do;
1338 call move_dot_backward (-1);
1339 dot1 = dot1 + 1;
1340 dot2 = dot2 + 1;
1341 end;
1342 else if dot2 > 0
1343 then substr (buffer2, dot2, 1) = new_line_char;
1344
1345 do arg1 = 1 to arg1;
1346 if temp_dot >= arg2
1347 then goto S_fail;
1348 call search_file_ (quoted_string_address, 1, i, b2, temp_dot + 1, arg2, j, temp_dot, count);
1349 if count ^= 0
1350 then do;
1351 current_Q_register_number = quoted_string_Q_register_number;
1352 call allocate_Q_register_have_number (current_Q_register_number);
1353 quoted_string_length = 0;
1354 goto S_fail;
1355 end;
1356 i = 0;
1357 end;
1358 current_Q_register_number = quoted_string_Q_register_number;
1359 call allocate_Q_register_have_number (current_Q_register_number);
1360 count = temp_dot - j + 1;
1361 if count = 0
1362 then goto S_succeed_forward;
1363 substr (quoted_string, 1, count) = substr (buffer2, j, count);
1364 quoted_string_length = count;
1365 goto S_succeed_forward;
1366 ^L
1367 COMMAND (79):
1368 COMMAND (111):
1369 call get_quoted_string;
1370 count = quoted_string_length + 1;
1371 substr (quoted_string, count, 1) = "!";
1372 O_have_label:
1373 command_char_number = 1;
1374 do while ("1"b);
1375 if command_char_number + count >= command_line_length
1376 then goto O_unwind_command;
1377 i = index (substr (command_line, command_char_number + 1), substr (quoted_string, 1, count));
1378 if i = 0
1379 then
1380 O_unwind_command:
1381 do;
1382 if command_level = 0
1383 then goto label_not_found;
1384 call revert_command_level;
1385 goto O_have_label;
1386 end O_unwind_command;
1387 command_char_number = command_char_number + i + quoted_string_length;
1388 if substr (command_line, command_char_number - count, 1) = "!"
1389 then goto command_complete;
1390 end;
1391
1392
1393 COMMAND (80):
1394 COMMAND (112):
1395 immediate_interrupt_ok = "0"b;
1396 current_Q_register_number = get_Q_register_number ();
1397 if num_arg = 0
1398 then arg1 = 1;
1399 if current_Q_register_seg_number ^= 0
1400 then do;
1401 if current_Q_register_usage_count > 1
1402 then do;
1403 file_address = current_Q_register_address;
1404 count = current_Q_register_value;
1405 call allocate_Q_register_have_number (current_Q_register_number);
1406 current_Q_register_value = count;
1407 current_Q_register = file;
1408 end;
1409 file_address = current_Q_register_address;
1410 start = current_Q_register_value + 1;
1411 EO_X_common_return = normal_P_close_Q_reg;
1412 goto EO_X_common;
1413
1414 normal_P_close_Q_reg:
1415 current_Q_register_value = current_Q_register_value + count;
1416 end;
1417 else do;
1418 call allocate_Q_register_have_number (current_Q_register_number);
1419 file_address = current_Q_register_address;
1420 EO_X_common_return = null_P_close_Q_reg;
1421 start = 1;
1422 goto EO_X_common;
1423 null_P_close_Q_reg:
1424 current_Q_register_value = count;
1425 end;
1426 goto command_complete;
1427
1428
1429 COMMAND (82):
1430 COMMAND (114):
1431 if num_arg = 0
1432 then arg1 = 1;
1433 arg1 = -arg1;
1434 goto C_check;
1435 ^L
1436 COMMAND (83):
1437 COMMAND (115):
1438 do;
1439 if num_arg = 0
1440 then arg1 = 1;
1441 if num_arg > 2
1442 then goto too_many_args;
1443 if num_arg = 2
1444 then do;
1445 if arg1 >= 1
1446 then do;
1447 if arg2 < 0
1448 then goto S_fail;
1449 call find_line_forward;
1450 end;
1451 else do;
1452 if arg2 > 0
1453 then goto S_fail;
1454 call find_line_reverse;
1455 end;
1456 arg1 = arg2;
1457 arg2 = temp_dot;
1458 end;
1459 else
1460 if arg1 >= 0
1461 then arg2 = end_buffer;
1462 else arg2 = 0;
1463 num_arg = colon_flag;
1464 do;
1465 call get_quoted_string;
1466 if quoted_string_length = 0
1467 then goto command_complete;
1468 if arg1 = 0
1469 then goto command_complete;
1470 if arg1 >= 0
1471 then do;
1472 temp_dot = dot2;
1473 plus_S_loop:
1474 do;
1475 if arg2 = temp_dot
1476 then goto S_fail;
1477 j = index (substr (buffer2, temp_dot + 1, arg2 - temp_dot), quoted_string);
1478 if j = 0
1479 then
1480 S_fail:
1481 do;
1482 search_answer = 0;
1483 if colon_flag = 0
1484 then goto fatal_S_fail;
1485 else do;
1486 current_expression = search_answer;
1487 goto command_return_value;
1488 end;
1489 end S_fail;
1490 temp_dot = temp_dot + (j - 1 + quoted_string_length);
1491 arg1 = arg1 - 1;
1492 if arg1 ^= 0
1493 then goto plus_S_loop;
1494 end plus_S_loop;
1495 S_succeed_forward:
1496 arg1 = temp_dot - dot2;
1497 S_succeed:
1498 search_answer = -1;
1499 current_expression = search_answer;
1500 call move_dot (arg1, "0"b);
1501 goto command_return_value;
1502 end;
1503 ^L
1504
1505
1506
1507
1508 else do;
1509 temp_dot = dot1;
1510 search_chars = substr (quoted_string, 1, 2);
1511 if quoted_string_length = 1
1512 then do while (arg1 < 0);
1513 if temp_dot = arg2
1514 then goto S_fail;
1515 j = index (reverse (substr (buffer1, arg2 + 1, temp_dot - arg2)),
1516 substr (search_chars, 1, 1));
1517 if j = 0
1518 then goto S_fail;
1519 temp_dot = temp_dot - j;
1520 arg1 = arg1 + 1;
1521 end;
1522 else do;
1523 minus_S_iterate:
1524 if temp_dot - arg2 < 2
1525 then go to S_fail;
1526 j = index (reverse (substr (buffer1, arg2 + 1, temp_dot - arg2)), reverse (search_chars));
1527 if j = 0
1528 then go to S_fail;
1529 temp_dot = temp_dot - j;
1530 if (temp_dot - 1) + quoted_string_length > dot1
1531 then go to minus_S_iterate;
1532 if quoted_string_length > 2
1533 then if substr (buffer1, temp_dot + 2, quoted_string_length - 2)
1534 ^= substr (quoted_string, 3, quoted_string_length - 2)
1535 then goto minus_S_iterate;
1536 temp_dot = temp_dot - 1;
1537 arg1 = arg1 + 1;
1538 if arg1 < 0
1539 then goto minus_S_iterate;
1540 end;
1541 arg1 = temp_dot - dot1;
1542 goto S_succeed;
1543 end;
1544 end;
1545 end;
1546 ^L
1547 COMMAND (84):
1548 COMMAND (116):
1549 if colon_flag = 0
1550 then do;
1551 if num_arg = 0
1552 then arg1 = 1;
1553 if num_arg > 2
1554 then goto too_many_args;
1555 if num_arg < 2
1556 then if arg1 >= 1
1557 then do;
1558 call find_line_forward;
1559 arg1 = dot1;
1560 arg2 = dot1 + count;
1561 end;
1562 else
1563 do;
1564 call find_line_reverse;
1565 arg1 = temp_dot;
1566 arg2 = dot1;
1567 end;
1568 else do;
1569 if arg1 < 0
1570 then arg1 = 0;
1571 if arg2 > dot1 + end_buffer - dot2
1572 then arg2 = dot1 + end_buffer - dot2;
1573 end;
1574 count = arg2 - arg1;
1575 if count < 0
1576 then goto args_wrong_order;
1577 if count = 0
1578 then goto command_complete;
1579 i = arg2 - dot1;
1580 j = dot1 - arg1;
1581 if j > 0
1582 then do;
1583 j = 0;
1584 if i < 0
1585 then i = 0;
1586 call WRITE (b1, arg1, count - i);
1587 end;
1588 if i > 0
1589 then call WRITE (b2, dot2 - j, i + j);
1590 goto command_complete;
1591 end;
1592 else do;
1593 if num_arg ^= 0
1594 then goto too_many_args;
1595 call get_quoted_string;
1596 call WRITE (quoted_string_address, 0, quoted_string_length);
1597 goto command_complete;
1598 end;
1599 ^L
1600 COMMAND (85):
1601 COMMAND (117):
1602 current_Q_register_number = get_Q_register_number ();
1603 immediate_interrupt_ok = "0"b;
1604 i = current_Q_register_seg_number;
1605 current_Q_register_seg_number = 0;
1606 if num_arg = 0
1607 then do;
1608 num_arg = 1;
1609 arg1 = max_positive_integer;
1610 end;
1611 current_Q_register_value = arg (num_arg);
1612 if i ^= 0
1613 then temp_seg_usage_count (i) = temp_seg_usage_count (i) - 1;
1614 num_arg = num_arg - 1;
1615 current_expression = arg (num_arg);
1616 goto command_return_value;
1617
1618
1619 COMMAND (86):
1620 COMMAND (118):
1621
1622 get_character_fail_handler = command_complete;
1623 call get_character;
1624 if current_character = "w"
1625 then goto VW;
1626 if current_character = "W"
1627 then goto VW;
1628 backup_command_line_1_char = 1;
1629 goto command_complete;
1630
1631
1632 VW:
1633 if colon_flag = 0
1634 then do;
1635 call READ_CHAR;
1636 current_expression = fixed (unspec (io_char), 9, 0);
1637 num_arg = 1;
1638 goto command_return_value;
1639 end;
1640 else do;
1641 call allocate_Q_register (current_Q_register_number);
1642 call READ (current_Q_register_address, 0);
1643 current_Q_register_value = read_count;
1644 goto command_complete;
1645 end;
1646
1647
1648 COMMAND (87):
1649 COMMAND (119):
1650 goto command_complete;
1651 ^L
1652 COMMAND (88):
1653 COMMAND (120):
1654 if colon_flag = 0
1655 then do;
1656 if num_arg = 0
1657 then arg1 = 1;
1658 immediate_interrupt_ok = "0"b;
1659 call allocate_Q_register (current_Q_register_number);
1660 file_address = current_Q_register_address;
1661 EO_X_common_return = normal_X_close_Q_register;
1662 start = 1;
1663 goto EO_X_common;
1664 normal_X_close_Q_register:
1665 current_Q_register_value = count;
1666 goto command_complete;
1667 end;
1668 else do;
1669 if num_arg ^= 0
1670 then goto too_many_args;
1671 current_Q_register_number = get_Q_register_number ();
1672 if command_level = 0
1673 then goto colon_X_not_in_macro;
1674 colon_X_save_command_level = command_level;
1675 command_char_stack (command_level) = command_char_number;
1676 command_length_stack (command_level) = command_line_length;
1677 command_iteration_stack (command_level) = iteration_level;
1678 iteration_level = base_iteration_level;
1679 temp_seg_usage_count (command_seg_stack (command_level)) =
1680 temp_seg_usage_count (command_seg_stack (command_level)) + 1;
1681 call revert_command_level;
1682 call get_quoted_string;
1683 command_char_stack (command_level) = command_char_number;
1684 i, command_seg_stack (command_level + 1) = command_seg_stack (colon_X_save_command_level);
1685 immediate_interrupt_ok = "0"b;
1686 command_line_address = temp_seg_address (i);
1687 command_char_number = command_char_stack (colon_X_save_command_level);
1688 command_line_length = command_length_stack (colon_X_save_command_level);
1689 base_iteration_level = iteration_level;
1690 iteration_level = command_iteration_stack (colon_X_save_command_level);
1691 command_level = command_level + 1;
1692 temp_seg_usage_count (quoted_string_seg_number) = temp_seg_usage_count (quoted_string_seg_number) + 1;
1693 i = current_Q_register_seg_number;
1694 current_Q_register_seg_number = quoted_string_seg_number;
1695 current_Q_register_value = quoted_string_length;
1696 if i ^= 0
1697 then temp_seg_usage_count (i) = temp_seg_usage_count (i) - 1;
1698 goto command_complete;
1699 end;
1700 ^L
1701 backslash:
1702 COMMAND (92):
1703 do;
1704 if num_arg = 0
1705 then
1706 do;
1707 num_arg = 1;
1708 current_expression = 0;
1709 if dot2 = end_buffer
1710 then goto backslash_0_args_number_not_found;
1711 j = verify (substr (buffer2, dot2 + 1, end_buffer - dot2), white_space) - 1;
1712 if j < 0
1713 then goto backslash_0_args_number_not_found;
1714 temp_dot, i = dot2 + j;
1715 current_sign = 1;
1716 j = index ("+-", substr (buffer2, i + 1, 1));
1717 if j ^= 0
1718 then do;
1719 i = i + 1;
1720 if colon_flag ^= 0
1721 then do;
1722 temp_dot = i;
1723 if j = 2
1724 then current_sign = -1;
1725 end;
1726 if i = end_buffer
1727 then goto backslash_0_args_number_not_found;
1728 end;
1729 if colon_flag = 0
1730 then j = verify (substr (buffer2, i + 1, end_buffer - i), "0123456789") - 1;
1731 else j = verify (substr (buffer2, i + 1, end_buffer - i), "01234567") - 1;
1732 if j < 0
1733 then j = end_buffer - i;
1734 if j = 0
1735 then goto backslash_0_args_number_not_found;
1736 i = i + j;
1737 if colon_flag = 0
1738 then do;
1739 on fixedoverflow
1740 begin;
1741 current_expression = max_positive_integer;
1742 goto backslash_0_args_done;
1743 end;
1744 current_expression = convert (current_expression, substr (buffer2, temp_dot + 1, i - temp_dot));
1745 backslash_0_args_done:
1746 revert fixedoverflow;
1747 end;
1748 else do;
1749 current_expression = cv_oct_check_ (substr (buffer2, temp_dot + 1, i - temp_dot), error_code);
1750 if error_code ^= 0
1751 then do;
1752 error_code = 0;
1753 current_expression = max_positive_integer;
1754 end;
1755 if current_sign < 0
1756 then current_expression = -current_expression;
1757 end;
1758 call move_dot_forward (i - dot2);
1759 goto command_return_value;
1760 end;
1761 else do;
1762 if colon_flag = 0
1763 then do;
1764 cvb = arg1;
1765 i = length (cvb) - verify (cvb, white_space) + 1;
1766 if num_arg = 2
1767 then i = min (max (i, arg2), length (cvb));
1768 call add_chars (addr (substr (cvb, length (cvb) - i + 1, i)), i);
1769 end;
1770 else do;
1771 call ioa_$rsnnl ("^o", string, i, arg1);
1772 if num_arg = 2
1773 then call add_chars (addr (blanks), min (arg2 - i, length (blanks)));
1774 call add_chars (addr (string), i);
1775 end;
1776 go to command_complete;
1777 end;
1778 end backslash;
1779 ^L
1780 no_room:
1781 error_message = "NO ROOM ";
1782 goto print_error_message;
1783 unimplemented_feature:
1784 error_message = "NOT IMPL";
1785 goto print_error_message;
1786 label_not_found:
1787 error_message = "NO LABEL";
1788 goto print_error_message;
1789 backslash_0_args_number_not_found:
1790 error_message = "\:NUMBR?";
1791 goto print_error_message;
1792 A_1_arg_beyond_Z:
1793 dot_beyond_Z:
1794 error_message = "TOO BIG ";
1795 goto print_error_message;
1796 A_1_arg_before_0:
1797 bad_negative_argument:
1798 dot_before_0:
1799 error_message = "NEGATIVE";
1800 goto print_error_message;
1801 unbalanced_parentheses:
1802 strange_parentheses:
1803 parenthesis_overflow:
1804 error_message = "PARENS ";
1805 goto print_error_message;
1806 skip_fail:
1807 error_message = "BAD SKIP";
1808 goto print_error_message;
1809 iteration_overflow:
1810 iteration_underflow:
1811 unfinished_iteration:
1812 semi_colon_out_of_iteration:
1813 error_message = "BAD LOOP";
1814 goto print_error_message;
1815 too_many_args:
1816 error_message = "MANY ARG";
1817 goto print_error_message;
1818 too_few_args:
1819 error_message = "FEW ARGS";
1820 goto print_error_message;
1821 Q_register_pushdown_underflow:
1822 error_message = "CANT POP";
1823 goto print_error_message;
1824 Q_register_pushdown_overflow:
1825 command_level_overflow:
1826 string_too_long:
1827 EM_no_slot:
1828 error_message = "IMP.RES.";
1829 goto print_error_message;
1830 numeric_quoted_in_Q:
1831 ES_numeric_Q:
1832 M_numeric_Q_register:
1833 error_message = "numericQ";
1834 goto print_error_message;
1835 percent_cant_increment:
1836 error_message = "% ? ";
1837 goto print_error_message;
1838 missing_double_quote_command:
1839 QUOTE_COMMAND (0):
1840 error_message = "BAD "" ";
1841 goto print_error_message;
1842 EXTERNAL_COMMAND (0):
1843 error_message = "BAD E ";
1844 goto print_error_message;
1845 missing_Q_register_name:
1846 illegal_Q_register_name:
1847 error_message = "Qreg ? ";
1848 goto print_error_message;
1849 COMMAND (0):
1850 COMMAND (1):
1851 COMMAND (2):
1852 COMMAND (3):
1853 COMMAND (4):
1854 COMMAND (5):
1855 COMMAND (6):
1856 COMMAND (7):
1857 COMMAND (8):
1858 COMMAND (9):
1859 COMMAND (11):
1860 COMMAND (12):
1861 COMMAND (13):
1862 COMMAND (14):
1863 COMMAND (15):
1864 COMMAND (16):
1865 COMMAND (17):
1866 COMMAND (18):
1867 COMMAND (19):
1868 COMMAND (20):
1869 COMMAND (21):
1870 COMMAND (22):
1871 COMMAND (23):
1872 COMMAND (24):
1873 COMMAND (25):
1874 COMMAND (26):
1875 COMMAND (27):
1876 COMMAND (28):
1877 COMMAND (29):
1878 COMMAND (30):
1879 COMMAND (31):
1880 COMMAND (32):
1881 COMMAND (35):
1882 COMMAND (37):
1883 COMMAND (38):
1884 COMMAND (40):
1885 COMMAND (42):
1886 COMMAND (45):
1887 COMMAND (46):
1888 COMMAND (47):
1889 COMMAND (48):
1890 COMMAND (49):
1891 COMMAND (50):
1892 COMMAND (51):
1893 COMMAND (52):
1894 COMMAND (53):
1895 COMMAND (54):
1896 COMMAND (55):
1897 COMMAND (56):
1898 COMMAND (57):
1899 COMMAND (58):
1900 COMMAND (63):
1901 COMMAND (64):
1902 COMMAND (66):
1903 COMMAND (81):
1904 COMMAND (89):
1905 COMMAND (90):
1906 COMMAND (94):
1907 COMMAND (95):
1908 COMMAND (96):
1909 COMMAND (98):
1910 COMMAND (113):
1911 COMMAND (121):
1912 COMMAND (122):
1913 COMMAND (123):
1914 COMMAND (124):
1915 COMMAND (125):
1916 COMMAND (126):
1917 COMMAND (127):
1918 error_message = current_character || ": ? ";
1919 goto print_error_message;
1920 illegal_delimiter:
1921 error_message = delimiter || ":DELIM?";
1922 goto print_error_message;
1923 tty_no_read:
1924 no_more_temp_segs:
1925 error_message = "DISASTER";
1926 goto print_error_message;
1927 args_wrong_order:
1928 error_message = "ORDER ? ";
1929 goto print_error_message;
1930 missing_right_operand:
1931 colon_X_not_in_macro:
1932 error_message = "? ";
1933 goto print_error_message;
1934 F_COMMAND (0):
1935 error_message = "BAD F ";
1936 goto print_error_message;
1937 EM_macro_not_found:
1938 ES_subroutine_not_found:
1939 file_error:
1940 call check_errset;
1941 call com_err_ (error_code, program_name, quoted_string);
1942 goto command_abort;
1943 fatal_S_fail:
1944 error_message = "S: fail ";
1945 goto print_error_message;
1946 print_error_message:
1947 call check_errset;
1948 if error_mode = "long"
1949 then call teco_error (error_message);
1950 else call WRITE (addr (error_structure), 0, length (error_message) + 1);
1951 goto command_abort;
1952 ^L
1953 read_line:
1954 procedure;
1955 do while ("1"b);
1956 call READ (command_line_address, command_line_length);
1957 command_line_length = command_line_length + read_count;
1958 if command_line_length >= 2
1959 then if substr (command_line, command_line_length - 1, 1) = "$"
1960 then do;
1961 command_line_length = command_line_length - 2;
1962
1963 return;
1964 end;
1965 end;
1966 end read_line;
1967
1968 get_character:
1969 procedure;
1970
1971 command_char_number = command_char_number - backup_command_line_1_char;
1972 do while (command_char_number >= command_line_length);
1973 if command_level = 0
1974 then goto get_character_fail_handler;
1975 call revert_command_level;
1976 end;
1977 current_character = substr (command_line, command_char_number + 1, 1);
1978 io_char = current_character;
1979 if trace_flag
1980 then if backup_command_line_1_char = 0
1981 then call WRITE (io_char_address, 0, 1);
1982 command_char_number = command_char_number + 1;
1983 backup_command_line_1_char = 0;
1984 return;
1985
1986 print_command_line:
1987 entry;
1988 search_successful = search_length ^= 0;
1989 if ^search_successful
1990 then search_length = command_line_length - command_char_number;
1991 if trace_flag
1992 then call WRITE (command_line_address, command_char_number, search_length);
1993 command_char_number = command_char_number + search_length;
1994 return;
1995
1996 find_character:
1997 entry;
1998 do while (command_char_number >= command_line_length);
1999 if command_level = 0
2000 then goto get_character_fail_handler;
2001 call revert_command_level;
2002 end;
2003 end get_character;
2004 ^L
2005 check_errset:
2006 procedure;
2007 if iteration_level > 0
2008 then do;
2009 do return_iteration_level = iteration_level by -1 to 1 while (^iteration.errset (return_iteration_level));
2010 end;
2011 if return_iteration_level = 0
2012 then return;
2013 do while (return_iteration_level <= base_iteration_level);
2014 call unwind_command_level;
2015 end;
2016 call unwind_iteration (return_iteration_level - 1);
2017 iteration_answer = 0;
2018 goto get_out_of_iteration;
2019 end;
2020 return;
2021 end check_errset;
2022
2023 revert_command_level:
2024 procedure;
2025 dcl save_interrupt_ok bit (1) aligned;
2026 if iteration_level ^= base_iteration_level
2027 then goto unfinished_iteration;
2028 unwind_command_level:
2029 entry;
2030 save_interrupt_ok = immediate_interrupt_ok;
2031 immediate_interrupt_ok = "0"b;
2032 command_level = command_level - 1;
2033 temp_seg_usage_count (command_seg_stack (command_level + 1)) =
2034 temp_seg_usage_count (command_seg_stack (command_level + 1)) - 1;
2035 command_line_address = temp_seg_address (command_seg_stack (command_level));
2036 command_char_number = command_char_stack (command_level);
2037 command_line_length = command_length_stack (command_level);
2038 base_iteration_level = command_iteration_stack (command_level);
2039 immediate_interrupt_ok = save_interrupt_ok;
2040 end revert_command_level;
2041
2042
2043 unwind_iteration:
2044 procedure (return_iteration_level);
2045 dcl return_iteration_level fixed bin (24);
2046 iteration_level = return_iteration_level;
2047 if iteration_level < base_iteration_level
2048 then goto unfinished_iteration;
2049 if iteration.end (iteration_level + 1) >= 0
2050 then command_char_number = iteration.end (iteration_level + 1);
2051 else do;
2052 command_char_number = iteration.begin (iteration_level + 1);
2053 call skip ("<>");
2054 end;
2055 return;
2056 end unwind_iteration;
2057
2058
2059 skip:
2060 procedure (search_chars);
2061 dcl search_chars char (2) aligned;
2062 trace_flag = "0"b;
2063 skip_with_trace:
2064 entry (search_chars);
2065 skip_count = 0;
2066 get_character_fail_handler = skip_fail;
2067 do while ("1"b);
2068 search_length = search (substr (command_line, command_char_number + 1), search_chars);
2069 call print_command_line;
2070 if search_successful
2071 then if substr (command_line, command_char_number, 1) = substr (search_chars, 2, 1)
2072 then do;
2073 skip_count = skip_count - 1;
2074 if skip_count < 0
2075 then do;
2076 trace_flag = trace_flag_copy;
2077 return;
2078 end;
2079 end;
2080 else skip_count = skip_count + 1;
2081 call find_character;
2082 end;
2083 end skip;
2084 ^L
2085
2086
2087 must_find_line_forward:
2088 procedure;
2089 dcl must_find bit (1) aligned;
2090
2091 must_find = "1"b;
2092 if "0"b
2093 then do;
2094 find_line_forward:
2095 entry;
2096 must_find = "0"b;
2097 end;
2098 temp_dot = dot2;
2099 count = end_buffer - dot2;
2100 do arg1 = 1 to arg1;
2101 if temp_dot >= end_buffer
2102 then if must_find
2103 then goto dot_beyond_Z;
2104 else return;
2105 j = index (substr (buffer2, temp_dot + 1, end_buffer - temp_dot), new_line_char);
2106
2107 if j = 0
2108 then temp_dot = end_buffer;
2109 else temp_dot = temp_dot + j;
2110 end;
2111 count = temp_dot - dot2;
2112 return;
2113
2114 must_find_line_reverse:
2115 entry;
2116 must_find = "1"b;
2117 if "0"b
2118 then do;
2119 find_line_reverse:
2120 entry;
2121 must_find = "0"b;
2122 end;
2123 temp_dot = dot1;
2124 do arg1 = 1 to 1 - arg1;
2125 j = 1;
2126 if temp_dot > 0
2127 then do;
2128 j = index (reverse (substr (buffer1, 1, temp_dot)), new_line_char);
2129 if j = 0
2130 then j = temp_dot + 1;
2131 end;
2132 temp_dot = temp_dot - j;
2133 end;
2134 temp_dot = temp_dot + 1;
2135 if temp_dot >= 0
2136 then return;
2137 if must_find
2138 then goto dot_before_0;
2139 temp_dot = 0;
2140 end ;
2141 ^L
2142 get_quoted_string:
2143 procedure;
2144 dcl save_immediate_interrupt_ok bit (1) aligned,
2145 (quote_name, quote_seg, old_seg) fixed bin (24);
2146
2147 call get_character;
2148 delimiter = current_character;
2149 if delimiter = "q"
2150 then goto quoted_string_in_Q_register;
2151 if delimiter = "Q"
2152 then goto quoted_string_in_Q_register;
2153 if delimiter >= "a"
2154 then if delimiter <= "z"
2155 then goto illegal_delimiter;
2156 if delimiter >= "0"
2157 then if delimiter <= "9"
2158 then goto illegal_delimiter;
2159 if delimiter >= "A"
2160 then if delimiter <= "Z"
2161 then goto illegal_delimiter;
2162 quote_name = quoted_string_Q_register_number;
2163 call allocate_Q_register_have_number (quote_name);
2164 get_character_fail_handler = no_quoting_delimiter;
2165 do while ("1"b);
2166 j = command_char_number;
2167 search_length = index (substr (command_line, j + 1, command_line_length - j), delimiter);
2168 call print_command_line;
2169 i = search_length - fixed (search_successful, 1, 0);
2170
2171 if i > 0
2172 then do;
2173 if quoted_string_length + i > max_seg_size
2174 then goto string_too_long;
2175 substr (quoted_string, quoted_string_length + 1, i) = substr (command_line, j + 1, i);
2176 quoted_string_length = quoted_string_length + i;
2177 end;
2178 if search_successful
2179 then return;
2180 call find_character;
2181 if "0"b
2182 then do;
2183 no_quoting_delimiter:
2184 command_line_length = command_line_length + 2;
2185 call read_line;
2186 end;
2187 end;
2188
2189 quoted_string_in_Q_register:
2190 quote_name = get_Q_register_number ();
2191 quote_seg = Q_register_seg_number (quote_name);
2192 if quote_seg = 0
2193 then goto numeric_quoted_in_Q;
2194 save_immediate_interrupt_ok = immediate_interrupt_ok;
2195 immediate_interrupt_ok = "0"b;
2196 temp_seg_usage_count (quote_seg) = temp_seg_usage_count (quote_seg) + 1;
2197 old_seg = quoted_string_seg_number;
2198 quoted_string_seg_number = quote_seg;
2199 quoted_string_length = Q_register_value (quote_name);
2200 temp_seg_usage_count (old_seg) = temp_seg_usage_count (old_seg) - 1;
2201 immediate_interrupt_ok = save_immediate_interrupt_ok;
2202 end get_quoted_string;
2203 ^L
2204
2205 get_Q_register_number:
2206 procedure () returns (fixed bin (24));
2207 dcl Q_number fixed bin (24);
2208 get_character_fail_handler = missing_Q_register_name;
2209 call get_character;
2210 Q_number = fixed (unspec (io_char), 9, 0);
2211 if Q_number < lbound (Q_register_value, 1)
2212 then goto illegal_Q_register_name;
2213 if Q_number >= hbound (Q_register_value, 1)
2214 then goto illegal_Q_register_name;
2215 return (Q_number);
2216 end get_Q_register_number;
2217
2218
2219
2220 allocate_Q_register:
2221 procedure (alloc_name);
2222 dcl (alloc_name, alloc_seg) fixed bin (24),
2223 save_immediate_interrupt_ok bit (1) aligned;
2224 alloc_name = get_Q_register_number ();
2225
2226 allocate_Q_register_have_number:
2227 entry (alloc_name);
2228 save_immediate_interrupt_ok = immediate_interrupt_ok;
2229 immediate_interrupt_ok = "0"b;
2230 alloc_seg = Q_register_seg_number (alloc_name);
2231 if alloc_seg = 0
2232 then goto must_allocate_Q_register;
2233 temp_seg_usage_count (alloc_seg) = temp_seg_usage_count (alloc_seg) - 1;
2234 if temp_seg_usage_count (alloc_seg) ^= 0
2235 then do;
2236 must_allocate_Q_register:
2237 alloc_seg = number_reserved_temp_segs;
2238 find_free_seg:
2239 do;
2240 if alloc_seg >= hbound (temp_seg_address, 1)
2241 then goto no_more_temp_segs;
2242 alloc_seg = alloc_seg + 1;
2243 if temp_seg_usage_count (alloc_seg) ^= 0
2244 then goto find_free_seg;
2245 end find_free_seg;
2246 Q_register_seg_number (alloc_name) = alloc_seg;
2247 if temp_seg_address (alloc_seg) = null
2248 then
2249 do;
2250 call get_temp_seg_ (my_id, rwa_access, temp_seg_address (alloc_seg), error_code);
2251 if error_code ^= 0
2252 then goto no_more_temp_segs;
2253 end;
2254 end;
2255 temp_seg_usage_count (alloc_seg) = 1;
2256 Q_register_value (alloc_name) = 0;
2257 immediate_interrupt_ok = save_immediate_interrupt_ok;
2258 end allocate_Q_register;
2259 ^L
2260 READ:
2261 procedure (buffer_pointer, offset);
2262 dcl buffer_pointer ptr,
2263 (offset, length) fixed bin (24);
2264
2265 p = buffer_pointer;
2266 if offset ^= 0
2267 then p = addr (substr (p -> file, offset + 1, 1));
2268 call iox_$get_line (iox_$user_input, p, max_seg_size - offset, read_count, error_code);
2269 in_chk:
2270 if error_code ^= 0
2271 then goto io_diaster;
2272 if read_count = 0
2273 then goto tty_no_read;
2274 return;
2275
2276 READ_CHAR:
2277 entry;
2278 call iox_$get_chars (iox_$user_input, io_char_address, 1, read_count, error_code);
2279 goto in_chk;
2280
2281 WRITE:
2282 entry (buffer_pointer, offset, length);
2283 p = buffer_pointer;
2284 if offset ^= 0
2285 then p = addr (substr (p -> file, offset + 1, 1));
2286 call iox_$put_chars (iox_$user_output, p, length, error_code);
2287 if error_code = 0
2288 then return;
2289 io_diaster:
2290 call com_err_ (error_code, program_name);
2291 goto tty_no_read;
2292 end READ;
2293
2294
2295 move_dot:
2296 procedure (char_count, a_accept_error);
2297 dcl a_accept_error bit (1) aligned,
2298 accept_error bit (1) aligned init ("0"b),
2299 (char_count, cc, tc) fixed bin (24);
2300 accept_error = a_accept_error;
2301 if char_count > 0
2302 then do;
2303 move_dot_forward:
2304 entry (char_count);
2305 cc = char_count;
2306 if dot2 + cc > end_buffer
2307 then if accept_error
2308 then cc = end_buffer - dot2;
2309 else goto dot_beyond_Z;
2310 if cc <= 0
2311 then return;
2312 immediate_interrupt_ok = "0"b;
2313 if max_dot1 - dot1 < cc
2314 then do;
2315 if max_dot1 - dot1 > 0
2316 then do;
2317 tc = max_dot1 - dot1;
2318 dot1 = max_dot1;
2319 dot2 = dot2 + tc;
2320 cc = cc - tc;
2321 end;
2322 substr (buffer1, dot1 + 1, cc) = substr (buffer2, dot2 + 1, cc);
2323 max_dot1 = dot1 + cc;
2324 if dot2 + cc = end_buffer
2325 then goto move_to_b1;
2326 end;
2327 end;
2328 else do;
2329 move_dot_backward:
2330 entry (char_count);
2331 cc = char_count;
2332 if -cc > dot1
2333 then if accept_error
2334 then cc = -dot1;
2335 else goto dot_before_0;
2336 if cc >= 0
2337 then return;
2338 immediate_interrupt_ok = "0"b;
2339 if dot2 - min_dot2 < -cc
2340 then do;
2341 if -cc <= dot2
2342 then do;
2343 if dot2 - min_dot2 > 0
2344 then do;
2345 tc = dot2 - min_dot2;
2346 dot1 = dot1 - tc;
2347 dot2 = min_dot2;
2348 cc = cc + tc;
2349 end;
2350 substr (buffer2, dot2 + (cc + 1), -cc) = substr (buffer1, dot1 + (cc + 1), -cc);
2351 min_dot2 = dot2 + cc;
2352 if min_dot2 + (dot1 + cc) = 0
2353 then do;
2354 max_dot1 = end_buffer;
2355 b1 = b2;
2356 n1 = n2;
2357 end;
2358 end;
2359 else do;
2360 if end_buffer - dot2 > 0
2361 then substr (buffer1, dot1 + 1, end_buffer - dot2) =
2362 substr (buffer2, dot2 + 1, end_buffer - dot2);
2363 move_to_b1:
2364 end_buffer, max_dot1 = dot1 + (end_buffer - dot2);
2365
2366 b2 = b1;
2367 n2 = n1;
2368 min_dot2 = 0;
2369 dot2 = dot1;
2370 end;
2371 end;
2372 end;
2373 dot1 = dot1 + cc;
2374 dot2 = dot2 + cc;
2375 end move_dot;
2376 ^L
2377
2378 copy_source:
2379 procedure;
2380 dcl ichar char (ic) based unaligned,
2381 (source, in_ptr) ptr,
2382 (new_dot1, new_dot2, insert_count, n0, s1, s2, nd2, ic, new_end) fixed bin (24);
2383
2384 ic = 0;
2385 s1 = dot1;
2386 nd2 = dot2;
2387 goto copy_text;
2388
2389
2390 delete_chars:
2391 entry (new_dot1, new_dot2);
2392 s1 = new_dot1;
2393 if s1 < 0
2394 then goto dot_before_0;
2395 nd2 = new_dot2;
2396 if nd2 > end_buffer
2397 then goto dot_beyond_Z;
2398 if s1 = dot1 & nd2 = dot2
2399 then return;
2400 ic = 0;
2401 goto copy_text;
2402
2403
2404 add_chars:
2405 entry (in_ptr, insert_count);
2406 ic = insert_count;
2407 if ic = 0
2408 then return;
2409 s1 = dot1;
2410 nd2 = dot2;
2411 if s1 + end_buffer - nd2 + ic > max_seg_size
2412 then goto no_room;
2413
2414 copy_text:
2415 s2 = end_buffer - nd2;
2416 immediate_interrupt_ok = "0"b;
2417 n0 = n1;
2418 if s2 = 0 | (s1 + ic + nd2) = 0
2419 then do;
2420 n0 = n1;
2421 end_buffer, max_dot1 = s1 + s2 + ic;
2422 min_dot2 = 0;
2423 if n1 = 0
2424 then do;
2425 n1, n2 = 1;
2426 source = b1;
2427 b1, b2 = temp_seg_address (1);
2428 substr (b1 -> buffer1, 1, s1 + s2) = substr (source -> buffer1, 1, s1 + s2);
2429
2430 end;
2431 else do;
2432 if s2 > 0
2433 then n1 = n2;
2434 else n2 = n1;
2435 b1, b2 = temp_seg_address (n1);
2436 end;
2437 end;
2438 else do;
2439 max_dot1 = s1 + ic;
2440 min_dot2 = nd2;
2441 if n1 = n2
2442 then do;
2443 if n1 = 0
2444 then do;
2445 n1 = 1;
2446 n2 = 2;
2447 end;
2448 else if s1 < s2
2449 then n1 = 3 - n2;
2450 else n2 = 3 - n1;
2451 source = b1;
2452 b1 = temp_seg_address (n1);
2453 b2 = temp_seg_address (n2);
2454 if s1 > 0 & n0 ^= n1
2455 then do;
2456 substr (b1 -> buffer1, 1, s1) = substr (source -> buffer1, 1, s1);
2457 end;
2458 if s2 > 0 & n0 ^= n2
2459 then do;
2460 new_end = min (divide (s1 + s2 + ic + 512 + 4095, 4096, 17, 0) * 4096, max_seg_size);
2461 if n1 ^= n2
2462 then min_dot2 = new_end - s2;
2463 substr (b2 -> buffer2, new_end - s2 + 1, s2) =
2464 substr (source -> buffer2, end_buffer - s2 + 1, s2);
2465 end_buffer = new_end;
2466 end;
2467 end;
2468 end;
2469
2470 dot1 = s1 + ic;
2471 dot2 = end_buffer - s2;
2472
2473 if ic > 0
2474 then substr (b1 -> buffer1, s1 + 1, ic) = substr (in_ptr -> ichar, 1, ic);
2475
2476 if n0 = 0
2477 then goto close_a_file;
2478 return;
2479
2480 close_file:
2481 entry (in_ptr);
2482 source = in_ptr;
2483
2484 close_a_file:
2485 if source = null
2486 then return;
2487 call release_seg_ptr_ (source, -1, error_code);
2488 if error_code ^= 0
2489 then goto file_error;
2490 end copy_source;
2491 end TECO;