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);                 /* "-delete" */
  7 dcl dl bit(1) aligned init("0"b);                 /* "-newpage" */
  8 dcl first fixed bin init(0);                      /* argno of first segment name in command line */
  9 dcl segptr(nargs) controlled ptr init((nargs)null); /* pointer to each segment, indexed by argno */
 10 dcl seglen(nargs) fixed bin(24) controlled;       /* length of each segment */
 11 dcl copies (nargs) fixed bin(35) controlled;      /* no. of copies of each segment (-1 if "-copy" not specified) */
 12 dcl new_seglen fixed bin(24) init(0);
 13 dcl made bit(1) aligned init("0"b);               /* "1"b if output segment had to be created */
 14 dcl max_bits fixed bin(24);
 15 dcl n fixed bin(35);
 16 dcl overflow bit(1) aligned init("0"b);           /* set if segment length overflows */
 17 dcl last_seg fixed bin init (0);                  /* argno of last segment name in command line so far */
 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;             /* this allows for maximum no. of segment names */
 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;                       /* takes care of illegal numeric arguments */
 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;  /* next argument should be numeric number of copies */
 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                               /* determine for which segment copy applies to */
 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; /* newly created segment can't have copies */
 92                                    call com_err_ (0, who, "Copies may not be specified for new output segment.");
 93                                    goto clean;
 94                                    end;
 95 
 96                               /* At this point, if the current copy argument is the first following the
 97                                  previous segment name, reduce its value by 1 because 1 copy was already
 98                                  counted when the name was prevously encountered */
 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; /* add additional copies */
105                               new_seglen = new_seglen + seglen(last_seg)*n; /* add additional length */
106                               /* Note that if -copy 0 is specified, n will be -1 thereby
107                                  subtracting the segment's length that was already counted */
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;                /* this is first segment name */
139                     new_segptr = segptr (argno);  /* it is definitely the output segment */
140                     end;
141                last_seg = argno;
142                copies(argno) = -1;
143                if argno ^= first & segptr(argno) = new_segptr then do; /* output segment is an input segment */
144                     if made then do;              /* not allowed, if it didn't previously exist */
145                          code = error_table_$noentry;
146                          goto patherr;
147                          end;
148                     if copies(first) = 0 then do; /* was output segment to be truncated? */
149                          /* If output segment is to be truncated, and it's also an input segment specified
150                             later in the command line, it must be saved in temporary segment. */
151                          if temptr = null then do; /* original output segment must be saved */
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;  /* point to copy of original segment */
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; /* if no copies of original output segment wanted */
181                     if temptr = null then do;
182                          call hcs_$truncate_seg (new_segptr, 0, code); /* and copy not made */
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;                           /* at least one copy of output segment wanted */
190                     copies(argno) = copies(argno) - 1;      /* we already have one copy, so just set bitcount */
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;                            /* reset so that cleanup_proc doesn't delete output segment */
219 
220 /* Now try to delete segments, if -delete was specified. Don't try to delete a segment more than once,
221    and don't delete the output segment. */
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; /* "invalidsegno" means segment already deleted */
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); /* aborted operation deletes output segment */
242   call hcs_$delentry_seg (temptr, code);          /* always delete temporary segment */
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;