program test;
{ Test multi-tasking under MP/M with Pascal MT+86
  Uses simple booleans for task exclusion
  ABORT used for subtask termination		  }

  const
    pd_max = 61;  {max byte address in process descriptor table}
    uda_max = 255;  {max byte address in user data area table}
    def_prior = 201;  {default process priority}

  type
    name_type = packed array [1..8] of char;

    pd_size = 0..pd_max;  {Process Descriptor}
    pd_type =
      record
	case boolean of
	  true:
	    (z1: packed array [1..5] of byte;
	     prior: byte;
	     flag: word;
	     name: name_type;
	     uda: word;
	     user, disk: byte;
	     z2: packed array [1..12] of byte;
	     cns: byte;
	     z3: packed array [1..3] of byte;
	     list: byte;
	     z4: packed array [1..15] of byte;
	     cns2: byte;
	     z5: byte;
	     name2: name_type);
	  false:
	    (ray: array [pd_size] of byte);
      end;

    uda_size = 0..uda_max;  {User Data Area for Process}
    uda_type = array [uda_size] of byte;

    ptr = ^integer;
    pdp = ^pd_type;
    udap = ^uda_type;

    ptrtype = (ptrp, pdpp, udapp, offseg);
    pointer =
      record  {kludge to allow any type of pointer reference}
	case ptrtype of
	  ptrp:
	    (pptr: ptr);
	  pdpp:
	    (ppdp: pdp);
	  udapp:
	    (puda: udap);
	  offseg:
	    (off: word;
	     seg: word)
      end;

  var
    uda_b, uda_a: uda_type;  {user data area for sub-processes}
    pd_b, pd_a: pd_type;  {process descriptor for sub-processes}
    count_b, count_a: integer;
    flag_b, flag_a: boolean;
    done_b, done_a: boolean;

  external procedure init_mpm_util(size: integer);
  external procedure fix_stack(taskp: ptr;
			       var uda: uda_type;
			       size: integer);
  external procedure delay(ticks: integer);
  external procedure dispatch;
  external procedure abort(var pd: pd_type);
  external function create_process(var pd: pd_type): boolean;
  external function set_priority(priority: byte): boolean;

{ ********************************************************** }


  procedure startup(var pd: pd_type;
		    var uda: uda_type;
		    task: ptr;
		    name: string;
		    priority: integer;
		    size: integer);

    var
      i: integer;
      p: pointer;

    begin
      for i := 0 to pd_max do
	pd.ray[i] := 0;
      for i := 0 to uda_max do
	uda[i] := 0;

      pd.prior := priority;
      for i := 1 to 8 do
	begin
	pd.name[i] := name[i];
	pd.name2[i] := name[i]
	end;
      p.puda := addr(uda);
      pd.uda := shr(p.off, 4);  {make into paragraph address}
      fix_stack(task, uda, size);

      if create_process(pd) then
	writeln('Starting ', name)
      else
	writeln('Startup of ', name, ' failed');
    end;


  procedure task_a;

    begin
      while true do
	begin
	while flag_a do
	  delay(40);  {wait for flag to be cleared}
	count_a := count_a + 1;
	flag_a := true;
	end;
    end;


  procedure task_b;

    begin
      while true do
	begin
	while flag_b do
	  delay(50);  {wait for flag to be cleared}
	count_b := count_b + 1;
	flag_b := true;
	end;
    end;


  begin  {main program}
    writeln('Entered MAIN');
    if not set_priority(def_prior) then
      begin
      writeln('Unable to set main program priority');
      exit
      end;
    count_a := 0;	count_b := 0;
    flag_a := false;	flag_b := false;
    done_a := false;	done_b := false;
    init_mpm_util(6000);
    startup(pd_a, uda_a, addr(task_a), 'TASK_A  ', def_prior, 900);
    startup(pd_b, uda_b, addr(task_b), 'TASK_B  ', def_prior, 900);

    repeat
      dispatch;
      if flag_a then
	begin
	writeln('loop A count = ', count_a);
	flag_a := false
	end;
      if (count_a >= 10) and (not done_a) then
	begin
	abort(pd_a);
	writeln('Task A complete');
	done_a := true;
	end;
      if flag_b then
	begin
	writeln('loop B count = ', count_b);
	flag_b := false
	end;
      if (count_b >= 10) and (not done_b) then
	begin
	abort(pd_b);
	writeln('Task B complete');
	done_b := true;
	end;
    until done_a and done_b;

  end.