/* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ cv_alm: proc; dcl (i, ci, typ, code, bit_count, char_count, start, arg_start, stop, next) fixed bin, (lab_start, lab_end, op_start, op_end, var_start, var_end, com_start, com_end) fixed bin, have_first_name bit (1) init ("0"b), havent_got_second_name bit (1) init ("1"b), dirname (2) char (168) aligned, name (2) char (32) aligned, (ilp, olp) ptr, c char (1), mode fixed bin (2) init (2), /* 1 = long, 2 = brief */ used (6) fixed bin init (0, 0, 0, 0, 0, 0), get_pdir_ ext entry returns (char (168) aligned), opcode char (3) aligned, hcs_$set_bc ext entry options (variable), hcs_$fs_move_seg ext entry options (variable), (tname, oname) char (168) aligned, (addr, substr, divide, null) builtin, expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin), com_err_ ext entry options (variable), ioa_ ext entry options (variable), len fixed bin, hcs_$initiate_count ext entry options (variable), hcs_$delentry_seg ext entry options (variable), il char (131072) aligned based (ilp), (line_no, line_no1, output_start) fixed bin, li fixed bin, (c16, cc16) char (16) aligned, cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin), nargs fixed bin, argno fixed bin, (argp, outp) ptr, arglen fixed bin, arg_in char (arglen) based (argp), cu_$arg_count entry (fixed bin), QUOTE char (1) aligned static init (""""), message (12) char (64) aligned static init ( "WARNING 1, LINE ^4d: ILLEGAL INSTRUCTION ON FOLLOW-ON.", "WARNING 2, LINE ^4d: SAME INSTRUCTION, BUT SOMEWHAT DIFFERENT.", "WARNING 3, LINE ^4d: INSTRUCTION RENAMED AND CHANGED.", "WARNING 4, LINE ^4d: INSTRUCTION RENAMED (ONLY).", "WARNING 5, LINE ^4d: EIS INSTRUCTION.", "WARNING 6, LINE ^4d: NEW INSTRUCTION AND ORDER CODE.", "WARNING 1, LINE ^4d.", "WARNING 2, LINE ^4d.", "WARNING 3, LINE ^4d.", "WARNING 4, LINE ^4d.", "WARNING 5, LINE ^4d.", "WARNING 6, LINE ^4d."), ol char (131072) aligned based (olp), (frst, lst) fixed bin, hcs_$make_seg ext entry options (variable), TAB3 char (3) aligned static init (" "), TAB4 char (4) aligned static init (" "), NL char (1) static init (" "), TAB char (1) static init (" "); dcl 1 cv_opcodes$ ext aligned, 2 first (8) fixed bin, 2 last (8) fixed bin, 2 data (0: 1), 3 (old, new) char (8) aligned, 3 (type, length) fixed bin; /* */ START: argno = 0; call cu_$arg_count (nargs); /* get the number of arguments passed */ if nargs < 1 | nargs > 3 then do; call ioa_ ("cv_alm old -new- -mode-, (new may be ==)"); return; end; NEXT_ARG: argno = argno + 1; /* increment argument number index */ call cu_$arg_ptr (argno, argp, arglen, code); /* get the next argument */ if code ^= 0 | arglen = 0 then goto END_ARGS; /* if no more args, continue ... */ if arg_in = "-long" | arg_in = "-lg" then do; /* if long mode was specified */ mode = 1; /* set falg */ goto NEXT_ARG; end; else if arg_in = "-brief" | arg_in = "-bf" then do; /* brief mode was specified */ mode = 2; /* set flag for brief mode */ goto NEXT_ARG; end; else do; /* must be a path name */ if have_first_name then do; /* this must be the second name */ havent_got_second_name = "0"b; /* now we got another name, so ... */ call get_name (2); /* parse name and do useful stuff */ call hcs_$make_seg (dirname (2), name (2), name (2), 1011b, outp, code); /* get a pointer to the output segment */ if outp = null then do; /* couldn't for some reason */ call com_err_ (code, "cv_alm", "^a>^a", dirname (2), name (2)); return; end; end; else do; /* must be the first pathname (source) */ have_first_name = "1"b; call get_name (1); /* get the info we want */ call hcs_$initiate_count (dirname (1), name (1), name (1), bit_count, 0, ilp, code); if ilp = null then do; call com_err_ (code, "cv_alm", "^a>^a", dirname (1), name (1)); return; end; char_count = divide (bit_count, 9, 17, 0); /* convert bit count to character count */ end; end; goto NEXT_ARG; END_ARGS: if havent_got_second_name then do; /* if we weren't given a second name ... */ dirname (2) = dirname (1); /* copy info from first name that was given */ name (2) = name (1); outp = ilp; end; /* Now make a temporary segment to work with */ call hcs_$make_seg ("", "cv_alm_temp_", "", 1011b, olp, code); if olp = null then do; /* can't get the temporary, give up */ call com_err_ (code, "cv_alm", "Temporary in process directory."); return; end; /* */ stop = 0; /* inititate variables for the scan */ line_no, line_no1 = 0; /* initialize line number counter */ next = 1; /* initialize ouput character index */ if substr (il, 1, 2) = "%;" then do; /* special case if file start with this */ substr (ol, 1, 2) = "%;"; substr (ol, 3, 1) = NL; next = 4; stop = 3; end; GETLINE: start = stop+1; /* get start of next line */ do i = start to char_count while (substr (il, i, 1) ^= NL & substr (il, i, 1) ^= ";"); end; stop = i; /* update new value of last character in line */ if stop > char_count then goto clean_up; /* all done, copy new segment into old */ if substr (il, stop, 1) = NL then do; line_no = line_no + 1; line_no1 = line_no1 + 1; end; if stop = start then goto copy_terminator; /* blank line, just copy new-line character */ ci = start; /* initialize scanning index */ call sob; /* skip over blanks */ lab_start, op_start, var_start, com_start = -1; /* initialize starting indexes as flags */ arg_start = ci; /* remember where the scan started */ /* The first search is special cased because of label possibilities */ check_char: c = substr (il, ci, 1); /* pick up the next character of the line */ if c = ":" then do; /* we've come across a label */ lab_start = arg_start; /* set index to start of the label */ lab_end = ci; /* set index to end of label */ if ci = arg_start then goto syn; /* check for initial : */ ci = ci + 1; /* skip over the : */ goto scan_opcode; /* look for an opcode */ end; if c = " " | c = TAB then do; /* if we've come to white space we just scanned an opcode */ op_start = arg_start; /* set the index to the start of the opcode */ op_end = ci-1; /* and the index to the end of the opcode */ goto scan_var; /* scan the variables field */ end; if c = NL | c = ";" then do; /* we've come to the end of the line */ if ci ^= arg_start then do; /* if opcode was given, remember it */ op_start = arg_start; op_end = ci-1; end; goto output_current_line; /* go clean up the current line */ end; if c = QUOTE then do; /* we came across a comment */ if ci ^= arg_start then do; syn: call com_err_ (0, "cv_alm", "Unexpected syntax in line ^d", line_no); call com_err_ (0, "cv_alm", "line is: ^R^/^a^B", substr (il, start, stop-start+1)); len = stop-start+1; /* get size of input string */ substr (ol, next, len) = substr (il, start, len); /* and copy it straight */ next = next + len; goto GETLINE; end; comment: com_start = ci; /* save start of the comment */ com_end = stop - 1; goto output_current_line; end; ci = ci + 1; /* scan to the next character */ goto check_char; /* */ scan_opcode: call sob; /* skip over blanks and tabs */ if substr (il, ci, 1) = QUOTE then goto comment; /* check for a comment */ op_start = ci; /* save start of the opcode */ call soc; /* skip over non-white characters */ op_end = ci-1; /* save end of the opcode */ if ci > stop then op_end = op_end - 1; /* if last thing on line was opcode, don't copy term */ scan_var: call sob; /* skip over blanks again */ c = substr (il, ci, 1); /* get current character */ if c = QUOTE | c = "'" then do; /* check for acc pseudo-op */ opcode = substr (il, op_start, 3); /* get the opcode */ if opcode = "acc" | opcode = "aci" then do; /* special case these opcodes */ do i = ci+1 to stop while (substr (il, i, 1) ^= c); /* look for quote that matches */ end; if i >= stop then goto com; /* really was a comment */ var_start = ci; /* treat char string as variable field */ var_end = i; ci = i+1; end; else goto comment; /* not special opcodes, treat as comment */ end; else do; /* a normal variable was found */ var_start = ci; /* save start of variable field */ call soc; /* skip over non-white characters */ var_end = ci-1; /* save last char of variable field */ if ci > stop then var_end = var_end - 1; end; scan_comment: call sob; /* skip over blanks again */ com: com_start = ci; com_end = stop-1; /* save index to end of comment */ /* */ output_current_line: output_start = next; /* save location of start of output line */ typ = 0; /* default type is 0 */ if lab_start > 0 then do; /* a label was given */ len = lab_end-lab_start+1; /* get the length of the label (and colon) */ substr (ol, next, len) = substr (il, lab_start, len); /* copy the label */ next = next + len; /* update output string index */ if len > 9 then if lab_end+1 < stop then do; /* if label overflows into opcode field */ substr (ol, next, 1) = NL; /* then make it on a line by itself */ line_no1 = line_no1 + 1; /* correct new line count */ next = next + 1; end; end; if op_start > 0 then do; /* see if an opcode was given */ len = op_end-op_start+1; /* get number of chars in opcode */ substr (ol, next, 1) = TAB; /* prefix the opcode with a tab */ if substr (il, op_start, 4) = "odd;" then if lab_start < 0 then next = next - 1; /* special case odd; vfd ... */ cc16 = lookup (substr (il, op_start, len)); substr (ol, next+1, len) = cc16; next = next + len + 1; /* update output string index */ end; if var_start > 0 then do; /* see if a variable field was given */ len = var_end-var_start+1; /* get number of chars in field */ substr (ol, next, 1) = TAB; /* prefix it with a tab */ substr (ol, next+1, len) = substr (il, var_start, len); /* copy the characters of the variable field */ if substr (il, var_start+1, 2) = "b|" then if mode = 1 then /* check for odd base reference */ call ioa_ ("WARNING 0, LINE ^4d: REFERENCE TO ODD BASE.", line_no1); next = next + len + 1; /* update output string index */ end; if com_start > 0 then do; /* see if a comment was given */ if var_start+op_start < 0 then do; /* no opcode or variable was given */ if lab_start < 0 then goto copy_com; /* if no label either left-justify the comment */ substr (ol, next, 4) = TAB4; /* copy in 4 tabs */ next = next + 4; end; else if var_start < 0 then do; /* no variable field was given */ substr (ol, next, 3) = TAB3; /* needs 3 tabs in this case */ next = next + 3; end; else do; /* variable field was given --- use its length (len) */ if len <= 19 then do; substr (ol, next, 1) = TAB; next = next + 1; end; else do; /* nor enough room for tabs */ substr (ol, next, 1) = " "; /* so put in a singla space */ next = next + 1; end; if len <= 9 then do; substr (ol, next, 1) = TAB; next = next + 1; end; end; copy_com: len = com_end-com_start+1; /* get size of comment field */ substr (ol, next, len) = substr (il, com_start, len); /* copy the comment field */ next = next + len; end; if typ = 0 then goto copy_terminator; /* if normal opcode, just finish copying line */ if mode = 1 then do; call ioa_ (message (typ+used (typ)), line_no1); used (typ) = 6; end; if mode = 1 then do; /* long mode, print out the changes */ if typ = 3 | typ = 4 then call ioa_ ("^- ^aCHANGED TO: ^a^/", substr (il, start, stop-start+1), substr (ol, output_start, next-output_start)); if typ = 1 | typ = 2 then call ioa_ ("^- ^a", substr (il, start, stop-start+1)); end; copy_terminator: substr (ol, next, 1) = substr (il, stop, 1); /* copy the terminator */ next = next + 1; goto GETLINE; /* go process the next line */ /* */ clean_up: call hcs_$fs_move_seg (olp, outp, 1, code); /* copy the data into the segment */ if code ^= 0 then do; /* some trouble */ call com_err_ (code, "cv_alm", "Copying segment from process directory."); call com_err_ (0, "cv_alm", "Segment is in process directory with name cv_alm_temp_."); call hcs_$set_bc ((get_pdir_ ()), "cv_alm_temp_", (next-1)*9, code); if code ^= 0 then call com_err_ (code, "cv_alm", "Setting bit count on cv_alm_temp_."); return; end; call hcs_$set_bc (dirname (2), name (2), (next-1)*9, code); if code ^= 0 then call com_err_ (code, "cv_alm", "Setting bit count on file."); call hcs_$delentry_seg (olp, code); /* delete the temp */ if code ^= 0 then call com_err_ (code, "cv_alm", "cv_alm_temp_"); abort: return; /* */ sob: proc; /* to skip over blanks and tabs */ do ci = ci to stop; /* skip to end of line */ c = substr (il, ci, 1); /* get current character */ if (c ^= " ") & (c ^= TAB) then goto outb; /* exit if found non-blank */ end; outb: if ci >= stop then goto output_current_line; end; soc: proc; /* to skip over non-blank characters */ do ci = ci to stop; c = substr (il, ci, 1); /* get the current character */ if (c = " ") | (c = TAB) | (c = QUOTE) then return; end; end; lookup: proc (opcode) returns (char (16) aligned); dcl opcode char (*); c16 = opcode; /* copy opcode for faster compares */ if len > 7 then return (c16); /* pseudo-ops longer than 7 are ignored */ frst = divide (cv_opcodes$.first (len) - 16, 6, 17, 0); lst = divide (cv_opcodes$.last (len) - 16, 6, 17, 0); do li = frst to lst; if c16 = cv_opcodes$.data (li).old then do; /* we found the opcode */ typ = cv_opcodes$.data (li).type; len = cv_opcodes$.data (li).length; /* set up len of new opcode */ return (cv_opcodes$.data (li).new); end; end; return (c16); end lookup; get_name: proc (name_no); dcl name_no fixed bin; tname = arg_in; if substr (tname, arglen-3, 4) ^= ".alm" then do; if arglen > 28 then do; /* not enough room left to add suffix */ call com_err_ (0, "cv_alm", "Name too long to add "".alm"" suffix: ^a", name (name_no)); goto abort; end; substr (tname, arglen+1, 4) = ".alm"; /* add suffix */ arglen = arglen + 4; /* update new length up arg */ end; call expand_path_ (addr (tname), arglen, addr (dirname (name_no)), addr (name (name_no)), code); if code ^= 0 then do; /* something screwed up for expand_path_ */ call com_err_ (code, "cv_alm", arg_in); goto abort; end; return; end; end cv_alm; */ ----------------------------------------------------------- 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 */