1 concatenate_segs: ccs: proc;
2 dcl seg bit(seglen(argno)) based (segptr(argno));
3 dcl new_seg bit(new_seglen) based (new_segptr);
4 dcl new_segptr ptr init(null);
5 dcl temptr ptr init(null);
6 dcl np bit(1) aligned init("0"b);
7 dcl dl bit(1) aligned init("0"b);
8 dcl first fixed bin init(0);
9 dcl segptr(nargs) controlled ptr init((nargs)null);
10 dcl seglen(nargs) fixed bin(24) controlled;
11 dcl copies (nargs) fixed bin(35) controlled;
12 dcl new_seglen fixed bin(24) init(0);
13 dcl made bit(1) aligned init("0"b);
14 dcl max_bits fixed bin(24);
15 dcl n fixed bin(35);
16 dcl overflow bit(1) aligned init("0"b);
17 dcl last_seg fixed bin init (0);
18 dcl who char(32) static init("concatenate_segs") options(constant);
19 dcl com_err_ entry options (variable);
20 dcl cu_$arg_count entry (fixed bin);
21 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin(35));
22 dcl expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin(35));
23 dcl hcs_$delentry_seg entry (ptr, fixed bin(35));
24 dcl hcs_$fs_move_seg entry (ptr, ptr, fixed bin(1), fixed bin(35));
25 dcl hcs_$initiate_count entry (char(*), char(*), char(*), fixed bin(24), fixed bin(2), ptr, fixed bin(35));
26 dcl hcs_$make_seg entry (char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35));
27 dcl hcs_$set_bc_seg entry (ptr, fixed bin(24), fixed bin(35));
28 dcl hcs_$terminate_noname entry (ptr, fixed bin(35));
29 dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin(35));
30 dcl arg char(arglen) based(argptr);
31 dcl dirname char(168) aligned;
32 dcl ename char(32) aligned;
33 dcl arglen fixed bin;
34 dcl argno fixed bin;
35 dcl nargs fixed bin;
36 dcl argptr ptr;
37 dcl code fixed bin(35);
38 dcl sys_info$max_seg_size fixed bin(18) external;
39 dcl error_table_$clnzero external fixed bin(35);
40 dcl error_table_$badopt external fixed bin(35);
41 dcl error_table_$invalidsegno external fixed bin(35);
42 dcl error_table_$noarg external fixed bin(35);
43 dcl error_table_$noentry external fixed bin(35);
44 dcl null builtin;
45 dcl (cleanup, size, conversion) condition;
46 dcl newpage char(1) static init("^L");
47
48 on cleanup call cleanup_proc;
49
50 call cu_$arg_count (nargs);
51 if nargs ^= 0
52 then allocate segptr, seglen, copies;
53 else do;
54 noarg:
55 call com_err_ (error_table_$noarg, who, "Pathname of at least one segment.");
56 return;
57 end;
58
59 on conversion goto bad_num;
60 on size goto bad_num;
61
62 max_bits = sys_info$max_seg_size * 36;
63
64 do argno = 1 to nargs;
65 call cu_$arg_ptr (argno, argptr, arglen, code);
66 if arglen ^= 0
67 then if substr (arg, 1, 1) = "-"
68 then if arg = "-newpage" | arg = "-np"
69 then np = "1"b;
70 else if arg = "-delete" | arg = "-dl"
71 then dl = "1"b;
72 else if arg = "-copy" | arg = "-cp" then do;
73 argno = argno + 1;
74 call cu_$arg_ptr (argno, argptr, arglen, code);
75 if code ^= 0 then do;
76 call com_err_ (error_table_$noarg, who, "Number of copies.");
77 goto clean;
78 end;
79 n = bin (arg, 35, 0);
80 if n < 0 then do;
81 bad_num: call com_err_ (0, who, """^a"" is too large or not numeric.", arg);
82 goto clean;
83 end;
84
85
86
87 if last_seg = 0 then do;
88 call com_err_ (0, who, """-copy"" control argument may not be first.");
89 goto clean;
90 end;
91 if last_seg = first & made then do;
92 call com_err_ (0, who, "Copies may not be specified for new output segment.");
93 goto clean;
94 end;
95
96
97
98
99
100 if copies(last_seg) = -1 then do;
101 n = n - 1;
102 copies(last_seg) = 1;
103 end;
104 copies(last_seg) = copies(last_seg) + n;
105 new_seglen = new_seglen + seglen(last_seg)*n;
106 Note
107
108 if new_seglen > max_bits then overflow = "1"b;
109 end;
110 else do;
111 call com_err_ (error_table_$badopt, who, arg);
112 goto clean;
113 end;
114 else do;
115 call expand_path_ (argptr, arglen, addr(dirname), addr(ename), code);
116 if code ^= 0 then do;
117 argerr: call com_err_ (code, who, arg);
118 goto clean;
119 end;
120
121 call hcs_$initiate_count ((dirname), (ename), "", seglen(argno), 0, segptr(argno), code);
122 if segptr (argno) = null then do;
123 if first = 0 then do;
124 first = argno;
125 call hcs_$make_seg ((dirname), (ename), "", 1010b, new_segptr, code);
126 segptr(argno) = new_segptr;
127 seglen(argno) = 0;
128 made = "1"b;
129 if code ^= 0 then goto patherr;
130 end;
131 else do;
132 patherr: call com_err_ (code, who, "^a>^a", dirname, ename);
133 goto clean;
134 end;
135 end;
136 new_seglen = new_seglen + seglen(argno);
137 if first = 0 then do;
138 first = argno;
139 new_segptr = segptr (argno);
140 end;
141 last_seg = argno;
142 copies(argno) = -1;
143 if argno ^= first & segptr(argno) = new_segptr then do;
144 if made then do;
145 code = error_table_$noentry;
146 goto patherr;
147 end;
148 if copies(first) = 0 then do;
149
150
151 if temptr = null then do;
152 call hcs_$make_seg ("", "", "", 1010b, temptr, code);
153 if code ^= 0 then do;
154 call com_err_ (code, who, "Couldn't create temporary segment in [pd].");
155 goto clean;
156 end;
157 call hcs_$fs_move_seg (new_segptr, temptr, 0, code);
158 end;
159 segptr(argno) = temptr;
160 end;
161 if new_seglen > max_bits then overflow = "1"b;;
162 end;
163 end;
164 end;
165
166 revert size;
167 revert conversion;
168 if first = 0 then goto noarg;
169 if overflow then do;
170 oflo: call com_err_ (0, who, "Total length of segments is ^d words (^d bits), which is greater than the maximum of ^d words.", divide (new_seglen+35, 36, 17, 0), new_seglen, sys_info$max_seg_size);
171 goto clean;
172 end;
173
174 new_seglen = 1;
175
176 do argno = first to nargs;
177 if segptr(argno) ^= null then do;
178 if copies(argno) = -1 then copies(argno) = 1;
179 if argno = first then do;
180 if copies(argno) = 0 then do;
181 if temptr = null then do;
182 call hcs_$truncate_seg (new_segptr, 0, code);
183 if code ^= 0 then do;
184 call com_err_ (code, who, "While truncating output segment.");
185 goto clean;
186 end;
187 end;
188 end;
189 else do;
190 copies(argno) = copies(argno) - 1;
191 new_seglen = seglen(first) + new_seglen;
192 end;
193 end;
194 do n = 1 to copies(argno);
195 if np & new_seglen ^= 1 & substr (seg, 1, min(9, seglen(argno))) ^= unspec(newpage)
196 & substr (new_seg, max (1, new_seglen-9), 9) ^= unspec(newpage) then do;
197 substr (new_seg, new_seglen, 9) = unspec(newpage);
198 new_seglen = new_seglen + 9;
199 end;
200 if new_seglen + seglen(argno) >= max_bits then do;
201 call com_err_ (0, who, "Addition of newpage characters yields segment larger than ^d words.", sys_info$max_seg_size);
202 goto clean;
203 end;
204 substr (new_seg, new_seglen, seglen(argno)) = seg;
205 new_seglen = new_seglen + seglen(argno);
206 end;
207 end;
208 end;
209
210 new_seglen = new_seglen - 1;
211 if new_seglen > max_bits then goto oflo;
212 call hcs_$set_bc_seg (new_segptr, new_seglen, code);
213 if code ^= 0 then do;
214 call com_err_ (code, who, "While setting the bitcount of the output segment.");
215 goto clean;
216 end;
217
218 made = "0"b;
219
220
221
222
223 if dl
224 then do argno = first+1 to nargs;
225 if segptr(argno) ^= null & segptr(argno) ^= new_segptr then do;
226 call hcs_$delentry_seg (segptr(argno), code);
227 if code ^= 0 & code ^= error_table_$invalidsegno then do;
228 call cu_$arg_ptr (argno, argptr, arglen, 0);
229 call com_err_ (code, who, "Segment ^a not deleted.", arg);
230 end;
231 end;
232 segptr(argno) = null;
233 end;
234
235 clean:
236 call cleanup_proc;
237 return;
238
239
240 cleanup_proc: proc;
241 if made then call hcs_$delentry_seg (new_segptr, code);
242 call hcs_$delentry_seg (temptr, code);
243 do argno = 1 to nargs;
244 if segptr(argno) ^= null then call hcs_$terminate_noname(segptr(argno), code);
245 end;
246 if allocation(segptr) > 0 then free segptr;
247 if allocation(seglen) > 0 then free seglen;
248 if allocation(copies) > 0 then free copies;
249 end;
250
251 end;