build_message_segment.pl1 11/15/82 1837.9rew 11/15/82 1508.8 65133 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ build_message_segment: proc(xsource_ptr,xobj_ptr, bitcnt); /* Modified: 17 Dec 1979 to make all return statements in another_string return value */ /* This program is in sad shape and should be rewritten. */ dcl (xsource_ptr, xobj_ptr, source_ptr, obj_ptr) ptr, bitcnt fixed bin(24); dcl 1 object_segment based(obj_ptr), 2 index_block(0:500), 3 message_pointer fixed bin(17), /*Pointer to start of message.*/ 3 severity fixed bin(17), /*Severity level for this message*/ 3 len fixed bin(17), /*Number of characters for this message.*/ 2 message_block char(248000) aligned; /*Text for all messages.*/ dcl (old_seq_number init(0), new_seq_number,i, severity_code) fixed bin(17); dcl xstring char(64) varying aligned, garbage bit(1) aligned; dcl ll fixed bin(15); dcl ioa_ entry options(variable); dcl ( s_first,s_last,o_current ) fixed bin(17) init (1); dcl source_string char(256000) aligned based(source_ptr); dcl old_first fixed bin(17); /*Beginning of string; to facilitate backing up. */ dcl cur_char char(1) aligned; dcl white_space char(3) static init(" "); /* new_lline, space, tab */ dcl NLNL init(" ") char(2) int static; dcl (index,length,search,substr) builtin; obj_ptr = xobj_ptr; source_ptr=xsource_ptr; do while(another_message()); /*Process sequence number.*/ garbage=another_string(xstring); /*Get first string*/ new_seq_number=0; do ll=1 to length(xstring); new_seq_number=new_seq_number*10+index("123456789",substr(xstring,ll,1)); end; if new_seq_number > 500 then do; call ioa_("Sequence number > 500--fatal error"); return; end; if new_seq_number <= old_seq_number then do; call ioa_("Message number ^d is out of sequence--fatal error",new_seq_number); return; end; else do i=old_seq_number+1 to new_seq_number-1; /*Set index block entries for missing messages.*/ index_block(i).message_pointer = -1; index_block(i).len = 0; index_block(i).severity = 0; end; old_seq_number = new_seq_number; /*Advance old_seq_number.*/ /*Process Severity Level Code.*/ old_first = s_first; /*To permit backing up if no Severity Code.*/ if another_string(xstring) then do; /*Determine and insert severity level code*/ if substr(xstring,1,1) = "(" /*Assume "(" adequate*/ then do; do i = 2 by 1 while(substr(xstring,i,1) ^= ")" ); end; /*Extract severity code from enclosing parentheses*/ severity_code = index("1234",substr(xstring,2,1)); if severity_code > 4 then do; call ioa_("Invalid severity for message ^d--fatal error",new_seq_number); return; end; else index_block(new_seq_number).severity = severity_code; end; else do; index_block(new_seq_number).severity = 2; /*Default value of two.*/ s_first = old_first; /*Back up.*/ end; end; else do; /*No more strings after sequence number*/ call ioa_("Message number ^d is null--fatal error."); return; end; /*End of Severity Level Code Processing.*/ /* Move message text to object segment. */ dcl cum_length fixed bin(17), delim_count fixed bin(17) init(0); cum_length=0; do s_first = s_first by 1 while (substr(source_string,s_first,2)^=NLNL); /*Copy message.*/ cur_char=substr(source_string,s_first,1); if search(cur_char,white_space) = 1 then do; delim_count=delim_count+1;/*Count redundant delimeters.*/ if delim_count = 1 then do; substr(message_block,o_current,1)=" "; o_current=o_current+1; cum_length=cum_length+1; end; end; else do; delim_count=0; substr(message_block,o_current,1)=cur_char; o_current=o_current+1; cum_length=cum_length+1; end; end; index_block(new_seq_number).len = cum_length; index_block(new_seq_number).message_pointer =o_current-cum_length; s_first=s_first+2; /*Bypass two trailing nl's.*/ end; /*End of the major "do while(another_message)" block.*/ /*Close out object segment by filling in remaining index block entries with "null" values. */ do i=old_seq_number+1 to 500; index_block(i).message_pointer = -1; index_block(i).len = 0; index_block(i).severity = 0; end; /*Compute bit count for return to command.*/ bitcnt = 3*501*36+9*o_current; return; /*Processing done.*/ /*Internal procedure to locate next string in text.*/ another_string: proc(xstring) returns(bit(1)); /*another_string locates and returns the next string, if there is one, in a message, returning with its function value set to "1". If no more strings exist in the message, the value is "0". another_string is entered with s_first pointing to the first character following the previous string in the message.*/ dcl xstring char(64) varying aligned; dcl k fixed bin, skip_comments bit(1); if substr(source_string,s_first,2)^=NLNL then do; skip_comments = "1"b; do while(skip_comments); /* skip over white space */ do while(search(substr(source_string,s_first,1),white_space) ^= 0); s_first = s_first + 1; end; if substr(source_string,s_first,2) = "/*" then do; k = index(substr(source_string,s_first+2),"*/"); if k = 0 then do; call ioa_("Unbalanced comment--fatal error"); return("0"b); end; s_first = s_first + k + 4; end; else skip_comments = "0"b; end; /* scan until we hit white space */ s_last = s_first + 1; do while(search(substr(source_string,s_last,1),white_space) = 0); s_last = s_last + 1; end; xstring = substr(source_string,s_first,s_last-s_first); s_first = s_last; return("1"b); end; return("0"b); /*End of message.*/ end another_string; /*Internal procedure to determine existance of another message in the text.*/ another_message: proc returns(bit(1)); /*another_message returns with a function value of "1" if there is another message in the text; else it returns with a value of "0".*/ dcl xstring char(64) varying aligned; old_first=s_first; /*To permit backing up, if necessary.*/ garbage=another_string(xstring); if xstring="(end)" then return("0"b); else do; s_first=old_first; /*Back up.*/ return("1"b); end; end another_message; end build_message_segment;  compile_messages.pl1 12/01/87 1600.6rew 12/01/87 1558.0 42588 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-06-01,Huen), approve(87-06-01,MCR7696), audit(87-06-17,RWaters), install(87-12-01,MR12.2-1005): Fix bug 2173: If incorrect number of argument is supplied when invoking "compile_messages", a usage message is printed. END HISTORY COMMENTS */ compile_messages: proc; /* Modified: 29 Apr 1987 by SH to fix bug 2173 - A usage message should be printed when invoking this procedure with incorrect number of argument. */ /* Apr29,1987. This procedure is rewritten so that it accepts any valid pathname (such as the pathname of the source segment or archive segment). In addition, the ".message" suffix is added by default if the user does not supply it. */ /* This procedure accepts a pathname of a "source" segment as an argument. The source segment which is suffixed by ".message" containing messages to be reformatted is initialised. An object segment with the name object_name is created in the user's working directory and the reformatted messages are placed into it. */ dcl my_name char(16) int static options(constant) init("compile_messages"); dcl arg char(arg_len) based(arg_ptr); dcl arg_count fixed bin; dcl arg_len fixed bin(21); dcl arg_ptr ptr; dcl code fixed bin(35); dcl dir char(512); dcl (entry, comp) char(33); /* 33 to force trailing blank */ dcl (object_bc, source_bc) fixed bin(24); dcl object_name char(32); dcl (source_ptr, obj_ptr, aclinfo) ptr; dcl w_dir_path char(168); dcl (before, null) builtin; dcl cleanup condition; dcl build_message_segment external entry (ptr, ptr, fixed bin(24)); dcl com_err_ external entry options(variable); dcl cu_$arg_count entry(fixed bin, fixed bin(35)); dcl cu_$arg_ptr entry(fixed bin, ptr, fixed bin(21), fixed bin(35)); dcl expand_pathname_$component_add_suffix entry(char(*), char(*), char(*), char(*), char(*), fixed bin(35)); dcl get_wdir_ entry() returns(char(168) aligned); dcl initiate_file_$component entry(char(*), char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)); dcl terminate_file_ entry(ptr, fixed bin(24), bit(*), fixed bin(35)); dcl tssi_$clean_up_segment entry(ptr); dcl tssi_$finish_segment entry(ptr, fixed bin(24), bit(36) aligned, ptr, fixed bin(35)); dcl tssi_$get_segment entry(char(*), char(*), ptr, ptr, fixed bin(35)); source_ptr, obj_ptr, aclinfo = null(); call cu_$arg_count(arg_count, code); if code ^= 0 then call error(""); if arg_count ^= 1 then call error("^/Usage: compile_messages "); call cu_$arg_ptr(1, arg_ptr, arg_len, code); if code ^= 0 then call error(""); call expand_pathname_$component_add_suffix(arg, "message", dir, entry, comp, code); if code ^= 0 then call error(arg); on cleanup begin; if source_ptr ^= null() then call terminate_file_(source_ptr, 0, "001"b, 0); if aclinfo ^= null() then call tssi_$clean_up_segment(aclinfo); end; call initiate_file_$component(dir, entry, comp, "100"b, source_ptr, source_bc, code); if code ^= 0 then call error(arg); /* Get pathname for current working directory. */ w_dir_path = get_wdir_(); if comp = "" then object_name = before(entry, ".message "); else object_name = before(comp, ".message "); /* Create an object segment with name object_name and get a pointer to it. */ call tssi_$get_segment(w_dir_path, object_name, obj_ptr, aclinfo, code); if code ^= 0 then call error(object_name); /* Reformat messages. */ call build_message_segment(source_ptr, obj_ptr, object_bc); /* Wrap up by setting bit count and access control information on the new object segment and terminating the source segment. */ call tssi_$finish_segment(obj_ptr, object_bc, "1100"b, aclinfo, code); if code ^= 0 then call error(object_name); call terminate_file_(source_ptr, 0, "001"b, code); if code ^= 0 then call error(arg); error: proc(str); dcl str char(*); call com_err_(code, my_name, str); goto abort; end error; abort: return; end compile_messages;  gen_pl1_version_.pl1 11/15/82 1837.9rew 11/15/82 1509.2 30564 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ (stringsize): gen_pl1_version_: procedure(pl1_version_struc,RELEASE,code); /* Written: 12 Dec 1979 by PCK to generate pl1_version information from the installation time (the current clock time) and the RELEASE string */ /* parameters */ dcl RELEASE character(3) varying; /* RELEASE = "EXL" for the >experimental_library compiler, = for the >system_standard_library compiler */ dcl 1 pl1_version_struc, 2 pl1_version character(256) varying, 2 pl1_release character(3) varying; dcl code fixed bin(35); /* external entries */ dcl ioa_ entry options (variable); dcl decode_clock_value_$date_time entry (fixed bin(71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin(71), fixed bin, char(3), fixed bin(35)); /* builtins */ dcl (clock,addr) builtin; /* internal static */ dcl day_of_week_string(1:7) character(9) varying int static options(constant) init("Monday","Tuesday","Wednesday","Thursday", "Friday","Saturday","Sunday"); dcl month_string(1:12) character(9) varying int static options(constant) init("January","February","March","April","May","June","July","August", "September","October","November","December"); dcl my_name character(16) int static init("gen_pl1_version_") options(constant); /* conditions */ dcl (stringsize,error) condition; /* automatic */ dcl (clock_reading,microsecond) fixed bin(71); dcl (month,day_of_month,year,day_of_week,hour,minute,second) fixed bin; dcl time_zone character(3) init(""); dcl pl1_version_string character(256) varying; dcl year_pic picture "9999"; dcl day_of_month_pic picture "zz"; dcl hour_pic picture "99"; dcl minute_pic picture "99"; /* on unit */ on stringsize begin; call ioa_("^a: ^a",my_name,"Stringsize raised."); signal error; end; /* program */ /* Read system clock and convert to calendar date-time */ clock_reading = clock(); call decode_clock_value_$date_time(clock_reading,month,day_of_month ,year,hour,minute,second,microsecond,day_of_week,time_zone,code); if code^=0 then return; year_pic = year; day_of_month_pic = day_of_month; /* Generate a pl1_version_string appropriate for an EXL or SSS compiler */ if RELEASE ^= "EXL" then pl1_version_string = "Multics PL/I Compiler, Release " || RELEASE || ", of " || month_string(month) || " " || ltrim(day_of_month_pic) || ", " || year_pic; else do; hour_pic = hour; minute_pic = minute; pl1_version_string = "Experimental PL/I Compiler of " || day_of_week_string(day_of_week) || ", " || month_string(month) || " " || day_of_month_pic || ", " || year_pic || " at " || hour_pic || ":" || minute_pic; end; /* Fill in pl1_version_struc with version and release info */ pl1_version = pl1_version_string; pl1_release = RELEASE; code = 0; return; end /* gen_pl1_version_ */;  generate_compatible.pl1 11/15/82 1837.9rew 11/15/82 1508.9 143460 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ generate_compatible: genc: proc; /* Automatic */ dcl linep ptr; dcl c1 char (1); dcl chars72 char (72); dcl new bit (1); dcl old bit (1); dcl error_phase fixed bin; dcl next_term fixed bin; dcl next_pr fixed bin; dcl pname char (36) var; dcl search_name char (36) var; dcl (i, j, k) fixed bin; dcl linel fixed bin; dcl tx fixed bin; dcl pr_ptrs (20) ptr; dcl term_names (20) char (36) var; dcl 1 symbols (200) aligned, 2 name char (36) var, 2 nt_ptr ptr unal, 2 unused bit (1) aligned; dcl ptrs (1) ptr; dcl N fixed bin; dcl matrix (108, 108) bit (1) unal; dcl code fixed bin (35); dcl txp ptr; dcl rootp ptr; dcl temp ptr; dcl nsymbols fixed bin; dcl stack (108) fixed bin; dcl depth fixed bin; dcl bits (72) bit (72); dcl eof bit (1) aligned; /* Based */ dcl line char (linel) based (linep); dcl total_buffer char (8000) based (txp); dcl chars (10000) char (1) unaligned based; dcl area area based; dcl 1 symbol based, 2 name char (36) var, 2 nt_ptr ptr unal; dcl 1 pr based aligned, 2 numt fixed bin, 2 dummy bit (1), 2 term (N refer (pr.numt)), 3 terminal bit (1) unal, 3 processed bit (1) unal, 3 pad bit (34) unal, 3 value fixed bin, 3 datap ptr; dcl 1 nt based aligned, 2 nump fixed bin, 2 id char (36) var, 2 prod (N refer (nt.nump)) ptr; /* Static */ dcl formats (10) char (48) aligned static options (constant) init ( "No ""NL"" found in bnf text.", "No ""NL<"" sequence found in bnf text.", "Not enough lines in bnf text.", "No root production found.", "Missing "">"" in line: ^s^a", "Missing "">"" in line: ^s^a", "Keyword lookup failed: ""^a""", "Non-terminal ""^a"" is undefined.", "Non-terminal ""^a"" has never been referenced.", "Missing ""]"" in line: ^s^a"); dcl me char (2) static options (constant) init ("gc"); dcl gc_new bit (1) static init ("1"b); dcl gc_diff bit (1) static init ("1"b); dcl NL char (1) static options (constant) init (" "); dcl NL_LESS char (2) static options (constant) init (" <"); dcl WHITE char (3) static options (constant) init (" "); dcl cleanup condition; /* Builtin */ dcl (null, addr, substr, search, verify, index) builtin; /* External */ dcl compatible_bnf$ ext; dcl incompatible_bnf$ ext; /* Entries */ dcl com_err_ entry options (variable); dcl ioa_ entry options (variable); dcl (get_temp_segments_, release_temp_segments_) entry (char (*), (*) ptr, fixed bin (35)); dcl area_ entry (fixed bin (19), ptr); /* */ /* Initialize variables, set up buffer, get ptrs */ txp = addr (compatible_bnf$); ptrs (1) = null; on cleanup call clean; call get_temp_segments_ (me, ptrs, code); temp = ptrs (1); call area_ (200000, temp); /* Initially, every attribute is incompatible with every other attribute except itself. */ do i = 1 to 108; do j = 1 to 108; matrix (i, j) = "1"b; end; matrix (i, i) = "0"b; end; /* Mark compatible attributes. */ error_phase = 0; call parse_bnf; call mark (rootp, "0"b); /* Now mark as incompatible certain combinations that fell out of the compatible BNF that we didn't want */ error_phase = 10; txp = addr (incompatible_bnf$); call parse_bnf; call mark (rootp, "1"b); do i = 1 to 108; matrix (i, i) = "0"b; end; /* Output the compatible matrix, both to user_output and to file */ if gc_new then do; call ioa_ ("^-PROGRAM GENERATED TABLE^2/"); call ioa_ (" 111111111122222222223333333333444444444455555555556666666666777"); call ioa_ (" 123456789012345678901234567890123456789012345678901234567890123456789012"); call ioa_ (" ------------------------------------------------------------------------"); end; do i = 1 to 72; do j = 1 to 72; substr (bits (i), j, 1) = matrix (i, j); end; if gc_new then call ioa_ ("""^b""b, /* ^2d ^a */", bits (i), i, lookup_keyword (i)); end; if gc_diff then do; call ioa_ ("^|^2/^-DIFFERENCES FROM REAL TABLE^2/"); call ioa_ (" 1111111111222222222233333333334444444444555555555566666666667777777"); call ioa_ (" 1234567890123456789012345678901234567890123456789012345678901234567890123456"); call ioa_ (" ----------------------------------------------------------------------------"); do i = 1 to 72; do j = 1 to 72; new = substr (bits (i), j, 1); old = substr (incompatable (i), j, 1); if old = new then c1 = "="; else if old then c1 = "I"; else c1 = "C"; substr (chars72, j, 1) = c1; end; substr (chars72, i, 1) = "\"; call ioa_ ("""^a""b, /* ^2d ^a */", chars72, i, lookup_keyword (i)); end; call ioa_ (" ----------------------------------------------------------------------------"); call ioa_ (" 1111111111222222222233333333334444444444555555555566666666667777777"); call ioa_ (" 1234567890123456789012345678901234567890123456789012345678901234567890123456"); end; call clean; return; GLOBAL_ERROR: call clean; return; ERROR: proc (x); dcl x fixed bin; call com_err_ (0, "generate_compatible", "Error ^d while scanning ^[^;in^]compatible_bnf.", x, error_phase=0); call com_err_ (0, "generate_compatible", formats (x), search_name, line); goto GLOBAL_ERROR; end; lookup_keyword: proc (x) returns (char (16) aligned); dcl x fixed bin; dcl first_i fixed bin; dcl i fixed bin; first_i = 0; do i = 1 to hbound (keyword (*), 1); if x = bit_index (i) then if first_i = 0 then first_i = i; else return (keyword (i)); /* short names usually preceed long names... */ end; if first_i ^= 0 then return (keyword (first_i)); do i = 1 to hbound (system_keyword (*), 1); if x = system_bit_index (i) then return (system_keyword (i)); end; return ("***"); end lookup_keyword; clean: proc; call release_temp_segments_ (me, ptrs, code); end; /* */ /* Subroutines */ parse_bnf: proc; /* This routine parses the BNF pointed to by txp. It allocates nodes for all terminals and non-terminals and threads them together in the indicated fashion (not necessarily tree form). The syntax of the BNF is as follows: first char on line is "<" implies new non-terminal, i.e. a production that defines a new non-terminal. first char on line is blank implies another production for the current non-terminal. first chars on line are "eof" implies no more productions. any other first char(s) implies line is ignored. The total BNF cannot be more than 8K characters. A production must be entirely on a single line. Nonterminals are distinguished by being enclosed in "<" and ">". Symbols must be <= 36 characters. The root of the tree is called "". */ rootp = null; eof = "0"b; nsymbols = 0; depth = 0; linep = txp; next_term = 1; next_pr = 1; pname = ""; /* start scan with first line with a "<" at beginning */ if substr (total_buffer, 1, 1) = "<" then do; i = index (total_buffer, NL); if i <= 0 then call ERROR (1); linel = i; end; else do; i = index (total_buffer, NL_LESS); if i <= 0 then call ERROR (2); linep = addr (linep -> chars (i+1)); linel = index (linep -> total_buffer, NL); if linel <= 0 then call ERROR (3); end; do while (linep ^= null); call parse_production; call finish_production; call get_line; end; eof = "1"b; linep = txp; /* so test in parse_production will not get null ptr ref */ call parse_production; /* to get last NT structure allocated */ /* Now scan all nodes converting pointers to symbols into pointers to non-terminal nodes */ rootp = lookup ("") -> symbol.nt_ptr; if rootp = null then call ERROR (4); call scan (rootp); do i = 1 to nsymbols while (symbols (i).unused = "0"b); end; if i <= nsymbols then do; search_name = symbols (i).name; call ERROR (9); end; return; /* */ get_line: proc; dcl i fixed bin; dummy_line: linep = addr (linep -> chars (linel+1)); i = index (linep -> total_buffer, NL); if i <= 0 then do; linep = null; return; end; linel = i; if substr (line, 1, 3) = "eof" then do; linep = null; return; end; if substr (line, 1, 1) = "<" | substr (line, 1, 1) = " " | substr (line, 1, 1) = " " then return; goto dummy_line; end get_line; /* */ parse_production: proc; dcl ntp ptr; /* called with production in "line". If first char is not "<" then start filling in terms at position 2. Else start with position 1 and finish the previous non-terminal. */ tx = 1; if (substr (line, 1, 1) = "<" & pname ^= "") | eof then do; /* a new production, clean up previous */ N = next_pr - 1; allocate nt in (temp -> area) set (ntp); ntp -> nt.nump = N; ntp -> nt.id = pname; do i = 1 to N; ntp -> nt.prod (i) = pr_ptrs (i); end; do i = 1 to nsymbols; if pname = symbols (i).name /* name used on rhs before defined on lhs */ then do; symbols (i).nt_ptr = ntp; goto done; end; end; nsymbols = nsymbols + 1; symbols (nsymbols).name = pname; symbols (nsymbols).nt_ptr = ntp; symbols (nsymbols).unused = "1"b; done: next_pr = 1; end; if eof then return; /* all we wanted was to generate the nt structure */ if substr (line, 1, 1) = "<" then do; i = index (line, ">"); if i <= 0 then call ERROR (5); pname = substr (line, 1, i); tx = i+1; end; /* Now scan for specific terms */ next_token: j = verify (substr (line, tx), WHITE)-1; if j < 0 then return; /* all filled in */ tx = tx + j; if substr (line, tx, 1) = "<" then do; /* a non-terminal term */ k = index (substr (line, tx), ">"); if k <= 0 then call ERROR (6); end; else if substr (line, tx, 1) = "[" /* optional terminal */ then do; k = index (substr (line, tx), "]"); if k = 0 then call ERROR (10); end; else do; k = search (substr (line, tx), WHITE)-1; if k < 0 then return; end; term_names (next_term) = substr (line, tx, k); next_term = next_term + 1; tx = tx + k; goto next_token; end parse_production; finish_production: proc; /* input is array of symbols in term_names. This program builds a "pr" structure and fills in a pointer to the structure in pr_ptrs (i). */ dcl pp ptr; N = next_term - 1; allocate pr in (temp -> area) set (pp); pp -> pr.numt = N; do i = 1 to N; pp -> pr (i).datap = lookup (term_names (i)); if substr (term_names (i), 1, 1) ^= "<" then do; pp -> pr (i).terminal = "1"b; pp -> pr (i).value = map_number (term_names (i)); end; end; pr_ptrs (next_pr) = pp; next_pr = next_pr + 1; next_term = 1; return; map_number: proc (name) returns (fixed bin); dcl name char (36) var; dcl i fixed bin; search_name = name; do i = 1 to hbound (keyword (*), 1) while (keyword (i) ^= name); end; if i <= hbound (keyword (*), 1) then return (bit_index (i)); do i = 1 to hbound (system_keyword (*), 1) while (system_keyword (i) ^= name); end; if i <= hbound (system_keyword (*), 1) then return (system_bit_index (i)); call ERROR (7); end; end /* finish_production */; lookup: proc (tname) returns (ptr); dcl tname char (36) var; dcl i fixed bin; do i = 1 to nsymbols while (symbols (i).name ^= tname); end; if i > nsymbols then do; i, nsymbols = nsymbols + 1; symbols (nsymbols).name = tname; symbols (nsymbols).nt_ptr = null; end; symbols (i).unused = "0"b; return (addr (symbols (i))); end lookup; scan: proc (rp); dcl rp ptr; dcl (i, j) fixed bin; dcl (pp, q) ptr; /* This routine does a recursive walk of the tree changing any non-terminal pointers from a pointer to the symbol to a pointer to the allocated node */ do i = 1 to rp -> nt.nump; /* scan each production of this non-terminal */ pp = rp -> nt.prod (i); do j = 1 to pp -> pr.numt; /* scan each brother of this production */ if ^ pp -> pr (j).terminal then do; if ^ pp -> pr (j).processed then do; q = pp -> pr (j).datap -> symbol.nt_ptr; if q = null then do; search_name = pp -> pr (j).datap -> symbol.name; call ERROR (8); end; pp -> pr (j).datap = q; pp -> pr (j).processed = "1"b; call scan (q); end; end; end; end; end scan; end parse_bnf; /* */ mark: proc (p, mark_value); dcl p ptr; dcl mark_value bit (1) aligned; dcl (i, j) fixed bin; dcl pp ptr; dcl save_depth fixed bin; dcl save_depth1 fixed bin; dcl k fixed bin; /* This routine walks the tree and marks each compatible set of attributes. It does this by keeping a stack of all terminal symbols above the current node of the tree that are immediate brothers to non-terminal nodes that are direct ancestors of the current node. That is, terminal symbols in the same production as the ancestor non-terminal. Before recursing to a lower level (when finding a non-terminal in the tree walk) all immediate brothers (of the same production as the non-terminal) that are terminal nodes, are placed on the stack. When a terminal node is encountered, it is placed on the stack and "reflect" is called to mark all terminals on the stack as being compatible. */ do i = 1 to p -> nt.nump; pp = p -> nt.prod (i); save_depth = depth; do j = 1 to pp -> pr.numt; if pp -> pr (j).terminal then do; depth = depth + 1; stack (depth) = pp -> pr (j).value; end; end; do j = 1 to pp -> pr.numt; save_depth1 = depth; do k = 1 to pp -> pr.numt; if (^ pp -> pr (k).terminal) & (j ^= k) then call markt (pp -> pr (k).datap, mark_value); end; if pp -> pr (j).terminal then call reflect (pp -> pr (j).value, mark_value); else call mark (pp -> pr (j).datap, mark_value); depth = save_depth1; end; depth = save_depth; end; return; end mark; markt: proc (p, mark_value); dcl p ptr; dcl mark_value bit (1) aligned; dcl (dx, v) fixed bin; dcl (i, j) fixed bin; dcl pp ptr; do i = 1 to p -> nt.nump; pp = p -> nt.prod (i); do j = 1 to pp -> pr.numt; if pp -> pr (j).terminal then do; v = pp -> pr (j).value; do dx = 1 to depth while (stack (dx) ^= v); end; if dx > depth then do; depth = depth + 1; stack (depth) = v; end; end; else call markt (pp -> pr (j).datap, mark_value); end; end; return; end markt; reflect: proc (x, mark_value); dcl x fixed bin; dcl mark_value bit (1) aligned; dcl i fixed bin; do i = 1 to depth; matrix (x, stack (i)) = mark_value; matrix (stack (i), x) = mark_value; end; end reflect; /* */ gc_set_new: entry; gc_new = "1"b; return; gc_reset_new: entry; gc_new = "0"b; return; gc_set_diff: entry; gc_diff = "1"b; return; gc_reset_diff: entry; gc_diff = "0"b; return; /* */ %include pl1_attribute_table; end generate_compatible;  print_pl1_version.pl1 11/15/82 1837.9rew 11/15/82 1509.1 31149 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* A tool to print pl1_version information in bound_pl1_ */ print_pl1_version: procedure; /* Written: 12 Dec 1979 by Peter Krupp */ /* external entries */ dcl ioa_ entry options(variable); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$arg_count entry() returns (fixed bin); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl com_err_ entry options (variable); dcl com_err_$suppress_name entry options(variable); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl component_info_$name entry (ptr, char(32), ptr, fixed bin(35)); dcl hcs_$terminate_noname entry (ptr, fixed bin(35)); /* automatic */ dcl path_arg_length fixed bin; dcl path_arg_ptr ptr; dcl object_dir char(168); dcl object_entry char(32); dcl nargs fixed bin; dcl code fixed bin(35); dcl null_ref_name char(0); dcl bound_seg_ptr ptr init(null()); dcl area_ret_ptr ptr; dcl call_terminate bit(1) aligned initial("0"b); /* internal static */ dcl (my_name char(17) initial("print_pl1_version"), path_arg_no fixed bin init(1), copy_sw fixed bin(2) init(0), seg_sw fixed bin(1) init(0), component_name char(32) init("pl1_version")) int static options(constant); /* based */ dcl path_arg char(path_arg_length) based(path_arg_ptr); dcl 1 pl1_version_struc based, 2 pl1_version char(256) var, 2 pl1_release char(3) var; /* builtin */ dcl (addr,null) builtin; /* condition */ dcl cleanup condition; /* include files */ %include component_info; /* program */ on cleanup begin; if call_terminate & bound_seg_ptr ^= null() then call hcs_$terminate_noname(bound_seg_ptr,code); end; /* Determine number of arguments in command invocation */ nargs = cu_$arg_count(); if nargs ^= 1 then do; call com_err_$suppress_name(0,my_name,"Usage: print_pl1_version "); return; end; /* Get the pathname and validate it */ call cu_$arg_ptr(path_arg_no,path_arg_ptr,path_arg_length,code); call expand_pathname_(path_arg,object_dir,object_entry,code); if code ^= 0 then go to ERROR; /* Get pointer to segment and component */ call_terminate = "1"b; call hcs_$initiate(object_dir,object_entry,null_ref_name,seg_sw,copy_sw,bound_seg_ptr,code); if bound_seg_ptr = null() then go to ERROR; ci.dcl_version = 1; call component_info_$name(bound_seg_ptr,component_name,addr(ci),code); if code ^= 0 then go to ERROR; /* Print the version information */ call ioa_("^a: pl1_version=""^a""",my_name,ci.text_start -> pl1_version); call ioa_("^a: pl1_release=""^a""",my_name,ci.text_start -> pl1_release); /* Terminate the segment */ call hcs_$terminate_noname(bound_seg_ptr,code); return; /* Error exit: print a message and quit */ ERROR: call com_err_(code,my_name); if call_terminate then call hcs_$terminate_noname(bound_seg_ptr,code); return; end /* print_pl1_version */;  tmg.pl1 11/15/82 1837.9rew 11/15/82 1508.9 62631 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ table: tmg: proc(name); dcl name char(*); dcl (in_pos,in_length,ll,out_pos,line_no,unique, code,n,m,i,j) fixed bin, (input_pt,output_pt,output_hold) ptr, had_if bit(1), first_time bit(1) int static init("1"b), c char(1), (vf,vg,sourcename,outputname) char(32) varying, what char(8), op_code char(12) varying, line char(132) varying, ent char(32), (temppath,dir,wdir) char(168); dcl sw(16) label local int static; dcl (addr,divide,index,length,null,substr) builtin; dcl n_special fixed bin int static init(16), special(16) char(8) init("if","ifnot","flipto","jump","put", "fetch","get_fx2","compile","cplalt","cplsave","load","add", "switch","erase","bump","drop") int static; dcl n_tests fixed bin int static init(11), test(11) char(4) init("q2","q3","a2","a3","c2","c3","z2","z3", "atm2", "atm3", "atm4") int static; dcl n_switches fixed bin int static init(5), switches(5) char(8) init("code","op","type1","type2","type3") int static; dcl (com_err_,ioa_,ioa_$rsnp,ioa_$rsnpnnl) entry options(variable), hcs_$initiate_count entry(char(*),char(*),char(*),fixed bin, fixed bin,ptr,fixed bin), expand_path_ entry(ptr,fixed bin,ptr,ptr,fixed bin), get_wdir_ entry() returns(char(168)), tssi_$get_segment entry(char(*),char(*),ptr,ptr,fixed bin), tssi_$finish_segment entry(ptr,fixed bin(24),bit(36) aligned,ptr,fixed bin); dcl ( nl init(" "), quote init(""""), star init("*"), tab init(" "), colon init(":")) char(1) int static; dcl my_name char(3) int static init("tmg"); dcl input char(in_length) aligned based(input_pt); dcl output char(262144) aligned based(output_pt); dcl 1 output_structure aligned based(output_pt), 2 skip unaligned char(out_pos - 1), 2 output_line unaligned char(132); if first_time then do; sw(1) = if; sw(2) = ifnot; sw(3) = flipto; sw(4) = jump; sw(5) = put; sw(6) = fetch; sw(7) = get_fx2; sw(8) = compile; sw(9) = cplalt; sw(10) = cplsave; sw(11) = load; sw(12) = add; sw(13) = switch; sw(14) = erase; sw(15) = bump; sw(16) = drop; first_time = "0"b; end; temppath = name; call expand_path_(addr(temppath),length(name),addr(dir),addr(ent),code); if code ^= 0 then do; call com_err_(code,my_name,temppath); return; end; n = index(ent," "); if n = 0 then n = 33; n = n - 1; sourcename = substr(ent,1,n) || ".table"; outputname = substr(ent,1,n) || ".alm"; call hcs_$initiate_count(dir,(sourcename),"",in_length,1,input_pt,code); if input_pt = null then do; call com_err_(code,my_name,sourcename); return; end; if in_length = 0 then do; call com_err_(0,my_name,"Zero length input."); return; end; wdir = get_wdir_(); call tssi_$get_segment(wdir,(outputname),output_pt,output_hold,code); if code ^= 0 then do; out_err: call com_err_(code,my_name,outputname); return; end; in_length = divide(in_length,9,17,0); in_pos, out_pos, unique = 1; line_no = 0; had_if = "0"b; find_nl: if in_pos >= in_length then goto done; ll = index(substr(input,in_pos),nl); if ll = 0 then goto done; line_no = line_no + 1; if ll = 1 then do; in_pos = in_pos + 1; put_nl: substr(output,out_pos,1) = nl; out_pos = out_pos + 1; goto find_nl; end; line = substr(input,in_pos,ll); in_pos = in_pos + ll; c = substr(line,1,1); if c = quote then do; put_line: substr(output,out_pos,length(line)) = line; out_pos = out_pos + length(line); goto find_nl; end; if c = star then do; if ll = 3 then if substr(line,2,1) ^= star then goto star_err; else do; call ioa_$rsnp("^-zero^-0,128",output_line,n); out_pos = out_pos + n; goto put_lab; end; if ll = 2 then do; put_lab: if had_if then do; call ioa_$rsnpnnl("L^d:",output_line,n,unique); out_pos = out_pos + n; unique = unique + 1; had_if = "0"b; end; goto find_nl; end; star_err: call com_err_(0,my_name,"Illegal use of ""*"" in line # ^d:^/^a",line_no,line); goto find_nl; end; /* check for labels */ labels: n = index(line,colon); if n ^= 0 then do; substr(output,out_pos,n) = substr(line,1,n); out_pos = out_pos + n; if n = length(line)-1 then goto put_nl; line = substr(line,n+1); goto labels; end; /* having eliminated all labels, the first character on the line should now be a tab */ if substr(line,1,1) ^= tab then do; err: call com_err_(0,my_name,"Syntax error in line # ^d:^/^a",line_no,line); goto find_nl; end; /* pickup op code */ n = index(substr(line,2),tab); if n = 0 then n = length(line) - 1; op_code = substr(line,2,n-1); /* check for one of our special pseudo-ops */ do i = 1 to n_special; if op_code = special(i) then goto found; end; /* not special op code */ goto put_line; /* have pseudo-op, get variable field */ found: if n >= length(line) - 1 then vf = ""; else do; m = index(substr(line,n+2),tab); if m = 0 then m = length(line)-n-1; vf = substr(line,n+2,m-1); end; goto sw(i); /* conditional, check to make sure vf specifies legal test */ if: ifnot: do j = 1 to n_tests; if vf = test(j) then goto if_ok; end; what = "Test"; err2: call com_err_(0,my_name,"^a ""^a"" not known, ""^a"" on line # ^d:^/^a",what,vf,op_code, line_no,line); goto find_nl; if_ok: call ioa_$rsnpnnl("^-vfd^-18/L^d,9/^d,9/128+^d^a",output_line,n,unique,i,j,line); had_if = "1"b; goto inc; /* switch, extract code from variable field */ switch: n = index(vf,","); if n = 0 then do; call com_err_(0,my_name,"Variable field error, switch on line # ^d:^/^a",line_no,line); goto find_nl; end; vg = substr(vf,n+1); do j = 1 to n_switches; if vg = switches(j) then goto switch_ok; end; what = "Switch"; vf = vg; goto err2; switch_ok: call ioa_$rsnpnnl("^-vfd^-18/^a,9/13,9/128+^d^a",output_line,n,substr(vf,1,n-1), j,line); goto inc; drop: bump: erase: flipto: jump: put: fetch: get_fx2: compile: cplalt: cplsave: load: add: call ioa_$rsnpnnl("^-vfd^-18/^a,9/^d,9/128^a",output_line,n,vf,i,line); inc: out_pos = out_pos + n; goto find_nl; done: call tssi_$finish_segment(output_pt,out_pos*9 - 9,"1010"b,output_hold,code); if code ^= 0 then goto out_err; end;  update_pl1_version.pl1 11/15/82 1837.9rew 11/15/82 1509.0 55935 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* A tool to update pl1_version information in bound_pl1_ directly */ update_pl1_version: procedure; /* Written: 12 Dec 1979 by Peter Krupp */ /* external entries */ dcl ioa_ entry options(variable); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$arg_count entry() returns (fixed bin); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl com_err_ entry options (variable); dcl com_err_$suppress_name entry options(variable); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl component_info_$name entry (ptr, char(32), ptr, fixed bin(35)); dcl gen_pl1_version_ entry (1 structure, 2 char(256) var aligned, 2 char(3) var aligned, char(3) var, fixed bin(35)); dcl get_group_id_ entry () returns (char (32)); dcl hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$delete_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$list_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin(35)); /* automatic */ dcl ACCESS_NAME char(32) aligned; dcl release char(3) var; dcl release_arg_length fixed bin; dcl release_arg_ptr ptr; dcl path_arg_length fixed bin; dcl path_arg_ptr ptr; dcl object_dir char(168); dcl object_entry char(32); dcl nargs fixed bin; dcl code fixed bin(35); dcl null_ref_name char(0); dcl bound_seg_ptr ptr init(null()); dcl area_ret_ptr ptr; dcl cleanup_access bit(1) aligned initial("0"b); dcl call_restore_acl_and_terminate bit(1) aligned initial("0"b); dcl 1 old_acl_entry aligned, 2 access_name char(32), 2 modes bit(36), 2 zero_pad bit(36), 2 status_code fixed bin(35); dcl 1 new_acl_entry like old_acl_entry aligned; /* internal static */ dcl (my_name char(18) initial("update_pl1_version"), release_arg_no fixed bin init(2), path_arg_no fixed bin init(1), copy_sw fixed bin(2) init(0), seg_sw fixed bin(1) init(0), acl_count fixed bin init(1), component_name char(32) init("pl1_version")) int static options(constant); /* external static */ dcl error_table_$user_not_found fixed bin(35) ext; /* based */ dcl path_arg char(path_arg_length) based(path_arg_ptr); dcl release_arg char(release_arg_length) based(release_arg_ptr); dcl 1 pl1_version_struc based, 2 pl1_version char(256) var, 2 pl1_release char(3) var; /* builtin */ dcl (addr,null,length) builtin; /* condition */ dcl cleanup condition; /* include files */ %include component_info; /* program */ on cleanup begin; if call_restore_acl_and_terminate then call restore_acl_and_terminate; end; /* Determine number of arguments in command invocation */ nargs = cu_$arg_count(); if nargs ^= 2 then do; call com_err_$suppress_name(0,my_name,"Usage: update pl1_version { | EXL}"); return; end; /* Get the pathname and validate it */ call cu_$arg_ptr(path_arg_no,path_arg_ptr,path_arg_length,code); call expand_pathname_(path_arg,object_dir,object_entry,code); if code ^= 0 then go to ERROR; /* Get the release and validate its length */ call cu_$arg_ptr(release_arg_no,release_arg_ptr,release_arg_length,code); release = release_arg; if length(release) > 3 then do; call com_err_(0,my_name,"The length of release may not be greater than 3"); return; end; /* Get current acl of bound segment if it exists */ ACCESS_NAME = get_group_id_(); old_acl_entry.access_name = ACCESS_NAME; call hcs_$list_acl(object_dir,object_entry,null(),area_ret_ptr,addr(old_acl_entry),acl_count,code); if code ^= 0 then go to ERROR; if old_acl_entry.status_code ^= error_table_$user_not_found then cleanup_access = "1"b; /* Get pointer to segment and component */ call_restore_acl_and_terminate = "1"b; call hcs_$initiate(object_dir,object_entry,null_ref_name,seg_sw,copy_sw,bound_seg_ptr,code); if bound_seg_ptr = null() then go to ERROR; ci.dcl_version = 1; call component_info_$name(bound_seg_ptr,component_name,addr(ci),code); if code ^= 0 then go to ERROR; /* Now try to get rw access to bound segment */ new_acl_entry.access_name = ACCESS_NAME; new_acl_entry.modes = "101"b; /* rw */ new_acl_entry.zero_pad = "0"b; call hcs_$add_acl_entries(object_dir,object_entry,addr(new_acl_entry),acl_count,code); if code ^= 0 then go to ERROR; /* At this point update_pl1_version has rw access to the bound segment (usually bound_pl1_) */ /* and may alter it. */ call gen_pl1_version_(ci.text_start -> pl1_version_struc,release,code); if code ^= 0 then go to ERROR; call ioa_("^a: pl1_version=""^a""",my_name,ci.text_start -> pl1_version); call ioa_("^a: pl1_release=""^a""",my_name,ci.text_start -> pl1_release); /* Restore acl to original state */ call restore_acl_and_terminate; return; /* Error exit: print a message and quit */ ERROR: call com_err_(code,my_name); if call_restore_acl_and_terminate then call restore_acl_and_terminate; return; %page; /* Delete new acl entry and restore the old acl entry if one existed */ restore_acl_and_terminate: procedure; /* automatic */ dcl 1 delete_acl aligned, 2 access_name char(32), 2 status_code fixed bin(35); /* program */ delete_acl.access_name = ACCESS_NAME; call hcs_$delete_acl_entries(object_dir,object_entry,addr(delete_acl),acl_count,code); if cleanup_access then call hcs_$add_acl_entries(object_dir,object_entry, addr(old_acl_entry),acl_count,code); if bound_seg_ptr ^= null() then call hcs_$terminate_noname(bound_seg_ptr,code); end /* restore_acl_and_terminate */; end /* update_pl1_version */; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- 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