1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24 substr: procedure;
25
26 dcl
27 Larg (3) fixed bin,
28 Lret fixed bin,
29 Nargs fixed bin,
30 Npic pic "(10)z9",
31 Parg (3) ptr,
32 Pret ptr,
33 Scommand bit (1) aligned,
34 arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin(35)) variable,
35 args_sw bit (1),
36 bit3 bit(3) aligned,
37 bit4 bit(4) aligned,
38 char3 char(3) aligned,
39 char4 char(4) aligned,
40 (cleanup, conversion) condition,
41 code fixed bin(35),
42 e fixed bin,
43 error entry options (variable) variable,
44 (i, j, n) fixed bin,
45 leading_sw bit (1);
46
47 dcl
48 arg1 char(Larg(1)) based (Parg(1)),
49 arg2 char(Larg(2)) based (Parg(2)),
50 arg3 char(Larg(3)) based (Parg(3)),
51 ret char(Lret) varying based (Pret);
52
53 dcl (addr, after, before, bit, bool, character, collate, collate9, convert, copy, decat,
54 high, high9, index, length, low, ltrim, min, null, reverse, rtrim, search,
55 substr, translate, verify)
56 builtin;
57
58 dcl
59 active_fnc_err_ entry options (variable),
60 com_err_ entry options (variable),
61 (cu_$af_return_arg,
62 cu_$af_arg_ptr,
63 cu_$arg_ptr) entry (fixed bin, ptr, fixed bin, fixed bin(35)),
64 cu_$arg_count entry returns (fixed bin),
65 (get_temp_segment_,
66 release_temp_segment_) entry (char(*), ptr, fixed bin(35)),
67 ioa_ entry() options(variable);
68
69 dcl
70 UP_A char (2) int static options (constant) init ("^a"),
71 UPPERCASE char (26) aligned int static options (constant) init
72 ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
73 LOWERCASE char (26) aligned int static options (constant) init
74 ("abcdefghijklmnopqrstuvwxyz"),
75 (error_table_$bad_arg,
76 error_table_$bad_conversion,
77 error_table_$badopt,
78 error_table_$wrong_no_of_args)
79 fixed bin(35) ext static,
80
81 ep (28) char(15) int static options(constant) init (
82 "after",
83 "before",
84 "bool",
85 "collate",
86 "collate9",
87 "copy_characters",
88 "decat",
89 "high",
90 "high9",
91 "index",
92 "length",
93 "low",
94 "lower_case",
95 "ltrim",
96 "reverse",
97 "reverse_after",
98 "reverse_before",
99 "reverse_decat",
100 "reverse_index",
101 "reverse_search",
102 "reverse_substr",
103 "reverse_verify",
104 "rtrim",
105 "search",
106 "substr",
107 "translate",
108 "upper_case",
109 "verify"),
110 max_args (28) fixed bin int static options(constant) init (
111 2, 2, 3, 0, 0, 2, 3, 1, 1, 2,
112 1, 1, 999, 2, 1, 2, 2, 3, 2, 2,
113 3, 2, 2, 2, 3, 3, 999, 2),
114 min_args (28) fixed bin int static options(constant) init (
115 2, 2, 3, 0, 0, 2, 3, 1, 1, 2,
116 1, 1, 1, 1, 1, 2, 2, 3, 2, 2,
117 2, 2, 1, 2, 2, 2, 1, 2),
118 options (28) char(52) int static options(constant) init (
119 "source_string indexing_string",
120 "source_string indexing_string",
121 "bit_string bit_string 4_bit_string",
122 "",
123 "",
124 "string number_of_copies",
125 "source_string indexing_string 3_bit_string",
126 "number_of_copies",
127 "number_of_copies",
128 "source_string indexing_string",
129 "string",
130 "number_of_copies",
131 "strings",
132 "source_string search_string",
133 "string",
134 "source_string indexing_string",
135 "source_string indexing_string",
136 "source_string indexing_string 3_bit_string",
137 "source_string indexing_string",
138 "source_string search_string",
139 "string starting_index_number {length}",
140 "source_string verify_string",
141 "source_string search_string",
142 "source_string search_string",
143 "string starting_index_number {length}",
144 "string translate_to_string {translate_from_string}",
145 "strings",
146 "source_string verify_string"),
147 sys_info$max_seg_size fixed bin(35) ext static;
148
149 dcl TRUE bit (1) aligned internal static options (constant) init ("1"b),
150 FALSE bit (1) aligned internal static options (constant) init ("0"b);
151 ^L
152
153
154
155 e = 25;
156 go to COMMON;
157
158
159 after: af: entry;
160
161 e = 1;
162 go to COMMON;
163
164
165 before: be: entry;
166
167 e = 2;
168 go to COMMON;
169
170
171 bool: entry;
172
173 e = 3;
174 go to COMMON;
175
176
177 collate: entry;
178
179 e = 4;
180 go to COMMON;
181
182
183 collate9: entry;
184
185 e = 5;
186 go to COMMON;
187
188
189 copy_characters: cpch: entry;
190
191 e = 6;
192 go to COMMON;
193
194
195 decat: entry;
196
197 e = 7;
198 go to COMMON;
199
200
201 high: entry;
202
203 e = 8;
204 go to COMMON;
205
206
207 high9: entry;
208
209 e = 9;
210 go to COMMON;
211
212
213 index: entry;
214
215 e = 10;
216 go to COMMON;
217
218
219 length: ln: entry;
220
221 e = 11;
222 go to COMMON;
223
224
225 low: entry;
226
227 e = 12;
228 go to COMMON;
229
230
231 lower_case: lowercase: entry;
232
233 e = 13;
234 go to COMMON;
235
236
237 ltrim: entry;
238
239 e = 14;
240 go to COMMON;
241
242
243 reverse: rv: entry;
244
245 e = 15;
246 go to COMMON;
247
248
249 reverse_after: rvaf: entry;
250
251 e = 16;
252 go to COMMON;
253
254
255 reverse_before: rvbe: entry;
256
257 e = 17;
258 go to COMMON;
259
260
261 reverse_decat: rvdecat: entry;
262
263 e = 18;
264 go to COMMON;
265
266
267 reverse_index: rvindex: entry;
268
269 e = 19;
270 go to COMMON;
271
272
273 reverse_search: rvsrh: entry;
274
275 e = 20;
276 go to COMMON;
277
278 reverse_substr: rvsubstr: entry;
279
280 e = 21;
281 go to COMMON;
282
283 reverse_verify: rvverify: entry;
284
285 e = 22;
286 go to COMMON;
287
288
289 rtrim: entry;
290
291 e = 23;
292 go to COMMON;
293
294
295 search: srh: entry;
296
297 e = 24;
298 go to COMMON;
299
300
301 translate: entry;
302
303 e = 26;
304 go to COMMON;
305
306
307 upper_case: uppercase: entry;
308
309 e = 27;
310 go to COMMON;
311
312
313 verify: entry;
314
315 e = 28;
316 go to COMMON;
317
318
319 ^L
320
321 COMMON: call cu_$af_return_arg (Nargs, Pret, Lret, code);
322 if code = 0 then do;
323 error = active_fnc_err_;
324 arg_ptr = cu_$af_arg_ptr;
325 Scommand = FALSE;
326 end;
327 else do;
328 error = com_err_;
329 arg_ptr = cu_$arg_ptr;
330 Scommand = TRUE;
331 Nargs = cu_$arg_count();
332 Pret = null;
333 on cleanup call janitor();
334 call get_temp_segment_ (ep(e), Pret, code);
335 if code ^= 0 then go to NO_TEMP_SEG;
336 Lret = (sys_info$max_seg_size - 1) * 4;
337 end;
338 ^L
339 if Nargs < min_args(e) then
340 go to wnoa;
341 if Nargs > max_args(e) then
342 go to wnoa;
343 do i = 1 to min (Nargs, 3);
344 call arg_ptr (i, Parg(i), Larg(i), code);
345 end;
346
347 ret = "";
348 go to do(e);
349 ^L
350 do( 1):
351 ret = double_quotes(after(arg1,arg2));
352 go to return;
353
354 do( 2):
355 ret = double_quotes(before (arg1, arg2));
356 go to return;
357
358 do( 3):
359 i = verify(arg1, "01");
360 if i > 0 then do;
361 i = 1;
362 go to bad_conversion;
363 end;
364 i = verify(arg2, "01");
365 if i > 0 then do;
366 i = 2;
367 go to bad_conversion;
368 end;
369 if Larg(3) ^= 4 then do;
370 i = 4;
371 go to bad_bit_string;
372 end;
373 char4 = arg3;
374 i = verify(char4, "01");
375 if i > 0 then do;
376 i = 3;
377 go to bad_conversion;
378 end;
379 bit4 = bit(char4, 4);
380 ret = character(bool(bit(arg1), bit(arg2), bit4));
381 go to return;
382
383 do( 4):
384 if Scommand then
385 ret = collate();
386 else do;
387 ret = """";
388 ret = ret || substr (collate(),1,35);
389 ret = ret || substr (collate(),35);
390 ret = ret || """";
391 end;
392 go to return;
393
394 do( 5):
395 if Scommand then
396 ret = collate9();
397 else do;
398 ret = """";
399 ret = ret || substr (collate(),1,35);
400 ret = ret || substr (collate9(),35);
401 ret = ret || """";
402 end;
403 go to return;
404 ^L
405 do( 6):
406 on conversion begin;
407 i = 2;
408 go to bad_conversion;
409 end;
410 n = convert(n, arg2);
411 revert conversion;
412 if n < 0 then do;
413 i = 2;
414 go to nonnegative_arg;
415 end;
416 else if n = 0 then;
417 else
418 ret = double_quotes(copy (arg1, n));
419 go to return;
420
421 do( 7):
422 if Larg(3) ^= 3 then do;
423 i = 3;
424 go to bad_bit_string;
425 end;
426 char3 = arg3;
427 i = verify (char3, "01");
428 if i > 0 then do;
429 i = 3;
430 go to bad_conversion;
431 end;
432 bit3 = bit(char3, 3);
433 ret = double_quotes(decat (arg1, arg2, bit3));
434 go to return;
435
436 do( 8):
437 do( 9):
438 do(12):
439 on conversion begin;
440 i = 1;
441 go to bad_conversion;
442 end;
443 n = convert(n, arg1);
444 revert conversion;
445 if n < 0 then do;
446 i = 1;
447 go to nonnegative_arg;
448 end;
449 else if n = 0 then
450 go to return;
451 else go to do_hl(e);
452 do_hl(8):
453 ret = high(n);
454 go to return;
455 do_hl(9):
456 ret = high9(n);
457 go to return;
458 do_hl(12):
459 ret = low(n);
460 go to return;
461 ^L
462 do(10):
463 i = index (arg1, arg2);
464 ret_num: Npic = i;
465 ret = ltrim(Npic);
466 go to return;
467
468 do(11):
469 i = Larg(1);
470 go to ret_num;
471
472 do(13):
473 do i = 1 to Nargs;
474 call arg_ptr (i, Parg (1), Larg (1), 0);
475 if ret ^= "" then ret = ret || " ";
476 ret = ret || double_quotes (translate (arg1, LOWERCASE, UPPERCASE));
477 end;
478 go to return;
479
480 do(14):
481 if Nargs = 2 then
482 ret = double_quotes(ltrim(arg1, arg2));
483 else ret = double_quotes(ltrim(arg1));
484 go to return;
485
486 do(15):
487 if Larg(1) <= 0 then;
488 else
489 ret = double_quotes(reverse (arg1));
490 go to return;
491
492 do(16):
493 if index(arg1, arg2) > 0 then
494 ret = double_quotes(reverse(before(reverse(arg1), reverse(arg2))));
495 else ret = "";
496 go to return;
497
498 do(17):
499 if index(arg1, arg2) > 0 then
500 ret = double_quotes(reverse(after(reverse(arg1), reverse(arg2))));
501 else ret = double_quotes(arg1);
502 go to return;
503
504 do(18):
505 if Larg(3) ^= 3 then do;
506 i = 3;
507 go to bad_bit_string;
508 end;
509 char3 = arg3;
510 i = verify (char3, "01");
511 if i > 0 then do;
512 i = 3;
513 go to bad_conversion;
514 end;
515 bit3 = bit(char3, 3);
516 if index(arg1, arg2) > 0 then
517 ret = double_quotes(reverse(decat(reverse(arg1), reverse(arg2), reverse(bit3))));
518 else ret = double_quotes(decat(arg1, arg2, bit3));
519 go to return;
520 ^L
521 do(19):
522 i = index (reverse(arg1), reverse(arg2));
523 if i > 0 then
524 i = Larg(1) - i + 2 - Larg(2);
525 go to ret_num;
526
527 do(20):
528 i = search (reverse(arg1), arg2);
529 if i > 0 then
530 i = Larg(1) - i + 1;
531 go to ret_num;
532
533 do(21):
534 on conversion begin;
535 i = 2;
536 go to bad_conversion;
537 end;
538 i = convert(i, arg2);
539 revert conversion;
540 if Nargs = 3 then do;
541 on conversion begin;
542 i = 3;
543 go to bad_conversion;
544 end;
545 j = convert(j, arg3);
546 revert conversion;
547 end;
548 else
549 j = Larg(1);
550 if i <= 0 then do;
551 i = 2;
552 go to positive_arg;
553 end;
554 else if i > Larg(1) then;
555 else if j < 0 then do;
556 i = 3;
557 go to nonnegative_arg;
558 end;
559 else if j = 0 then;
560 else do;
561 if i+j-1 > Larg(1) then
562 j = Larg(1) - i + 1;
563 ret = double_quotes(reverse (substr (reverse (arg1), i, j)));
564 end;
565 go to return;
566
567 do(22):
568 i = verify (reverse(arg1), arg2);
569 if i > 0 then
570 i = Larg(1) - i + 1;
571 go to ret_num;
572
573 do(23):
574 if Nargs = 2 then
575 ret = double_quotes(rtrim(arg1, arg2));
576 else ret = double_quotes(rtrim(arg1));
577 go to return;
578
579 do(24):
580 i = search (arg1, arg2);
581 go to ret_num;
582 ^L
583 do(25):
584 on conversion begin;
585 i = 2;
586 go to bad_conversion;
587 end;
588 i = convert(i, arg2);
589 revert conversion;
590 if Nargs = 3 then do;
591 on conversion begin;
592 i = 3;
593 go to bad_conversion;
594 end;
595 j = convert(j, arg3);
596 revert conversion;
597 end;
598 else
599 j = Larg(1);
600 if i <= 0 then do;
601 i = 2;
602 go to positive_arg;
603 end;
604 else if i > Larg(1) then;
605 else if j < 0 then do;
606 i = 3;
607 go to nonnegative_arg;
608 end;
609 else if j = 0 then;
610 else do;
611 if i+j-1 > Larg(1) then
612 j = Larg(1) - i + 1;
613 ret = double_quotes(substr (arg1, i, j));
614 end;
615 go to return;
616
617 do(26):
618 if Nargs = 2 then
619 ret = double_quotes(translate (arg1, arg2));
620 else
621 ret = double_quotes(translate (arg1, arg2, arg3));
622 go to return;
623 ^L
624 do(27):
625 args_sw, leading_sw = "0"b;
626 do i = 1 to Nargs;
627 call arg_ptr (i, Parg (1), Larg (1), 0);
628 if ^args_sw & substr (arg1, 1, 1) = "-" then
629 if arg1 = "-leading" then leading_sw = "1"b;
630 else if arg1 = "-arguments" | arg1 = "-ag" then args_sw = "1"b;
631 else do;
632 call error (error_table_$badopt, "uppercase", "^a", arg1);
633 return;
634 end;
635 else do;
636 args_sw = "1"b;
637 if leading_sw then do;
638 if ret ^= "" then ret = ret || " ";
639 ret = ret || double_quotes (arg1);
640 end;
641 else do;
642 if ret ^= "" then ret = ret || " ";
643 ret = ret || double_quotes (translate (arg1, UPPERCASE, LOWERCASE));
644 end;
645 end;
646 end;
647
648 if leading_sw then do;
649 substr (ret, 1, 1) = translate (substr (ret, 1, 1), UPPERCASE, LOWERCASE);
650 do i = 2 to length (ret);
651 if index (LOWERCASE, substr (ret, i, 1)) ^= 0 then
652 if index (UPPERCASE || LOWERCASE || "'-", substr (ret, i - 1, 1)) = 0 then
653
654 substr (ret, i, 1) = translate (substr (ret, i, 1), UPPERCASE, LOWERCASE);
655 end;
656 end;
657 go to return;
658
659 do(28):
660 i = verify (arg1, arg2);
661 go to ret_num;
662
663 return: if Scommand then do;
664 call ioa_ (UP_A, ret);
665 call release_temp_segment_ (ep(e), Pret, code);
666 end;
667 return;
668 ^L
669
670
671
672 positive_arg:
673 j = 1;
674 go to bad_arg;
675 nonnegative_arg:
676 j = 2;
677 bad_arg: Parg(1) = Parg(i);
678 Larg(1) = Larg(i);
679 call error (error_table_$bad_arg, ep(e), " ^a
680 Argument ^d must be a ^[positive^;nonnegative^] integer.", arg1, i, j);
681 call janitor();
682 return;
683
684 wnoa: call error (error_table_$wrong_no_of_args, ep(e), "
685 Usage: ^[[^]^a ^a^[]^]", ^Scommand, ep(e), options(e), ^Scommand);
686 call janitor();
687 return;
688
689 NO_TEMP_SEG:
690 call error (code, ep(e), "^/While obtaining a temporary segment.");
691 return;
692
693 bad_bit_string:
694 call error (error_table_$bad_arg, ep(e), " ^a
695 Third argument must be a bit string of length ^d.
696 Usage: ^[[^]^a ^a^[]^]", arg3, i, ^Scommand, ep(e), options(e), ^Scommand);
697 call janitor();
698 return;
699
700 bad_conversion:
701 Parg(1) = Parg(i);
702 Larg(1) = Larg(i);
703 call error (error_table_$bad_conversion, ep(e), " ^a
704 Usage: ^[[^]^a ^a^[]^]", arg1, ^Scommand,ep(e), options(e), ^Scommand);
705 call janitor();
706 return;
707
708
709 ^L
710
711
712
713 double_quotes: procedure (string) returns (char(*) varying);
714
715
716
717 dcl string char(*);
718
719 dcl (i, j) fixed bin;
720
721
722 dcl copied_string char(length(string)*2+2) varying;
723
724 dcl string_begin char(i-1) based (addr(string_array(j))),
725 string_end char(length(string)-(j-1)) based(addr(string_array(j))),
726 string_array (length(string)) char(1) based (addr(string));
727
728 if Scommand then return (string);
729 i = search(string,"""");
730 if i = 0 then return("""" || string || """");
731 j = 1;
732 copied_string = """";
733 do while (i > 0);
734 copied_string = copied_string || string_begin;
735 copied_string = copied_string || """""";
736 j = i+j;
737 i = search (string_end, """");
738 end;
739 copied_string = copied_string || string_end;
740 copied_string = copied_string || """";
741 return (copied_string);
742
743
744 end double_quotes;
745
746
747
748
749 janitor: procedure;
750
751 if Scommand & Pret ^= null then
752 call release_temp_segment_ (ep(e), Pret, code);
753
754 end janitor;
755
756
757
758
759 end substr;