{$W-,Y-}
program overlay;

{
	Author :  Earl Chew
	Date :    26 January 1984

Copyright (C) 1984
C. E. Chew

}


const
  debug = true;

  printerwidth = 132;
  stringlength = 20;

  option = 1;
  command = 2;
  execute = 3;
  object = 4;
  min_args = 5;
  initialobj = object - 1;

  usersignal = '<*>';

  progid = "OVRLAY";
  version = '03.00';


type
  string = array [1..stringlength + 1] of char;
  rad50_name = array [1..2] of integer;
  blocktype = (EOFOBJ, GSD, ENDGSD, TXT, RLD, ISD, ENDMOD);
  gsdtype = (MN, CSN, ISN, TA, GSN, PSN, PVI, MAD);
  balance = (unleft, balanced, unright);
  state = (referred, tied, paved, printed);
  setstate = set of state;
  comparison = (less, equal, greater);

  tree = @node;
  call_list = @call_rec;
  node = record
           name : rad50_name;
           bal : balance;
           status : setstate;
           lex : integer;
           left, right, lexparent, ring : tree;
           tolist, fromlist : call_list
         end;
  call_rec = record
               call : tree;
               next : call_list
             end;
  queue = @queue_rec;
  queue_rec = record
                head, tail : queue;
                item : tree
              end;

const
  datasection = rad50_name(14644b, 140116b);	{DDD000}
var
  lextree, searchtree : tree;
  blocklength : integer;
  thisobj : integer;
  f : text;
  obj : file of char;
  freequeue : queue;
  data_psect : rad50_name;
  listopt, bindopt, stripopt, extractopt : boolean;

procedure fatal(p,m:string); external;

procedure warn(p,m:string); external;

procedure error(p,m:string); external;

function iand(i,j:integer):integer; external;

procedure r50tos(r:rad50_name;l:integer;var s:string;m:integer); external;

procedure stor50(s:string;var r:rad50_name;m:integer); external;

procedure rerun; external;

function position(s, p :string; t : integer):integer; external;

procedure trim(var s:string); external;

function length(s:string):integer; external;

procedure gtlin(p:string;var s:string); external;


function match(var n1, n2 : rad50_name):comparison;

var
  i, r : integer;

begin
  i := 0;
  repeat
    i := i + 1;
    r := n1[i] - n2[i]
  until (r <> 0) or (i = 2);
  if r < 0 then
    match := less
  else if r > 0 then
    match := greater
  else
    match := equal
end;


procedure insert(var n : rad50_name; var t : tree);

var
  h : boolean;


procedure inserting(var n : rad50_name; var t : tree; var h : boolean);

var
  tl, tr : tree;
  r : comparison;

begin
  if t = nil then begin
    new(t);
    h := true;
    with t@ do begin
      name := n;
      status := [];
      bal := balanced;
      left := nil;
      right := nil;
      tolist := nil;
      fromlist := nil;
      ring := t;
      lex := -1
    end
  end
  else begin
    r := match(n, t@.name);
    if r = less then begin
      inserting(n, t@.left, h);
      if h then begin
        case t@.bal of
          unright : begin
            t@.bal := balanced;
            h := false
          end;
          balanced : begin
            t@.bal := unleft
          end;
          unleft : begin
            tl := t@.left;
            if tl@.bal = unleft then begin
              t@.left := tl@.right;
              tl@.right := t;
              t@.bal := balanced;
              t := tl
            end
            else begin
              tr := tl@.right;
              tl@.right := tr@.left;
              tr@.left := tl;
              t@.left := tr@.right;
              tr@.right := t;
              if tr@.bal = unleft then
                t@.bal := unright
              else
                t@.bal := balanced;
              if tr@.bal = unright then
                tl@.bal := unleft
              else
                tl@.bal := balanced;
              t := tr
            end;
            t@.bal := balanced;
            h := false
          end
        end
      end
    end
    else if r = greater then begin
      inserting(n, t@.right, h);
      if h then begin
        case t@.bal of
          unleft : begin
            t@.bal := balanced;
            h := false
          end;
          balanced : begin
            t@.bal := unright
          end;
          unright : begin
            tr := t@.right;
            if tr@.bal = unright then begin
              t@.right := tr@.left;
              tr@.left := t;
              t@.bal := balanced;
              t := tr
            end
            else begin
              tl := tr@.left;
              tr@.left := tl@.right;
              tl@.right := tr;
              t@.right := tl@.left;
              tl@.left := t;
              if tl@.bal = unright then
                t@.bal := unleft
              else
                t@.bal := balanced;
              if tl@.bal = unleft then
                tr@.bal := unright
              else
                tr@.bal := balanced;
              t := tl
            end;
            t@.bal := balanced;
            h := false
          end
        end
      end
    end
    else begin
      fatal(progid, "Duplicate module name")
    end
  end
end;

begin
  inserting(n, t, h)
end;


procedure addlist(var list : call_list; item : tree);

var
  p : call_list;

begin
  new(p);
  with p@ do begin
    call := item;
    next := list
  end;
  list := p
end;


function locate(n : rad50_name; t : tree):tree;

var
  r : comparison;

begin
  r := less;
  while (t <> nil) and (r <> equal) do begin
    with t@ do begin
      r := match(n, name);
      if r = less then
        t := left
      else if r = greater then
        t := right
    end
  end;
  locate := t
end;


procedure insertqueue(q : queue; t : tree);

var
  p : queue;

begin
  if freequeue = nil then
    new(p)
  else begin
    p := freequeue;
    freequeue := freequeue@.head
  end;
  with p@ do begin
    item := t;
    tail := q;
    q@.head@.tail := p;
    head := q@.head;
    q@.head := p
  end
end;


procedure deletequeue(q : queue);

var
  p : queue;

begin
  p := q@.tail;
  with p@ do begin
    tail@.head := head;
    q@.tail := tail;
    head := freequeue;
    freequeue := p
  end
end;


function bound(t1, t2 : tree):boolean;

var
  t : tree;

begin
  t := t1;
  repeat
    t := t@.ring
  until (t = t1) or (t = t2);
  bound := (t = t2)
end;


procedure bind(t1, t2 : tree);

var
  t : tree;

begin
  if not bound(t1, t2) then begin
    t := t1@.ring;
    t1@.ring := t2@.ring;
    t2@.ring := t
  end
end;


procedure nullify(q : queue);

begin
  q@.head := q;
  q@.tail := q
end;


function empty(q : queue):boolean;

begin
  empty := (q@.head = q) {and (q@.tail = q)}
end;


function nextobj:boolean;

begin
  if (thisobj + 1) < argc then begin
    thisobj := thisobj + 1;
    nextobj := true
  end
  else begin
    thisobj := initialobj;
    nextobj := false
  end
end;


procedure openobj;

begin
  reset(obj, argv[thisobj]@, "OBJ")
end;


procedure r50convert(n : rad50_name; var s : string; trimmed, check : boolean);

var
  i, j : integer;

begin
  r50tos(n, 6, s, stringlength);
  if trimmed then
    trim(s);
  if check then begin
    loop
      i := position(s, "$", 1);
    exit if i = 0;
      for j := (i - 1) downto 1 do
        s[j + 1] := s[j];
      s[1] := '9';
    end;
    loop
      i := position(s, ".", 1);
    exit if i = 0;
      for j := (i - 1) downto 1 do
        s[j + 1] := s[j];
      s[1] := '0';
    end
  end
end;


procedure outname(var f : text; n : rad50_name; trimmed : boolean);

var
  s : string;

begin
  r50convert(n, s, trimmed, false);
  write(f, s)
end;


function getbyte:integer;

begin
  if blocklength = 0 then
    fatal(progid, "Unexpected end of object module");
  getbyte := ord(obj@);
  get(obj);
  blocklength := blocklength - 1
end;


function getword:integer;

var
  l : integer;

begin
  l := getbyte;
  getword := getbyte * 256 + l
end;


procedure skipblock;

var
  t : integer;

begin
  while blocklength > 0 do
    t := getbyte;
  blocklength := 1;
  t := getbyte
end;


procedure gsdentry(var n : rad50_name; var entry : gsdtype;
                   var flags, value : integer);

var
  ent : record
          case boolean of
            true : (entint : integer);
            false : (entgsd : gsdtype)
        end;

begin
  n[1] := getword;
  n[2] := getword;
  flags := getbyte;
  ent.entint := getbyte;
  if ent.entgsd > MAD then
    fatal(progid, "Bad GSD block type");
  entry := ent.entgsd;
  value := getword
end;


procedure initialgsd(var n: rad50_name; block : blocktype);

var
  entry : gsdtype;
  flags, value : integer;

begin
  if block <> GSD then
    fatal(progid, "No initial GSD");
  gsdentry(n, entry, flags, value);
  if (entry <> MN) or (flags <> 0) or (value <> 0) then
    fatal(progid, "No module identification")
end;


function binaryblock:blocktype;

var
  t : integer;
  block : record
            case boolean of
              true : (int : integer);
              false : (blk : blocktype)
          end;

begin
  while not eof(obj) and (obj@ = chr(0)) do
    get(obj);
  if eof(obj) then
    binaryblock := EOFOBJ
  else begin
    if obj@ <> chr(1) then
      fatal(progid, "Bad object module format");
    get(obj);
    if (obj@ <> chr(0)) or eof(obj) then
      fatal(progid, "Bad binary block header");
    get(obj);
    blocklength := 2;
    t := getbyte;
    blocklength := getbyte * 256 + t - 4;
    block.int := getword;
    if (block.blk < GSD) or (block.blk > ENDMOD) then
      fatal(progid, "Bad binary block type");
    binaryblock := block.blk
  end
end;


procedure dumpsearchtree(var lst : text; root : tree);

const
  maxdepth = printerwidth div 9;

type
  direction = (lost, port, starboard);

var
  join : array [1..maxdepth] of direction;


procedure dumpnode(t : tree; level : integer; bearing : direction);

var
  i : integer;

begin
  if t <> nil then begin
    if level > maxdepth then
      fatal(progid, "Search tree too deep to dump");
    with t@ do begin
      join[level] := bearing;
      dumpnode(right, level + 1, starboard);
      for i := 1 to (level - 1) do begin
        if ord(join[i]) + ord(join[i + 1]) = 3 then
          write(lst, '|')
        else
          write(lst, ' ');
        write(lst, ' ':8)
      end;
      write(lst, '|');
      outname(lst, name, false);
      if (right <> nil) or (left <> nil) then
        write(lst, '--<');
      writeln(lst);
      dumpnode(left, level + 1, port)
    end
  end
end;


begin
  dumpnode(root, 1, lost)
end;


procedure dumplextree(var lst : text; root : tree);

const
  maxdepth = printerwidth div 9;

var
  i : integer;
  join : array [1..maxdepth + 1] of boolean;


procedure dumpcalls(t : tree; level : integer);

var
  list : call_list;
  ch : char;
  lev : integer;

begin
  if level > maxdepth then
    fatal(progid, "Lexical tree too deep to dump");
  with t@ do begin
    if printed in status then
      ch := '*'
    else begin
      ch := '|';
      lev := level + 1;
      status := status + [printed];
      list := tolist;
      while list <> nil do begin
        with list@ do begin
          dumpcalls(call, lev);
          join[lev] := true;
          list := next
        end
      end;
      status := status - [printed];
      join[lev] := false
    end;
    for lev := 1 to (level - 1) do begin
      if join[lev] then
        write(lst, '|')
      else
        write(lst, ' ');
      write(lst, ' ':8)
    end;
    write(lst, ch);
    outname(lst, name, false);
    if (tolist <> nil) and (ch = '|') then
      write(lst, '-/');
    writeln(lst)
  end
end;


begin
  for i := 1 to maxdepth do
    join[i] := false;
  dumpcalls(root, 1)
end;


procedure bindbranches(root, t : tree);


procedure scancalls(t : tree);

var
  list : call_list;
  tx : tree;


function associate(level : integer):tree;

var
  i : integer;
  tx : tree;

begin
  if level > root@.lex then
    associate := nil
  else begin
    tx := root;
    for i := 1 to (root@.lex - level) do
      tx := tx@.lexparent;
    associate := tx
  end
end;


begin
  with t@ do begin
    if not (tied in status) then begin
      if debug then begin
        write(' ':8);
        outname(output, name, false)
      end;
      if not (paved in status) then begin
        tx := associate(lex);
        if debug then begin
          if tx <> nil then begin
            write(' -- ');
            outname(output, tx@.name, false)
          end
        end;
        if tx <> nil then
          bind(tx, t)
      end;
      if debug then
        writeln;
      status := status + [tied];
      list := tolist;
      while list <> nil do begin
        with list@ do begin
          scancalls(call);
          list := next
        end
      end;
      status := status - [tied]
    end
  end
end;


begin
  scancalls(t)
end;


procedure reassignlevels(root : tree; level : integer);

var
  list : call_list;

begin
  with root@ do begin
    lex := level;
    if debug then begin
      write(' ':16);
      outname(output, name, false);
      writeln(level:4)
    end;
    list := tolist;
    while list <> nil do begin
      with list@ do begin
        if call@.lexparent = root then
          reassignlevels(call, level + 1);
        list := next
      end
    end
  end
end;


procedure buildsearchtree(var t : tree);

var
  thisblock : blocktype;
  module : rad50_name;
  s : string;
  i, j : integer;

begin
  if debug then begin
    writeln;
    writeln('Build Search Tree');
    writeln('-----------------');
    writeln
  end;
  while nextobj do begin
    openobj;
    thisblock := binaryblock;
    repeat
      initialgsd(module, thisblock);
      if debug then
        outname(output, module, false);
      r50tos(module, 6, s, stringlength);
      trim(s);
      if (match(module,datasection) = equal) or (s[length(s)] = '.') then begin
        data_psect := module;
        if debug then
          write(usersignal)
      end;
      if debug then
        writeln;
      insert(module, t);
      repeat
        skipblock
      until binaryblock = ENDMOD;
      skipblock;
      thisblock := binaryblock
    until thisblock = EOFOBJ
  end
end;


procedure references(t : tree);

var
  thisblock : blocktype;
  module : rad50_name;
  flags, value : integer;
  gsdent : gsdtype;
  this, that : tree;

begin
  if debug then begin
    writeln;
    writeln('References');
    writeln('----------');
    writeln
  end;
  while nextobj do begin
    openobj;
    thisblock := binaryblock;
    repeat
      initialgsd(module, thisblock);
      if debug then begin
        outname(output, module, false);
        writeln
      end;
      this := locate(module, t);
      if this = nil then
         fatal(progid, "Module name has disappeared");
      with this@ do begin
        repeat
          if thisblock = GSD then begin
            while blocklength > 0 do begin
              gsdentry(module, gsdent, flags, value);
              if (gsdent = GSN) and (iand(flags, 8) = 0) then begin
                if debug then begin
                  write(' ':8);
                  outname(output, module, false)
                end;
                that := locate(module, t);
                if (that <> nil) and (this <> that) then begin
                  if debug then
                    write(usersignal);
                  addlist(tolist, that);
                  with that@ do begin
                    addlist(fromlist, this);
                    status := status + [referred]
                  end
                end;
                if debug then
                  writeln
              end
            end
          end;
          skipblock;
          thisblock := binaryblock
        until thisblock = ENDMOD
      end;
      skipblock;
      thisblock := binaryblock
    until thisblock = EOFOBJ
  end
end;


procedure buildcalltree(root, t : tree);


procedure unreferenced(t : tree);

begin
  if t <> nil then begin
    with t@ do begin
      if debug then
        outname(output, name, false);
      if not (referred in status) then begin
        if debug then
          write(usersignal);
        addlist(root@.tolist, t);
        addlist(fromlist, root);
        status := status + [referred]
      end;
      if debug then
        writeln;
      unreferenced(left);
      unreferenced(right)
    end
  end
end;


begin
  if debug then begin
    writeln;
    writeln('Build Call Tree');
    writeln('---------------');
    writeln
  end;
  unreferenced(t);
  if root@.tolist = nil then
    fatal(progid, "No root section")
end;


procedure lexicallevels(root : tree);


procedure assignlevels(list : call_list; level : integer; lexp : tree);

var
  rlevel : integer;
  slist : call_list;

begin
  slist := list;
  rlevel := -level;
  while slist <> nil do begin
    with slist@ do begin
      with call@ do begin
        if lex = -1 then
          lex := lex + rlevel
      end;
      slist := next
    end
  end;
  while list <> nil do begin
    with list@ do begin
      with call@ do begin
        if lex < rlevel then begin
          if debug then begin
            outname(output, name, false);
            writeln(level:4)
          end;
          lex := level;
          lexparent := lexp;
          assignlevels(tolist, level + 1, call)
        end
      end;
      list := next
    end
  end
end;


begin
  if debug then begin
    writeln;
    writeln('Assign Lexical Levels');
    writeln('---------------------');
    writeln
  end;
  assignlevels(root@.tolist, 0, root)
end;


procedure datarelocation(root, t : tree);

var
  tx : tree;

begin
  if debug then begin
    writeln;
    writeln('Data Section Relocation');
    writeln('-----------------------');
    writeln
  end;
  tx := locate(data_psect, t);
  with tx@ do begin
    if lexparent <> root then begin
      addlist(root@.tolist, tx);
      addlist(fromlist, root);
      lexparent := root;
      reassignlevels(tx, root@.lex + 1)
    end
  end
end;


function relocate(root : tree):boolean;

var
  tx, ty : tree;
  list : call_list;
  sideeffects : boolean;


function followdown(t : tree):tree;

begin
  while not (paved in t@.status) do
    t := t@.lexparent;
  followdown := t
end;


begin
  sideeffects := false;
  with root@ do begin
    if debug then begin
      if lex = -1 then begin
        writeln;
        writeln('Relocate');
        writeln('--------');
        writeln
      end
    end;
    list := tolist;
    status := status + [paved];
    while list <> nil do begin
      with list@ do begin
        if call@.lexparent = root then
          sideeffects := sideeffects or relocate(call);
        list := next
      end
    end;
    if debug then begin
      outname(output, name, false);
      writeln
    end;
    ty := lexparent;
    list := fromlist;
    while list <> nil do begin
      with list@ do begin
        if debug then begin
          write(' ':8);
          outname(output, call@.name, false);
        end;
        if not (paved in call@.status) then begin
          if debug then
            write(usersignal);
          tx := followdown(call);
          if tx@.lex < ty@.lex then
            ty := tx
        end;
        if debug then
          writeln;
        list := next
      end
    end;
    if debug then begin
      outname(output, ty@.name, false);
      writeln(usersignal)
    end;
    if ty <> lexparent then begin
      sideeffects := true;
      addlist(ty@.tolist, root);
      addlist(fromlist, ty);
      lexparent := ty;
      reassignlevels(root, ty@.lex + 1)
    end;
    status := status - [paved]
  end;
  relocate := sideeffects
end;


procedure checkcalls(root : tree);

var
  lev : integer;
  list : call_list;


begin
  with root@ do begin
    if debug then begin
      if lex = -1 then begin
        writeln;
        writeln('Check Calls');
        writeln('-----------');
        writeln
      end
    end;
    lev := lex + 1;
    list := tolist;
    status := status + [paved];
    while list <> nil do begin
      with list@ do begin
        with call@ do begin
          if lexparent = root then
            checkcalls(call);
          if debug then begin
            outname(output, root@.name, false);
            write(' <- ');
            outname(output, name, false);
            writeln
          end;
          if lex = lev then begin
            if lexparent <> root then
              fatal(progid, "Illegal call to next lexical level")
          end
          else if lex > lev then
            fatal(progid, "Illeagl call to a higher lexical level")
          else begin
            if not ((paved in status) or (paved in lexparent@.status)) then
              fatal(progid, "Illegal call to lower or same lexical level");
            bindbranches(root, call);
            if (lex = root@.lex) and not bound(root, list@.call) then
              fatal(progid, "Call to same level not bound")
          end
        end;
        list := next
      end
    end;
    status := status - [paved]
  end
end;


procedure userbind(root, t : tree);

var
  goption, gbind1, gbind2 : string;
  t1, t2 : tree;
  r1, r2 : rad50_name;
  i : integer;
  ch : char;
  bind_all, bind_end : boolean;

begin
  bind_end := false;
  loop
    gtlin("Bind Option : ", goption);
    gtlin("Primary Subprogram   : ", gbind1);
    gtlin("Secondary Subprogram : ", gbind2);
    i := 0;
    bind_all := false;
    loop
      i := i + 1;
      ch := goption[i];
    exit if ch = chr(0);
      if ch = 'A' then bind_all := true
      else if ch = 'E' then bind_end := true
      else warn(progid, "Illegal binding option");
    end;
  exit if bind_end;
    trim(gbind1);
    trim(gbind2);
    stor50(gbind1, r1, 6);
    stor50(gbind2, r2, 6);
    t1 := locate(r1, t);
    t2 := locate(r2, t);
    if (t1 = nil) or (t2 = nil) then
      error(progid, "Cannot find subprogram")
    else begin
      if bind_all then begin
        bindbranches(t1, t2)
      end
      else begin
        if t1@.lexparent <> t2@.lexparent then
          error(progid, "Subprograms on different branches")
        else
          bind(t1,t2)
      end
    end
  end
end;


procedure stripmodules(var out : text; n : rad50_name; all : boolean);

var
  done : boolean;
  thisblock : blocktype;
  module : rad50_name;
  s : string;


procedure outword(w : integer);

begin
  write(out, chr(w), chr(w div 256))
end;


procedure blockheader(additional : integer);

begin
  write(out, chr(1), chr(0));
  outword(blocklength + additional + 4)
end;


begin
  if debug then begin
    writeln;
    writeln('Extracting Modules');
    writeln('------------------');
    writeln
  end;
  done := false;
  while not done and nextobj do begin
    openobj;
    thisblock := binaryblock;
    repeat
      initialgsd(module, thisblock);
      if debug then
        outname(output, module, false);
      if all or (match(module, n) = equal) then begin
        if debug then
          write(usersignal);
        r50convert(module, s, true, true);
        rewrite(out, s, "OBJ");
        blockheader(10);
        write(out, chr(ord(GSD)), chr(0));
        outword(module[1]);
        outword(module[2]);
        write(out, chr(0), chr(ord(MN)), chr(0), chr(0));
        loop
          blocklength := blocklength + 1;
          repeat
            write(out, chr(getbyte))
          until blocklength = 0;
        exit if thisblock = ENDMOD;
          thisblock := binaryblock;
          blockheader(2);
          write(out, chr(ord(thisblock)), chr(0));
        end;
        done := not all
      end
      else begin
        repeat
          skipblock
        until binaryblock = ENDMOD;
        skipblock
      end;
      if debug then
        writeln;
      thisblock := binaryblock
    until done or (thisblock = EOFOBJ)
  end
end;


procedure extractmodules(var out : text; root : tree);

var
  s : string;
  r : rad50_name;
  t : tree;

begin
  loop
    gtlin("Module : ", s);
  exit if s[1] = chr(0);
    trim(s);
    stor50(s, r, 6);
    t := locate(r, root);
    if t = nil then
      error(progid, "Subprogram not in object files")
    else begin
      stripmodules(out, r, false)
    end
  end
end;


procedure linkfiles(var com : text; root : tree);

var
  t, rung : tree;
  q : queue;
  list : call_list;

begin
  mark;
  writeln(com, 'R LINK');
  writeln(com, argv[execute]@, '=//');
  new(q);
  nullify(q);
  freequeue := nil;
  insertqueue(q, root);
  while not empty(q) do begin
    t := q@.tail@.item;
    deletequeue(q);
    with t@ do begin
      if not (printed in status) then begin
        if lex > -1 then begin
          outname(com, name, true);
          if lex > 0 then
            write(com, '/O:', lex);
          writeln(com);
          status := status + [printed];
          rung := ring;
          while rung <> t do begin
            with rung@ do begin
              outname(com, name, true);
              writeln(com);
              status := status + [printed];
              rung := ring
            end
          end
        end
      end;
      list := tolist;
      while list <> nil do begin
        with list@ do begin
          if not (printed in call@.status) then
            insertqueue(q, call);
          list := next
        end
      end
    end
  end;
  writeln(com, '//');
  writeln(com, '^C');
  release
end;


function initialise:boolean;

var
   i : integer;
  ch : char;

begin
  initialise := true;
  searchtree := nil;
  thisobj := initialobj;
  new(lextree);
  with lextree@ do begin
    name[1] := 130737b;    {.RO}
    name[2] := 060374b;    {OT.}
    status := [referred] + [tied];
    tolist := nil;
    fromlist := nil;
    lexparent := nil;
    lex := -1
  end;
  listopt := false;
  bindopt := false;
  stripopt := false;
  extractopt := false;
  if argc = 1 then
    initialise := false
  else begin
    if argv[option]@[0] = '-' then begin
      i := 0;
      loop
        i := i + 1;
        ch := argv[option]@[i];
      exit if ch = chr(0);
        if ch = 'E' then extractopt := true
        else if ch = 'L' then listopt := true
        else if ch = 'B' then bindopt := true
        else if ch = 'S' then stripopt := true;
      end;
      if listopt then
        argc := argc - 1;
      if extractopt then begin
        if stripopt then
          initialise := false
      end
    end;
    if argc < min_args then
      initialise := false
  end
end;



begin
  if initialise then begin
    if listopt then
      rewrite(f, argv[argc]@, "LST");
    buildsearchtree(searchtree);
    if listopt then begin
      writeln(f, 'Binary Search Tree Of Module Names');
      writeln(f, '----------------------------------');
      writeln(f);
      writeln(f);
      dumpsearchtree(f, searchtree)
    end;
    references(searchtree);
    buildcalltree(lextree, searchtree);
    if listopt then begin
      page(f);
      writeln(f, 'Initial Tree Of Module Calls');
      writeln(f, '----------------------------');
      writeln(f);
      writeln(f);
      dumplextree(f, lextree)
    end;
    lexicallevels(lextree);
    datarelocation(lextree, searchtree);
    while relocate(lextree) do ;
    if listopt then begin
      page(f);
      writeln(f, 'Final Tree Of Module Calls');
      writeln(f, '--------------------------');
      writeln(f);
      writeln(f);
      dumplextree(f, lextree)
    end;
    checkcalls(lextree);
    if bindopt then
      userbind(lextree, searchtree);
    if stripopt then
      stripmodules(f, lextree@.name, true);
    if extractopt then
      extractmodules(f, searchtree);
    rewrite(f, argv[command]@, "COM");
    linkfiles(f, lextree)
  end
  else begin
    writeln('Version  ', version);
    writeln;
    writeln('$-option command execute object ... [list]');
    writeln;
    writeln('command	Name of .COM file to be created');
    writeln('execute	Name of .SAV file to be created');
    writeln('object	Name(s) of .OBJ files to be linked');
    writeln('list	Optional .LST file to be generated');
    writeln;
    writeln('option B	Accept extra branch binding information');
    writeln('option E	Extract specified object modules and place on DK:');
    writeln('option L	Generate .LST file');
    writeln('option S	Extract all object modules and place on DK:');
    writeln;
    rerun
  end
end.