/* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ error_table_compiler:etc:proc (file); /* initially coded by E. Gardner June 1970 */ /* last modified by M. Weaver 10 September 1970 */ dcl file char(*), (i,j,k) fixed bin(17), expand_path_ ext entry (ptr,fixed bin(17),ptr,ptr,fixed bin(17)), (com_err_,com_err_$suppress_name) ext entry options(variable), hcs_$initiate_count ext entry(char(*),char(*),char(*),fixed bin(35),fixed bin(2),ptr,fixed bin), get_wdir_ ext entry returns(char(168) aligned), hcs_$truncate_seg ext entry(ptr,fixed bin,fixed bin), ti_$getseg ext entry(char(*),char(32),ptr,fixed bin(35),fixed bin), ti_$findata ext entry(ptr,fixed bin(35),fixed bin(35),fixed bin(17)), s168 char(168), s32 char(32), ch char(1) aligned, me char(20) aligned init("error_table_compiler"), (ic,oc) fixed bin(17), (inptr,outptr) pointer, 1 fooble1 aligned based(inptr), 2 inarr(800) char(1) unaligned, 1 fooble2 aligned based(outptr), 2 outarr(800) char(1) unaligned, outstr char(800) based(outptr) aligned, line fixed bin(17); dcl acinfo fixed bin(35); dcl errsw bit(1), system_table bit(1), stmt fixed bin(17), cc fixed bin(17); dcl nl char(1) static initial(" "); dcl (addr, divide, index, length, null, min, substr) builtin; system_table = "0"b; start: outptr=addr(s168); /*find path name of file*/ call expand_path_(addr(file),length(file),outptr,addr(s32),k); if k^=0 then do; call com_err_(k,me,file); return; end; j=index(s32," "); /*find last character of ename and check*/ if j=0 then go to erra; /*that length is OK*/ if j>29 then do; erra: call com_err_(0,me,"entry name is either too long or of zero length"); return; end; substr(s32,j,3)=".et"; /*initiate input file, get character count*/ call hcs_$initiate_count(s168,s32,"",acinfo,0,inptr,k); if inptr=null() then do; call com_err_(k,me,s32); return; end; cc=divide(acinfo,9,17,0); s168 = get_wdir_(); substr(s32,j+1,3)="alm"; /*initiate output file. "." left over*/ call ti_$getseg(s168,s32,outptr,acinfo,k); /*from ".et"*/ if k^=0 then do; call com_err_(k,me,s32); return; end; /********************************************************************************/ /* INITIALIZATION */ /* */ /* Put opening statements into output file, cause the input file name */ /* to be the title. Initialize line and statement counters. Set errsw */ /* fo no errors. Set ic (input character index) */ /* to beginning of segment, oc(output char) to first char after initial */ /* heading. */ /********************************************************************************/ substr(outstr,1,6)=" name "; substr(outstr,7,j-1)=s32; substr(outstr,6+j,1)=nl; oc=j+7; substr(outstr,oc,60) = " use codes .code_start: null use past_codes .code_end: null"; oc = oc+60; stmt,ic=0; errsw="0"b; line=1; loop: stmt=stmt+1; /*main loop of program*/ /********************************************************************************/ /* GET NAME */ /* i contains character count of name(so far), and is also position in */ /* s32 where next character should go. The name is gathered in s32 */ /********************************************************************************/ loop1: i,j,k=0; /*get name*/ skp1: ic=ic+1; /*get next character*/ if ic>cc then do; /*check that we haven't overrun bitcount*/ noend: call com_err_$suppress_name(0,me,"ERROR IN STATEMENT ^d ON LINE ^d.^/^a",stmt,line,"No end statement."); go to abort; end; ch=inarr(ic); if ch=" " then go to skp1; /*skip over blanks*/ if ch = "/" then do; /* comment ? */ if inarr(ic+1) ^= "*" then go to err1; /* otherwise illegal */ ic = ic + 2; /* start scan */ skip_com: do ic = ic to cc while(inarr(ic)^="*"); if inarr(ic) = nl then line = line+1; end; if ic >= cc then go to noend; ic = ic + 1; if inarr(ic) ^= "/" then go to skip_com; go to skp1; end; if ch=nl then do; /*and new line*/ line=line+1; go to skp1; end; /********************************************************************************/ /* CHECK FOR TERMINATION */ /* "end;" in the text signals the end of the text. If this character */ /* sequence is seen, it can be detected by checking the current character */ /* to see if it is a semicolon, checking the current length for three, and */ /* checking the three characters of the name for being "end". If these */ /* conditions are met, finish up the output segment. All there is */ /* left to do is add the closing statements for alm. Then check errsw */ /* to see if any errors occured, and if they did truncate the segment. In */ /* any case, set the bit count and restore the ACL. */ /********************************************************************************/ if ch=";" then do; /*check for "end;"*/ if i=3 then if substr(s168,1,3)="end" then do; if system_table then do; substr(outstr,oc,64) = " bool .sys_sw,77777 join /text/codes,past_codes,messages end "; oc = oc + 63; end; else do; substr(outstr,oc,200) = " bool .sys_sw,0 "" use messages tempd .tp .trapproc: save eppbp 0,ic spribp .tp lda .tp ana =o77777,du epbpsb sp|0 lda sb|22,*au easplp 0,au eawplp 0,al ldx0 .tp eax1 .code_start"; substr(outstr,oc+200,160) = " .loop: stx0 lp|0,x1 eax1 1,x1 cmpx1 .code_end,du tmi .loop-*,ic return firstref <*text>|.trapproc join /text/messages join /link/codes,past_codes end "; oc = oc+359; end; if errsw then do; /*did any errors occur?*/ abort: oc=0; /*abortive return*/ call com_err_$suppress_name(0,me,"A fatal error has occurred."); call hcs_$truncate_seg(outptr,0,i); if i^=0 then call com_err_(i,me,""); end; call ti_$findata(outptr,9*oc,acinfo,i); if i^=0 then call com_err_(i,me,""); return; end; if i=6 then if substr(s168,1,6) = "system" then /* special keyword */ do; system_table = "1"b; /* set flag indicating system table */ go to loop1; /* and scan for next name */ end; err1: call com_err_$suppress_name(0,me,"ERROR IN STATEMENT ^d ON LINE ^d.^/^a ^R^a^B.", stmt,line,"Illegal character in name:",ch); errsw="1"b; go to loop1; end; if ch ^= ":" then do; /*check for end of name*/ if ch=" " then go to skp1; if ch="," then go to err1; substr(s168,i+1,1) = ch; i=i+1; go to skp1; end; if i=0 then do; /*check that it isn't the null() name*/ call com_err_$suppress_name(0,me,"ERROR IN STATEMENT ^d ON LINE ^d.^/^a", stmt,line,"Zero length name."); errsw="1"b; end; if i^<31 then do; /*is there room to append period?*/ call com_err_$suppress_name(0,me,"ERROR IN STATEMENT ^d ON LINE ^d.^/^a", stmt,line,"Name longer than 30 characters."); errsw="1"b; end; substr(outstr,oc,20)=" use codes segdef "; oc=oc+20; substr(outstr,oc,i)=s168; oc=oc+i; substr(outstr,oc,1) = nl; oc = oc + 1; substr(outstr,oc,i)=s168; oc=oc+i; substr(outstr,oc,21)=": vfd 18/.sys_sw,18/."; oc=oc+21; substr(outstr,oc,i)=s168; oc=oc+i; substr(outstr,oc,21)=" use messages aci ,"; k,oc=oc+21; /********************************************************************************/ /* GET SHORT MESSAGE */ /* gather short message directly into output segment. keep k pointing */ /* to the first character of the short message, while oc is advanced with */ /* each character. When done, if no characters were received for the */ /* short message, use the first eight characters of the name. Then force */ /* the length of the short message to eight characters, either by padding */ /* with blanks or by truncating. After getting the short message, output */ /* some more cruft. Since comma is used to terminate the short message, */ /* it cannot occur within it and is thus used to delimit the short message */ /* in the input to eplbsa. */ /********************************************************************************/ skp3: ic=ic+1; /*get short message*/ if ic>cc then go to noend; ch=inarr(ic); if ch=" " then go to skp3; if ch = "/" then do; /* skip comment */ if inarr(ic+1) ^= "*" then do; call com_err_$suppress_name(0,me,"ERROR IN STATEMENT ^d ON LINE ^d.^/^a",stmt,line, "Invalid character ""/"""); errsw = "1"b; go to skp3; end; ic = ic + 2; skip_cmt: do ic = ic to cc while(inarr(ic)^="*"); if inarr(ic) = nl then line = line+1; end; if ic >= cc then go to noend; ic = ic+1; if inarr(ic) ^= "/" then go to skip_cmt; go to skp3; end; if ch=nl then do; line=line+1; go to skp3; end; if ch = ":" then do; /* another name found for this code */ k = k-oc; /* get length of name found */ if k = 0 then do; /* if null name */ call com_err_$suppress_name(0,me,"ERROR IN STATEMENT ^d ON LINE ^d.^/^a", stmt,line,"Zero length name."); errsw = "1"b; end; else if k ^< 31 then do; /* name too long */ call com_err_$suppress_name(0,me,"ERROR IN STATEMENT ^d ON LINE ^d.^/^a", stmt, line, "Name longer than 30 characters."); errsw = "1"b; end; k = min(32,k); /* so it will fit in 32 chars */ substr(s32,1,k) = substr(outstr,oc,k); oc = oc - 20; /* back up to before the use statement */ substr(outstr,oc,8) = " segdef "; oc = oc + 8; substr(outstr,oc,k) = substr(s32,1,k); oc = oc + k; substr(outstr,oc,6) = " equ "; oc = oc + 6; substr(outstr,oc,k) = substr(s32,1,k); oc = oc + k; substr(outstr,oc,25) = ",*-1 use messages aci ,"; oc,k = oc +25; go to skp3; end; if ch^="," then do; /*ended by comma, put directly in output*/ if ch=" " then go to skp3; outarr(k)=ch; k=k+1; go to skp3; end; if oc=k then do; /*if message=null(), use name*/ substr(outstr,oc,8)=substr(s168,1,i); k=k+i; end; else substr(outstr,k,7)=" "; /*pad with blanks, force length of 8*/ if k-oc>8 then call com_err_$suppress_name(0,me,"WARNING IN STATEMENT ^d ON LINE ^d.^/^a" ,stmt,line,"Short message has been truncated to 8 characters."); ch = substr(outstr,oc,1); /* here check for old syntax of number, and ignore */ if ch >= "0" then if ch <= "9" then do; call com_err_$suppress_name(0,me,"WARNING IN STATEMENT ^d ON LINE ^d.^/^a",stmt,line, "A code value was found. It has been ignored."); k = oc; go to skp3; end; oc = oc+8; substr(outstr,oc,1) = ","; oc = oc+1; substr(outstr,oc,1) = nl; substr(outstr,oc+1,1) = "."; oc = oc + 2; substr(outstr,oc,i) = s168; oc = oc+i; substr(outstr,oc,7) = ": acc ;"; i,j,oc=oc+7; /********************************************************************************/ /* GET LONG MESSAGE */ /* Gather long message, putting it directly to the output segment. First */ /* skip over leading blanks, then get characters. When you get a blank */ /* character, only increment i; when you get a non-blank character, */ /* also update oc. Then, when you find the terminating semicolon, use oc */ /* as the pointer to the last character, thus deleting trailing blanks. */ /* Also, j is maintained as a pointer to the beginning of the character */ /* string so that the length can be calculated. Afterwards, check that */ /* length is not over 100. Note that since a semicolon is used to termin- */ /* ate the long message, it cannot possibly occur in the long message, */ /* and thus it is used to delimit the long message for alm. */ /********************************************************************************/ skp4: ic=ic+1; /*skip leading blanks*/ if ic>cc then go to noend; ch=inarr(ic); if ch=" " then go to skp4; /*skip blanks*/ if ch=nl then do; /*count newlines*/ line=line+1; go to skp4; end; skp5: if ch^=";" then do; /*have character worth looking at*/ outarr(i)=ch; i=i+1; if ch^=" " then oc=i; /*keep all characters up through this one*/ skp6: ic=ic+1; if ic>cc then go to noend; ch=inarr(ic); if ch^=nl then go to skp5; line=line+1; go to skp6; end; outarr(oc)=";"; oc=oc+1; if oc-j>101 then do; /*length > 100?*/ call com_err_$suppress_name(0,me,"ERROR IN STATEMENT ^d ON LINE ^d.^/^a", stmt,line,"Long message longer than 100 characters."); errsw="1"b; end; go to loop; end; */ ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved */