$title ('MP/M II V2.0  Submit')
submit:
do;

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

  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 (1) byte external;
  declare fcb16 (1) byte external;
  declare tbuff (1) byte external;

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

  print$console$buffer:
    procedure (buffer$address);
      declare buffer$address address;
      call mon1 (9,buffer$address);
    end print$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) byte;
      declare fcb$address address;
      return mon2 (16,fcb$address);
    end close$file;

  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) byte;
      declare fcb$address address;
      return mon2 (21,fcb$address);
    end write$record;

  create$file:
    procedure (fcb$address) byte;
      declare fcb$address address;
      return mon2 (22,fcb$address);
    end create$file;

  set$DMA:
    procedure (DMA$address);
      declare DMA$address address;
      call mon1 (26,DMA$address);
    end set$DMA;

  getuser:
    procedure byte;
      return mon2 (32,0ffh);
    end getuser;

  read$random:
    procedure (fcb$address);
      declare fcb$address address;
      call mon1 (33,fcb$address);
    end read$random;

  compute$file$size:
    procedure (fcb$address);
      declare fcb$address address;
      call mon1 (35,fcb$address);
    end compute$file$size;

  /**************************************
   *                                    *
   *       X D O S   Externals          *
   *                                    *
   **************************************/

  terminate:
    procedure;
      call mon1 (143,0);
    end terminate;

  parse$filename:
    procedure (pfcb$address) address;
      declare pfcb$address address;
      return mon2a (152,pfcb$address);
    end parse$filename;

  get$console$number:
    procedure byte;
      return mon2 (153,0);
    end get$console$number;

  system$data$adr:
    procedure address;
      return mon2a (154,0);
    end system$data$adr;

declare
    copyright(*) byte data
        (' Copyright(c) 1981, Digital Research ');

declare subflgadr address;
declare subflg based subflgadr (1) byte;

declare tmpfiledradr address;
declare tmpfiledr based tmpfiledradr byte;

declare
    include$level byte initial (0),
    cur$console byte,
    pfcb structure (
        ASCII$string address,
        FCB$address address )  initial (
        .a$buff,
        .a$sfcb  ),
    ln(5) byte initial('001 $'),
    ln1 byte at(.ln(0)),
    ln2 byte at(.ln(1)),
    ln3 byte at(.ln(2)),
    dfcb(33) byte initial(1,'$$$     ','SUB',0),
    console byte at(.dfcb(2)), /* current console number */
    drec byte at(.dfcb(32)),  /* current record */
    a$buff(128) byte at(.tbuff),   /* default buffer */
    a$sfcb(33)  byte at(.fcb);   /* default fcb */

declare
    (sfcb$adr,buff$adr,sstring$adr,sbp$adr) address,
    sfcb based sfcb$adr (33) byte,
    buff based buff$adr (128) byte,
    sstring based sstring$adr (128) byte,
    sbp based sbp$adr byte;

declare
    source (4) structure (
        sfcb (36) byte,
        buff (128) byte,
        sstring (128) byte,
        sbp byte  );

    /*  t h e    m p /  m   's u b m i t'   f u n c t i o n

    */
declare lit literally 'literally',
    dcl lit 'declare',
    proc lit 'procedure',
    addr lit 'address',
    lca  lit '110$0001b',  /* lower case a */
    lcz  lit '111$1010b',  /* lower case z */
    endfile lit '1ah';    /* cp/m end of file */

declare
    true literally '1',
    false literally '0',
    forever literally 'while true',
    cr literally '13',
    lf literally '10',
    what literally '63';

move: procedure(s,d,n);
    declare (s,d) address, n byte;
    declare a based s byte, b based d byte;
        do while (n := n - 1) <> 255;
        b = a; s = s + 1; d = d + 1;
        end;
    end move;

error: procedure(a);
    declare a address;
    call print$console$buffer(.(cr,lf,'$'));
    call print$console$buffer(.('error on line $'));
    call print$console$buffer(.ln1);
    call print$console$buffer(a);
    call terminate;
    end error;

/*
declare sstring(128) byte, |* substitute string *|
    sbp byte;             |* source buffer pointer (0-128) *|
*/


setup$adr: procedure;
    sfcb$adr = .source(include$level).sfcb;
    buff$adr = .source(include$level).buff;
    sstring$adr = .source(include$level).sstring;
    sbp$adr = .source(include$level).sbp;
    call set$DMA (.buff);
    end setup$adr;

setup: procedure;
    call setup$adr;
    call move (.a$sfcb,.sfcb,33);
    call move (.a$buff,.buff,128);
    subflgadr = system$data$adr + 128;
    cur$console = get$console$number;
    console = cur$console + '0';
    /* move buffer to substitute string */
    call move(.buff(1),.sstring(0),127);
    sstring(buff(0))=0; /* mark end of string */
    call move(.('SUB'),.sfcb(9),3); /* set file type to sub */
    if open$file(.sfcb(0)) = 255 then
        call error(.('no ''SUB'' file present$'));
    /* otherwise file is open - read subsequent data */
    sbp = 128; /* causes read below */
    sfcb(32) = 0; /* nr = 0 for sub file to read */

    end setup;


getsource: procedure byte;
    /* read the next source character */
    declare b byte;

    do forever;
      do while sbp > 127;
        if read$record (.sfcb) <> 0 then
        do;
          if include$level = 0
            then return endfile;
          include$level = include$level - 1;
          call setup$adr;
        end;
        else
          sbp = 0;
      end;
      if (b := buff((sbp:=sbp+1)-1)) = cr then
          do; /* increment line */
          if (ln3 := ln3 + 1) > '9' then
              do; ln3 = '0';
              if (ln2 := ln2 + 1) > '9' then
                  do; ln2 = '0';
                  ln1 = ln1 + 1;
                  end;
              end;
          end;
    /*
      |* translate to upper case *|
      if (b-61h) < 26 then |* lower case alpha *|
          b = b and 5fh; |* change to upper case *|
    */
  
      if (b <> endfile) or
         ((b = endfile) and (include$level = 0)) then
        return b;
      else
      do;
        include$level = include$level - 1;
        call setup$adr;
      end;
    end;
    end getsource;

writebuff: procedure;
    /* write the contents of the buffer to disk */
    if write$record(.dfcb) <> 0 then /* error */
        call error(.('disk write error$'));
    end writebuff;

declare rbuff(1) byte at (.minimum$buffer), /* jcl buffer */
    rbp address,      /* jcl buffer pointer */
    rlen byte;     /* length of current command */

fillrbuff: procedure;
    declare (s,ssbp) byte;  /* sub string buffer pointer */

    notend: procedure byte;
        /* look at next character in sstring, return
        true if not at the end of the string - char passed
        back in 's' */
        if not ((s := sstring(ssbp)) = ' ' or s = 0) then
            do;
            ssbp = ssbp + 1;
            return true;
            end;
        return false;
        end notend;

    deblankparm: procedure;
        /* clear to next non blank substitute string */
            do while sstring(ssbp) = ' ';
            ssbp = ssbp + 1;
            end;
        end deblankparm;

    putrbuff: procedure(b);
       declare b byte;
        if (rbp := rbp + 1) > (maxb-.rbuff) then
            call error(.('command buffer overflow$'));
        rbuff(rbp) = b;
        /* len: c1 ... c125 :00:$ = 128 chars */
        if (rlen := rlen + 1) > 125 then
            call error(.('command too long$'));
        end putrbuff;

    declare (reading,b,fptr) byte;
    /* fill the jcl buffer */
    rbuff(0) = 0ffh;
    rbp = 0;
    reading = true;
        do while reading;
          rlen = 0; /* reset command length */
          do while (b:=getsource) <> endfile and b <> cr;
            if b <> lf then
            do;
              if b = '$' then /* copy substitute string */
              do;
                if (b:=getsource) = '$' then
                  /* $$ replaced by $ */
                  call putrbuff(b);
                else
                do;
                   if (b and 0101$1111b) = 'I' then
                   do;
                     /* process include */
                     if (include$level:=include$level+1) = 4 then
                       call error (.(
                         'Exceeding 4 include levels$'));
                     do while (b:=getsource) <> ' ';
                     end;
                     fptr = 0;
                     b = getsource;
                     do while (b <> ' ') and
                              (b <> cr );
                       a$buff(fptr) = b;
                       if (fptr:=fptr+1) > 127 then
                         call error (.(
                           'Include filename too long$'));
                       b = getsource;
                     end;
                     a$buff(fptr) = '$';
                     call print$console$buffer (.(cr,lf,'$'));
                     call print$console$buffer (.('Include $'));
                     call print$console$buffer (.a$buff);
                     a$buff(fptr) = cr;
                     if parse$filename (.pfcb) = 0ffffh then
                       call error (.(
                         'Bad include filename$'));
                     if (a$buff(fptr):=b) <> cr then
                     do;
                       fptr = fptr + 1;
                       b = getsource;
                       do while b <> cr;
                         if b = '$' then
                         do;
                           b = getsource;
                           if b <> '$' then
                           do;
                             if (b := b - '0') > 9 then
                               call error (.('parameter error$'));
                             sstringadr = .source(include$level-1).sstring;
                             ssbp = 0; call deblankparm;
                             /* ready to scan sstring */
                             do while b <> 0; b = b - 1;
                               /* clear next parameter */
                               do while notend;
                               end;
                               call deblankparm;
                             end;
                             /* ready to copy substitute string from
                                position ssbp */
                             do while notend;
                               a$buff(fptr) = s;
                               fptr = fptr + 1;
                             end;
                             fptr = fptr - 1;
                             sstringadr = .source(include$level).sstring;
                           end;
                           else
                           do;
                             a$buff(fptr) = b;
                           end;
                         end;
                         else
                         do;
                           a$buff(fptr) = b;
                         end;
                         if (fptr:=fptr+1) > 127 then
                           call error (.(
                             'Include substring too long$'));
                         b = getsource;
                       end;
                     end;
                     a$buff(0) = fptr - 1;
                     call setup;
                   end;
                   else
                   do;
                     if (b := b - '0') > 9 then
                       call error(.('parameter error$'));
                     else
                     do; /* find string 'b' in sstring */
                       ssbp = 0; call deblankparm;
                       /* ready to scan sstring */
                       do while b <> 0; b = b - 1;
                         /* clear next parameter */
                         do while notend;
                         end;
                         call deblankparm;
                       end;
                       /* ready to copy substitute string from
                          position ssbp */
                       do while notend;
                         call putrbuff(s);
                       end;
                     end;
                   end;
                 end;
               end;
               else /* not a '$' */
               do;
                 if b = '^' then /* control character */
                 do; /* must be ^a ... ^z */
                   if (b:=getsource - 'A') > 25 then
                     call error(.(
                        'invalid control character$'));
                   else
                     call putrbuff(b+1);
                 end;
                 else /* not $ or ^ */
                   call putrbuff(b);
               end;
             end;
           end; /* of line or input file - compute length */
           reading = (b=cr);
           call putrbuff(rlen); /* store length */
         end;
    /* entire file has been read and processed */
    end fillrbuff;

makefile: procedure;
    /* write resulting command file */
    declare i byte;
    getrbuff: procedure byte;
        return rbuff(rbp := rbp - 1);
        end getrbuff;

    tmpfiledradr = system$data$adr + 196;
    dfcb(0) = tmpfiledr;
    call delete$file(.dfcb);
    drec = 0; /* zero the next record to write */
    if create$file(.dfcb) = 255
        then call error(.('directory full$'));
        do while (i := getrbuff) <> 0ffh;
        /* copy i characters to buffer */
        /* 00 $ at end of line gives 1.3 & 1.4 compatibility */
        buff(0) = i; buff(i+1) = 00; buff(i+2) = '$';
            do while i > 0;
            buff(i) = getrbuff; i=i-1;
            end;
        /* buffer filled to $ */
        call writebuff;
        end;
    if close$file(.dfcb) = 255
      then call error(.('close error$'));
      else subflg(cur$console) = (getuser or 1111$0000b);
    end makefile;

declare minimum$buffer (1024) byte;
declare last$dseg$byte byte
  initial (0);

start:
  do;
    call setup;
    call fillrbuff;
    call makefile;
    call terminate;
  end;
end submit;