$title('MP/M II V2.0  Spool Program')
spool:
do;

$include (copyrt.lit)
/*
  Revised:
    14 Sept 81  by Thomas Rolander
*/

$include (proces.lit)
$include (queue.lit)
$include (xdos.lit)
$include (fcb.lit)

/*
    Common Literals
*/

  declare true literally '0FFFFH';
  declare false literally '0';
  declare forever literally 'while true';
  declare boolean literally 'byte';

  declare start label;
  declare jmp$to$start structure (
    jmp$instr byte,
    jmp$location address ) data (
    0c3h,
    .start-3);

  mon1:
    procedure (func,info) external;
      declare func byte;
      declare info address;
    end mon1;

  mon2:
    procedure (func,info) byte external;
      declare func byte;
      declare info address;
    end mon2;

  mon2a:
    procedure (func,info) address external;
      declare func byte;
      declare info address;
    end mon2a;

  declare maxb address external;
  declare fcb fcb$descriptor external;
  declare tbuff fcb$descriptor external;

  declare get$user literally '32',
          get$disk literally '25';

  read$console:
    procedure byte;
      return mon2 (1,0);
    end read$console;

  print$console$buffer:
    procedure (buff$adr);
      declare buff$adr address;
      call mon1 (9,buff$adr);
    end print$console$buffer;

  check$console$status:
    procedure byte;
      return mon2 (11,0);
    end check$console$status;

  open:
    procedure (fcb$adr) byte public;
      declare fcb$adr address;
      declare fcb based fcb$adr fcb$descriptor;
      return mon2 (15,fcb$adr);
    end open;
  
  delete$file:
    procedure (fcb$adr) public;
      declare fcb$adr address;
      call mon1 (19,fcb$adr);
    end delete$file;

  readbf:
    procedure (fcb$adr) byte public;
      declare fcb$adr address;
      return mon2 (20,fcb$adr);
    end readbf;
  
  set$dma:
    procedure (dma$adr) public;
      declare dma$adr address;
      call mon1 (26,dma$adr);
    end set$dma;

  free$drives:
    procedure;
      call mon1 (39,0ffffh);
    end free$drives;

  co:
    procedure (char) public;
      declare char byte;
      call mon1 (2,char);
    end co;

  lo:
    procedure (char) public;
      declare char byte;
      call mon1 (5,char);
    end lo;

  system$reset:
    procedure;
      call mon1 (0,0);
    end system$reset;

  declare xdos literally 'mon2';
  declare xdosa literally 'mon2a';

  declare pcb structure (
    field$adr address,
    fcb$adr address)
    initial (0,.fcb);

  declare control$z literally '1AH';

  declare (nmbufs,actbuf) address;

  list$buf:
    procedure (buf$adr) byte;
      declare buf$adr address;
      declare buffer based buf$adr (1) byte;
      declare i byte;

      do i = 0 to 127;
        if (char := buffer(i)) = control$z
          then return true;
        itab = (char = 09H) and (7 - (column and 7));
        if char = 09H
          then char = ' ';
        do jtab = 0 to itab;
          if char >= ' '
            then column = column + 1;
          if char = 0AH then column = 0;
          call lo(char);
          if check$console$status then
          do;
            i = read$console;
            call system$reset;
          end;
        end;
      end;
      return false;
    end list$buf;

  copy$file:
    procedure (buf$base);
      declare buf$base address;
      declare buffer based buf$base (1) structure (
        record (128) byte);
      declare ok byte;
      declare i address;

      do forever;
        actbuf = 0;
        ok = true;
        do while ok;
          call set$dma (.buffer(actbuf));
          if (ok := (readbf (.fcb) = 0)) then
          do;
            ok = ((actbuf := actbuf+1) <> nmbufs);
          end;
          else
          do;
            if actbuf = 0 then return;
          end;
        end;
        do i = 0 to actbuf-1;
          if list$buf (.buffer(i))
            then return;
        end;
        if actbuf <> nmbufs then return;
      end;
    end copy$file;

  detach$msg:
    procedure;
      declare ret byte;

      call print$console$buffer (.(
             '- Enter STOPSPLR to abort the spooler',0dh,0ah,
             '- Enter ATTACH SPOOL to re-attach console to spooler',0dh,0ah,
             '*** Spooler detaching from console ***','$'));
      ret = xdos (detach,0);
    end detach$msg;

  declare ret byte;

  declare (char,column,itab,jtab,i) byte;

  declare nxt$chr$adr address;
  declare delim based nxt$chr$adr byte;

  declare spool$msg (1) byte at (.tbuff-1);

  declare SPOOLQ$uqcb userqcb
    initial (0,.spool$msg,'SPOOLQ  ');

  declare reserved$for$disk (3) byte;
  declare dummy$buffer (128) byte;
  declare buffer (1) structure (
    char (128) byte) at (.dummy$buffer);

  declare last$dseg$byte byte
    initial (0);


/*
  spool:
*/

start:

  call print$console$buffer (.(
    'MP/M II V2.0  Spooler',0dh,0ah,'$'));
  nxt$chr$adr = .tbuff;		/* make sure files exit */
  do while (nxt$chr$adr <> 0);
    pcb.field$adr = nxt$chr$adr + 1;
    nxt$chr$adr = xdosa (parse$fname,.pcb);
    if nxt$chr$adr = 0FFFFH then
    do;
      call print$console$buffer(.(0dh,0ah,
                                'Illegal File Name',0dh,0ah,'$'));
      call system$reset;
    end;
    else
    do;
      if open (.fcb) = 0FFH then
      do;
        call print$console$buffer (.(0dh,0ah,
                                   'Can''t Open File = $'));
        if fcb.et <> 0 then
        do;
          call co ('A'+fcb.et-1);
          call co (':');
        end;
        fcb.ex = '$';
        call print$console$buffer(.fcb.fn);
        call co (0dh);
        call co (0ah);
        call system$reset;
      end;
      call free$drives;
    end;
  end; /* of while */

  if xdos (open$queue,.SPOOLQ$uqcb) <> 0ffh then
  do;
    spool$msg(0) = xdos (get$disk,0)*16 + xdos (get$user,0ffh);
    spool$msg(1) = xdos (get$list$nmb,0)*16 + xdos (get$console$nmb,0);  
    if xdos (cond$write$queue,.SPOOLQ$uqcb) = 0ffh then
    do;
      call print$console$buffer (.(
        '*** Spool Queue is full ***',0dh,0ah,'$'));
    end;
    call system$reset;
  end;

  nmbufs = shr((maxb-.buffer),8);
  if xdos (cond$attach$list,0) = 0ffh then
  do;
    call print$console$buffer (.(
      '*** Printer busy ***',0dh,0ah,
      '- Spooler will wait until printer free',0dh,0ah,'$'));
    call detach$msg;
    ret = xdos (attach$list,0);
  end;
  else
  do;
    call detach$msg;
  end;
  nxt$chr$adr = .tbuff;
  do while (nxt$chr$adr <> 0) and
           (nxt$chr$adr <> 0FFFFH);
    pcb.field$adr = nxt$chr$adr + 1;
    nxt$chr$adr = xdosa (parse$fname,.pcb);
    if nxt$chr$adr <> 0FFFFH then
    do;
      fcb.fn(5) = (fcb.fn(5) or 80h);
      if open (.fcb) <> 0FFH then
      do;
        fcb.nr = 0;
        call copy$file(.buffer);
        call free$drives;
	if (nxt$chr$adr <> 0) and
           (delim = '[') then
        do;
          pcb.field$adr = nxt$chr$adr + 1;
          pcb.fcb$adr = .dummy$buffer;
          nxt$chr$adr = xdosa (parse$fname,.pcb);
          if nxt$chr$adr <> 0ffffh then
          do;
            if dummy$buffer(1) = 'D' then
            do;
              fcb.ex = 0;
              call delete$file (.fcb);
            end;
            if (nxt$chr$adr <> 0) and
               (delim <> ']') then
            do;
              nxt$chr$adr = 0ffffh;
            end;
          end;
          pcb.fcb$adr = .fcb;
        end;
      end;
    end;
  end; /* of while */
  call system$reset;
end spool;
