1 /* ******************************************************
  2    *                                                    *
  3    *                                                    *
  4    * Copyright (c) 1972 by Massachusetts Institute of   *
  5    * Technology and Honeywell Information Systems, Inc. *
  6    *                                                    *
  7    *                                                    *
  8    ****************************************************** */
  9 
 10 error_table_compiler:etc:proc (file);
 11 
 12           /* initially coded by E. Gardner June 1970 */
 13           /* last modified by M. Weaver 10 September 1970 */
 14 
 15 
 16 dcl       file char(*),
 17           (i,j,k) fixed bin(17),
 18           expand_path_ ext entry (ptr,fixed bin(17),ptr,ptr,fixed bin(17)),
 19           (com_err_,com_err_$suppress_name) ext entry options(variable),
 20           hcs_$initiate_count ext entry(char(*),char(*),char(*),fixed bin(35),fixed bin(2),ptr,fixed bin),
 21           get_wdir_ ext entry returns(char(168) aligned),
 22           hcs_$truncate_seg ext entry(ptr,fixed bin,fixed bin),
 23           ti_$getseg ext entry(char(*),char(32),ptr,fixed bin(35),fixed bin),
 24           ti_$findata ext entry(ptr,fixed bin(35),fixed bin(35),fixed bin(17)),
 25           s168 char(168),
 26           s32 char(32),
 27           ch char(1) aligned,
 28           me char(20) aligned init("error_table_compiler"),
 29           (ic,oc) fixed bin(17),
 30           (inptr,outptr) pointer,
 31           1 fooble1 aligned based(inptr),
 32                     2 inarr(800) char(1) unaligned,
 33           1 fooble2 aligned based(outptr),
 34                     2 outarr(800) char(1) unaligned,
 35           outstr char(800) based(outptr) aligned,
 36           line fixed bin(17);
 37 dcl       acinfo fixed bin(35);
 38 dcl       errsw bit(1),
 39           system_table bit(1),
 40           stmt fixed bin(17),
 41           cc fixed bin(17);
 42 dcl       nl char(1) static initial("
 43 ");
 44 dcl       (addr, divide, index, length, null, min, substr) builtin;
 45 
 46 
 47           system_table = "0"b;
 48 start:
 49           outptr=addr(s168);                                          /*find path name of file*/
 50           call expand_path_(addr(file),length(file),outptr,addr(s32),k);
 51           if k^=0 then do;
 52                     call com_err_(k,me,file);
 53                     return;
 54                     end;
 55           j=index(s32," ");                                           /*find last character of ename and check*/
 56           if j=0 then go to erra;                                     /*that length is OK*/
 57           if j>29 then do;
 58           erra:     call com_err_(0,me,"entry name is either too long or of zero length");
 59                     return;
 60                     end;
 61           substr(s32,j,3)=".et";                                      /*initiate input file, get character count*/
 62           call hcs_$initiate_count(s168,s32,"",acinfo,0,inptr,k);
 63           if inptr=null() then do;
 64                     call com_err_(k,me,s32);
 65                     return;
 66                     end;
 67           cc=divide(acinfo,9,17,0);
 68           s168 = get_wdir_();
 69           substr(s32,j+1,3)="alm";                                    /*initiate output file. "." left over*/
 70           call ti_$getseg(s168,s32,outptr,acinfo,k);                  /*from ".et"*/
 71           if k^=0 then do;
 72                     call com_err_(k,me,s32);
 73                     return;
 74                     end;
 75 /********************************************************************************/
 76 /*                                      INITIALIZATION                          */
 77 /*                                                                              */
 78 /*     Put opening statements into output file, cause the input file name       */
 79 /*     to be the title.  Initialize line and statement counters.  Set errsw     */
 80 /*     fo no errors.  Set ic (input character index)                            */
 81 /*     to beginning of segment, oc(output char) to first char after initial     */
 82 /*     heading.                                                                 */
 83 /********************************************************************************/
 84           substr(outstr,1,6)="          name      ";
 85           substr(outstr,7,j-1)=s32;
 86           substr(outstr,6+j,1)=nl;
 87           oc=j+7;
 88           substr(outstr,oc,60) = "      use       codes
 89 .code_start:        null
 90           use       past_codes
 91 .code_end:          null";
 92           oc = oc+60;
 93           stmt,ic=0;
 94           errsw="0"b;
 95           line=1;
 96 
 97 
 98 loop:     stmt=stmt+1;                                                /*main loop of program*/
 99 /********************************************************************************/
100 /*                                      GET NAME                                */
101 /*     i contains character count of name(so far), and is also position in      */
102 /*     s32 where next character should go. The name is gathered in s32          */
103 /********************************************************************************/
104 loop1:    i,j,k=0;                                                    /*get name*/
105 skp1:     ic=ic+1;                                                    /*get next character*/
106           if ic>cc then do;                                           /*check that we haven't overrun bitcount*/
107           noend:    call com_err_$suppress_name(0,me,"ERROR IN STATEMENT ^d ON LINE ^d.^/^a",stmt,line,"No end statement.");
108                     go to abort;
109                     end;
110           ch=inarr(ic);
111           if ch=" " then go to skp1;                                  /*skip over blanks*/
112           if ch = "/" then do;                                        /* comment ? */
113                     if inarr(ic+1) ^= "*" then go to err1;            /* otherwise illegal */
114                     ic = ic + 2;                                      /* start scan */
115 skip_com:           do ic = ic to cc while(inarr(ic)^="*");
116                               if inarr(ic) = nl then line = line+1;
117                               end;
118                     if ic >= cc then go to noend;
119                     ic = ic + 1;
120                     if inarr(ic) ^= "/" then go to skip_com;
121                     go to skp1;
122                     end;
123           if ch=nl then do;                                           /*and new line*/
124                     line=line+1;
125                     go to skp1;
126                     end;
127 /********************************************************************************/
128 /*                                      CHECK FOR TERMINATION                   */
129 /*     "end;" in the text signals the end of the text.  If this character       */
130 /*     sequence is seen, it can be detected by checking the current character   */
131 /*     to see if it is a semicolon, checking the current length for three, and  */
132 /*     checking the three characters of the name for being "end".  If these     */
133 /*     conditions are met, finish up the output segment. All there is           */
134 /*     left to do is add the closing statements for alm.  Then check errsw      */
135 /*     to see if any errors occured, and if they did truncate the segment.  In  */
136 /*     any case, set the bit count and restore the ACL.                         */
137 /********************************************************************************/
138           if ch=";" then do;                                          /*check for "end;"*/
139                     if i=3 then
140                               if substr(s168,1,3)="end" then do;
141                                         if system_table then do;
142                                              substr(outstr,oc,64) = "
143           bool      .sys_sw,77777
144           join      /text/codes,past_codes,messages
145           end
146 ";
147                                              oc = oc + 63;
148                                              end;
149                                         else do;
150                                              substr(outstr,oc,200) = "
151           bool      .sys_sw,0
152 ""^L
153           use       messages
154           tempd     .tp
155 .trapproc: save
156           eppbp     0,ic
157           spribp    .tp
158           lda       .tp
159           ana       =o77777,du
160           epbpsb    sp|0
161           lda       sb|22,*au
162           easplp    0,au
163           eawplp    0,al
164           ldx0      .tp
165           eax1      .code_start";
166                                              substr(outstr,oc+200,160) = "
167 .loop:    stx0      lp|0,x1
168           eax1      1,x1
169           cmpx1     .code_end,du
170           tmi       .loop-*,ic
171           return
172 
173           firstref  <*text>|.trapproc
174           join      /text/messages
175           join      /link/codes,past_codes
176           end
177 ";
178                                              oc = oc+359;
179                                              end;
180                                         if errsw then do;             /*did any errors occur?*/
181                                         abort:    oc=0;               /*abortive return*/
182                                                   call com_err_$suppress_name(0,me,"A fatal error has occurred.");
183                                                   call hcs_$truncate_seg(outptr,0,i);
184                                                   if i^=0 then call com_err_(i,me,"");
185                                                   end;
186                                         call ti_$findata(outptr,9*oc,acinfo,i);
187                                         if i^=0 then call com_err_(i,me,"");
188                                         return;
189                                         end;
190                     if i=6 then
191                               if substr(s168,1,6) = "system" then     /* special keyword */
192                                    do;
193                                         system_table = "1"b;          /* set flag indicating system table */
194                                         go to loop1;                  /* and scan for next name */
195                                         end;
196           err1:     call com_err_$suppress_name(0,me,"ERROR IN STATEMENT ^d ON LINE ^d.^/^a ^R^a^B.",
197                          stmt,line,"Illegal character in name:",ch);
198                     errsw="1"b;
199                     go to loop1;
200                     end;
201           if ch ^= ":" then do;                                       /*check for end of name*/
202                     if ch="   " then go to skp1;
203                     if ch="," then go to err1;
204                     substr(s168,i+1,1) = ch;
205                     i=i+1;
206                     go to skp1;
207                     end;
208           if i=0 then do;                                             /*check that it isn't the null() name*/
209                     call com_err_$suppress_name(0,me,"ERROR IN STATEMENT ^d ON LINE ^d.^/^a",
210                          stmt,line,"Zero length name.");
211                     errsw="1"b;
212                     end;
213           if i^<31 then do;                                           /*is there room to append period?*/
214                     call com_err_$suppress_name(0,me,"ERROR IN STATEMENT ^d ON LINE ^d.^/^a",
215                          stmt,line,"Name longer than 30 characters.");
216                     errsw="1"b;
217                     end;
218           substr(outstr,oc,20)="
219           use       codes
220           segdef    ";
221           oc=oc+20;
222           substr(outstr,oc,i)=s168;
223           oc=oc+i;
224           substr(outstr,oc,1) = nl;
225           oc = oc + 1;
226           substr(outstr,oc,i)=s168;
227           oc=oc+i;
228           substr(outstr,oc,21)=":       vfd       18/.sys_sw,18/.";
229           oc=oc+21;
230           substr(outstr,oc,i)=s168;
231           oc=oc+i;
232           substr(outstr,oc,21)="
233           use       messages
234           aci       ,";
235           k,oc=oc+21;
236 /********************************************************************************/
237 /*                                      GET SHORT MESSAGE                       */
238 /*     gather short message directly into output segment.  keep k pointing      */
239 /*     to the first character of the short message, while oc is advanced with   */
240 /*     each character.  When done, if no characters were received for the       */
241 /*     short message, use the first eight characters of the name.  Then force   */
242 /*     the length of the short message to eight characters, either by padding   */
243 /*     with blanks or by truncating.  After getting the short message, output   */
244 /*     some more cruft.  Since comma is used to terminate the short message,    */
245 /*     it cannot occur within it and is thus used to delimit the short message  */
246 /*     in the input to eplbsa.                                                  */
247 /********************************************************************************/
248 skp3:     ic=ic+1;                                                    /*get short message*/
249           if ic>cc then go to noend;
250           ch=inarr(ic);
251           if ch=" " then go to skp3;
252           if ch = "/" then do;                                        /* skip comment */
253                     if inarr(ic+1) ^= "*" then do;
254                               call com_err_$suppress_name(0,me,"ERROR IN STATEMENT ^d ON LINE ^d.^/^a",stmt,line,
255                                    "Invalid character ""/""");
256                               errsw = "1"b;
257                               go to skp3;
258                               end;
259                     ic = ic + 2;
260 skip_cmt:           do ic = ic to cc while(inarr(ic)^="*");
261                               if inarr(ic) = nl then line = line+1;
262                               end;
263                     if ic >= cc then go to noend;
264                     ic = ic+1;
265                     if inarr(ic) ^= "/" then go to skip_cmt;
266                     go to skp3;
267                     end;
268           if ch=nl then do;
269                     line=line+1;
270                     go to skp3;
271                     end;
272           if ch = ":" then do;                              /* another name found for this code */
273                     k = k-oc;                               /* get length of name found */
274                     if k = 0 then do;                       /* if null name */
275                               call com_err_$suppress_name(0,me,"ERROR IN STATEMENT ^d ON LINE ^d.^/^a",
276                                         stmt,line,"Zero length name.");
277                               errsw = "1"b;
278                               end;
279                     else if k ^< 31 then do;                /* name too long */
280                               call com_err_$suppress_name(0,me,"ERROR IN STATEMENT ^d ON LINE ^d.^/^a",
281                                         stmt, line, "Name longer than 30 characters.");
282                               errsw = "1"b;
283                               end;
284 
285                     k = min(32,k);                /* so it will fit in 32 chars */
286                     substr(s32,1,k) = substr(outstr,oc,k);
287                     oc = oc - 20;                           /* back up to before the use statement */
288                     substr(outstr,oc,8) = "       segdef    ";
289                     oc = oc + 8;
290                     substr(outstr,oc,k) = substr(s32,1,k);
291                     oc = oc + k;
292                     substr(outstr,oc,6) = "
293           equ       ";
294                     oc = oc + 6;
295                     substr(outstr,oc,k) = substr(s32,1,k);
296                     oc = oc + k;
297                     substr(outstr,oc,25) = ",*-1
298           use       messages
299           aci       ,";
300                     oc,k = oc +25;
301                     go to skp3;
302                     end;
303           if ch^="," then do;                                         /*ended by comma, put directly in output*/
304                     if ch="   " then go to skp3;
305                     outarr(k)=ch;
306                     k=k+1;
307                     go to skp3;
308                     end;
309           if oc=k then do;                                            /*if message=null(), use name*/
310                     substr(outstr,oc,8)=substr(s168,1,i);
311                     k=k+i;
312                     end;
313                else substr(outstr,k,7)="       ";                     /*pad with blanks, force length of 8*/
314           if k-oc>8 then call com_err_$suppress_name(0,me,"WARNING IN STATEMENT ^d ON LINE ^d.^/^a"
315                ,stmt,line,"Short message has been truncated to 8 characters.");
316           ch = substr(outstr,oc,1);               /* here check for old syntax of number, and ignore */
317           if ch >= "0" then if ch <= "9" then do;
318                     call com_err_$suppress_name(0,me,"WARNING IN STATEMENT ^d ON LINE ^d.^/^a",stmt,line,
319                          "A code value was found. It has been ignored.");
320                     k = oc;
321                     go to skp3;
322                     end;
323           oc = oc+8;
324           substr(outstr,oc,1) = ",";
325           oc = oc+1;
326           substr(outstr,oc,1) = nl;
327           substr(outstr,oc+1,1) = ".";
328           oc = oc + 2;
329           substr(outstr,oc,i) = s168;
330           oc = oc+i;
331           substr(outstr,oc,7) = ":      acc       ;";
332           i,j,oc=oc+7;
333 /********************************************************************************/
334 /*                                      GET LONG MESSAGE                        */
335 /*     Gather long message, putting it directly to the output segment.  First   */
336 /*     skip over leading blanks, then get characters.  When you get a blank     */
337 /*     character, only increment i;  when you get a non-blank character,        */
338 /*     also update oc.  Then, when you find the terminating semicolon, use oc   */
339 /*     as the pointer to the last character, thus deleting trailing blanks.     */
340 /*     Also, j is maintained as a pointer to the beginning of the character     */
341 /*     string so that the length can be calculated.  Afterwards, check that     */
342 /*     length is not over 100.  Note that since a semicolon is used to termin-  */
343 /*     ate the long message, it cannot possibly occur in the long message,      */
344 /*     and thus it is used to delimit the long message for alm.                 */
345 /********************************************************************************/
346 skp4:     ic=ic+1;                                                    /*skip leading blanks*/
347           if ic>cc then go to noend;
348           ch=inarr(ic);
349           if ch=" " then go to skp4;                                  /*skip blanks*/
350           if ch=nl then do;                                           /*count newlines*/
351                     line=line+1;
352                     go to skp4;
353                     end;
354 skp5:     if ch^=";" then do;                                         /*have character worth looking at*/
355                     outarr(i)=ch;
356                     i=i+1;
357                     if ch^=" " then oc=i;                             /*keep all characters up through this one*/
358           skp6:     ic=ic+1;
359                     if ic>cc then go to noend;
360                     ch=inarr(ic);
361                     if ch^=nl then go to skp5;
362                     line=line+1;
363                     go to skp6;
364                     end;
365           outarr(oc)=";";
366           oc=oc+1;
367           if oc-j>101 then do;                                        /*length > 100?*/
368                     call com_err_$suppress_name(0,me,"ERROR IN STATEMENT ^d ON LINE ^d.^/^a",
369                          stmt,line,"Long message longer than 100 characters.");
370                     errsw="1"b;
371                     end;
372           go to loop;
373           end;