$title('MP/M 1.1 System Generation')
gensys:
do;

/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */
/*  Gensys   Gensys   Gensys   Gensys   Gensys   Gensys  */

$include (copyrt.lit)
/*
    Revised:
      7 Jan 80  by Thomas Rolander
*/

  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);

  declare copyright (*) byte data (
    'COPYRIGHT (C) 1980, DIGITAL RESEARCH ');
  declare serial$number (6) byte data (
    '654321');

  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;

  declare fcb (1) byte external;
  declare fcb16 (1) byte external;
  declare tbuff (1) byte external;

  /**************************************
   *                                    *
   *       B D O S   Externals          *
   *                                    *
   **************************************/

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

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

  write$console:
    procedure (char);
      declare char byte;
      call mon1 (2,char);
    end write$console;

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

  read$console$buffer:
    procedure (buffer$address);
      declare buffer$address address;
      declare buf based buffer$address (1) byte;
      buf(1) = 0;
      do while buf(1) = 0;
        call mon1 (10,buffer$address);
        if buf(1) = 0
          then call print$console$buffer (.(0ah,'?','$'));
      end;
      buf(buf(1)+2) = 0;
    end read$console$buffer;

  open$file:
    procedure (fcb$address) byte;
      declare fcb$address address;
      return mon2 (15,fcb$address);
    end open$file;

  close$file:
    procedure (fcb$address);
      declare fcb$address address;
      call mon1 (16,fcb$address);
    end close$file;

  search$first:
    procedure (fcb$address) byte;
      declare fcb$address address;
      return mon2 (17,fcb$address);
    end search$first;

  search$next:
    procedure (fcb$address) byte;
      declare fcb$address address;
      return mon2 (18,fcb$address);
    end search$next;

  delete$file:
    procedure (fcb$address);
      declare fcb$address address;
      call mon1 (19,fcb$address);
    end delete$file;

  read$record:
    procedure (fcb$address) byte;
      declare fcb$address address;
      return mon2 (20,fcb$address);
    end read$record;

  write$record:
    procedure (fcb$address);
      declare fcb$address address;
      if mon2 (21,fcb$address) <> 0 then
      do;
        call print$console$buffer (.(
          'Disk write error','$'));
        call system$reset;
      end;
    end write$record;

  create$file:
    procedure (fcb$address);
      declare fcb$address address;
      if mon2 (22,fcb$address) = 255 then
      do;
        call print$console$buffer (.(
          'Directory full','$'));
        call system$reset;
      end;
    end create$file;

  set$DMA$address:
    procedure (DMA$address);
      declare DMA$address address;
      call mon1 (26,DMA$address);
    end set$DMA$address;
  
  crlf:
    procedure;
      call write$console (0dh);
      call write$console (0ah);
    end crlf;


  gnctran:
    procedure(b) byte;
      declare b byte;
  
      if b < ' ' then return 0dh; /* all non-graphics */
      /* translate alpha to upper case */
      if b >= 'a' and b <= 'z' then
        b = b and 101$1111b; /* upper case */
      return b;
    end gnctran;
  
  parse:
    procedure (pcb$adr) address;
    declare pcb$adr address;
    declare pcb based pcb$adr structure (
      filename$adr address,
      fcb$adr address      );
    declare pcb$filename$adr address;
    declare pcb$fcb$adr address;
    declare filename based pcb$filename$adr (1) byte;
    declare fcb based pcb$fcb$adr (1) byte;
  
    declare
      /* return conditions */
      endline literally '00000H',
      badfile literally '0FFFFH',
      /* useful literals */
      disk    literally 'fcb(0)',
      fcbname literally '8',  /* end of name */
      fcbtype literally '11', /* end of type field */
      fcbsize literally '16'; /* partial size of fcb */
  
    declare char byte; /* global temp for current char */
    declare fnp  byte; /* index into file name buffer */
    declare fnlen byte;
  
    gnc:
      procedure;
  
        char = gnctran(filename(fnp := fnp + 1));
      end gnc;
  
    delimiter:
      procedure byte;
        declare i byte;
        declare del(*) byte data
          (0dh,' =.:<>_[],');
  
        do i = 0 to last(del);
          if char = del(i) then return true;
        end;
        return false;
      end delimiter;
  
    putchar:
      procedure;
  
        fcb(fnlen:=fnlen+1) = char;
        /* can check here for ambig ref's "char = '?'" */
      end putchar;
  
    fillq:
      procedure(len);
      /* fill current name or type with question marks */
  
        declare len byte;
  
        char = '?'; /* question mark */
        do while fnlen < len; 
          call putchar;
        end;
      end fillq;
  
    /* initialize local bases */
    pcb$filename$adr = pcb.filename$adr;
    pcb$fcb$adr      = pcb.fcb$adr;
    /* initialize file control block to empty */
    char  = ' ';
    fnlen  = 0;
    fnp   = -1;
    do while fnlen < fcbsize-1;
      if fnlen = fcbtype then char = 0;
      call putchar;
    end;
    disk = 0;
    /* scan next name */
    do forever;
    /* deblank command buffer */
      call gnc;
      do while char = ' ';
        call gnc;
      end;
      if delimiter then return badfile;
      fnlen = 0;
      do while not delimiter;
        if fnlen >= fcbname then /* error, file name too long */
          return badfile;
        if char = '*' then call fillq(fcbname); else call putchar;
        call gnc;
      end;
  
      /* check for disk name */
      if char = ':' then
      do;
        if not (disk = 0 and fnlen = 1) then
          return badfile;
        /* must be a disk name */
        if (disk := fcb(1) - 'A' + 1) > 26
          /* invalid disk name */
          then return badfile;
          /* valid disk name replace space in name */
          else fcb(fnlen) = ' ';
      end;
      else
      do;
        /* char is not ':', so file name is set. scan remainder */
        /* at least one char scanned */
        fnlen = fcbname;
        if char = '.' then /* scan file type */
        do;
          call gnc;
          do while not delimiter;
            if fnlen >= fcbtype then
              /* error, type field too long */
              return badfile;
            if char = '*'
              then call fillq(fcbtype);
              else call putchar;
              call gnc;
          end;
        end;
  
        if char = 0dh
          then return endline;
          else return .filename(fnp);
      end;
    end; /* of forever */
  end parse;

  declare pcb structure (
    filename$adr address,
    fcb$adr address      );
  declare nxt$chr$adr address;
  declare old$nxt$chr$adr address at (.pcb.filename$adr);
  declare char byte;
  declare ret byte at (.char);
  declare delim based nxt$chr$adr byte;
  declare fcbin (33) byte;
  declare fcbout (33) byte initial (
    0,'        ','   ',0,0,0,0,0,0,0,0,
    0,0,0,0,0,0,0,0,0,0,0,0,0);
  declare default$fcb (33) byte data (
    0,'        ','   ',0,0,0,0,0,0,0,0,
    0,0,0,0,0,0,0,0,0,0,0,0,0);
  declare rspfcb (33) byte initial (
    0,'????????','RSP',0,0,0,0,0,0,0,0,
    0,0,0,0,0,0,0,0,0,0,0,0,0);
  declare nmb$sect literally '32';
  declare buffer (nmb$sect) structure (
    record (128) byte);
  declare sysdatpg (256) byte at (.buffer(1));


  setup$output$file:
    procedure;
      pcb.filename$adr = .tbuff(1);
      pcb.fcb$adr = .fcbout;
      nxt$chr$adr = parse (.pcb);
      if delim <> '=' then
      do;
        if nxt$chr$adr = 0 then
        do;
          call print$console$buffer (.(
            'No input files specified','$'));
          go to error;
        end;
        if nxt$chr$adr = 0ffffh then
        do;
          call print$console$buffer (.(
            'Bad output file name','$'));
          go to error;
        end;
        call print$console$buffer (.(
          'A ''='' delimeter expected after output file name','$'));
        go to error;
      end;
      call set$DMA$address (.buffer);
      if open$file (.fcbout) <> 255
        then call delete$file (.fcbout);
      call create$file (.fcbout);
    end setup$output$file;

  setup$input$file:
    procedure;
      pcb.filename$adr = nxt$chr$adr + 1;
      pcb.fcb$adr = .fcbin;
      call move (33,.default$fcb,.fcbin);
      if (nxt$chr$adr := parse (.pcb)) = 0ffffh then
      do;
        call print$console$buffer (.(
          'Bad input file name','$'));
        go to error;
      end;
      call set$DMA$address (.buffer);
      if open$file (.fcbin) = 255 then
      do;
        call print$console$buffer (.(
          'No such input file','$'));
        go to error;
      end;
    end setup$input$file;

  copy$file:
    procedure;
      declare (i,cnt) byte;
      declare ok boolean;

      do forever;
        cnt = 0;
        ok = true;
        do while ok;
          call set$DMA$address (.buffer(cnt));
          if (ok := (read$record (.fcbin) = 0)) then
          do;
            ok = ((cnt:=cnt+1) <> nmb$sect);
          end;
          else
          do;
            if cnt = 0 then return;
          end;
        end;
        do i = 0 to cnt-1;
          call set$DMA$address (.buffer(i));
          call write$record (.fcbout);
        end;
        if cnt <> nmb$sect then return;
      end;
    end copy$file;

  declare lnbfr (14) byte initial (12);

  response:
    procedure byte;

      call read$console$buffer (.lnbfr);
      return (lnbfr(2) = 'y') or (lnbfr(2) = 'Y');
    end response;

  get$param:
    procedure (string$adr,val$adr);
      declare (string$adr,val$adr) address;
      declare val based val$adr byte;
      declare char byte;
      declare lbindx byte;

      call print$console$buffer (string$adr);
      val = 0;
      call read$console$buffer (.lnbfr);
      lbindx = 1;
      do while (char := gnctran(lnbfr(lbindx:=lbindx+1))) <> 0dh;
        if char = ',' then
        do;
          val$adr = val$adr + 1;
          val = 0;
        end;
        else
        do;
          char = char - '0';
          if char > 9 then
          do;
            if char > 16
              then char = char - 7;
              else char = 255;
          end;
          if char < 16 then
          do;
            val = val*16 + char;
          end;
          else
          do;
            char,
            val = 0;
            call print$console$buffer (.(
              '<- bad character, re-enter',0ah,0dh,'$'));
            call print$console$buffer (string$adr);
            call read$console$buffer (.lnbfr);
          end;
        end;
      end;
      call crlf;
    end get$param;

  make$system$dat:
    procedure;
      declare i byte;

      call move (12,.(0,'SYSTEM  DAT'),.fcb);
      call set$DMA$address (.buffer);
      if open$file (.fcb) <> 255
        then call delete$file (.fcb);
      call create$file (.fcb);
      do i = 0 to 255;
        sysdatpg(i) = 0;
      end;
      call move (43,.copyright,.sysdatpg(144));
      call print$console$buffer (.(  0ah,0dh,
        'MP/M 1.1 System Generation',0dh,0ah,
        '==========================',0dh,0ah,0ah,'$'));
      call get$param (.('Top page of memory = ','$'),
                      .sysdatpg(0));
      call get$param (.('Number of consoles = ','$'),
                      .sysdatpg(1));
      call get$param (.('Breakpoint RST #   = ','$'),
                      .sysdatpg(2));
      call print$console$buffer (
                      .('Add system call user stacks (Y/N)? ','$'));
      sysdatpg(3) = response;
      call print$console$buffer (.(0dh,0ah,
                      'Z80 CPU (Y/N)? ','$'));
      sysdatpg(5) = response;
      call print$console$buffer (.(0dh,0ah,
                      'Bank switched memory (Y/N)? ','$'));
      sysdatpg(4) = response;
      if sysdatpg(4) then
      do;
        call print$console$buffer (.(0dh,0ah,
                        'Banked BDOS file manager (Y/N)? ','$'));
        sysdatpg(6) = response;
        /* Bank switched memory segment table input */
        call print$console$buffer (.(0ah,0dh,
          'Enter memory segment table: (ff terminates list)',
          0ah,0dh,'$'));
        sysdatpg(15) = 0;
        i = 16;
        do while sysdatpg(i) <> 0ffh;
          if i = 48 then
          do;
            call print$console$buffer (.(
              ' Entry terminated, 8 segments maximum',0dh,0ah,'$'));
            sysdatpg(48) = 0ffh;
          end;
          else
          do;
            call get$param (.(' Base,size,attrib,bank = ','$'),
                            .sysdatpg(i));
            if sysdatpg(i) <> 0ffh then
            do;
              sysdatpg(15) = sysdatpg(15) + 1;
              i = i + 4;
            end;
          end;
        end;
      end;
      else
      do;
        call print$console$buffer (.(0ah,0dh,
          'Memory segment bases, (ff terminates list)',0ah,0dh,'$'));
        sysdatpg(i:=112) = 0;
        do while sysdatpg(i) <> 0ffh;
          i = i + 1;
          if i = 121 then
          do;
            sysdatpg(121) = 0ffh;
            call print$console$buffer (.(
              ' : ff  <- forced end, 8 segments maximum',0dh,0ah));
          end;
          else
          do;
            call get$param (.(' : ','$'),.sysdatpg(i));
            if i = 113 then
            do;
              if sysdatpg(113) = 0ffh then
              do;
                sysdatpg(113) = 0;
                sysdatpg(114) = 0ffh;
                i = 114;
              end;
            end;
            else
            do;
              if sysdatpg(i) <= sysdatpg(i-1) then
              do;
                i = i - 1;
                call print$console$buffer (.(
                  '*** error ***',
                  '  segment base must be greater than previous',
                  0dh,0ah,'$'));
              end;
            end;
          end;
        end;
        sysdatpg(15) = i - 113;
      end;
      call set$DMA$address (.sysdatpg);
      call write$record (.fcb);
      call set$DMA$address (.sysdatpg(128));
      call write$record (.fcb);
      call close$file (.fcb);
    end make$system$dat;

  declare rsp$filename (12) byte initial (
    '-------- ? ','$');

  setup$cmd$tail:
    procedure;
      declare (i,ret,ptr) byte;
      declare actual$rspfcb$adr address;
      declare actual$rspfcb based actual$rspfcb$adr (1) byte;
      declare nchars literally '45';

      call move (nchars,.('mpm.sys=system.dat,xios.spr,',
                'bdos.spr,xdos.spr'),.tbuff(1));
      if sysdatpg(6)
        then tbuff(29) = 'o';
      call set$DMA$address (.buffer);
      ret = search$first (.rspfcb);
      ptr = nchars;
      if ret <> 255 then
      do;
        call print$console$buffer (.(
          'Select Resident System Processes: (Y/N)',0dh,0ah,'$'));
        do while ret <> 255;
          actual$rspfcb$adr = .buffer + (ret mod 4)*32;
          call move (8,.actual$rspfcb(1),.rsp$filename);
          call print$console$buffer (.rsp$filename);
          if response then
          do;
            tbuff(ptr:=ptr+1) = ',';
            do i = 1 to 11;
              if i = 9
                then tbuff(ptr:=ptr+1) = '.';
              if actual$rspfcb(i) <> ' '
                then tbuff(ptr:=ptr+1) = actual$rspfcb(i);
            end;
          end;
          call crlf;
          ret = search$next (.rspfcb);
        end;
      end;
      tbuff(ptr:=ptr+1) = 0;
      tbuff(0) = ptr;
    end setup$cmd$tail;

  /*
      F i l e   C o n c a t e n a t i o n
  */

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

start:
  if fcb(1) = ' ' then
  do;
    call make$system$dat;
    call setup$cmd$tail;
  end;
  call setup$output$file;
  do forever;
    call setup$input$file;
    call copy$file;
    if nxt$chr$adr = 0 then
    do;
      call close$file (.fcbout);
      call system$reset;
    end;
  end;
  
error:
  call crlf;
  tbuff(tbuff(0)+1) = '$';
  call print$console$buffer (old$nxt$chr$adr);
  call system$reset;

end gensys;