1 /* ******************************************************
  2    *                                                    *
  3    *                                                    *
  4    * Copyright (c) 1972 by Massachusetts Institute of   *
  5    * Technology and Honeywell Information Systems, Inc. *
  6    *                                                    *
  7    *                                                    *
  8    ****************************************************** */
  9 
 10 cv_alm: proc;
 11 
 12 
 13 dcl (i, ci, typ, code, bit_count, char_count, start, arg_start, stop, next) fixed bin,
 14     (lab_start, lab_end, op_start, op_end, var_start, var_end, com_start, com_end) fixed bin,
 15      have_first_name bit (1) init ("0"b),
 16      havent_got_second_name bit (1) init ("1"b),
 17      dirname (2) char (168) aligned,
 18      name (2) char (32) aligned,
 19     (ilp, olp) ptr,
 20      c char (1),
 21      mode fixed bin (2) init (2),                           /* 1 = long, 2 = brief */
 22      used (6) fixed bin init (0, 0, 0, 0, 0, 0),
 23      get_pdir_ ext entry returns (char (168) aligned),
 24      opcode char (3) aligned,
 25      hcs_$set_bc ext entry options (variable),
 26      hcs_$fs_move_seg ext entry options (variable),
 27     (tname, oname) char (168) aligned,
 28     (addr, substr, divide, null) builtin,
 29      expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin),
 30      com_err_ ext entry options (variable),
 31      ioa_ ext entry options (variable),
 32      len fixed bin,
 33      hcs_$initiate_count ext entry options (variable),
 34      hcs_$delentry_seg ext entry options (variable),
 35      il char (131072) aligned based (ilp),
 36     (line_no, line_no1, output_start) fixed bin,
 37      li fixed bin,
 38     (c16, cc16) char (16) aligned,
 39      cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
 40      nargs fixed bin,
 41      argno fixed bin,
 42     (argp, outp) ptr,
 43      arglen fixed bin,
 44      arg_in char (arglen) based (argp),
 45      cu_$arg_count entry (fixed bin),
 46      QUOTE char (1) aligned static init (""""),
 47      message (12) char (64) aligned static init (
 48      "WARNING 1, LINE ^4d:  ILLEGAL INSTRUCTION ON FOLLOW-ON.",
 49      "WARNING 2, LINE ^4d:  SAME INSTRUCTION, BUT SOMEWHAT DIFFERENT.",
 50      "WARNING 3, LINE ^4d:  INSTRUCTION RENAMED AND CHANGED.",
 51      "WARNING 4, LINE ^4d:  INSTRUCTION RENAMED (ONLY).",
 52      "WARNING 5, LINE ^4d:  EIS INSTRUCTION.",
 53      "WARNING 6, LINE ^4d:  NEW INSTRUCTION AND ORDER CODE.",
 54      "WARNING 1, LINE ^4d.",
 55      "WARNING 2, LINE ^4d.",
 56      "WARNING 3, LINE ^4d.",
 57      "WARNING 4, LINE ^4d.",
 58      "WARNING 5, LINE ^4d.",
 59      "WARNING 6, LINE ^4d."),
 60      ol char (131072) aligned based (olp),
 61     (frst, lst) fixed bin,
 62      hcs_$make_seg ext entry options (variable),
 63      TAB3 char (3) aligned static init ("                             "),
 64      TAB4 char (4) aligned static init ("                                       "),
 65      NL char (1) static init ("
 66 "),
 67      TAB char (1) static init ("        ");
 68 
 69 dcl 1 cv_opcodes$ ext aligned,
 70     2 first (8) fixed bin,
 71     2 last (8) fixed bin,
 72     2 data (0: 1),
 73       3 (old, new) char (8) aligned,
 74       3 (type, length) fixed bin;
 75 
 76 /* ^L */
 77 
 78 START:
 79           argno = 0;
 80           call cu_$arg_count (nargs);                       /* get the number of arguments passed */
 81           if nargs < 1 | nargs > 3 then do;
 82                call ioa_ ("cv_alm old -new- -mode-, (new may be ==)");
 83                return;
 84           end;
 85 NEXT_ARG:
 86           argno = argno + 1;                                /* increment argument number index */
 87           call cu_$arg_ptr (argno, argp, arglen, code);     /* get the next argument */
 88           if code ^= 0 | arglen = 0 then goto END_ARGS;     /* if no more args, continue ... */
 89 
 90           if arg_in = "-long" | arg_in = "-lg" then do;     /* if long mode was specified */
 91                mode = 1;                                    /* set falg */
 92                goto NEXT_ARG;
 93           end;
 94           else if arg_in = "-brief" | arg_in = "-bf" then do; /* brief mode was specified */
 95                mode = 2;                                    /* set flag for brief mode */
 96                goto NEXT_ARG;
 97           end;
 98           else do;                                          /* must be a path name */
 99                if have_first_name then do;                  /* this must be the second name */
100                     havent_got_second_name = "0"b;          /* now we got another name, so ... */
101                     call get_name (2);                      /* parse name and do useful stuff */
102                     call hcs_$make_seg (dirname (2), name (2), name (2), 1011b, outp, code); /* get a pointer to the output segment */
103                     if outp = null then do;                 /* couldn't for some reason */
104                          call com_err_ (code, "cv_alm", "^a>^a", dirname (2), name (2));
105                          return;
106                     end;
107                end;
108                else do;                                     /* must be the first pathname (source) */
109                     have_first_name = "1"b;
110                     call get_name (1);                      /* get the info we want */
111                     call hcs_$initiate_count (dirname (1), name (1), name (1), bit_count, 0, ilp, code);
112                     if ilp = null then do;
113                          call com_err_ (code, "cv_alm", "^a>^a", dirname (1), name (1));
114                          return;
115                     end;
116                     char_count = divide (bit_count, 9, 17, 0); /* convert bit count to character count */
117                end;
118           end;
119           goto NEXT_ARG;
120 END_ARGS:
121           if havent_got_second_name then do;                /* if we weren't given a second name ... */
122                dirname (2) = dirname (1);                   /* copy info from first name that was given */
123                name (2) = name (1);
124                outp = ilp;
125           end;
126 
127 /* Now make a temporary segment to work with */
128 
129           call hcs_$make_seg ("", "cv_alm_temp_", "", 1011b, olp, code);
130           if olp = null then do;                            /* can't get the temporary, give up */
131                call com_err_ (code, "cv_alm", "Temporary in process directory.");
132                return;
133           end;
134 
135 /* ^L */
136 
137           stop = 0;                                         /* inititate variables for the scan */
138           line_no, line_no1 = 0;                            /* initialize line number counter */
139           next = 1;                                         /* initialize ouput character index */
140 
141           if substr (il, 1, 2) = "%;" then do;              /* special case if file start with this */
142                substr (ol, 1, 2) = "%;";
143                substr (ol, 3, 1) = NL;
144                next = 4;
145                stop = 3;
146           end;
147 
148 GETLINE:
149 
150           start = stop+1;                                   /* get start of next line */
151           do i = start to char_count while (substr (il, i, 1) ^= NL & substr (il, i, 1) ^= ";");
152           end;
153           stop = i;                                         /* update new value of last character in line */
154           if stop > char_count then goto clean_up;          /* all done, copy new segment into old */
155           if substr (il, stop, 1) = NL then do;
156                line_no = line_no + 1;
157                line_no1 = line_no1 + 1;
158           end;
159 
160           if stop = start then goto copy_terminator;        /* blank line, just copy new-line character */
161 
162           ci = start;                                       /* initialize scanning index */
163           call sob;                                         /* skip over blanks */
164 
165 
166           lab_start, op_start, var_start, com_start = -1;   /* initialize starting indexes as flags */
167           arg_start = ci;                                   /* remember where the scan started */
168 
169 /* The first search is special cased because of label possibilities */
170 
171 check_char:
172           c = substr (il, ci, 1);                           /* pick up the next character of the line */
173 
174           if c = ":" then do;                               /* we've come across a label */
175                lab_start = arg_start;                       /* set index to start of the label */
176                lab_end = ci;                                /* set index to end of label */
177                if ci = arg_start then goto syn;             /* check for initial : */
178                ci = ci + 1;                                 /* skip over the : */
179                goto scan_opcode;                            /* look for an opcode */
180           end;
181 
182           if c = " " | c = TAB then do;                     /* if we've come to white space we just scanned an opcode */
183                op_start = arg_start;                        /* set the index to the start of the opcode */
184                op_end = ci-1;                               /* and the index to the end of the opcode */
185                goto scan_var;                               /* scan the variables field */
186           end;
187 
188           if c = NL | c = ";" then do;                      /* we've come to the end of the line */
189                if ci ^= arg_start then do;                  /* if opcode was given, remember it */
190                     op_start = arg_start;
191                     op_end = ci-1;
192                end;
193                goto output_current_line;                    /* go clean up the current line */
194           end;
195 
196           if c = QUOTE then do;                             /* we came across a comment */
197                if ci ^= arg_start then do;
198 syn:                call com_err_ (0, "cv_alm", "Unexpected syntax in line ^d", line_no);
199                     call com_err_ (0, "cv_alm", "line is: ^R^/^a^B", substr (il, start, stop-start+1));
200                     len = stop-start+1;                     /* get size of input string */
201                     substr (ol, next, len) = substr (il, start, len); /* and copy it straight */
202                     next = next + len;
203                     goto GETLINE;
204                end;
205 comment:       com_start = ci;                              /* save start of the comment */
206                com_end = stop - 1;
207                goto output_current_line;
208           end;
209 
210           ci = ci + 1;                                      /* scan to the next character */
211           goto check_char;
212 
213 /* ^L */
214 
215 scan_opcode:
216           call sob;                                         /* skip over blanks and tabs */
217           if substr (il, ci, 1) = QUOTE then goto comment;  /* check for a comment */
218 
219           op_start = ci;                                    /* save start of the opcode */
220           call soc;                                         /* skip over non-white characters */
221           op_end = ci-1;                                    /* save end of the opcode */
222           if ci > stop then op_end = op_end - 1;            /* if last thing on line was opcode, don't copy term */
223 
224 scan_var:
225           call sob;                                         /* skip over blanks again */
226           c = substr (il, ci, 1);                           /* get current character */
227           if c = QUOTE | c = "'" then do;                   /* check for acc pseudo-op */
228                opcode = substr (il, op_start, 3);           /* get the opcode */
229                if opcode = "acc" | opcode = "aci" then do;  /* special case these opcodes */
230                     do i = ci+1 to stop while (substr (il, i, 1) ^= c); /* look for quote that matches */
231                     end;
232                     if i >= stop then goto com;             /* really was a comment */
233                     var_start = ci;                         /* treat char string as variable field */
234                     var_end = i;
235                     ci = i+1;
236                end;
237                else goto comment;                           /* not special opcodes, treat as comment */
238           end;
239           else do;                                          /* a normal variable was found */
240                var_start = ci;                              /* save start of variable field */
241                call soc;                                    /* skip over non-white characters */
242                var_end = ci-1;                              /* save last char of variable field */
243                if ci > stop then var_end = var_end - 1;
244           end;
245 
246 scan_comment:
247           call sob;                                         /* skip over blanks again */
248 com:      com_start = ci;
249           com_end = stop-1;                                 /* save index to end of comment */
250 
251 /* ^L */
252 
253 output_current_line:
254 
255           output_start = next;                              /* save location of start of output line */
256           typ = 0;                                          /* default type is 0 */
257 
258           if lab_start > 0 then do;                         /* a label was given */
259                len = lab_end-lab_start+1;                   /* get the length of the label (and colon) */
260                substr (ol, next, len) = substr (il, lab_start, len); /* copy the label */
261                next = next + len;                           /* update output string index */
262                if len > 9 then if lab_end+1 < stop then do; /* if label overflows into opcode field */
263                     substr (ol, next, 1) = NL;              /* then make it on a line by itself */
264                     line_no1 = line_no1 + 1;                /* correct new line count */
265                     next = next + 1;
266                end;
267           end;
268 
269           if op_start > 0 then do;                          /* see if an opcode was given */
270                len = op_end-op_start+1;                     /* get number of chars in opcode */
271                substr (ol, next, 1) = TAB;                  /* prefix the opcode with a tab */
272                if substr (il, op_start, 4) = "odd;" then if lab_start < 0 then next = next - 1;
273                                                             /* special case odd;  vfd ... */
274                cc16 = lookup (substr (il, op_start, len));
275                substr (ol, next+1, len) = cc16;
276                next = next + len + 1;                       /* update output string index */
277           end;
278 
279           if var_start > 0 then do;                         /* see if a variable field was given */
280                len = var_end-var_start+1;                   /* get number of chars in field */
281                substr (ol, next, 1) = TAB;                  /* prefix it with a tab */
282                substr (ol, next+1, len) = substr (il, var_start, len); /* copy the characters of the variable field */
283                if substr (il, var_start+1, 2) = "b|" then if mode = 1 then /* check for odd base reference */
284                call ioa_ ("WARNING 0, LINE ^4d:  REFERENCE TO ODD BASE.", line_no1);
285                next = next + len + 1;                       /* update output string index */
286           end;
287 
288           if com_start > 0 then do;                         /* see if a comment was given */
289                if var_start+op_start < 0 then do;           /* no opcode or variable was given */
290                     if lab_start < 0 then goto copy_com;    /* if no label either left-justify the comment */
291                     substr (ol, next, 4) = TAB4;            /* copy in 4 tabs */
292                     next = next + 4;
293                end;
294                else if var_start < 0 then do;               /* no variable field was given */
295                     substr (ol, next, 3) = TAB3;            /* needs 3 tabs in this case */
296                     next = next + 3;
297                end;
298                else do;                                     /* variable field was given --- use its length (len) */
299                     if len <= 19 then do;
300                          substr (ol, next, 1) = TAB;
301                          next = next + 1;
302                     end;
303                     else do;                                /* nor enough room for tabs */
304                          substr (ol, next, 1) = " ";        /* so put in a singla space */
305                          next = next + 1;
306                     end;
307                     if len <= 9 then do;
308                          substr (ol, next, 1) = TAB;
309                          next = next + 1;
310                     end;
311                end;
312 copy_com:      len = com_end-com_start+1;                   /* get size of comment field */
313                substr (ol, next, len) = substr (il, com_start, len); /* copy the comment field */
314                next = next + len;
315           end;
316 
317           if typ = 0 then goto copy_terminator;             /* if normal opcode, just finish copying line */
318 
319           if mode = 1 then do;
320                call ioa_ (message (typ+used (typ)), line_no1);
321                used (typ) = 6;
322           end;
323 
324           if mode = 1 then do;                              /* long mode, print out the changes */
325                if typ = 3 | typ = 4 then call ioa_ ("^-     ^aCHANGED TO:     ^a^/",
326                     substr (il, start, stop-start+1), substr (ol, output_start, next-output_start));
327                if typ = 1 | typ = 2 then call ioa_ ("^-     ^a", substr (il, start, stop-start+1));
328           end;
329 copy_terminator:
330           substr (ol, next, 1) = substr (il, stop, 1);      /* copy the terminator */
331           next = next + 1;
332           goto GETLINE;                                     /* go process the next line */
333 
334 /* ^L */
335 
336 clean_up:
337           call hcs_$fs_move_seg (olp, outp, 1, code);       /* copy the data into the segment */
338           if code ^= 0 then do;                             /* some trouble */
339                call com_err_ (code, "cv_alm", "Copying segment from process directory.");
340                call com_err_ (0, "cv_alm", "Segment is in process directory with name cv_alm_temp_.");
341                call hcs_$set_bc ((get_pdir_ ()), "cv_alm_temp_", (next-1)*9, code);
342                if code ^= 0 then call com_err_ (code, "cv_alm", "Setting bit count on cv_alm_temp_.");
343                return;
344           end;
345           call hcs_$set_bc (dirname (2), name (2), (next-1)*9, code);
346           if code ^= 0 then call com_err_ (code, "cv_alm", "Setting bit count on file.");
347           call hcs_$delentry_seg (olp, code);               /* delete the temp */
348           if code ^= 0 then call com_err_ (code, "cv_alm", "cv_alm_temp_");
349 abort:    return;
350 
351 /* ^L */
352 
353 sob:      proc;                                             /* to skip over blanks and tabs */
354 
355                do ci = ci to stop;                          /* skip to end of line */
356                     c = substr (il, ci, 1);                 /* get current character */
357                     if (c ^= " ") & (c ^= TAB) then goto outb; /* exit if found non-blank */
358                end;
359 outb:          if ci >= stop then goto output_current_line;
360           end;
361 
362 soc:      proc;                                             /* to skip over non-blank characters */
363 
364                do ci = ci to stop;
365                     c = substr (il, ci, 1);                 /* get the current character */
366                     if (c = " ") | (c = TAB) | (c = QUOTE) then return;
367                end;
368           end;
369 
370 lookup:   proc (opcode) returns (char (16) aligned);
371 
372 dcl  opcode char (*);
373 
374                c16 = opcode;                                /* copy opcode for faster compares */
375                if len > 7 then return (c16);                /* pseudo-ops longer than 7 are ignored */
376                frst = divide (cv_opcodes$.first (len) - 16, 6, 17, 0);
377                lst = divide (cv_opcodes$.last (len) - 16, 6, 17, 0);
378                do li = frst to lst;
379                     if c16 = cv_opcodes$.data (li).old then do;       /* we found the opcode */
380                          typ = cv_opcodes$.data (li).type;
381                          len = cv_opcodes$.data (li).length;          /* set up len of new opcode */
382                          return (cv_opcodes$.data (li).new);
383                     end;
384                end;
385                return (c16);
386 
387           end lookup;
388 
389 
390 get_name: proc (name_no);
391 
392 dcl  name_no fixed bin;
393 
394                tname = arg_in;
395                if substr (tname, arglen-3, 4) ^= ".alm" then do;
396                     if arglen > 28 then do;                 /* not enough room left to add suffix */
397                          call com_err_ (0, "cv_alm", "Name too long to add "".alm"" suffix: ^a", name (name_no));
398                          goto abort;
399                     end;
400                     substr (tname, arglen+1, 4) = ".alm";   /* add suffix */
401                     arglen = arglen + 4;                    /* update new length up arg */
402                end;
403 
404                call expand_path_ (addr (tname), arglen, addr (dirname (name_no)), addr (name (name_no)), code);
405                if code ^= 0 then do;                        /* something screwed up for expand_path_ */
406                     call com_err_ (code, "cv_alm", arg_in);
407                     goto abort;
408                end;
409 
410                return;
411 
412           end;
413      end cv_alm;