1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22 terminate: tm: proc;
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39 dcl arg char (arg_len) based (arg_ptr);
40 dcl dn char (168);
41 dcl (en, myname, refname, usage) char (32);
42
43 dcl (brief_sw, some_args) bit (1);
44
45 dcl (arg_ptr, seg_ptr) ptr;
46
47 dcl (arg_count, arg_len, i, segno) fixed bin;
48 dcl code fixed bin (35);
49
50 dcl error_table_$badopt fixed bin (35) ext;
51 dcl error_table_$invalidsegno fixed bin (35) ext;
52 dcl error_table_$name_not_found fixed bin (35) ext;
53 dcl error_table_$seg_unknown fixed bin (35) ext;
54
55 dcl active_fnc_err_ entry options (variable);
56 dcl (com_err_, com_err_$suppress_name) entry options (variable);
57 dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
58 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
59 dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
60 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
61 dcl get_wdir_ entry returns (char (168));
62 dcl term_ entry (char (*), char (*), fixed bin (35));
63 dcl term_$refname entry (char (*), fixed bin (35));
64 dcl term_$seg_ptr entry (ptr, fixed bin (35));
65 dcl term_$single_refname entry (char (*), fixed bin (35));
66
67 dcl (baseptr, null, substr) builtin;
68
69 myname = "terminate";
70 usage = "paths";
71 go to COMMON;
72
73 terminate_segno: tms: entry;
74
75 myname = "terminate_segno";
76 usage = "segment_numbers";
77 go to COMMON;
78
79 terminate_refname: tmr: entry;
80
81 myname = "terminate_refname";
82 usage = "reference_names";
83 go to COMMON;
84
85 terminate_single_refname: tmsr: entry;
86
87 myname = "terminate_single_refname";
88 usage = "reference_names";
89
90
91 COMMON: call cu_$af_return_arg (arg_count, null, 0, code);
92 if code = 0 then do;
93 call active_fnc_err_ (0, myname, "Cannot be called as an active function.");
94 return;
95 end;
96
97 brief_sw, some_args = "0"b;
98 do i = 1 to arg_count;
99
100 call cu_$arg_ptr (i, arg_ptr, arg_len, code);
101
102 if substr (arg, 1, 1) ^= "-" then some_args = "1"b;
103
104 else if arg = "-brief" | arg = "-bf" then brief_sw = "1"b;
105 else if arg = "-long" | arg = "-lg" then brief_sw = "0"b;
106 else if arg = "-name" | arg = "-nm" then do;
107 i = i + 1;
108 if i > arg_count then do;
109 call com_err_ (0, myname, "No value specified for -name");
110 return;
111 end;
112 some_args = "1"b;
113 end;
114 else do;
115 call com_err_ (error_table_$badopt, myname, "^a", arg);
116 return;
117 end;
118 end;
119
120 if ^some_args then do;
121 call com_err_$suppress_name (0, myname, "Usage: ^a ^a {-control_args}", myname, usage);
122 return;
123 end;
124
125 do i = 1 to arg_count;
126
127 call cu_$arg_ptr (i, arg_ptr, arg_len, code);
128
129 if substr (arg, 1, 1) ^= "-" then do;
130
131 TERMINATE: if myname = "terminate" then do;
132 call expand_pathname_ (arg, dn, en, code);
133 if code ^= 0 then do;
134 call com_err_ (code, myname, "^a", arg);
135 return;
136 end;
137 TERM_PATH: call term_ (dn, en, code);
138 if code ^= 0 then do;
139 if ^brief_sw | code ^= error_table_$seg_unknown then
140 call com_err_ (code, myname, "^a^[>^]^a", dn, dn ^= ">", en);
141 if code ^= error_table_$seg_unknown then return;
142 end;
143 end;
144 else if myname = "terminate_segno" then do;
145 segno = cv_oct_check_ (arg, code);
146 if code ^= 0 then do;
147 call com_err_ (0, myname, "Invalid octal number ^a", arg);
148 return;
149 end;
150 seg_ptr = baseptr (segno);
151 call term_$seg_ptr (seg_ptr, code);
152 if code ^= 0 then do;
153 if ^brief_sw | (code ^= error_table_$seg_unknown & code ^= error_table_$invalidsegno) then
154 call com_err_ (code, myname, "^a", arg);
155 if code ^= error_table_$seg_unknown then return;
156 end;
157 end;
158 else if myname = "terminate_refname" then do;
159 refname = arg;
160 call term_$refname (refname, code);
161 if code ^= 0 then do;
162 TERM_ERROR: if ^brief_sw | (code ^= error_table_$seg_unknown & code ^= error_table_$name_not_found) then
163 call com_err_ (code, myname, "^a", arg);
164 if code ^= error_table_$seg_unknown then return;
165 end;
166 end;
167 else do;
168 refname = arg;
169 call term_$single_refname (refname, code);
170 if code ^= 0 then go to TERM_ERROR;
171 end;
172 end;
173 else if arg = "-name" | arg = "-nm" then do;
174 i = i + 1;
175 call cu_$arg_ptr (i, arg_ptr, arg_len, code);
176 if myname = "terminate" then do;
177 dn = get_wdir_ ();
178 en = arg;
179 go to TERM_PATH;
180 end;
181 else go to TERMINATE;
182 end;
183 end;
184
185 end terminate;