Upload

Digital Research

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_1/dir.plm

@@ -0,0 +1,355 @@
+$ TITLE('MP/M II --- DIR 2.0')
+dir:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    19 Jan  80  by Thomas Rolander
+    14 Sept 81  by Doug Huskey
+*/
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data  (
+    0C3H,
+    .start-3);
+
+
+declare
+    true literally '1',
+    false literally '0',
+    forever literally 'while true',
+    lit literally 'literally',
+    proc literally 'procedure',
+    dcl literally 'declare',
+    addr literally 'address',
+    cr literally '13',
+    lf literally '10';
+
+
+  /**************************************
+   *                                    *
+   *       B D O S   INTERFACE          *
+   *                                    *
+   **************************************/
+
+
+  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;
+
+  mon3:
+    procedure (func,info) address external;
+      declare func byte;
+      declare info address;
+    end mon3;
+
+  declare cmdrv     byte    external;	/* command drive      */
+  declare fcb (1)   byte    external;	/* 1st default fcb    */
+  declare fcb16 (1) byte    external;	/* 2nd default fcb    */
+  declare pass0     address external;	/* 1st password ptr   */
+  declare len0      byte    external;	/* 1st passwd length  */
+  declare pass1     address external;	/* 2nd password ptr   */
+  declare len1      byte    external;	/* 2nd passwd length  */
+  declare tbuff (1) byte    external;	/* default dma buffer */
+
+  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$buf:
+    procedure (buffer$address);
+      declare buffer$address address;
+      call mon1 (9,buffer$address);
+    end print$buf;
+
+  check$con$stat:
+    procedure byte;
+      return mon2 (11,0);
+    end check$con$stat;
+
+  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;
+
+  setdma: procedure(dma);
+    declare dma address;
+    call mon1(26,dma);
+    end setdma;
+
+  get$user$code:
+    procedure byte;
+      return mon2 (32,0ffh);
+    end get$user$code;
+
+  set$user$code:
+    procedure(user);
+      declare user byte;
+      call mon1 (32,user);
+    end set$user$code;
+
+  declare
+    parse$fn structure (
+      buff$adr  address,
+      fcb$adr   address),
+    delimiter based parse$fn.buff$adr byte;
+
+  parse: procedure address;
+    return mon3(152,.parse$fn);
+    end parse;
+
+  terminate:
+    procedure;
+      call mon1 (143,0);
+    end terminate;
+
+  crlf:
+    procedure;
+      call write$console (0dh);
+      call write$console (0ah);
+    end crlf;
+
+
+
+/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+
+
+                * * *  GLOBAL VARIABLES  * * *
+
+
+ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+
+declare dir$title (*) byte initial
+  ('Directory for User  x:','$');
+
+declare (sys,temp,dcnt,cnt,user) byte;
+declare 
+   i          byte initial (0),
+   new$user   byte initial (true),
+   sys$exists byte initial (false),
+   incl$sys   byte initial (false),
+   option     byte initial (false);
+
+declare 
+   dirbuf (128) byte;
+
+
+/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+
+
+                * * *  DIRECTORY DISPLAY  * * *
+
+
+ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+                  /* display directory heading */
+heading: procedure;
+
+    if user > 9 then
+    do;
+      dir$title(19) = '1';
+      dir$title(20) = user - 10 + '0';
+    end;
+    else
+    do;
+      dir$title(19) = ' ';
+      dir$title(20) = user + '0';
+    end;
+    call print$buf (.dir$title);
+    end heading;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* do next directory display */
+directory: procedure;
+
+    if new$user then do;
+        call heading;
+        new$user = false;
+        end;
+    sys$exists = false;
+    cnt = -1;
+    /* if drive is 0 (default) 
+       then set to current disk */
+    if fcb(0) = 0
+      then fcb(0) = mon2 (25,0) + 1;
+    if fcb(1) = ' ' then
+    /* check for blank filename => wildcard */
+    do i = 1 to 11;
+      fcb(i) = '?';
+    end;
+    /* get first file */
+    if (dcnt := search$first (.fcb)) <> 0ffh then
+    do while dcnt <> 0ffh;
+      temp = ror(dcnt,3) and 0110$0000b;
+      sys = ((dirbuf(temp+10) and 80h) = 80h);
+      if (dirbuf(temp) = user) and
+         (incl$sys or not sys) then
+      do;
+        if ((cnt:=cnt+1) mod 4) = 0 then
+        do;
+          call crlf;
+          call write$console ('A'+fcb(0)-1);
+        end;
+        else
+        do;
+          call write$console (' ');
+        end;
+        call write$console (':');
+        call write$console (' ');
+        do i = 1 to 11;
+          if i = 9 then call write$console (' ');
+          call write$console
+            (dirbuf(temp+i) and 7fh);
+          if check$con$stat then
+          do;
+            dcnt = read$console;
+            call terminate;
+          end;
+        end;
+      end;
+      else if sys then
+        sys$exists = true;
+      dcnt = search$next (.fcb);
+    end;
+    if cnt = -1 then
+    do;
+      call print$buf (.(0dh,0ah,
+        'File not found.','$'));
+    end;
+    if sys$exists then 
+      call print$buf (.(0dh,0ah,
+        'System Files Exist','$'));
+    end directory;
+
+
+
+/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+
+
+                    * * *  PARSING  * * *
+
+
+ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
+
+
+                  /* parse next item */
+parse$next: procedure;
+
+    /* skip comma or space delimiter */
+    parse$fn.buff$adr = parse$fn.buff$adr + 1;
+    parse$fn.buff$adr = parse;
+    if parse$fn.buff$adr = 0ffffh then do;
+        call print$buf (.(0dh,0ah,
+          'Bad entry','$'));
+        call terminate;
+        end;
+    if delimiter = ']' then do;    /* skip */
+        parse$fn.buff$adr = parse$fn.buff$adr + 1;
+        if delimiter = 0 then 
+            parse$fn.buff$adr = 0;
+        option = false;
+        end;
+    if delimiter = '[' then 
+        option = true;
+    if parse$fn.buff$adr = 0 then 
+        option = false;
+    end parse$next;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* parse & interpret option */
+parse$option: procedure;
+
+    parse$fn.fcb$adr = .dirbuf;
+        do while option;
+        call parse$next;
+        if dirbuf(1) = 'S' then
+            incl$sys = true;
+        else if dirbuf(1) = 'G' then do;
+            if dirbuf(3) <> ' ' then 
+                temp = dirbuf(3) - '0' + 10;
+            else if dirbuf(2) <> ' ' then
+                temp = dirbuf(2) - '0';
+            if temp < 16 then do;
+                call set$user$code(user:=temp);
+                new$user = true;
+                end;
+            end;
+        end;
+    parse$fn.fcb$adr = .fcb;
+    end parse$option;
+
+
+
+/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+
+
+             * * *  M A I N   P R O G R A M  * * *
+
+
+ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
+
+declare last$dseg$byte byte
+  initial (0);
+
+start:
+  do;
+    user = get$user$code;
+    incl$sys = (fcb16(1) = 'S');
+    call setdma(.dirbuf);
+    parse$fn.buff$adr = .tbuff;
+    parse$fn.fcb$adr = .fcb;
+
+        /* scan for global option */
+        do while tbuff(i:=i+1)=' ';
+        end;
+    if tbuff(i) = '[' then do;   /* skip leading [ */
+        parse$fn.buff$adr = .tbuff(i);
+        option = true;
+        call parse$option;
+        fcb(0) = 0;              /* set current disk */
+        fcb(1) = ' ';            /* clear fcb */
+        call directory;
+        end;
+
+        /* do command line */
+        do while parse$fn.buff$adr <> 0;
+        call parse$next;      /* filename */
+        if option then
+            call parse$option;
+        call directory;
+        end;
+    call terminate;
+  end;
+
+end dir;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_1/era.plm

@@ -0,0 +1,422 @@
+$ TITLE('MP/M II --- ERA 2.0')
+erase:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    19 Jan  80  by Thomas Rolander
+    14 Sept 81  by Doug Huskey
+*/
+declare
+    mpmproduct literally '01h', /* requires mp/m */
+    cpmversion literally '30h'; /* requires 3.0 cp/m */
+
+
+declare
+    true    literally '1',
+    false   literally '0',
+    forever literally 'while true',
+    lit     literally 'literally',
+    proc    literally 'procedure',
+    dcl     literally 'declare',
+    addr    literally 'address',
+    cr      literally '13',
+    lf      literally '10',
+    ctrlc   literally '3',
+    ctrlx   literally '18h',
+    bksp    literally '8';
+
+$include (proces.lit)
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data  (
+    0C3H,
+    .start-3);
+
+
+  /**************************************
+   *                                    *
+   *       B D O S   INTERFACE          *
+   *                                    *
+   **************************************/
+
+
+  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;
+
+  mon3:
+    procedure (func,info) address external;
+      declare func byte;
+      declare info address;
+    end mon3;
+
+  declare cmdrv     byte    external;	/* command drive      */
+  declare fcb (1)   byte    external;	/* 1st default fcb    */
+  declare fcb16 (1) byte    external;	/* 2nd default fcb    */
+  declare pass0     address external;	/* 1st password ptr   */
+  declare len0      byte    external;	/* 1st passwd length  */
+  declare pass1     address external;	/* 2nd password ptr   */
+  declare len1      byte    external;	/* 2nd passwd length  */
+  declare tbuff (1) byte    external;	/* default dma buffer */
+
+
+  /**************************************
+   *                                    *
+   *       B D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  read$console:
+    procedure byte;
+      return mon2 (1,0);
+    end read$console;
+
+
+  printchar: 
+    procedure(char);
+    declare char byte;
+    call mon1(2,char);
+    end printchar;
+
+  conin: 
+    procedure byte;
+    return mon2(6,0fdh);
+    end conin;
+
+  print$buf:
+    procedure (buffer$address);
+      declare buffer$address address;
+      call mon1 (9,buffer$address);
+    end print$buf;
+
+
+  check$con$stat:
+    procedure byte;
+      return mon2 (11,0);
+    end check$con$stat;
+
+  version: procedure address;
+    /* returns current cp/m version # */
+    return mon3(12,0);
+    end version;
+
+  setdma: procedure(dma);
+    declare dma address;
+    call mon1(26,dma);
+    end setdma;
+
+  search:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (17,fcb$address);
+    end search;
+
+  searchn:
+    procedure byte;
+      return mon2 (18,0);
+    end searchn;
+
+  delete$file:
+    procedure (fcb$address) address;
+      declare fcb$address address;
+      return mon3 (19,fcb$address);
+    end delete$file;
+
+  get$user$code:
+    procedure byte;
+      return mon2 (32,0ffh);
+    end get$user$code;
+
+  /* 0ff => return BDOS errors */
+  return$errors:
+    procedure;
+      call mon1 (45,0ffh);	
+    end return$errors;
+
+
+  terminate:
+    procedure;
+      call mon1 (143,0);
+    end terminate;
+
+  declare
+    parse$fn structure (
+      buff$adr  address,
+      fcb$adr   address);
+
+  parse: procedure;
+    call mon1(152,.parse$fn);
+    end parse;
+
+
+declare
+    pdadr      addr,
+    pd         based pdadr process$descriptor;
+
+getpd: procedure;
+
+    pdadr = mon3(156,0);
+    end getpd;
+
+  /**************************************
+   *                                    *
+   *         GLOBAL VARIABLES           *
+   *                                    *
+   **************************************/
+
+  declare xfcb     byte initial(0);
+  declare successful lit '0FFh';
+
+  /**************************************
+   *                                    *
+   *       S U B R O U T I N E S        *
+   *                                    *
+   **************************************/
+
+
+                  /* upper case character from console */
+crlf:   proc;
+    call printchar(cr);
+    call printchar(lf);
+    end crlf;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* fill string @ s for c bytes with f */
+fill:   proc(s,f,c);
+    dcl s addr,
+        (f,c) byte,
+        a based s byte;
+
+        do while (c:=c-1)<>255;
+        a = f;
+        s = s+1;
+        end;
+    end fill;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* error message routine */
+error:   proc(code);
+   declare
+      code byte;
+
+    call printchar(' ');
+    if code=1 then 
+        call print$buf(.(cr,lf,'BDOS Bad Sector$'));
+    if code=2 then 
+        call print$buf(.(cr,lf,'Drive $'));
+    if code = 3 or code = 2 then
+        call print$buf(.('Read Only$'));
+    if code = 5 then      
+        call print$buf(.('Currently Opened$'));
+    if code = 7 then
+        call print$buf(.('Password Error$'));
+    if code < 3 then 
+        call terminate;
+    end error;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                 /* print file name */
+print$file: procedure(fcbp);
+        declare k byte;
+        declare typ lit '9';        /* file type */
+        declare fnam lit '11';        /* file type */
+        declare
+            fcbp   addr,
+            fcbv   based fcbp (32) byte;
+
+            do k = 1 to fnam;
+            if k = typ then 
+	       call printchar('.');
+            call printchar(fcbv(k) and 7fh);
+            end;
+        end print$file;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+  /* try to delete fcb at fcb$address
+            return error code if unsuccessful */
+  delete:
+    procedure(fcb$address) byte;
+    declare
+       fcb$address address,
+       fcbv based  fcb$address (32) byte,
+       error$code  address,
+       code        byte;
+       
+    if xfcb then 
+        fcbv(5) = fcbv(5) or 80h;
+    call setdma(.fcb16);                   /* password */
+    fcbv(0) = fcb(0);                      /* drive */
+    error$code = delete$file(fcb$address);
+    fcbv(5) = fcbv(5) and 7fh;             /* reset xfcb bit */
+    if low(error$code) = 0FFh then do;
+        code = high(error$code);
+        if (code=1) or (code=2) then 
+            call error(code);
+        return code;
+        end;
+    return successful;      
+    end delete;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* upper case character from console */
+ucase:   proc byte;
+    dcl c byte;
+
+    if (c:=conin) >= 'a' then
+       if c < '{' then
+          return(c-20h);
+    return c;
+    end ucase;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* get password and place at fcb + 16 */
+getpasswd:   proc;
+    dcl (i,c) byte;
+
+    call crlf;
+    call print$buf(.('Password ? ','$'));
+retry:
+    call fill(.fcb16,' ',8);
+        do i = 0 to 7;
+nxtchr:
+        if (c:=ucase) >= ' ' then 
+            fcb16(i)=c;
+        if c = cr then do;
+            call crlf;
+            go to exit;
+            end;
+        if c = ctrlx then
+            goto retry;
+        if c = bksp then do;
+            if i<1 then
+                goto retry;
+            else do;
+                fcb16(i:=i-1)=' ';
+                goto nxtchr;
+                end;
+            end;
+        if c = 3 then
+            call terminate;
+        end;
+exit:
+    c = check$con$stat;             /* clear raw I/O mode */
+    end getpasswd;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* try deleting files one at a time */
+  single$file:
+    procedure;
+    declare (code,dcnt,sav$searchl) byte;
+    declare (fcba,sav$dcnt) addr;
+
+    file$err: procedure;
+        call crlf;
+        call print$buf(.('Not erased: $'));
+        call print$file(fcba);
+        call error(code);
+        end file$err;
+
+    call setdma(.tbuff);
+    dcnt = search(.fcb);
+        do while dcnt <> 0ffh;
+        fcba = shl(dcnt,5) + .tbuff;
+        sav$dcnt = pd.dcnt;
+        sav$searchl = pd.searchl;
+        if (code:=delete(fcba)) = 7 then do;
+            call file$err;
+            call getpasswd;
+            code = delete(fcba);
+            end;
+        if code <> successful then 
+            call file$err;
+        call setdma(.tbuff);
+        /* restore dcnt and search length of 11 */
+        pd.dcnt = sav$dcnt;
+        pd.searchl = sav$searchl;
+        dcnt = searchn;
+        end;
+    end single$file;
+
+  /**************************************
+   *                                    *
+   *       M A I N  P R O G R A M       *
+   *                                    *
+   **************************************/
+
+
+declare (i,response,user,code) byte;
+declare ver address;
+declare last$dseg$byte byte
+  initial (0);
+
+start:
+  do;
+    ver = version;
+    if low(ver) <> cpmversion or high(ver) <> mpmproduct then do;
+      call print$buf (.(
+        'Requires MP/M 2.0','$'));
+      call mon1(0,0);
+      end;
+
+    parse$fn.buff$adr = .tbuff(1);
+    parse$fn.fcb$adr = .fcb;
+    user = get$user$code;
+    call getpd;             /* process descriptor */
+    call return$errors;
+    if fcb(17) <> ' ' then 
+        if fcb(17) = 'X' then 
+            xfcb = true;
+        else do;
+            call print$buf (.(
+              'Invalid Parameter$'));
+            call terminate;
+            end;
+
+    i = 0;
+      do while fcb(i:=i+1) = '?';
+      ;
+      end;
+    if i > 11 then
+      if not xfcb then 
+        do;
+        call print$buf (.(
+          'Confirm delete all user files (Y/N)?','$'));
+        response = read$console;
+        if not ((response = 'y') or
+              (response = 'Y'))
+        then call terminate;
+        end;
+    call parse;
+    if (code:=delete(.fcb)) <> successful then do;
+        if code = 0 then 
+            call print$buf (.(cr,lf,
+            'No file','$'));
+        else if code < 3 then 
+            call error(code);            /* fatal errors */
+        else 
+            call single$file;       /* single file error */
+        end;
+    call terminate;
+  end;
+
+end erase;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_1/eraq.plm

@@ -0,0 +1,411 @@
+$ TITLE('MP/M II --- ERAQ 2.0')
+eraseq:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    19 Jan  80  by Thomas Rolander
+    14 Sept 81  by Doug Huskey
+*/
+
+declare
+    mpmproduct literally '01h', /* requires mp/m */
+    cpmversion literally '30h'; /* requires 3.0 cp/m */
+
+
+declare
+    true    literally '1',
+    false   literally '0',
+    forever literally 'while true',
+    lit     literally 'literally',
+    proc    literally 'procedure',
+    dcl     literally 'declare',
+    addr    literally 'address',
+    cr      literally '13',
+    lf      literally '10',
+    ctrlc   literally '3',
+    ctrlx   literally '18h',
+    bksp    literally '8';
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data  (
+    0C3H,
+    .start-3);
+
+
+  /**************************************
+   *                                    *
+   *       B D O S   INTERFACE          *
+   *                                    *
+   **************************************/
+
+
+  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;
+
+  mon3:
+    procedure (func,info) address external;
+      declare func byte;
+      declare info address;
+    end mon3;
+
+  declare cmdrv     byte    external;	/* command drive      */
+  declare fcb (1)   byte    external;	/* 1st default fcb    */
+  declare fcb16 (1) byte    external;	/* 2nd default fcb    */
+  declare pass0     address external;	/* 1st password ptr   */
+  declare len0      byte    external;	/* 1st passwd length  */
+  declare pass1     address external;	/* 2nd password ptr   */
+  declare len1      byte    external;	/* 2nd passwd length  */
+  declare tbuff (1) byte    external;	/* default dma buffer */
+
+
+  /**************************************
+   *                                    *
+   *       B D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  read$console:
+    procedure byte;
+      return mon2 (1,0);
+    end read$console;
+
+
+  printchar: 
+    procedure(char);
+    declare char byte;
+    call mon1(2,char);
+    end printchar;
+
+  conin: 
+    procedure byte;
+    return mon2(6,0fdh);
+    end conin;
+
+  print$buf:
+    procedure (buffer$address);
+      declare buffer$address address;
+      call mon1 (9,buffer$address);
+    end print$buf;
+
+
+  check$con$stat:
+    procedure byte;
+      return mon2 (11,0);
+    end check$con$stat;
+
+  version: procedure address;
+    /* returns current cp/m version # */
+    return mon3(12,0);
+    end version;
+
+  setdma: procedure(dma);
+    declare dma address;
+    call mon1(26,dma);
+    end setdma;
+
+  search$first:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (17,fcb$address);
+    end search$first;
+
+  search$next:
+    procedure byte;
+      return mon2 (18,0);
+    end search$next;
+
+  delete$file:
+    procedure (fcb$address) address;
+      declare fcb$address address;
+      return mon3 (19,fcb$address);
+    end delete$file;
+
+  get$user$code:
+    procedure byte;
+      return mon2 (32,0ffh);
+    end get$user$code;
+
+  /* 0ff => return BDOS errors */
+  return$errors:
+    procedure;
+      call mon1 (45,0ffh);	
+    end return$errors;
+
+
+  terminate:
+    procedure;
+      call mon1 (143,0);
+    end terminate;
+
+  declare
+    parse$fn structure (
+      buff$adr  address,
+      fcb$adr   address);
+
+  parse: procedure;
+    call mon1(152,.parse$fn);
+    end parse;
+
+
+
+  /**************************************
+   *                                    *
+   *         GLOBAL VARIABLES           *
+   *                                    *
+   **************************************/
+
+  declare xfcb     byte initial(0);
+  declare successful lit '0FFh';
+
+  declare dir$entries (128) structure (
+     file (12) byte );
+
+  declare dir$entry$adr address;
+  declare dir$entry based dir$entry$adr (1) byte;
+
+  /**************************************
+   *                                    *
+   *       S U B R O U T I N E S        *
+   *                                    *
+   **************************************/
+
+
+                  /* upper case character from console */
+crlf:   proc;
+    call printchar(cr);
+    call printchar(lf);
+    end crlf;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* fill string @ s for c bytes with f */
+fill:   proc(s,f,c);
+    dcl s addr,
+        (f,c) byte,
+        a based s byte;
+
+        do while (c:=c-1)<>255;
+        a = f;
+        s = s+1;
+        end;
+    end fill;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* error message routine */
+error:   proc(code);
+   declare
+      code byte;
+
+    call printchar(' ');
+    if code=1 then 
+        call print$buf(.(cr,lf,'BDOS Bad Sector$'));
+    if code=2 then 
+        call print$buf(.(cr,lf,'Drive $'));
+    if code = 3 or code = 2 then
+        call print$buf(.('Read Only$'));
+    if code = 5 then      
+        call print$buf(.('Currently Opened$'));
+    if code = 7 then
+        call print$buf(.('Password Error$'));
+    if code < 3 then 
+        call terminate;
+    end error;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+  /* try to delete fcb at fcb$address
+            return error code if unsuccessful */
+  delete:
+    procedure(fcb$address) byte;
+    declare
+       fcb$address address,
+       fcbv based  fcb$address (32) byte,
+       error$code  address,
+       code        byte;
+       
+    if xfcb then 
+        fcbv(5) = fcbv(5) or 80h;
+    call setdma(.fcb16);                   /* password */
+    fcbv(0) = fcb(0);                      /* drive */
+    error$code = delete$file(fcb$address);
+    fcbv(5) = fcbv(5) and 7fh;             /* reset xfcb bit */
+    if low(error$code) = 0FFh then do;
+        code = high(error$code);
+        if (code=1) or (code=2) then 
+            call error(code);
+        return code;
+        end;
+    return successful;      
+    end delete;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* upper case character from console */
+ucase:   proc byte;
+    dcl c byte;
+
+    if (c:=conin) >= 'a' then
+       if c < '{' then
+          return(c-20h);
+    return c;
+    end ucase;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* get password and place at fcb + 16 */
+getpasswd:   proc;
+    dcl (i,c) byte;
+
+    call print$buf(.('Password ? ','$'));
+retry:
+    call fill(.fcb16,' ',8);
+        do i = 0 to 7;
+nxtchr:
+        if (c:=ucase) >= ' ' then 
+            fcb16(i)=c;
+        if c = cr then
+            go to exit;
+        if c = ctrlx then
+            goto retry;
+        if c = bksp then do;
+            if i<1 then
+                goto retry;
+            else do;
+                fcb16(i:=i-1)=' ';
+                goto nxtchr;
+                end;
+            end;
+        if c = 3 then
+            call terminate;
+        end;
+exit:
+    c = check$con$stat;             /* clear raw I/O mode */
+    end getpasswd;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* error on deleting a file */
+    file$err: procedure(code);
+        declare code byte;
+
+        call crlf;
+        call print$buf(.('Not erased, $'));
+        call error(code);
+        call crlf;
+        end file$err;
+
+
+
+  /**************************************
+   *                                    *
+   *       M A I N  P R O G R A M       *
+   *                                    *
+   **************************************/
+
+
+declare (i,j,k,code,response,user,dcnt) byte;
+declare ver address;
+
+declare last$dseg$byte byte
+  initial (0);
+
+start:
+  do;
+    ver = version;
+    if low(ver) <> cpmversion or high(ver) <> mpmproduct then do;
+      call print$buf (.(
+        'Requires MP/M 2.0','$'));
+      call mon1(0,0);
+      end;
+
+    if fcb(17) <> ' ' then 
+        if fcb(17) = 'X' then 
+            xfcb = true;
+        else do;
+            call print$buf (.(
+              'Invalid Parameter$'));
+            call terminate;
+            end;
+
+    if len0 <> 0 then do;
+      parse$fn.buff$adr = .tbuff(1);
+      parse$fn.fcb$adr = .fcb;
+      call parse;
+      end;
+    if fcb(0) = 0 then
+      fcb(0) = low (mon2 (25,0)) + 1;
+    i = -1;
+    user = get$user$code;
+    call return$errors;
+    dcnt = search$first (.fcb);
+    do while dcnt <> 0ffh;
+      dir$entry$adr = .tbuff(ror(dcnt,3) and 110$0000b);
+      if dir$entry(0) = user then
+      do;
+        if (i:=i+1) = 128 then
+        do;
+          call print$buf (.(
+            'Too many directory entries for query.','$'));
+          call terminate;
+        end;
+        call move (12,.dir$entry(1),.dir$entries(i));
+      end;
+      dcnt = search$next;
+    end;
+    if i = -1 then
+    do;
+      call print$buf (.(
+        'No file','$'));
+    end;
+    else
+    do j = 0 to i;
+      call printchar ('A'+fcb(0)-1);
+      call printchar (':');
+      call printchar (' ');
+      do k = 0 to 10;
+        if k = 8
+          then call printchar ('.');
+        call printchar (dir$entries(j).file(k));
+      end;
+      call printchar (' ');
+      call printchar ('?');
+      response = read$console;
+      call printchar (0dh);
+      call printchar (0ah);
+      if (response = 'y') or
+         (response = 'Y') then
+      do;
+        call move (12,.dir$entries(j),.fcb(1));
+        if (code:=delete(.fcb)) <> successful then do;
+            if code < 3 then 
+                call error(code);            /* fatal errors */
+            else if code = 7 then do;
+                call file$err(code);
+                call getpasswd;
+                code = delete(.fcb);
+                end;
+            if code <> successful then 
+                call file$err(code);
+            call crlf;
+            end;
+      end;
+    end;
+    call terminate;
+  end;
+
+end eraseq;
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_1/prla1.sub

@@ -0,0 +1,73 @@
+pip a:=dir.plm[g8]
+seteof dir.plm
+isx
+plm80 dir.plm nolist debug
+era dir.plm
+link dir.obj,x0100,plm80.lib to dir1.mod
+locate dir1.mod code(0100H) stacksize(100)
+era dir1.mod
+objhex dir1 to dir1.hex
+link dir.obj,x0200,plm80.lib to dir2.mod
+locate dir2.mod code(0200H) stacksize(100)
+era dir2.mod
+objhex dir2 to dir2.hex
+era dir2
+cpm
+objcpm dir1
+era dir*.
+era dir1.com
+pip dir.hex=dir1.hex,dir2.hex
+era dir1.hex
+era dir2.hex
+zero
+genmod dir.hex xdir.prl 
+era *.hex
+pip a:=ed.plm[g8]
+seteof ed.plm
+isx
+plm80 ed.plm nolist debug
+era ed.plm
+link ed.obj,x0100,plm80.lib to ed1.mod
+locate ed1.mod code(0100H) stacksize(100)
+era ed1.mod
+objhex ed1 to ed1.hex
+link ed.obj,x0200,plm80.lib to ed2.mod
+locate ed2.mod code(0200H) stacksize(100)
+era ed2.mod
+objhex ed2 to ed2.hex
+era ed2
+cpm
+objcpm ed1
+era ed1.com
+pip ed.hex=ed1.hex,ed2.hex
+era ed1.hex
+era ed2.hex
+zero
+genmod ed.hex xed.prl $$1000
+era *.hex
+pip a:=era.plm[g8]
+seteof era.plm
+isx
+plm80 era.plm nolist debug
+era era.plm
+link era.obj,x0100,plm80.lib to era1.mod
+locate era1.mod code(0100H) stacksize(100)
+era era1.mod
+objhex era1 to era1.hex
+link era.obj,x0200,plm80.lib to era2.mod
+locate era2.mod code(0200H) stacksize(100)
+era era2.mod
+objhex era2 to era2.hex
+era era2
+cpm
+objcpm era1
+era era*.
+era era1.com
+pip era.hex=era1.hex,era2.hex
+era era1.hex
+era era2.hex
+zero
+genmod era.hex xera.prl 
+era *.hex
+sub prla2
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_1/prla2.sub

@@ -0,0 +1,71 @@
+pip a:=eraq.plm[g8]
+seteof eraq.plm
+isx
+plm80 eraq.plm nolist debug
+era eraq.plm
+link eraq.obj,x0100,plm80.lib to eraq1.mod
+locate eraq1.mod code(0100H) stacksize(100)
+era eraq1.mod
+objhex eraq1 to eraq1.hex
+link eraq.obj,x0200,plm80.lib to eraq2.mod
+locate eraq2.mod code(0200H) stacksize(100)
+era eraq2.mod
+objhex eraq2 to eraq2.hex
+era eraq2
+cpm
+objcpm eraq1
+era eraq1.com
+pip eraq.hex=eraq1.hex,eraq2.hex
+era eraq1.hex
+era eraq2.hex
+zero
+genmod eraq.hex xeraq.prl 
+era *.hex
+pip a:=ren.plm[g8]
+seteof ren.plm
+isx
+plm80 ren.plm nolist debug
+era ren.plm
+link ren.obj,x0100,plm80.lib to ren1.mod
+locate ren1.mod code(0100H) stacksize(100)
+era ren1.mod
+objhex ren1 to ren1.hex
+link ren.obj,x0200,plm80.lib to ren2.mod
+locate ren2.mod code(0200H) stacksize(100)
+era ren2.mod
+objhex ren2 to ren2.hex
+era ren2
+cpm
+objcpm ren1
+era ren1.com
+pip ren.hex=ren1.hex,ren2.hex
+era ren1.hex
+era ren2.hex
+zero
+genmod ren.hex xren.prl 
+era *.hex
+pip a:=set.plm[g8]
+seteof set.plm
+isx
+plm80 set.plm nolist debug
+era set.plm
+link set.obj,x0100,plm80.lib to set1.mod
+locate set1.mod code(0100H) stacksize(100)
+era set1.mod
+objhex set1 to set1.hex
+link set.obj,x0200,plm80.lib to set2.mod
+locate set2.mod code(0200H) stacksize(100)
+era set2.mod
+objhex set2 to set2.hex
+era set2
+cpm
+objcpm set1
+era set1.com
+pip set.hex=set1.hex,set2.hex
+era set1.hex
+era set2.hex
+zero
+genmod set.hex xset.prl 
+era *.hex
+sub prla3
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_1/prla3.sub

@@ -0,0 +1,70 @@
+pip a:=show.plm[g8]
+seteof show.plm
+isx
+plm80 show.plm nolist debug
+era show.plm
+link show.obj,x0100,plm80.lib to show1.mod
+locate show1.mod code(0100H) stacksize(100)
+era show1.mod
+objhex show1 to show1.hex
+link show.obj,x0200,plm80.lib to show2.mod
+locate show2.mod code(0200H) stacksize(100)
+era show2.mod
+objhex show2 to show2.hex
+era show2
+cpm
+objcpm show1
+era show1.com
+pip show.hex=show1.hex,show2.hex
+era show1.hex
+era show2.hex
+zero
+genmod show.hex xshow.prl 
+era *.hex
+pip a:=stat.plm[g8]
+seteof stat.plm
+isx
+plm80 stat.plm nolist debug
+era stat.plm
+link stat.obj,x0100,plm80.lib to stat1.mod
+locate stat1.mod code(0100H) stacksize(100)
+era stat1.mod
+objhex stat1 to stat1.hex
+link stat.obj,x0200,plm80.lib to stat2.mod
+locate stat2.mod code(0200H) stacksize(100)
+era stat2.mod
+objhex stat2 to stat2.hex
+era stat2
+cpm
+objcpm stat1
+era stat1.com
+pip stat.hex=stat1.hex,stat2.hex
+era stat1.hex
+era stat2.hex
+zero
+genmod stat.hex xstat.prl 
+era *.hex
+pip a:=type.plm[g8]
+seteof type.plm
+isx
+plm80 type.plm nolist debug
+era type.plm
+link type.obj,x0100,plm80.lib to type1.mod
+locate type1.mod code(0100H) stacksize(100)
+era type1.mod
+objhex type1 to type1.hex
+link type.obj,x0200,plm80.lib to type2.mod
+locate type2.mod code(0200H) stacksize(100)
+era type2.mod
+objhex type2 to type2.hex
+era type2
+cpm
+objcpm type1
+era type1.com
+pip type.hex=type1.hex,type2.hex
+era type1.hex
+era type2.hex
+zero
+genmod type.hex xtype.prl 
+era *.hex
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_1/ren.plm

@@ -0,0 +1,514 @@
+$ TITLE('MP/M II --- REN 2.0')
+ren:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    19 Jan  80  by Thomas Rolander
+    14 Sept 81  by Doug Huskey
+*/
+
+
+declare
+    mpmproduct literally '01h', /* requires mp/m */
+    cpmversion literally '30h'; /* requires 3.0 cp/m */
+
+
+declare
+    true    literally '0FFh',
+    false   literally '0',
+    forever literally 'while true',
+    lit     literally 'literally',
+    proc    literally 'procedure',
+    dcl     literally 'declare',
+    addr    literally 'address',
+    cr      literally '13',
+    lf      literally '10',
+    ctrlc   literally '3',
+    ctrlx   literally '18h',
+    bksp    literally '8';
+
+$include (proces.lit)
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data  (
+    0C3H,
+    .start-3);
+
+
+  /**************************************
+   *                                    *
+   *       B D O S   INTERFACE          *
+   *                                    *
+   **************************************/
+
+
+  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;
+
+  mon3:
+    procedure (func,info) address external;
+      declare func byte;
+      declare info address;
+    end mon3;
+
+  declare cmdrv     byte    external;	/* command drive      */
+  declare fcb (1)   byte    external;	/* 1st default fcb    */
+  declare fcb16 (1) byte    external;	/* 2nd default fcb    */
+  declare pass0     address external;	/* 1st password ptr   */
+  declare len0      byte    external;	/* 1st passwd length  */
+  declare pass1     address external;	/* 2nd password ptr   */
+  declare len1      byte    external;	/* 2nd passwd length  */
+  declare tbuff (1) byte    external;	/* default dma buffer */
+
+
+  /**************************************
+   *                                    *
+   *       B D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  read$console:
+    procedure byte;
+      return mon2 (1,0);
+    end read$console;
+
+  conin: 
+    procedure byte;
+    return mon2(6,0fdh);
+    end conin;
+
+  printchar:
+    procedure (char);
+      declare char byte;
+      call mon1 (2,char);
+    end printchar;
+
+  print$buf:
+    procedure (buffer$address);
+      declare buffer$address address;
+      call mon1 (9,buffer$address);
+    end print$buf;
+
+
+  check$con$stat:
+    procedure byte;
+      return mon2 (11,0);
+    end check$con$stat;
+
+  version: procedure address;
+    /* returns current cp/m version # */
+    return mon3(12,0);
+    end version;
+
+  search$first:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (17,fcb$address);
+    end search$first;
+
+  search$next:
+    procedure byte;
+      return mon2 (18,0);
+    end search$next;
+
+  delete$file:
+    procedure (fcb$address);
+      declare fcb$address address;
+      call mon1 (19,fcb$address);
+    end delete$file;
+
+  rename$file:
+    procedure (fcb$address) address;
+      declare fcb$address address;
+      return mon3 (23,fcb$address);
+    end rename$file;
+
+  setdma: procedure(dma);
+    declare dma address;
+    call mon1(26,dma);
+    end setdma;
+
+  /* 0ff => return BDOS errors */
+  return$errors:
+    procedure(mode);
+    declare mode byte;
+      call mon1 (45,mode);	
+    end return$errors;
+
+  terminate:
+    procedure;
+      call mon1 (143,0);
+    end terminate;
+
+  declare
+    parse$fn structure (
+      buff$adr  address,
+      fcb$adr   address);
+
+  parse: procedure address;
+    return mon3(152,.parse$fn);
+    end parse;
+
+  declare
+    pdadr      addr,
+    pd         based pdadr process$descriptor;
+
+  getpd: procedure;
+
+    pdadr = mon3(156,0);
+    end getpd;
+
+
+  /**************************************
+   *                                    *
+   *         GLOBAL VARIABLES           *
+   *                                    *
+   **************************************/
+
+  /* Note: there are three fcbs used by
+     this program:
+
+         1) new$fcb: the new file name
+            (this can be a wildcard if it
+            has the same pattern of question
+            marks as the old file name)
+            Any question marks are replaced
+            with the corresponding filename
+            character in the old$fcb before
+            doing the rename function.
+
+         2) cur$fcb: the file to be renamed
+            specified in the rename command.
+            (any question marks must correspond
+            to question marks in new$fcb).
+
+         3) old$fcb: a fcb in the directory
+            matching the cur$fcb and used in
+            the bdos rename function.  This
+            cannot contain any question marks.
+  */         
+
+  declare successful lit '0FFh';
+  declare failed       (*) byte data(cr,lf,'Not renamed: $'),
+          read$only    (*) byte data(cr,lf,'Drive Read Only$'),
+          bad$wildcard (*) byte data('Invalid Wildcard$');
+  declare passwd (8) byte;
+  declare 
+      new$fcb$adr address,       /* new name */
+      new$fcb based  new$fcb$adr (32) byte;
+  declare cur$fcb (33) byte;      /* current fcb (old name) */
+
+  /**************************************
+   *                                    *
+   *       S U B R O U T I N E S        *
+   *                                    *
+   **************************************/
+
+
+                  /* upper case character from console */
+crlf:   proc;
+    call printchar(cr);
+    call printchar(lf);
+    end crlf;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* fill string @ s for c bytes with f */
+fill:   proc(s,f,c);
+    dcl s addr,
+        (f,c) byte,
+        a based s byte;
+
+        do while (c:=c-1)<>255;
+        a = f;
+        s = s+1;
+        end;
+    end fill;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* error message routine */
+error:   proc(code);
+   declare
+      code byte;
+
+    if code = 0 then do;  
+        call print$buf(.('No such file to rename$'));
+        call terminate;
+        end;
+    if code=1 then do;
+        call print$buf(.(cr,lf,'BDOS Bad Sector$'));
+        call terminate;
+        end;
+    if code=2 then do;
+        call print$buf(.read$only);
+        call terminate;
+        end;
+    if code = 3 then
+        call print$buf(.read$only(8));
+    if code = 5 then      
+        call print$buf(.('Currently Opened$'));
+    if code = 7 then
+        call print$buf(.('Password Error$'));
+    if code = 8 then      
+        call print$buf(.('already exists$'));
+    if code = 9 then do;
+        call print$buf(.bad$wildcard);
+        call terminate;
+        end;
+    end error;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                 /* print file name */
+print$file: procedure(fcbp);
+        declare k byte;
+        declare typ lit '9';        /* file type */
+        declare fnam lit '11';        /* file type */
+        declare
+            fcbp   addr,
+            fcbv   based fcbp (32) byte;
+
+            do k = 1 to fnam;
+            if k = typ then 
+	       call printchar('.');
+            call printchar(fcbv(k) and 7fh);
+            end;
+        end print$file;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+  /* try to rename fcb at old$fcb$adr to name at new$fcb$adr 
+            return error code if unsuccessful */
+  rename:
+    procedure(old$fcb$adr) byte;
+    declare
+       old$fcb$adr address,
+       old$fcb based  old$fcb$adr (32) byte,
+       error$code  address,
+       code        byte;
+       
+    call move (16,new$fcb$adr,old$fcb$adr+16);
+    call setdma(.passwd);                   /* password    */
+    call return$errors(0FFh);        /* return bdos errors */
+    error$code = rename$file (old$fcb$adr);
+    call return$errors(0);           /* normal error mode  */
+    if low(error$code) = 0FFh then do;
+        code = high(error$code);
+        if code < 3 then 
+            call error(code);
+        return code;
+        end;
+    return successful;      
+    end rename;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* upper case character from console */
+ucase:   proc(c) byte;
+    dcl c byte;
+
+    if c >= 'a' then
+       if c < '{' then
+          return(c-20h);
+    return c;
+    end ucase;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* get password and place at fcb + 16 */
+getpasswd:   proc;
+    dcl (i,c) byte;
+
+    call crlf;
+    call print$buf(.('Password ? ','$'));
+retry:
+    call fill(.passwd,' ',8);
+        do i = 0 to 7;
+nxtchr:
+        if (c:=ucase(conin)) >= ' ' then 
+            passwd(i)=c;
+        if c = cr then do;
+            call crlf;
+            go to exit;
+            end;
+        if c = ctrlx then
+            goto retry;
+        if c = bksp then do;
+            if i<1 then
+                goto retry;
+            else do;
+                passwd(i:=i-1)=' ';
+                goto nxtchr;
+                end;
+            end;
+        if c = ctrlc then
+            call terminate;
+        end;
+exit:
+    c = check$con$stat;             /* clear raw I/O mode */
+    end getpasswd;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* check for wildcard in rename command */
+wildcard:   proc byte;
+    dcl (i,wild) byte;
+
+    wild = false;
+        do i=1 to 11;
+        if cur$fcb(i) = '?' then
+            if new$fcb(i) <> '?' then do;
+                call print$buf(.failed);
+                call print$buf(.bad$wildcard);
+                call terminate;
+                end;
+            else
+                wild = true;
+        end;
+    return wild;
+    end wildcard;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* set up new name for rename function */
+set$new$fcb:   proc(old$fcb$adr);
+    dcl old$fcb$adr address,
+        old$fcb based old$fcb$adr (32) byte;
+    dcl i byte;
+
+    old$fcb(0) = cur$fcb(0);    /* set up drive */
+        do i=1 to 11;
+        if cur$fcb(i) = '?' then 
+            new$fcb(i) = old$fcb(i);
+        end;
+    end set$new$fcb;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* try deleting files one at a time */
+  single$file:
+    procedure;
+    declare (code,dcnt,savsearchl) byte;
+    declare (old$fcb$adr,savdcnt,savsearcha) addr;
+    declare old$fcb based old$fcb$adr (32) byte;
+ 
+    file$err: procedure(fcba);
+        dcl fcba address;
+        call print$buf(.failed);
+        call print$file(fcba);
+        call printchar(' ');
+        call error(code);
+        end file$err;
+
+    call setdma(.tbuff);
+    if (dcnt:=search$first(.cur$fcb)) = 0ffh then
+        call error(0);
+
+        do while dcnt <> 0ffh;
+        old$fcb$adr = shl(dcnt,5) + .tbuff;
+        savdcnt = pd.dcnt;
+        savsearcha = pd.searcha;
+        savsearchl = pd.searchl;
+        call set$new$fcb(old$fcb$adr);
+        if (code:=rename(old$fcb$adr)) = 8 then do;
+            call file$err(new$fcb$adr);
+            call print$buf(.(', delete (Y/N)?$'));
+            if ucase(read$console) = 'Y' then do;
+                call delete$file(new$fcb$adr);
+                code = rename(old$fcb$adr);
+                end;
+            else
+                go to next;
+            end;
+        if code = 7 then do;
+            call file$err(old$fcb$adr);
+            call getpasswd;
+            code = rename(old$fcb$adr);
+            end;
+        if code <> successful then 
+            call file$err(old$fcb$adr);
+        else do;
+            call crlf;
+            call print$file(new$fcb$adr);
+            call printchar('=');
+            call print$file(old$fcb$adr);
+            end;
+next:
+        call setdma(.tbuff);
+        pd.dcnt = savdcnt;
+        pd.searcha = savsearcha;
+        pd.searchl = savsearchl;
+        dcnt = search$next;
+        end;
+    end single$file;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* invalid rename command */
+bad$entry:   proc;
+
+    call print$buf(.failed);
+    call print$buf(.('Invalid File','$'));
+    call terminate;
+    end bad$entry;
+
+
+  /**************************************
+   *                                    *
+   *       M A I N  P R O G R A M       *
+   *                                    *
+   **************************************/
+
+declare ver address;
+
+declare last$dseg$byte byte
+  initial (0);
+
+start:
+  
+    ver = version;
+    if low(ver) <> cpmversion or high(ver) <> mpmproduct then 
+        call print$buf (.(
+          'Requires MP/M 2.0','$'));
+    else do;
+        call getpd;
+        parse$fn.buff$adr = .tbuff(1);
+        new$fcb$adr, parse$fn.fcb$adr = .fcb;
+        if (parse$fn.fcb$adr:=parse) <> 0FFFFh then do; /* old file */
+            parse$fn.buff$adr = parse$fn.fcb$adr + 1; /* skip delim */
+            parse$fn.fcb$adr  = .cur$fcb;
+            parse$fn.fcb$adr = parse;                /* new file */
+            call move (8,.cur$fcb+16,.passwd);       /* password */
+            end;
+        if parse$fn.fcb$adr = 0ffffh then 
+            call bad$entry;
+        if fcb(0) <> 0 then
+            if cur$fcb(0) <> 0 then do;
+                if fcb(0) <> cur$fcb(0) then
+                    call bad$entry;
+                end;
+            else
+                cur$fcb(0) = new$fcb(0);        /* set drive */
+        if wildcard then
+            call singlefile;
+        else if rename(.cur$fcb) <> successful then 
+            call singlefile;
+        end;
+    call mon1(0,0);
+
+end ren;
+
+

MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE 2/CUSPs_1/type.plm

@@ -0,0 +1,334 @@
+$ TITLE('MP/M II --- TYPE 2.0')
+type:
+do;
+
+$include (copyrt.lit)
+/*
+  Revised:
+    19 Jan  80  by Thomas Rolander
+    14 Sept 81  by Doug Huskey
+*/
+
+declare
+    mpmproduct literally '01h', /* requires mp/m */
+    cpmversion literally '30h'; /* requires 3.0 cp/m */
+
+
+declare
+    true    literally '0FFh',
+    false   literally '0',
+    forever literally 'while true',
+    lit     literally 'literally',
+    proc    literally 'procedure',
+    dcl     literally 'declare',
+    addr    literally 'address',
+    cr      literally '13',
+    lf      literally '10',
+    ctrlc   literally '3',
+    ctrlx   literally '18h',
+    bksp    literally '8';
+
+
+  declare start label;
+  declare jmp$to$start structure (
+    jmp$instr byte,
+    jmp$location address ) data  (
+    0C3H,
+    .start-3);
+
+
+  /**************************************
+   *                                    *
+   *       B D O S   INTERFACE          *
+   *                                    *
+   **************************************/
+
+
+  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;
+
+  mon3:
+    procedure (func,info) address external;
+      declare func byte;
+      declare info address;
+    end mon3;
+
+  declare cmdrv     byte    external;	/* command drive      */
+  declare fcb (1)   byte    external;	/* 1st default fcb    */
+  declare fcb16 (1) byte    external;	/* 2nd default fcb    */
+  declare pass0     address external;	/* 1st password ptr   */
+  declare len0      byte    external;	/* 1st passwd length  */
+  declare pass1     address external;	/* 2nd password ptr   */
+  declare len1      byte    external;	/* 2nd passwd length  */
+  declare tbuff (1) byte    external;	/* default dma buffer */
+
+
+  /**************************************
+   *                                    *
+   *       B D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  read$console:
+    procedure byte;
+      return mon2 (1,0);
+    end read$console;
+
+  printchar:
+    procedure (char);
+      declare char byte;
+      call mon1 (2,char);
+    end printchar;
+
+  conin: 
+    procedure byte;
+    return mon2(6,0fdh);
+    end conin;
+
+  print$buf:
+    procedure (buff$adr);
+      declare buff$adr address;
+      call mon1 (9,buff$adr);
+    end print$buf;
+
+  version: procedure address;
+    /* returns current cp/m version # */
+    return mon3(12,0);
+    end version;
+
+
+  check$con$stat:
+    procedure byte;
+      return mon2 (11,0);
+    end check$con$stat;
+
+  open$file:
+    procedure (fcb$address) address;
+      declare fcb$address address;
+    return mon3 (15,fcb$address);
+    end open$file;
+
+  close$file:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (16,fcb$address);
+    end close$file;
+
+  read$record:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (20,fcb$address);
+    end read$record;
+
+  setdma: procedure(dma);
+    declare dma address;
+    call mon1(26,dma);
+    end setdma;
+
+  /* 0ff => return BDOS errors */
+  return$errors:
+    procedure(mode);
+    declare mode byte;
+      call mon1 (45,mode);	
+    end return$errors;
+
+  terminate:
+    procedure;
+      call mon1 (143,0);
+    end terminate;
+
+  declare
+    parse$fn structure (
+      buff$adr  address,
+      fcb$adr   address);
+
+  parse: procedure;
+    call mon1(152,.parse$fn);
+    end parse;
+
+
+  /**************************************
+   *                                    *
+   *       S U B R O U T I N E S        *
+   *                                    *
+   **************************************/
+
+
+
+                  /* upper case character from console */
+crlf:   proc;
+    call printchar(cr);
+    call printchar(lf);
+    end crlf;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* fill string @ s for c bytes with f */
+fill:   proc(s,f,c);
+    dcl s addr,
+        (f,c) byte,
+        a based s byte;
+
+        do while (c:=c-1)<>255;
+        a = f;
+        s = s+1;
+        end;
+    end fill;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* upper case character from console */
+ucase:   proc byte;
+    dcl c byte;
+
+    if (c:=conin) >= 'a' then
+       if c < '{' then
+          return(c-20h);
+    return c;
+    end ucase;
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+                  /* get password and place at fcb + 16 */
+getpasswd:   proc;
+    dcl (i,c) byte;
+
+    call crlf;
+    call crlf;
+    call print$buf(.('Password ? ','$'));
+retry:
+    call fill(.fcb16,' ',8);
+        do i = 0 to 7;
+nxtchr:
+        if (c:=ucase) >= ' ' then 
+            fcb16(i)=c;
+        if c = cr then
+            go to exit;
+        if c = ctrlx then
+            goto retry;
+        if c = bksp then do;
+            if i<1 then
+                goto retry;
+            else do;
+                fcb16(i:=i-1)=' ';
+                goto nxtchr;
+                end;
+            end;
+        if c = 3 then
+            call terminate;
+        end;
+exit:
+    c = check$con$stat;             /* clear raw I/O mode */
+    end getpasswd;
+
+  /**************************************
+   *                                    *
+   *       M A I N  P R O G R A M       *
+   *                                    *
+   **************************************/
+
+
+  declare (eod,i,char) byte;
+  declare control$z literally '1AH';
+
+  /*
+    Main Program
+  */
+
+declare (cnt,tcnt) byte;
+declare (ver, error$code)  address;
+
+declare last$dseg$byte byte
+  initial (0);
+
+start:
+  do;
+    ver = version;
+    if low(ver) <> cpmversion or high(ver) <> mpmproduct then do;
+      call print$buf (.(
+        'Requires MP/M 2.0','$'));
+      call mon1(0,0);
+      end;
+
+    tcnt,
+    cnt = 0;
+    if fcb16(1) = 'P' then
+      do;
+      if fcb16(2) = ' ' or fcb16(2) = 'A' then   
+        cnt = 24;
+      else
+        cnt = (fcb16(2)-'0')*10
+           +(fcb16(3)-'0');
+      end;
+    if len0 <> 0 then do;
+      parse$fn.buff$adr = .tbuff(1);
+      parse$fn.fcb$adr = .fcb;
+      call parse;                       /* get password */
+      end;
+    call return$errors(0FEh);           /* return after error message */
+    call setdma(.fcb16);                /* set dma to password */
+    fcb(6) = fcb(6) or 80h;             /* open in RO mode     */
+    error$code = open$file (.fcb);
+    if low(error$code) = 0FFh then 
+      if high(error$code) = 7 then do;
+         call getpasswd;
+         call crlf;
+         call setdma(.fcb16);                /* set dma to password */
+         fcb(6) = fcb(6) or 80h;             /* open in RO mode     */
+         error$code = open$file(.fcb);
+         end;
+    if low(error$code) <> 0FFH then
+    do;
+      call return$errors(0);        /* reset error mode */
+      call setdma(.tbuff);
+      fcb(32) = 0;
+      eod = 0;
+      do while (not eod) and (read$record (.fcb) = 0);
+        do i = 0 to 127;
+          if (char := tbuff(i)) = control$z
+            then eod = true;
+          if not eod then
+          do;
+            if check$con$stat then
+            do;
+              i = read$console;
+              call terminate;
+            end;
+            if cnt <> 0 then
+            do;
+              if char = 0ah then
+              do;
+                if (tcnt:=tcnt+1) = cnt then
+                do;
+                  tcnt = read$console;
+                  tcnt = 0;
+                end;
+              end;
+            end;
+            call printchar (char);
+          end;
+        end;
+      end;
+    /*
+      call close (.fcb);
+      *** Warning ***
+      If this call is left in, the file can be destroyed.
+    */
+    end;
+    else if high(error$code) = 0 then
+      call print$buf (.('No file.','$'));
+    call terminate;
+  end;
+
+end type;
+
+