/* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ mexp: proc; /* This program is a simple macro expander for alm type programs. */ dcl (char_count, next) fixed bin (21), bit_count fixed bin (24), code fixed bin (35), entry_no fixed bin (21), based_2_chars char (2) based, 1 dummy_dcl based, 2 pad char (3), 2 fourth_char char (1), WHITE char (2) static init (" "), TERM char (2) static init ("; "), ENDS char (4) static init ("(); "), WHITE_TERM char (4) static init (" ; "), (last_macro, old_free) ptr, (i, j) fixed bin (21), (unique_generator, unique_generator1) fixed bin init (0), unique_changed bit (1) aligned init ("0"b), discard fixed bin, vc char (12) var, convert_binary_integer_$octal_string entry (fixed bin) returns (char (12) var), get_wdir_ entry () returns (char (168) aligned), convert_binary_integer_$decimal_string entry (fixed bin) returns (char (12) var), cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin), path char (168) aligned, dirname char (168), ename char (32), sname char (32) var, (ilp, outp, olp, mbp, bp (32)) ptr, c char (1) aligned, hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)), hcs_$fs_move_seg entry (ptr, ptr, fixed bin, fixed bin (35)), (addr, substr, ptr, unspec, index, divide, null, addrel, baseno, baseptr, length, min) builtin, expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin (35)), com_err_ ext entry options (variable), find_include_file_$initiate_count entry (char (*), ptr, char (*) aligned, fixed bin (24), ptr, fixed bin (35)), hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin, ptr, fixed bin (35)), hcs_$delentry_seg entry (ptr, fixed bin (35)), line_no fixed bin, (nargs, arg_len) fixed bin, (no_exargs, no_ifargs) fixed bin, my_name char (4) aligned static init ("mexp"), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)), cu_$arg_count entry returns (fixed bin), dirname_p char (168), (ename2, ename_p) char (32), arg char (arg_len) based (arg_ptr), input_arg (0: 9) char (32) var init ((10) (1)""), no_input_args fixed bin, targ char (128) var, (arg_ptr, fp) ptr, QUOTE char (1) aligned static init (""""), ol char (max_char_count) aligned based (olp), max_char_count fixed bin (21), sys_info$max_seg_size ext static fixed bin (35), hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), COMMA_NL char (2) static init (", "), NL char (1) static init (" "), TAB char (1) static init (" "); dcl type_NORMAL fixed bin static options (constant) init (1); dcl type_PREV_UNIQUE fixed bin static options (constant) init (2); dcl type_UNIQUE fixed bin static options (constant) init (3); dcl type_NEXT_UNIQUE fixed bin static options (constant) init (4); dcl type_ITERATE fixed bin static options (constant) init (5); dcl type_OPEN fixed bin static options (constant) init (6); dcl type_CLOSE fixed bin static options (constant) init (7); dcl type_COMMAND_ARGNO fixed bin static options (constant) init (8); dcl type_SPEC_UNIQUE fixed bin static options (constant) init (9); dcl type_COMMAND_ARG fixed bin static options (constant) init (10); dcl type_LENGTH fixed bin static options (constant) init (11); dcl type_NARGS fixed bin static options (constant) init (12); dcl type_NITER fixed bin static options (constant) init (13); dcl type_ENDM fixed bin static options (constant) init (14); /* Based */ /* */ /* Scan the argument(s) and create necessary buffers, etc. */ max_char_count = sys_info$max_seg_size*4; nargs = cu_$arg_count (); /* get the number of arguments given */ no_input_args = min (10, nargs-1); /* get the number of additional arguments */ if nargs < 1 then do; /* wrong usage, give correct */ USAGE: call com_err_ (0, (my_name), "Usage: mexp name (looks for name.mexp)"); return; end; call cu_$arg_ptr (1, arg_ptr, arg_len, code); /* get the arg */ if code ^= 0 | arg_len = 0 then goto USAGE; call expand_path_ (arg_ptr, arg_len, addr (dirname), addr (ename), code); if code ^= 0 then goto USAGE; j = index (ename, " "); /* search for end of name, see if ends with ".mexp" */ if j > 0 then if j < 27 then if substr (ename, j-5, 5) ^= ".mexp" then do; substr (ename, j, 5) = ".mexp"; /* if doesn't end in ".mexp", make sure it does */ j = j + 5; end; sname = substr (ename, 1, j-6); /* get primary component of name */ call hcs_$initiate_count (dirname, ename, "", bit_count, 0, ilp, code); /* get pointer to source */ if ilp = null then do; call com_err_ (code, (my_name), "^a>^a", dirname, ename); return; end; ename2 = sname || ".alm"; /* get name of output segment */ call hcs_$make_seg (get_wdir_ (), ename2, "", 01011b, outp, code); if outp = null then goto USAGE; char_count = divide (bit_count, 9, 17, 0); /* get number of chars in source */ /* Now create the two temporary segments needed */ call hcs_$make_seg ("", "mexp.temp", "", 01011b, fp, code); if fp = null then goto USAGE; call hcs_$truncate_seg (fp, 0, code); if code ^= 0 then goto USAGE; call hcs_$make_seg ("", ename2, "", 01011b, olp, code); if olp = null then goto USAGE; call hcs_$make_seg ("", "macro_buffers.mexp", "", 01011b, mbp, code); if mbp = null then goto USAGE; do i = 2 to 32; bp (i) = addrel (mbp, (i-2)*1024); end; if nargs > 11 then call com_err_ (0, (my_name), "Only first 10 arguments will be accepted."); do i = 0 to no_input_args-1; call cu_$arg_ptr (i+2, arg_ptr, arg_len, code); if code ^= 0 then goto NOMOREARGS; input_arg (i) = arg; end; NOMOREARGS: /* */ /* Now expand the input text. This is done by expanding the data pointed to by bp (level) ... which is done by a (recursive) call to scan_buffer. */ old_free = ptr (fp, 0); /* initialize pointer to macro table */ last_macro = null; /* set up for reverse chain of macros */ line_no = 0; /* initialize line number counter */ next = 1; /* initialize output character index */ if ilp -> based_2_chars = "%;" then ilp = addr (ilp -> dummy_dcl.fourth_char); /* BUG */ bp (1) = ilp; /* first buffer load is input text */ call scan_buffer (1, char_count); /* this will do all the work */ ERROR: 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, (my_name), "Copying segment from process directory."); call com_err_ (0, (my_name), "Segment is in process directory with name ^a.", ename2); call hcs_$set_bc_seg (olp, (next-1)*9, code); if code ^= 0 then call com_err_ (code, (my_name), "Setting bit count on ^a.", ename2); return; end; call hcs_$set_bc_seg (outp, (next-1)*9, code); if code ^= 0 then call com_err_ (code, (my_name), "Setting bit count on ^a.", ename2); call hcs_$delentry_seg (olp, code); /* delete the temp */ call hcs_$delentry_seg (fp, code); call hcs_$delentry_seg (mbp, code); call hcs_$terminate_noname (ilp, code); call hcs_$terminate_noname (outp, code); return; /* */ /* SCAN_BUFFER This is the main work program of mexp. It scans the text pointed to by bp (level) and places output into the output temporary. Any buffers which are used for macro expansion along the way are expanded and hence output into the output segment with a recursive call to SCAN_BUFFER */ scan_buffer: proc (a_level, a_size); dcl (a_level, a_size) fixed bin (21); dcl (nparens, i, ci, start, stop, j, iterate, macro_len) fixed bin (21), found_number bit (1) aligned, si fixed bin (21), pfree ptr, save_free fixed bin (21), val fixed bin, filling_buffer bit (1), t fixed bin (21), type fixed bin, (nargs, level) fixed bin, (nchars, arg_start, len_op, start_name, len1, len, nextb, ia) fixed bin (21), ml char (macro_len) based (mp), ob char (max_char_count) based (obp), il char (nchars) based (tp), (end_index, ntimes) fixed bin (21), match bit (1) aligned, (lab_start, lab_end, op_start, op_end, var_start, var_end, mstart) fixed bin (21), opcode char (32) aligned, iterate_arg_no fixed bin (21), save_start fixed bin (21), (obp, mp, p, tp) ptr; dcl 1 ifargs (0: 99) aligned, 2 start fixed bin (21), 2 len fixed bin (21); dcl 1 exargs (0: 99) aligned, 2 start fixed bin (21), 2 len fixed bin (21); dcl 1 args (0: 99) aligned, 2 start fixed bin (21), 2 len fixed bin (21); dcl 1 macro based (pfree) aligned, 2 next_macro ptr unal, 2 segno fixed bin, 2 num_entries fixed bin, 2 name char (32) var, 2 entry (1), 3 type fixed bin, 3 value_1 fixed bin, 3 value_2 fixed bin, 3 first_char fixed bin (21), 3 n_chars fixed bin (21); stop = 0; /* initialize end of line index */ nchars = a_size; /* copy length of buffer to work on */ level = a_level; /* copy recursion depth */ if level > 32 then do; /* too much recursion ... */ call com_err_ (0, "mexp", "Maximum recursion exceeded."); goto ERROR; end; tp = bp (level); /* copy pointer to text to expand and copy */ obp = bp (level+1); /* get pointer to output buffer if needed */ nextb = 1; /* next available char position in output buffer */ filling_buffer = "0"b; /* indicates we are not using output buffer (yet) */ GETLINE: call skip_to_next_line; /* get bounds of next line */ if stop > nchars then do; /* all done, see if some thing in output buffer */ if filling_buffer then call scan_buffer (level+1, nextb-1); /* clean out the output buffer */ return; end; if stop = start then do; /* blank line, just copy NL */ copy_terminator: if filling_buffer then do; substr (ob, nextb, 1) = substr (il, stop, 1); nextb = nextb + 1; end; else do; substr (ol, next, 1) = substr (il, stop, 1); /* may also be a ";" */ next = next + 1; end; goto GETLINE; end; lab_start, op_start, var_start = -1; /* initialize starting indexes as flags */ ci = start; /* initialize scanning index */ call sob; /* skip over blanks */ 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 */ len_op = op_end - op_start + 1; opcode = substr (il, op_start, len_op); 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; len_op = op_end - op_start + 1; opcode = substr (il, op_start, len_op); 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, (my_name), "Unexpected syntax in line ^d", line_no); call com_err_ (0, (my_name), "line is: ^/^a", substr (il, start, stop-start+1)); call copy_line; goto GETLINE; end; 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 output_current_line; /* 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 */ len_op = op_end - op_start + 1; /* get length of opcode */ opcode = substr (il, op_start, len_op); /* get the opcode */ scan_var: call sob; /* skip over blanks again */ if opcode = "acc" | opcode = "aci" | opcode = "bci" then do; /* special case these opcodes */ c = substr (il, ci, 1); /* get quoting character used by ACC or ACI */ t = index (substr (il, ci+1, stop-ci), c)-1; /* look for matching char */ if t < 0 then goto output_current_line; /* really was comment */ else i = ci+1+t; /* index of matching char */ var_start = ci; /* treat char string as variable field */ var_end = i; ci = i+1; goto output_current_line; /* search for a comment */ end; 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; /* */ output_current_line: if op_start > 0 then do; /* see if an opcode was given */ /* See if the opcode is some special pseudo-op */ if opcode = "ife" | opcode = "ine" | opcode = "ifarg" | opcode = "ifint" | opcode = "inint" then do; j = index (substr (il, stop), "ifend"); /* search for end of conditional data */ if j <= 0 then do; /* bad use of pseudo-op */ BAD_PSEUDO: call com_err_ (0, (my_name), "Bad use of ^a at line ^d.", opcode, line_no); return; end; end_index = stop + j; /* save position of ifend */ if var_start < 0 then goto BAD_PSEUDO; /* must have args for INE and IFE */ call scan_args (ifargs, no_ifargs, var_start, var_end-var_start+1); targ = substr (il, ifargs (1).start, ifargs (1).len); if opcode = "ifarg" then do; /* conditional expansion on input arg */ match = "0"b; /* default is no match */ do ia = 1 to no_input_args while (match = "0"b); /* search all input args */ if targ = input_arg (ia-1) then match = "1"b; end; end; else if opcode = "ifint" | opcode = "inint" then do; discard = cv_dec_check_ ((targ), code); /* check for decimal number */ match = (code = 0); /* match if arg is decimal integer */ if opcode = "inint" then match = ^match; end; else do; if targ = substr (il, ifargs (2).start, ifargs (2).len) then match = "1"b; else match = ""b; if opcode = "ine" then match = ^match; /* inverse meaning for INE case */ end; ntimes = 1; /* we join the dup code so ... */ INE_JOIN: if lab_start > 0 then do; /* don't leave off label */ len1 = lab_end -lab_start + 1; substr (ob, nextb, len1) = substr (il, lab_start, len1); nextb = nextb + len1; end; filling_buffer = "1"b; GET_ANOTHER_LINE: call skip_to_next_line; /* scan another line */ if stop > end_index then do; /* if the new line includes the ifend ... */ ntimes = ntimes - 1; /* decrement number of passes through */ if ntimes > 0 then do; /* only for dup case */ stop = save_start; /* go back */ goto GET_ANOTHER_LINE; end; if match then do; len1 = end_index-start-1; call copy_line_len; end; if substr (il, end_index+4, 5) = "_exit" & level > 1 & match then do; if filling_buffer then call scan_buffer (level+1, nextb-1); return; end; goto GETLINE; /* and start with next normal line */ end; else do; /* one of the lines to be expanded conditionally */ if match then call copy_line; goto GET_ANOTHER_LINE; end; end; if opcode = "dup" then do; j = index (substr (il, stop), "dupend"); /* search for end of dup */ if j < 0 then goto BAD_PSEUDO; if var_start < 0 then goto BAD_PSEUDO; save_start = stop; match = "1"b; /* for later join with INE/IFE code */ end_index = stop + j; ntimes = cv_dec_check_ (substr (il, var_start, var_end-var_start+1), code); if code ^= 0 then goto BAD_PSEUDO; goto INE_JOIN; end; if opcode = "&include" then do; /* an include file was specified */ call copy_line_quoted; /* print out macro line as a comment */ if var_start < 0 then goto BAD_MACRO_FILE; /* no file name, bad style */ path = substr (il, var_start, var_end-var_start+1) || ".incl.mexp"; /* get pathname */ call find_include_file_$initiate_count ("mexp", tp, path, bit_count, mp, code); if mp = null then do; /* couldn't get pointer to macro file */ call com_err_ (code, (my_name), "Could not get pointer to include file ^a", path); goto BAD_MACRO_FILE; end; call build_macros (mp, bit_count); /* place macros in macro directory */ goto GETLINE; end; if opcode = "¯os" then do; /* a macro segment was specified */ call copy_line_quoted; /* print out macro line as a comment */ if var_start < 0 then goto nopath; /* if no macro file given, use default */ path = substr (il, var_start, var_end-var_start+1); /* get pathname */ if path = "&system" then do; nopath: dirname_p = ">system_library_tools"; /* use system standard macro segment */ ename_p = "mexp_system_macros"; end; else do; /* not system macros */ call expand_path_ (addr (path), var_end-var_start+1, addr (dirname_p), addr (ename_p), code); if code ^= 0 then do; /* something screwed up in pathname */ BAD_MACRO_FILE: call com_err_ (code, (my_name), "Bad syntax in macro pathname on line ^d", line_no); goto GETLINE; end; end; call hcs_$initiate_count (dirname_p, ename_p, "", bit_count, 0, mp, code); /* get pointer to macro file */ if mp = null then do; /* couldn't get pointer to macro file */ call com_err_ (code, (my_name), "Could not get pointer to macro file ^a>^a", dirname_p, ename_p); goto BAD_MACRO_FILE; end; call build_macros (mp, bit_count); /* place macros in macro directory */ goto GETLINE; end; if opcode = "¯o" then do; /* a macro was given within the text of this program */ j = index (substr (il, stop), "&end"); /* search for matching "&end" */ if j < 1 then do; /* bad macro definition */ call com_err_ (0, (my_name), "Bad macro definition starting at line ^d.", line_no); return; end; macro_len = j+stop+3; substr (ol, next, 1) = QUOTE; /* comment out macro def */ next = next + 1; start_name = var_start; len1 = var_end-var_start+1; pfree = old_free; /* restore free index (restored earlier) */ call build_macro (ilp, stop, len1, start_name); /* leaves stop pointing to end of macro def */ old_free = pfree; /* save free index (used later) */ do i = start to stop - 1; /* scan over all characters of the macro definition */ c = substr (il, i, 1); /* get current character */ substr (ol, next, 1) = c; /* copy it into the output segment */ next = next + 1; if c = NL | c = ";" then do; /* follow all NL's and ;'s with a " */ substr (ol, next, 1) = QUOTE; next = next+1; if level = 1 then if c = NL then line_no = line_no + 1; end; end; if level = 1 then line_no = line_no - 1; /* first line was counted twice, so ... */ goto copy_terminator; end; /* See if the opcode is a macro name */ do pfree = last_macro repeat macro.next_macro while (pfree ^= null); if macro.name = opcode then do; /* we have found a macro to expand */ if filling_buffer then do; /* must fisrt clean out what's in the buffer */ call scan_buffer (level+1, nextb-1); filling_buffer = "0"b; nextb = 1; end; mp = baseptr (macro.segno); /* get pointer to macro segment to use */ /* Write out the macro line preceded with a comment character */ if lab_start > 0 then do; /* if a label was given on the macro, don't comment it out */ len1 = lab_end - lab_start + 1; substr (ob, nextb, len1) = substr (il, lab_start, len1); nextb = nextb + len1; end; call copy_line_quoted; /* copy the macro line as a comment */ if unique_changed then do; /* did we use it last macro? */ unique_generator1 = unique_generator1 + 1; unique_changed = ""b; end; /* Now pick off any args from the input source, save pointers to them */ if var_start > 0 then do; /* if args were given ... */ call scan_args (args, nargs, var_start, var_end-var_start+1); end; else do; /* no args to macro */ do i = 0 to 99; args (i).len = 0; end; nargs = 0; end; if lab_start > 0 then do; args.len (0) = lab_end-lab_start; args.start (0) = lab_start; end; else args.len (0) = 0; iterate = 0; /* in case &x is used and iteration isn't */ /* Now copy expanded text into file */ do entry_no = 1 to macro.num_entries; len = macro.entry (entry_no).n_chars; /* get size of element */ if len > 0 then do; substr (ob, nextb, len) = substr (ml, macro.entry (entry_no).first_char, len); nextb = nextb + len; end; val = macro.entry (entry_no).value_1; /* extract value for this type of element */ type = macro.entry (entry_no).type; /* also extract type of element */ if type = type_UNIQUE then do; /* "u" expansion */ unique_generator = unique_generator + 1; i = unique_generator; /* get value for symbol */ UNIQUE: substr (ob, nextb, 3) = "..."; /* generate unique symbol */ UNIQUE1: nextb = nextb + 3; vc = convert_binary_integer_$octal_string (i + 1e27b); /* convert to char */ substr (ob, nextb, 5) = substr (vc, 6, 5); nextb = nextb + 5; end; else if type = type_PREV_UNIQUE then do; /* "p" expansion" */ i = unique_generator; /* get value for symbol */ goto UNIQUE; end; else if type = type_NEXT_UNIQUE then do; /* "n" expansion */ i = unique_generator + 1; goto UNIQUE; end; else if type = type_SPEC_UNIQUE then do; /* "U" expansion */ i = unique_generator1; substr (ob, nextb, 3) = ".._"; /* this "_" used to be "!" */ unique_changed = "1"b; goto UNIQUE1; end; else if type = type_ITERATE then do; /* 5 indicates &i */ len = exargs (iterate).len; if len > 0 then do; substr (ob, nextb, len) = substr (il, exargs (iterate).start, len); nextb = nextb + len; end; end; else if type = type_COMMAND_ARGNO then do; /* &x */ val = iterate; PUTNUM: vc = convert_binary_integer_$decimal_string (val); i = length (vc); substr (ob, nextb, i) = vc; nextb = nextb+i; end; else if type = type_COMMAND_ARG then do; /* A_n */ len = length (input_arg (val-1)); substr (ob, nextb, len) = input_arg (val-1); nextb = nextb + len; end; else if type = type_NORMAL then do; /* normal argument expansion */ if val <= nargs then do; len = args.len (val); substr (ob, nextb, len) = substr (il, args.start (val), len); nextb = nextb + len; end; end; else if type = type_CLOSE then do; /* &) */ iterate = iterate + 1; /* another iteration complete */ entry_no = save_free; goto ANY_ARGS_Q; end; else if type = type_OPEN then do; /* &( */ save_free = entry_no; iterate_arg_no = val; iterate = 1; i = args (iterate_arg_no).len; if i > 0 then do; j = args (iterate_arg_no).start; call scan_args (exargs, no_exargs, j, i); end; else no_exargs = 0; ANY_ARGS_Q: if no_exargs < iterate then do; entry_no = macro.entry (save_free).value_2; end; end; else if type = type_LENGTH then do; val = args (val).len; goto PUTNUM; end; else if type = type_NARGS then do; val = nargs; go to PUTNUM; end; else if type = type_NITER then do; val = no_exargs; go to PUTNUM; end; else if type ^= type_ENDM then do; /* internal error in mexp */ call com_err_ (0, (my_name), "Mexp internal error"); goto ERROR; end; end; call scan_buffer (level+1, nextb-1); /* scan newly expanded macro for more macros */ nextb = 1; goto GETLINE; /* get next line of text */ end; end; /* No macros match, just copy given line */ end; call copy_line; /* copy the line into the output text */ goto GETLINE; /* */ /* The following routine parses a string and picks off arguments */ scan_args: proc (array, no_args, firstx, count); dcl 1 array (0: 99) aligned, 2 first fixed bin (21), 2 size fixed bin (21); dcl c2 char (2) aligned; dcl no_args fixed bin, (firstx, count, arg_start, i, last) fixed bin (21); do i = 0 to 99; array (i).size = 0; end; arg_start, ci = firstx; last = ci + count - 1; no_args = 0; GET_ANOTHER_ARG: c2 = substr (il, ci-1, 2); if c2 = COMMA_NL | c2 = ", " | c2 = ", " | c2 = ",""" then do; /* continue on next line */ call skip_to_next_line; if stop > nchars then return; call copy_line_quoted; /* comment out the arguments */ t = verify (substr (il, start, stop-start+1), WHITE)-1; /* skip white space */ if t < 0 then ci = stop+1; else ci = start + t; arg_start = ci; /* save start of variable field */ call soc; /* skip to end of variable field */ if stop = ci-1 then last = ci-2; else last = ci-1; ci = arg_start; goto GET_ANOTHER_ARG; end; else if substr (il, ci, 1) = "(" then do; /* watch out for args with parens */ nparens = 1; /* skip till no more parens at this level */ do ci = ci+1 to last while (nparens > 0); if substr (il, ci, 1) = "(" then nparens = nparens + 1; else if substr (il, ci, 1) = ")" then nparens = nparens - 1; end; if nparens > 0 then do; call com_err_ (0, (my_name), "Unbalanced parentheses at line ^d", line_no); return; end; no_args = no_args + 1; array.first (no_args) = arg_start+1; /* copy information about where the arg is */ array.size (no_args) = ci - arg_start - 2; goto NEXT_ARG; end; else do; /* argument didn' start with paren */ t = index (substr (il, ci, last-ci+1), ",")-1; if t < 0 then ci = last + 1; else ci = ci + t; no_args = no_args + 1; array.first (no_args) = arg_start; array.size (no_args) = ci - arg_start; NEXT_ARG: ci, arg_start = ci+1; if arg_start <= last+1 then goto GET_ANOTHER_ARG; end; return; end scan_args; /* */ /* The following procedure is used to extract the macro definitions found in the macro file pointed to by mp. */ build_macros: proc (mp, bit_count); dcl mp ptr, bit_count fixed bin (24); /* Scan the macro source file extracting information about the macros and puting the information into the temporary segment pointed to by fp */ macro_len = divide (bit_count, 9, 17, 0); pfree = old_free; /* index to next free word of the free segment */ ci = 1; /* points to current character being scanned */ ANOTHER_MACRO: len = 100; j = index (substr (ml, ci), "¯o")-1; if j < 0 then do; /* no more, all done with this macro seg */ old_free = pfree; return; end; mstart = j+ci; /* get start of macro definition */ t = verify (substr (ml, mstart+6), WHITE)-1; if t < 0 then goto BAD_MACRO_DEF; start_name = mstart+6+t; t = search (substr (ml, start_name), WHITE_TERM)-1; if t < 0 then goto BAD_MACRO_DEF; ci = start_name + t; len = ci - start_name; /* get length of macro name */ call build_macro (mp, ci, len, start_name); goto ANOTHER_MACRO; /* process another macro */ BAD_MACRO_DEF: call com_err_ (0, (my_name), "Bad macro defintion at line ^d.", line_no); return; end build_macros; /* */ /* The following procedure is used to enter a single macro into the macro table */ build_macro: proc (mp, ci, len, start_name); dcl mp ptr, ci fixed bin (21), len fixed bin (21), start_name fixed bin (21); dcl ml char (macro_len) based (mp) aligned; dcl tfree ptr; dcl start fixed bin (21); dcl in_iteration fixed bin; in_iteration = 0; tfree = pfree; /* remember where this macro started */ macro.name = substr (ml, start_name, len); macro.segno = bin (baseno (mp)); /* save segment number in macro structure */ /* Now generate sub-structure */ t = search (substr (ml, ci), TERM)-1; if t < 0 then goto BAD_MACRO_DEF; ci = ci + t; do entry_no = 1 by 1; /* iterate until macro defined */ start = ci+1; /* get start of the current element */ do ci = start to macro_len while (substr (ml, ci, 1) ^= "&"); end; /* skip to next special character */ if ci >= macro_len then do; ci = macro_len; /* leave ci pointing to end of macro */ goto FIN_MACRO; end; macro.entry (entry_no).first_char = start; macro.entry (entry_no).n_chars = ci-start; c = substr (ml, ci+1, 1); /* copy next character -- might by argument number */ si = 1; /* indicates where to start scan */ call get_numeric_value; if found_number then do; type = type_NORMAL; /* normal arg expansion */ macro.entry (entry_no).value_1 = i; ci = ci-1; end; else if c = "p" then type = type_PREV_UNIQUE; /* predecessor */ else if c = "u" then type = type_UNIQUE; /* unique number */ else if c = "n" then type = type_NEXT_UNIQUE; /* next unique */ else if c = "i" then do; if in_iteration > 0 then do; type = type_ITERATE; end; else do; call com_err_ (0, (my_name), """&i"" occured outside of iteration bounds in macro ^a", macro.name); goto FIN_MACRO; end; end; else if c = "(" then do; /* start of iteration */ save_free = entry_no; si = 2; call get_numeric_value; if i = 0 then i = 1; type = type_OPEN; macro.entry (entry_no).value_1 = i; if in_iteration > 0 then do; /* warn against recursive iteration */ call com_err_ (0, (my_name), "Illegal recursive iteration in macro ^a", macro.name); goto FIN_MACRO; end; else in_iteration = 1; end; else if c = ")" then do; /* end of iteration */ in_iteration = in_iteration - 1; if in_iteration < 0 then goto bad_iter; type = type_CLOSE; macro.entry (entry_no).value_1 = save_free; macro.entry (save_free).value_2 = entry_no; end; else if c = "x" then type = type_COMMAND_ARGNO; else if c = "U" then type = type_SPEC_UNIQUE; else if c = "A" then do; /* &A0, ... &A9 */ si = 2; call get_numeric_value; type = type_COMMAND_ARG; macro.entry (entry_no).value_1 = i; end; else if c = "l" then do; si = 2; call get_numeric_value; if i = 0 then i = 1; type = type_LENGTH; macro.entry (entry_no).value_1 = i; end; else if c = "K" then type = type_NARGS; else if c = "k" then type = type_NITER; else if substr (ml, ci, 4) = "&end" then do; /* end of macro */ t = search (substr (ml, ci), TERM)-1; if t < 0 then ci = macro_len + 1; else ci = ci + t; goto FIN_MACRO; end; else do; /* unexpected control */ BAD_MACRO_DEF: call com_err_ (0, (my_name), "Bad macro definition within macro ^a", macro.name); t = index (substr (ml, ci), "&end")-1; if t < 0 then ci = macro_len+1; else ci = ci + t; end; macro.entry (entry_no).type = type; ci = ci + 1; end; FIN_MACRO: if in_iteration ^= 0 then do; bad_iter: call com_err_ (0, (my_name), "Unbalanced iteration within macro ^a", macro.name); end; macro.entry (entry_no).type = type_ENDM; /* indicates end of macro */ macro.num_entries = entry_no; macro.next_macro = last_macro; /* fill in pointer to previous macro structure */ last_macro = tfree; pfree = addr (macro.entry (entry_no+1)); /* save pointer to where next macro goes */ return; get_numeric_value: proc; dcl c char (1) aligned; i = 0; /* initialize return value */ found_number = "0"b; do ci = ci to ci+2; c = substr (ml, ci+si, 1); if c < "0" then return; if c > "9" then return; found_number = "1"b; i = i*10 + bin (unspec (c), 9) - 48; end; end; end build_macro; /* */ copy_line_quoted: proc; dcl tx fixed bin; if filling_buffer then do; substr (ob, nextb, 1) = QUOTE; nextb = nextb + 1; end; else do; substr (ol, next, 1) = QUOTE; next = next + 1; end; txl: tx = index (substr (il, start, stop-start), ";"); if tx ^= 0 then do; if filling_buffer then do; substr (ob, nextb, tx+1) = substr (il, start, tx) || QUOTE; nextb = nextb + tx+1; start = start + tx; end; else do; substr (ol, next, tx+1) = substr (il, start, tx) || QUOTE; next = next + tx+1; start = start + tx; end; go to txl; end; copy_line: entry; len1 = stop - start + 1; copy_line_len: entry; if filling_buffer then do; substr (ob, nextb, len1) = substr (il, start, len1); nextb = nextb + len1; end; else do; substr (ol, next, len1) = substr (il, start, len1); next = next + len1; end; return; end; skip_to_next_line: proc; start = stop+1; /* get start of next line */ dcl nparens fixed bin; nparens = 0; stop = start; more: t = search (substr (il, stop), ENDS)-1; if t < 0 then do; stop = nchars + 1; return; end; stop = stop + t; if substr (il, stop, 1) = "(" then nparens = nparens + 1; else if substr (il, stop, 1) = ")" then nparens = nparens - 1; else if substr (il, stop, 1) = ";" & nparens > 0 then; /* ignore ";" unless outside "()" */ else do; if level = 1 & substr (il, stop, 1) = NL then line_no = line_no + 1; return; end; stop = stop + 1; go to more; end; /* */ sob: proc; t = verify (substr (il, ci, stop-ci+1), WHITE)-1; if t < 0 then goto output_current_line; ci = ci + t; return; end; soc: proc; dcl nparens fixed bin; nparens = 0; more: t = search (substr (il, ci, stop-ci+1), "() """)-1; if t < 0 then do; ci = stop+1; return; end; ci = ci + t; c = substr (il, ci, 1); if c = "(" then nparens = nparens + 1; else if c = ")" then nparens = nparens - 1; else if nparens = 0 then return; ci = ci + 1; goto more; end; end scan_buffer; end mexp; */ ----------------------------------------------------------- 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 */