$ TITLE('MP/M II --- ED 2.0')
ED:
DO;
    /* MODIFIED FOR .PRL OPERATION MAY, 1979 */
    /* MODIFIED FOR OPERATION WITH CP/M 2.0 AUGUST 1979 */
    /* modified for MP/M 2.0 June 1981 */

declare
    mpmproduct literally '01h', /* requires mp/m */
    cpmversion literally '30h'; /* requires 3.0 cp/m */

DECLARE
    /* JMP EDCOMMAND - 3 (TO ADDRESS LXI SP) */
    EDJMP BYTE DATA(0C3H),
    EDADR ADDRESS DATA(.EDCOMMAND-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 */


DECLARE
    BDISK     BYTE    EXTERNAL, /* BOOT DISK 0004H */
    MAXB      ADDRESS EXTERNAL, /* MAX BASE 0006H */
    BUFF (128)BYTE    EXTERNAL, /* BUFFER 0080H */
    SECTSHF   LITERALLY '7',    /* SHL(1,SECTSHF) = SECTSIZE */
    SECTSIZE  LITERALLY '80H';  /* SECTOR SIZE */

BOOT: PROCEDURE EXTERNAL;
    /* SYSTEM REBOOT */
    END BOOT;

  /*  E D  :   T H E   C P / M   C O N T E X T    E D I T O R  */
 
    /*      COPYRIGHT (C) 1976, 1977, 1978, 1979, 1980, 1981
            DIGITAL RESEARCH
            BOX 579 PACIFIC GROVE
            CALIFORNIA 93950

            Revised:
              07 April 81  by Thomas Rolander
              14 Sept  81  by Doug Huskey
    */
DECLARE COPYRIGHT(*) BYTE DATA
   (' COPYRIGHT (C) 1981, DIGITAL RESEARCH ');
 
 /* COMMAND           FUNCTION
    -------           --------
     A            APPEND LINES OF TEXT TO BUFFER
     B            MOVE TO BEGINNING OR END OF TEXT
     C            SKIP CHARACTERS
     D            DELETE CHARACTERS
     E            END OF EDIT
     F            FIND STRING IN CURRENT BUFFER
     H            MOVE TO TOP OF FILE (HEAD)
     I            INSERT   CHARACTERS FROM KEYBOARD
                  UP TO NEXT <ENDFILE>
     J            JUXTAPOSITION OPERATION - SEARCH FOR FIRST STRING,
                  INSERT SECOND STRING, DELETE UNTIL THIRD STRING
     K            DELETE LINES
     L            SKIP LINES
     M            MACRO DEFINITION (SEE COMMENT BELOW)
     N            FIND NEXT OCCURRENCE OF STRING
                  WITH AUTO SCAN THROUGH FILE
     O            RE-EDIT OLD FILE
     P            PAGE AND DISPLAY (MOVES UP OR DOWN 24 LINES AND
                  DISPLAYS 24 LINES)
     Q            QUIT EDIT WITHOUT UPDATING THE FILE
     R<FILENAME>  READ FROM FILE <FILENAME>.LIB UNTIL <ENDFILE> AND
                  INSERT INTO TEXT
     S            SEARCH FOR FIRST STRING, REPLACE BY SECOND STRING
     T            TYPE LINES
     U            TRANSLATE TO UPPER CASE (-U CHANGES TO NO TRANSLATE)
     W            WRITE LINES OF TEXT TO FILE
     X            TRANSFER (XFER) LINES TO TEMP FILE
     Z            SLEEP FOR 1/2 SECOND (USED IN MACROS TO STOP DISPLAY)
     <CR>         MOVE UP OR DOWN AND PRINT ONE LINE
 

    IN GENERAL, THE EDITOR ACCEPTS SINGLE LETTER COMMANDS WITH OPTIONAL
INTEGER VALUES PRECEDING THE COMMAND.  THE EDITOR ACCEPTS BOTH UPPER AND LOWER
CASE COMMANDS AND VALUES, AND PERFORMS TRANSLATION TO UPPER CASE UNDER THE FOL-
LOWING CONDITIONS.  IF THE COMMAND IS TYPED IN UPPER CASE, THEN THE DATA WHICH
FOLLOWS IS TRANSLATED TO UPPER CASE.  THUS, IF THE "I" COMMAND IS TYPED IN
UPPER CASE, THEN ALL INPUT IS AUTOMATICALLY TRANSLATED (ALTHOUGH ECHOED IN
LOWER CASE, AS TYPED).  IF THE "A" COMMAND IS TYPED IN UPPER CASE, THEN ALL
INPUT IS TRANSLATED AS READ FROM THE DISK.  GLOBAL TRANSLATION TO UPPER CASE
CAN BE CONTROLLED BY THE "U" COMMAND (-U TO NEGATE ITS EFFECT).  IF YOU ARE
OPERATING WITH AN UPPER CASE ONLY TERMINAL, THEN OPERATION IS AUTOMATIC.
SIMILARLY, IF YOU ARE OPERATING WITH A LOWER CASE TERMINAL, AND TRANSLATION
TO UPPER CASE IS NOT SPECIFIED, THEN LOWER CASE CHARACTERS CAN BE ENTERED.

     A NUMBER OF COMMANDS CAN BE PRECEDED BY A POSITIVE OR
     NEGATIVE INTEGER BETWEEN 0 AND 65535 (1 IS DEFAULT IF NO VALUE
     IS SPECIFIED).  THIS VALUE DETERMINES THE NUMBER OF TIMES THE
     COMMAND IS APPLIED BEFORE RETURNING FOR ANOTHER COMMAND.
         THE COMMANDS
                       C D K L T P U  <CR>
     CAN BE PRECEDED BY AN UNSIGNED, POSITIVE, OR NEGATIVE NUMBER,
     THE COMMANDS
                       A F J N W Z
     CAN BE PRECEDED BY AN UNSIGNED OR POSITIVE NUMBER,
     THE COMMANDS
                       E H O Q
     CANNOT BE PRECEDED BY A NUMBER.  THE COMMANDS
                       F I J M R S
     ARE ALL FOLLOWED BY ONE OR MORE STRINGS OF CHARACTERS WHICH CAN
     BE OPTIONALLY SEPARATED OR TERMINATED BY EITHER <ENDFILE> OR <CR>.
     THE <ENDFILE> IS GENERALLY USED TO SEPARATE THE SEARCH STRINGS
     IN THE S AND J COMMANDS, AND IS USED AT THE END OF THE COMMANDS IF
     ADDITIONAL COMMANDS FOLLOW.  FOR EXAMPLE, THE FOLLOWING COMMAND
     SEQUENCE SEARCHES FOR  THE STRING 'GAMMA', SUBSTITUTES THE STRING
     'DELTA', AND THEN TYPES THE FIRST PART OF THE LINE WHERE THE
     CHANGE OCCURRED, FOLLOWED BY THE REMAINDER OF THE LINE WHICH WAS
     CHANGED:
                 SGAMMA<ENDFILE>DELTA<ENDFILE>0TT<CR>
 
     THE CONTROL-L CHARACTER IN SEARCH AND SUBSTITUTE STRINGS IS
     REPLACED ON INPUT BY <CR><LF> CHARACTERS.  THE CONTROL-I KEY
     IS TAKEN AS A TAB CHARACTER.
 
        THE COMMAND R MUST BE FOLLOWED BY A FILE NAME (WITH ASSUMED FILE
     TYPE OF 'LIB') WITH A TRAILING <CR> OR <ENDFILE>.  THE COMMAND
     I IS FOLLOWED BY A STRING OF SYMBOLS TO INSERT, TERMINATED BY
     A <CR> OR <ENDFILE>.  IF SEVERAL LINES OF TEXT ARE TO BE INSERTED,
     THE I CAN BE DIRECTLY FOLLOWED BY AN <ENDFILE> OR <CR> IN WHICH
     CASE THE EDITOR ACCEPTS LINES OF INPUT TO THE NEXT <ENDFILE>.
     THE COMMAND 0T PRINTS THE FIRST PART OF THE CURRENT LINE,
     AND THE COMMAND 0L MOVES THE REFERENCE TO THE BEGINNING OF THE
     CURRENT LINE.  THE COMMAND 0P PRINTS THE CURRENT PAGE ONLY, WHILE
     THE COMMAND 0Z READS THE CONSOLE RATHER THAN WAITING (THIS IS USED
     AGAIN WITHIN MACROS TO STOP THE DISPLAY - THE MACRO EXPANSION
     STOPS UNTIL A CHARACTER IS READ.  IF THE CHARACTER IS NOT A BREAK
     THEN THE MACRO EXPANSION CONTINUES NORMALLY).
 
        NOTE THAT A POUND SIGN IS TAKEN AS THE NUMBER 65535, ALL
     UNSIGNED NUMBERS ARE ASSUMED POSITIVE, AND A SINGLE - IS ASSUMED -1
 
     A NUMBER OF COMMANDS CAN BE GROUPED TOGETHER AND EXECUTED
     REPETITIVELY USING THE MACRO COMMAND WHICH TAKES THE FORM
 
             <NUMBER>MC1C2...CN<DELIMITER>
 
     WHERE <NUMBER> IS A NON-NEGATIVE INTEGER N, AND <DELIMITER> IS
     <ENDFILE> OR <CR>.  THE COMMANDS C1 ... CN  FOLLOWING THE M ARE
     EXECUTED N TIMES, STARTING AT THE CURRENT POSITION IN THE BUFFER.
     IF N IS 0, 1, OR OMITTED, THE COMMANDS ARE EXECUTED UNTIL THE END
     IF THE BUFFER IS ENCOUNTERED.
 
     THE FOLLOWING MACRO, FOR EXAMPLE, CHANGES ALL OCCURRENCES OF
     THE NAME 'GAMMA' TO 'DELTA', AND PRINTS THE LINES WHICH
     WERE CHANGED:
 
                 MFGAMMA<ENDFILE>-5DIDELTA<ENDFILE>0LT<CR>
 
    (NOTE: AN <ENDFILE> IS THE CP/M END OF FILE MARK - CONTROL-Z)
 
    IF ANY KEY IS DEPRESSED DURING TYPING OR MACRO EXPANSION, THE
    FUNCTION IS CONSIDERED TERMINATED, AND CONTROL RETURNS TO THE
    OPERATOR.
 
    ERROR CONDITIONS ARE INDICATED BY PRINTING ONE OF THE CHARACTERS:
 
     SYMBOL                    ERROR CONDITION
     ------      ----------------------------------------------------
     GREATER     FREE MEMORY IS EXHAUSTED - ANY COMMAND CAN BE ISSUED
                 WHICH DOES NOT INCREASE MEMORY REQUIREMENTS.
     QUESTION    UNRECOGNIZED COMMAND OR ILLEGAL NUMERIC FIELD
     POUND       CANNOT APPLY THE COMMAND THE NUMBER OF TIMES SPECFIED
                 (OCCURS IF SEARCH STRING CANNOT BE FOUND)
     LETTER O    CANNOT OPEN <FILENAME>.LIB IN R COMMAND
 
     THE ERROR CHARACTER IS ALSO ACCOMPANIED BY THE LAST CHARACTER
     SCANNED WHEN THE ERROR OCCURRED.                      */
 
DECLARE LIT LITERALLY 'LITERALLY',
    DCL LIT 'DECLARE',
    PROC LIT 'PROCEDURE',
    ADDR LIT 'ADDRESS',
    CTLL LIT '0CH',
    CTLR LIT '12H',  /* REPEAT LINE IN INSERT MODE */
    CTLU LIT '15H',  /* LINE DELETE IN INSERT MODE */
    CTLX LIT '18H',  /* EQUIVALENT TO CTLU */
    CTLH LIT '08H',  /* BACKSPACE */
    TAB LIT '09H',         /* TAB CHARACTER */
    LCA  LIT '110$0001B',  /* LOWER CASE A */
    LCZ  LIT '111$1010B',  /* LOWER CASE Z */
    ENDFILE LIT '1AH';    /* CP/M END OF FILE */
 
DECLARE
    MAX ADDRESS,                   /* .MEMORY(MAX)=0 (END) */
    MAXM ADDRESS,                  /* MINUS 1 */
    HMAX ADDRESS;                  /* = MAX/2 */
 
DECLARE
    us literally '8',  /* file from user 0   */
    RO LITERALLY '9',  /* R/O FILE INDICATOR */
    SY LITERALLY '10', /* SYSTEM FILE ATTRIBUTE */
    EX LITERALLY '12', /* EXTENT NUMBER POSITION */
    UB LITERALLY '13', /* UNFILLED BYTES */
    ck LITERALLY '13', /* checksum */
    MD LITERALLY '14', /* MODULE NUMBER POSITION */
    NR LITERALLY '32', /* NEXT RECORD FIELD */
    FS LITERALLY '33', /* FCB SIZE */
    RFCB (FS) BYTE /* READER FILE CONTROL BLOCK */
        INITIAL(0, /* FILE NAME */ '        ',
                   /* FILE TYPE */ 'LIB',0,0,0),
    RBP BYTE,      /* READ BUFFER POINTER */
    XFCB (FS) BYTE /* XFER FILE CONTROL BLOCK */
        INITIAL(0, 'X$$$$$$$','LIB',0,0,0),
    XFCBE BYTE AT(.XFCB(EX)),  /* XFCB EXTENT */
    XFCBM BYTE AT(.XFCB(MD)),  /* MODULE NUMBER */
    XFCBR BYTE AT(.XFCB(NR)),  /* XFCB RECORD # */
    xfcbc BYTE AT(.XFCB(ck)),  /* xfcb check sum # */
    XBUFF (SECTSIZE) BYTE, /* XFER BUFFER */
    XBP BYTE,              /* XFER POINTER */
    XFERON BYTE,           /* TRUE IF XFER ACTIVE */
    xchksum byte,          /* save xfcb checksum */

    NBUF BYTE,                 /* NUMBER OF BUFFERS */
    BUFFLENGTH ADDRESS,        /* NBUF * SECTSIZE */
    SFCB (FS) BYTE AT(.FCB),   /* SOURCE FCB = DEFAULT FCB */
    SBUFFADR ADDRESS,          /* SOURCE BUFFER ADDRESS */
    SBUFF BASED SBUFFADR (128) BYTE, /* SOURCE BUFFER */
    password (16) byte initial(0),    /* source password */

    DFCB (FS) BYTE,          /* DEST FILE CONTROL BLOCK */
    DFUB BYTE AT(.DFCB(UB)),  /* UNFILLED BYTES IN LAST RECORD */
    DBUFFADR ADDRESS,        /* DESTINATION BUFFER ADDRESS */
    DBUFF BASED DBUFFADR (128) BYTE, /* DEST BUFFER */
    NSOURCE ADDRESS,         /* NEXT SOURCE CHARACTER */
    NDEST   ADDRESS;         /* NEXT DESTINATION CHAR */
 
DECLARE SDISK BYTE,     /* SOURCE FILE DISK */
    DDISK BYTE;         /* DESTINATION FILE DISK */

 /* IO SECTION */
 
READCHAR: PROCEDURE BYTE; RETURN MON2(1,0);
    END READCHAR;

  conin: 
    procedure byte;
    return mon2(6,0fdh);
    end conin;

DECLARE TRUE LITERALLY '1', FALSE LITERALLY '0',
    FOREVER LITERALLY 'WHILE TRUE',
    CR LITERALLY '13',
    LF LITERALLY '10',
    WHAT LITERALLY '63';
 
DECLARE
   PRINTSUPPRESS BYTE, /* TRUE IF PRINT SUPPRESSED */
   sys byte initial(0), /* true if system file */
   protection byte initial(0); /* password protection mode */

declare
   error$code address;

PRINTCHAR: PROCEDURE(CHAR);
    DECLARE CHAR BYTE;
    IF PRINTSUPPRESS THEN RETURN;
    CALL MON1(2,CHAR);
    END PRINTCHAR;
 
DECLARE
    COLUMN  BYTE, /* CONSOLE COLUMN POSITION */
    SCOLUMN BYTE, /* STARTING COLUMN IN "I" MODE */
    TCOLUMN BYTE, /* TEMP DURING BACKSPACE */
    QCOLUMN BYTE; /* TEMP DURING BACKSPACE */

TTYCHAR: PROCEDURE(CHAR);
    DECLARE CHAR BYTE;
    IF CHAR >= ' ' THEN COLUMN = COLUMN + 1;
    IF CHAR = LF THEN COLUMN = 0;
    CALL PRINTCHAR(CHAR);
    END TTYCHAR;
 
BACKSPACE: PROCEDURE;
    /* MOVE BACK ONE POSITION */
    IF COLUMN = 0 THEN RETURN;
    CALL TTYCHAR(CTLH); /* COLUMN = COLUMN - 1 */
    CALL TTYCHAR(' ' ); /* COLUMN = COLUMN + 1 */
    CALL TTYCHAR(CTLH); /* COLUMN = COLUMN - 1 */
    COLUMN = COLUMN - 2;
    END BACKSPACE;

PRINTABS: PROCEDURE(CHAR);
    DECLARE (CHAR,I,J) BYTE;
    I = CHAR = TAB AND 7 - (COLUMN AND 7);
    IF CHAR = TAB THEN CHAR = ' ';
        DO J = 0 TO I;
        CALL TTYCHAR(CHAR);
        END;
    END PRINTABS;
 
GRAPHIC: PROCEDURE(C) BYTE;
    DECLARE C BYTE;
    /* RETURN TRUE IF GRAPHIC CHARACTER */
    IF C >= ' ' THEN RETURN TRUE;
    RETURN C = CR OR C = LF OR C = TAB;
    END GRAPHIC;

PRINTC: PROCEDURE(C);
    DECLARE C BYTE;
    IF NOT GRAPHIC(C) THEN
        DO; CALL PRINTABS('^');
        C = C + '@';
        END;
    CALL PRINTABS(C);
    END PRINTC;

CRLF: PROCEDURE;
    CALL PRINTC(CR); CALL PRINTC(LF);
    END CRLF;

PRINTM: PROCEDURE(A);
    DECLARE A ADDRESS;
    CALL MON1(9,A);
    END PRINTM;

PRINT: PROCEDURE(A);
    DECLARE A ADDRESS;
    CALL CRLF;
    CALL PRINTM(A);
    END PRINT;

READ: PROCEDURE(A);
    DECLARE A ADDRESS;
    CALL MON1(10,A);
    END READ;
 
DECLARE DCNT BYTE;
 
 
OPEN: PROCEDURE(FCB);
     DECLARE FCB ADDRESS;
     DCNT = MON2(15,FCB);
     END OPEN;
 
 
OPEN$FILE: PROCEDURE(FCB) ADDRESS;
     DECLARE FCB ADDRESS;
     RETURN MON3(15,FCB);
     END OPEN$FILE;
 
CLOSE: PROCEDURE(FCB);
    DECLARE FCB ADDRESS;
    DCNT = MON2(16,FCB);
    END CLOSE;
 
SEARCH: PROCEDURE(FCB);
    DECLARE FCB ADDRESS;
    DCNT = MON2(17,FCB);
    END SEARCH;
 
DELETE: PROCEDURE(FCB);
    DECLARE FCB ADDRESS;
    CALL MON1(19,FCB);
    END DELETE;
 
DISKREAD: PROCEDURE(FCB) BYTE;
    DECLARE FCB ADDRESS;
    RETURN MON2(20,FCB);
    END DISKREAD;
 
DISKWRITE: PROCEDURE(FCB) BYTE;
    DECLARE FCB ADDRESS;
    RETURN MON2(21,FCB);
    END DISKWRITE;
 
MAKE: PROCEDURE(FCB);
    DECLARE FCB ADDRESS;
    DCNT = MON2(22,FCB);
    END MAKE;
 
RENAME: PROCEDURE(FCB);
    DECLARE FCB ADDRESS;
    CALL MON1(23,FCB);
    END RENAME;
 
DECLARE (MAXLEN,COMLEN) BYTE, COMBUFF(128) BYTE,
    (TCBP,CBP) BYTE;
 
READCOM: PROCEDURE;
    MAXLEN = 128; CALL READ(.MAXLEN);
    END READCOM;
 
BREAK$KEY: PROCEDURE BYTE;
    IF MON2(11,0) THEN
        DO; /* CLEAR CHAR */
        CALL MON1(1,0); RETURN TRUE;
        END;
    RETURN FALSE;
    END BREAK$KEY;
 
CSELECT: PROCEDURE BYTE;
    /* RETURN CURRENT DRIVE NUMBER */
    RETURN MON2(25,0);
    END CSELECT;
 
SELECT: PROCEDURE(DISK);
    DECLARE DISK BYTE;
    /* SET DRIVE NUMBER */
    CALL MON1(14,DISK);
    END SELECT;
 
SETDMA: PROCEDURE(A);
    DECLARE A ADDRESS;
    /* SET DMA ADDRESS */
    CALL MON1(26,A);
    END SETDMA;
 
set$attribute: procedure(FCB);
    declare fcb address;
    call MON1(30,FCB);
    end set$attribute;
 
 
write$xfcb: PROCEDURE(FCB);
    DECLARE FCB ADDRESS;
    call move(8,.password,.password(8));
    if MON2(103,FCB)= 0ffh then
       call print(.('Error Creating Password$'));
    END write$xfcb;
 
read$xfcb: PROCEDURE(FCB);
    DECLARE FCB ADDRESS;
    call MON1(102,FCB);
    END read$xfcb;
 
  /* 0ff => return BDOS errors */
  return$errors:
    procedure(mode);
    declare mode byte;
      call mon1 (45,mode);	
    end return$errors;

REBOOT: PROCEDURE;
    IF XFERON THEN CALL DELETE(.XFCB);
    CALL BOOT;
    END REBOOT;


  version: procedure address;
    /* returns current cp/m version # */
    return mon3(12,0);
    end version;


  declare
    parse$fn structure (
      buff$adr  address,
      fcb$adr   address);

parse: procedure;
    call mon1(152,.parse$fn);
    end parse;

DECLARE /* LINE COUNTERS */
    BASELINE ADDRESS,       /* CURRENT LINE */
    RELLINE  ADDRESS,       /* RELATIVE LINE IN TYPEOUT */
    LINESET BYTE;           /* TRUE IF LINE #'S PRINTED */

  /*  INPUT / OUTPUT BUFFERING ROUTINES */
 
/* THE PL/M BUILT-IN PROCEDURE "MOVE" IS USED TO MOVE STORAGE,
   ITS DEFINITION IS:
    MOVE: PROCEDURE(COUNT,SOURCE,DEST);
        DECLARE (COUNT,SOURCE,DEST) ADDRESS;
        / MOVE DATA FROM SOURCE TO DEST ADDRESSES, FOR COUNT BYTES /
        END MOVE;
  */
 
ABORT: PROCEDURE(A);
    DECLARE A ADDRESS;
    CALL PRINT(A);
    CALL CRLF;
    CALL REBOOT;
    END ABORT;

 
delete$file: procedure(fcb);
    declare fcb address;
    call setdma(.password);
    call delete(fcb);
    end delete$file;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */


                  /* 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;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

FERR: PROCEDURE;
    CALL CLOSE(.DFCB); /* ATTEMPT TO CLOSE FILE FOR LATER RECOVERY */
    CALL ABORT (.('DISK OR DIRECTORY FULL$'));
    END FERR;
 
SETTYPE: PROCEDURE(A);
    DECLARE A ADDRESS;
    CALL MOVE(3,A,.DFCB+9);
    END SETTYPE;
 
XCLEAR: PROCEDURE;
    /* CLEAR THE XFER FILE PARAMETERS */
    XFERON, XFCBE, XFCBR, XBP = 0;
    END XCLEAR;

SETXDMA: PROCEDURE;
    CALL SELECT(SDISK);
    CALL SETDMA(.XBUFF);
    END SETXDMA;

FILLSOURCE: PROCEDURE;
    DECLARE I BYTE;
    ZN: PROCEDURE;
        NSOURCE = 0;
        END ZN;
 
     CALL ZN;
    CALL SELECT(SDISK);
        DO I = 0 TO NBUF;
        CALL SETDMA(SBUFFADR+NSOURCE);
        IF (DCNT := DISKREAD(.FCB)) <> 0 THEN
            DO; IF DCNT > 1 THEN CALL FERR;
            SBUFF(NSOURCE) = ENDFILE;
            I = NBUF;
            END;
        ELSE
            NSOURCE = NSOURCE + SECTSIZE;
        END;
    CALL ZN;
    END FILLSOURCE;
 
GETSOURCE: PROCEDURE BYTE;
    DECLARE B BYTE;
    IF NSOURCE >= BUFFLENGTH THEN CALL FILLSOURCE;
    IF (B := SBUFF(NSOURCE)) <> ENDFILE THEN
        NSOURCE = NSOURCE + 1;
    RETURN B;
    END GETSOURCE;
 
WRITEDEST: PROCEDURE;
    /* WRITE OUTPUT BUFFER UP TO (NOT INCLUDING) NDEST.
    LOW 7 BITS OF NDEST ARE ZERO */
    DECLARE (I,N) BYTE;
    ZN: PROCEDURE;
        NDEST = 0;
        END ZN;
 
    CALL SELECT(DDISK);
    IF LOW((N := SHR(NDEST,SECTSHF) - 1)) = 255 THEN RETURN;
    CALL ZN;
        DO I = 0 TO N;
        CALL SETDMA(DBUFFADR+NDEST);
        IF DISKWRITE(.DFCB) <> 0 THEN CALL FERR;
        NDEST = NDEST + SECTSIZE;
        END;
    CALL ZN;
    END WRITEDEST;
 
PUTDEST: PROCEDURE(B);
    DECLARE B BYTE;
    IF NDEST >= BUFFLENGTH THEN CALL WRITEDEST;
    DBUFF(NDEST) = B;
    NDEST = NDEST + 1;
    END PUTDEST;
 
PUTXFER: PROCEDURE(C);
    DECLARE C BYTE;
    /* WRITE C TO XFER FILE */
    IF XBP >= SECTSIZE THEN /* BUFFER OVERFLOW */
        DO; CALL SETXDMA;
        xfcbc = xchksum;
        IF DISKWRITE(.XFCB) <> 0 THEN CALL FERR;
        XBP = 0;
        xchksum = xfcbc;			/* save checksum */
        END;
    XBUFF(XBP) = C; XBP = XBP + 1;
    END PUTXFER;

FINIS: PROCEDURE;
    MOVEUP: PROCEDURE;
    CALL MOVE(16,.DFCB,.DFCB+16);
    END MOVEUP;
 
    /* CLEAR OUTPUT */
    /* SET UNFILLED BYTES - USED FOR ISIS-II COMPATIBILITY */
/*   DFUB = 0 ; <<<< REMOVE FOR MP/M 2 , CP/M 3 */
        DO WHILE (LOW(NDEST) AND 7FH) <> 0;
        /* COUNTS UNFILLED BYTES IN LAST RECORD */
        /* DFUB = DFUB + 1; */
        CALL PUTDEST(ENDFILE);
        END;
    CALL WRITEDEST;
 
    CALL CLOSE(.DFCB);
    IF DCNT = 255 THEN CALL FERR;
    if sys then do;
        dfcb(sy)=dfcb(sy) or 80h;
        call setdma(.password);
        call set$attribute(.dfcb);
        end;
    /* RENAME OLD FILE TO BAK */
    CALL SETTYPE(.('BAK')); CALL MOVEUP;
    CALL SELECT(SDISK);
    
    CALL MOVE(16,.FCB,.DFCB);
    call setdma(.password);
    CALL RENAME(.DFCB);
    CALL MOVEUP;
    /* RENAME $$$ TO OLD NAME */
    CALL SETTYPE(.('$$$'));
    CALL SELECT(DDISK);
    call setdma(.password);
    CALL RENAME(.DFCB);
    END FINIS;
 
 
DECLARE
    LPP LIT '23',          /* LINES PER PAGE */
    FORWARD LIT '1',
    BACKWARD LIT '0',
    RUBOUT LIT '07FH',
    POUND LIT '23H',
    MACSIZE LIT '128',       /* MAX MACRO SIZE */
    SCRSIZE LIT '100',       /* SCRATCH BUFFER SIZE */
    COMSIZE LIT 'ADDRESS';  /* DETERMINES MAX COMMAND NUMBER*/
 
DCL MACRO(MACSIZE) BYTE,
    SCRATCH(SCRSIZE) BYTE,     /* SCRATCH BUFFER FOR F,N,S */
    (WBP, WBE, WBJ)  BYTE,     /* END OF F STRING, S STRING, J STRING */
    (FLAG, MP, MI, XP) BYTE,
    MT COMSIZE;
 
DCL (START, RESTART, OVERCOUNT, OVERFLOW, RESET, BADCOM) LABEL;
 
DCL INSERTING BYTE,    /* TRUE IF INSERTING CHARACTERS */
    READBUFF  BYTE;    /* TRUE IF END OF READ BUFFER */
 
DECLARE
    EOS LITERALLY '0FFH';
 
 

PRINTNMAC: PROCEDURE(CHAR);
    DECLARE CHAR BYTE;
    /* PRINT IF NOT IN MACRO EXPANSION */
    IF MP <> 0 THEN RETURN;
    CALL PRINTC(CHAR);
    END PRINTNMAC;
 
 
 
 
DECLARE TRANSLATE BYTE, /* TRUE IF TRANSLATION TO UPPER CASE */
    UPPER BYTE;        /* TRUE IF GLOBALLY TRANLATING TO UC */
 
LOWERCASE: PROCEDURE(C) BYTE;
    DECLARE C BYTE;
    /* RETURN TRUE IF LOWER CASE ALPHABETIC */
    RETURN C >= LCA AND C <= LCZ;
    END LOWERCASE;
 
UCASE: PROCEDURE(C) BYTE;
    DECLARE C BYTE;
    /* TRANSLATE C TO UPPER CASE */
    IF LOWERCASE(C) THEN RETURN C AND 5FH;
    RETURN C;
    END UCASE;


                  /* get password and place at fcb + 16 */
getpasswd:   proc;
    dcl (i,c) byte;

    call crlf;
    call print(.('Password ? ','$'));
retry:
    call fill(.password,' ',8);
        do i = 0 to 7;
nxtchr:
        if (c:=ucase(conin)) >= ' ' then 
            password(i)=c;
        if c = cr then
            go to exit;
        if c = CTLX then
            goto retry;
        if c = CTLH then do;
            if i<1 then
                goto retry;
            else do;
                password(i:=i-1)=' ';
                goto nxtchr;
                end;
            end;
        if c = 3 then
            call reboot;
        end;
exit:
    c = break$key;     /* clear raw I/O mode */
    end getpasswd;
 
UTRAN: PROCEDURE(C) BYTE;
    DECLARE C BYTE;
    /* TRANSLATE TO UPPER CASE IF ALPHABETIC LOWER AND TRANSLATE */
    IF TRANSLATE THEN RETURN UCASE(C);
    RETURN C;
    END UTRAN;
 
PRINTVALUE: PROCEDURE(V);
    /* PRINT THE LINE VALUE V */
    DECLARE (D,ZERO) BYTE,
        (K,V) ADDRESS;
    K = 10000;
    ZERO = FALSE;
        DO WHILE K <> 0;
        D = LOW(V/K); V = V MOD K;
        K = K / 10;
        IF ZERO OR  D <> 0 THEN
            DO; ZERO = TRUE;
            CALL PRINTC('0'+D);
            END; ELSE
        CALL PRINTC(' ');
        END;
    END PRINTVALUE;

PRINTLINE: PROCEDURE(V);
    DECLARE V ADDRESS;
    IF NOT LINESET THEN RETURN;
    CALL PRINTVALUE(V);
    CALL PRINTC(':');
    CALL PRINTC(' ');
    IF INSERTING THEN CALL PRINTC(' '); ELSE
        CALL PRINTC('*');
    END PRINTLINE;


PRINTBASE: PROCEDURE;
    CALL PRINTLINE(BASELINE);
    END PRINTBASE;

PRINTNMBASE: PROCEDURE;
    IF MP <> 0 THEN RETURN;
    CALL PRINTBASE;
    END PRINTNMBASE;

READC: PROCEDURE BYTE;
    /* MAY BE MACRO EXPANSION */
    IF MP > 0 THEN
        DO;
        IF BREAK$KEY THEN GO TO OVERCOUNT;
        IF XP >= MP THEN
            DO; /* START AGAIN */
            IF MT <> 0 THEN
                DO; IF (MT:=MT-1) = 0 THEN
                    GO TO OVERCOUNT;
                END;
            XP = 0;
            END;
        RETURN UTRAN(MACRO((XP := XP + 1) - 1));
        END;
    IF INSERTING THEN RETURN UTRAN(READCHAR);
 
    /* GET COMMAND LINE */
    IF READBUFF THEN
        DO; READBUFF = FALSE;
        IF LINESET AND COLUMN = 0 THEN
            DO;
            IF BACK >= MAXM THEN
                CALL PRINTLINE(0); ELSE
                CALL PRINTBASE;
            END; ELSE
        CALL PRINTC('*');
        CALL READCOM; CBP = 0;
        CALL PRINTC(LF);
        COLUMN = 0;
        END;
    IF (READBUFF := CBP = COMLEN ) THEN COMBUFF(CBP) = CR;
    RETURN UTRAN(COMBUFF((CBP := CBP +1) -1));
    END READC;
 
SETRDMA: PROCEDURE;
    /* SET READ LIB DMA ADDRESS */
    CALL SELECT(SDISK);
    CALL SETDMA(.BUFF);
    END SETRDMA;

READFILE: PROCEDURE BYTE;
    IF RBP >= SECTSIZE THEN
        DO; CALL SETRDMA;
        IF DISKREAD(.RFCB) <> 0 THEN RETURN ENDFILE;
        RBP = 0;
        END;
    RETURN UTRAN(BUFF((RBP := RBP + 1) - 1));
    END READFILE;
 
SETUP: PROCEDURE;
    NSOURCE = BUFFLENGTH; NDEST = 0;
    parse$fn.buff$adr = .tbuff(1);
    parse$fn.fcb$adr = .fcb;
    if len0 <> 0 then do;
      call parse;		/* password in fcb16 */
      call move(8,.fcb16,.password);
      end;
    SFCB(EX), SFCB(MD), SFCB(NR) = 0;
    /* REEL AND RECORD ZEROED */
    /* COPY NAME TO DESTINATION FCB */
    CALL MOVE(33,.FCB,.DFCB);
    /* SOURCE AND DESTINATION DISKS SET */

    /* IF SOURCE AND DESTINATION DISKS DIFFER, CHECK FOR
    AN EXISTING SOURCE FILE ON THE DESTINATION DISK - THERE
    COULD BE A FATAL ERROR CONDITION WHICH COULD DESTROY A
    FILE IF THE USER HAPPENED TO BE ADDRESSING THE WRONG
    DISK */
    IF SDISK <> DDISK THEN
        DO; CALL SELECT(DDISK);
        CALL SEARCH(.FCB);
        IF DCNT <> 255 THEN /* SOURCE FILE PRESENT ON DEST DISK */
            CALL ABORT(.('FILE EXISTS, ERASE IT$'));
        END;
    CALL SELECT(SDISK);
    call return$errors(0FEh);            /* set error mode */
    call setdma(.password);
    error$code = open$file (.fcb);
    call return$errors(0);               /* reset error mode */
    if low(error$code) = 0FFh then 
      if high(error$code) = 7 then do;
         call getpasswd;
         call crlf;
         call crlf;
         call setdma(.password);         /* set dma to password */
         error$code = open$file(.fcb);
         end;
    dcnt=low(error$code);
    IF ROL(FCB(RO),1) THEN
        DO;
        CALL abort(.('** FILE IS READ/ONLY **$'));
        END; 
    else IF ROL(FCB(SY),1) THEN   /* system attribute */
        do;
        if rol(FCB(us),1) then
            dcnt = 0ffh;          /* user 0 file so create */
        else
            sys = true;
        end;
    IF DCNT = 255 THEN
        DO; CALL MAKE(.FCB);
        IF DCNT = 255 THEN CALL FERR;
        CALL PRINT(.('NEW FILE$'));
        CALL CRLF;
        END; 

    call read$xfcb(.dfcb);
    protection = dfcb(ex);       /* password protection mode */
    

    CALL SETTYPE(.('BAK'));
    CALL DELETE$file(.DFCB);
    IF SDISK <> DDISK THEN
        DO; /* REMOVE BAK FILES FROM DESTINATION DISK */
        CALL SELECT(DDISK);
        CALL DELETE$file(.DFCB);
        END;
    CALL SETTYPE(.('$$$'));
    CALL DELETE$file(.DFCB);
    DFCB(EX)=0;
    CALL SETDMA(.PASSWORD);
    CALL MAKE(.DFCB);
    IF DCNT = 255 THEN CALL FERR;
    /* THE TEMP FILE IS NOW CREATED */
    /* now create the password if any */
    if protection <> 0 then do;
        dfcb(ex) = protection or 1;  /* set password */
        call setdma(.password);
        call write$xfcb(.dfcb);
        end;
    dfcb(ex),DFCB(32) = 0;  /* NEXT RECORD IS ZERO */
    BASELINE = 1; /* START WITH LINE 1 */
    END SETUP;

DCL (DISTANCE, TDIST) COMSIZE,
    (DIRECTION, CHAR) BYTE,
    ( FRONT, BACK, FIRST, LAST) ADDR;
 
declare ver address;		/* VERSION NUMBER */

SETFF: PROCEDURE;
    DISTANCE = 0FFFFH;
    END SETFF;
 
DISTZERO: PROCEDURE BYTE;
    /* RETURN TRUE IF DISTANCE IS ZERO */
    RETURN DISTANCE = 0;
    END DISTZERO;
 
ZERODIST: PROCEDURE;
    DISTANCE = 0;
    END ZERODIST;
 
DISTNZERO: PROCEDURE BYTE;
    /* CHECK FOR ZERO DISTANCE AND DECREMENT */
    IF NOT DISTZERO THEN
        DO; DISTANCE = DISTANCE - 1;
        RETURN TRUE;
        END;
    RETURN FALSE;
    END DISTNZERO;
 
SETLIMITS: PROC;
    DCL (I,K,L,M) ADDR, (MIDDLE,LOOPING) BYTE;
    RELLINE = 1; /* RELATIVE LINE COUNT */
    IF DIRECTION = BACKWARD THEN
        DO; DISTANCE = DISTANCE+1; I = FRONT; L = 0; K = 0FFFFH;
        END; ELSE
        DO; I = BACK; L = MAXM; K = 1;
        END;
 
    LOOPING = TRUE;
        DO WHILE LOOPING;
            DO WHILE (MIDDLE := I <> L) AND
                MEMORY(M:=I+K) <> LF;
            I = M;
            END;
        RELLINE = RELLINE - 1;
        LOOPING = (DISTANCE := DISTANCE - 1) <> 0;
        IF NOT MIDDLE THEN
            DO; LOOPING = FALSE;
            I = I - K;
            END; ELSE
        IF LOOPING THEN I = M;
        END;
 
    IF DIRECTION = BACKWARD THEN
        DO; FIRST = I; LAST = FRONT - 1;
        END; ELSE
        DO; FIRST = BACK + 1; LAST = I + 1;
        END;
    END SETLIMITS;
 
INCFRONT: PROC; FRONT = FRONT + 1;
    END INCFRONT;
INCBACK: PROCEDURE; BACK = BACK + 1;
    END INCBACK;
DECFRONT: PROC; FRONT = FRONT - 1;
    END DECFRONT;
DECBACK: PROC; BACK = BACK - 1;
    END DECBACK;
INCBASE: PROCEDURE;
    BASELINE = BASELINE + 1;
    END INCBASE;

 
MEM$MOVE: PROC(MOVEFLAG);
    DECLARE (MOVEFLAG,C) BYTE;
    /* MOVE IF MOVEFLAG IS TRUE */
    IF DIRECTION = FORWARD THEN
        DO WHILE BACK < LAST; CALL INCBACK;
        IF MOVEFLAG THEN
            DO;
            IF (C := MEMORY(BACK)) = LF THEN CALL INCBASE;
            MEMORY(FRONT) = C; CALL INCFRONT;
            END;
        END; ELSE
        DO WHILE FRONT > FIRST; CALL DECFRONT;
        IF (C := MEMORY(FRONT)) = LF THEN BASELINE = BASELINE - 1;
        IF MOVEFLAG THEN
            DO; MEMORY(BACK) = C; CALL DECBACK;
            END;
        END;
    END MEM$MOVE;
 
MOVER: PROC;
    CALL MEM$MOVE(TRUE);
    END MOVER;

SETPTRS: PROC;
    CALL MEM$MOVE(FALSE);
    END SETPTRS;

MOVELINES: PROC;
    CALL SETLIMITS;
    CALL MOVER;
    END MOVELINES;
 
SETCLIMITS: PROC;
    IF DIRECTION = BACKWARD THEN
        DO; LAST = BACK;
        IF DISTANCE > FRONT THEN
            FIRST = 1; ELSE FIRST = FRONT - DISTANCE;
        END; ELSE
        DO; FIRST = FRONT;
        IF DISTANCE >= MAX - BACK THEN
            LAST = MAXM; ELSE LAST = BACK + DISTANCE;
        END;
    END SETCLIMITS;
 
READLINE: PROCEDURE;
    DECLARE B BYTE;
    /* READ ANOTHER LINE OF INPUT */
    CTRAN: PROCEDURE(B) BYTE;
        DECLARE B BYTE;
        /* CONDITIONALLY TRANSLATE TO UPPER CASE ON INPUT */
        IF UPPER THEN RETURN UTRAN(B);
        RETURN B;
        END CTRAN;
    DO FOREVER;
    IF FRONT >= BACK THEN GO TO OVERFLOW;
    IF (B := CTRAN(GETSOURCE)) = ENDFILE THEN
        DO; CALL ZERODIST; RETURN;
        END;
    MEMORY(FRONT) = B;
    CALL INCFRONT;
    IF B = LF THEN
        DO; CALL INCBASE;
        RETURN;
        END;
    END;
    END READLINE;
 
WRITELINE: PROCEDURE;
    /* WRITE ONE LINE OUT */
    DECLARE B BYTE;
        DO FOREVER;
        IF BACK >= MAXM THEN /* EMPTY */
            DO; CALL ZERODIST; RETURN;
            END;
        CALL INCBACK;
        CALL PUTDEST(B:=MEMORY(BACK));
        IF B = LF THEN
            DO; CALL INCBASE;
            RETURN;
            END;
        END;
    END WRITELINE;
 
WRHALF: PROCEDURE;
     /* WRITE LINES UNTIL AT LEAST HALF THE BUFFER IS EMPTY */
    CALL SETFF;
        DO WHILE DISTNZERO;
        IF HMAX >= (MAXM - BACK) THEN CALL ZERODIST; ELSE
        CALL WRITELINE;
        END;
    END WRHALF;
 
WRITEOUT: PROCEDURE;
    /* WRITE LINES DETERMINED BY 'DISTANCE',
    CALLED FROM W AND E COMMANDS */
    DIRECTION = BACKWARD; FIRST = 1; LAST = BACK;
    CALL MOVER;
    IF DISTZERO THEN CALL WRHALF;
    /* DISTANCE = 0 IF CALL WRHALF */
        DO WHILE DISTNZERO;
        CALL WRITELINE;
        END;
    IF BACK < LAST THEN
        DO; DIRECTION = FORWARD; CALL MOVER;
        END;
    END WRITEOUT;
 
CLEARMEM: PROCEDURE;
    /* CLEAR MEMORY BUFFER */
    CALL SETFF;
    CALL WRITEOUT;
    END CLEARMEM;
 
TERMINATE: PROCEDURE;
    /* CLEAR BUFFERS */
    CALL CLEARMEM;
        DO WHILE (CHAR := GETSOURCE) <> ENDFILE;
        CALL PUTDEST(CHAR);
        END;
    CALL FINIS;
    END TERMINATE;
 
 
INSERT: PROCEDURE;
    /* INSERT CHAR INTO MEMORY BUFFER */
    IF FRONT = BACK THEN GO TO OVERFLOW;
    MEMORY(FRONT) = CHAR; CALL INCFRONT;
    IF CHAR = LF THEN CALL INCBASE;
    END INSERT;
 
SCANNING: PROCEDURE BYTE;
    /* READ A CHARACTER AND CHECK FOR ENDFILE OR CR */
    RETURN NOT ((CHAR := READC) = ENDFILE OR
                   (CHAR = CR AND NOT INSERTING));
    END SCANNING;
 
COLLECT: PROCEDURE;
    /* READ COMMAND BUFFER AND INSERT CHARACTERS INTO
    SCRATCH 'TIL NEXT CONTROL-Z OR CR FOR  FIND, NEXT, JUXT, OR
    SUBSTITUTE COMMANDS - FILL AT WBE AND INCREMENT WBE SO IT
    ADDRESSES NEXT EMPTY POSITION OF SCRATCH */
    SETSCR: PROCEDURE;
        SCRATCH(WBE) = CHAR;
        IF (WBE := WBE + 1) >= SCRSIZE THEN GO TO OVERFLOW;
        END SETSCR;
        DO WHILE SCANNING;
        IF CHAR = CTLL THEN
            DO; CHAR = CR; CALL SETSCR;
            CHAR = LF;
            END;
        IF CHAR = 0 THEN GO TO BADCOM;
        CALL SETSCR;
        END;
    END COLLECT;
 
FIND: PROCEDURE(PA,PB) BYTE;
    DECLARE (PA,PB) BYTE;
    /* FIND THE STRING IN SCRATCH STARTING AT PA AND ENDING AT PB */
    DECLARE J ADDRESS,
        (K, MATCH) BYTE;
    J = BACK ;
    MATCH = FALSE;
        DO WHILE NOT MATCH AND (MAXM > J);
        LAST,J = J + 1; /* START SCAN AT J */
        K = PA ; /* ATTEMPT STRING MATCH AT K */
            DO WHILE SCRATCH(K) = MEMORY(LAST) AND
                NOT (MATCH := K = PB);
            /* MATCHED ONE MORE CHARACTER */
            K = K + 1; LAST = LAST + 1;
            END;
        END;
    IF MATCH THEN /* MOVE STORAGE */
        DO; LAST = LAST - 1; CALL MOVER;
        END;
    RETURN MATCH;
    END FIND;
 
SETFIND: PROCEDURE;
    /* SETUP THE SEARCH STRING FOR F,N, AND S COMMANDS */
    WBE = 0; CALL COLLECT; WBP = WBE;
    END SETFIND;
 
CHKFOUND: PROCEDURE;
    /* CHECK FOR FOUND STRING IN F AND S COMMANDS */
    IF NOT FIND(0,WBP) THEN /* NO MATCH */ GO TO OVERCOUNT;
    END CHKFOUND;
 
 
 
SETRFCB: PROCEDURE;
    /* PLACE CHAR INTO READ FILE CONTROL BLOCK AND INCREMENT */
    RFCB((RBP := RBP + 1) - 1) = UCASE(CHAR);
    END SETRFCB;
 
PRINTREL: PROCEDURE;
    CALL PRINTLINE(BASELINE+RELLINE);
    END PRINTREL;

TYPELINES: PROCEDURE;
    DCL I ADDR;
    DCL C BYTE;
    CALL SETLIMITS;
    /* DISABLE THE * PROMPT */
    INSERTING = TRUE;
    IF DIRECTION = FORWARD THEN
        DO; RELLINE = 0; I = FRONT;
        END; ELSE
        I = FIRST;
    IF (C := MEMORY(I-1)) = LF AND COLUMN <> 0 THEN
        CALL CRLF;
        DO I = FIRST TO LAST;
        IF C = LF THEN
            DO;
            CALL PRINTREL;
            RELLINE = RELLINE + 1;
            IF BREAK$KEY THEN GO TO OVERCOUNT;
            END;
        CALL PRINTC(C:=MEMORY(I));
        END;
    END TYPELINES;
 
SETLPP: PROCEDURE;
    /* SET DISTANCE TO LINES PER PAGE */
    DISTANCE = LPP;
    END SETLPP;
 
SAVEDIST: PROCEDURE;
    TDIST = DISTANCE;
    END SAVEDIST;
 
RESTDIST: PROCEDURE;
    DISTANCE = TDIST;
    END RESTDIST;
 
PAGE: PROCEDURE;
    DECLARE I BYTE;
    CALL SAVEDIST;
    CALL SETLPP;
    CALL MOVELINES;
    I = DIRECTION;
    DIRECTION = FORWARD;
    CALL SETLPP;
    CALL TYPELINES;
    DIRECTION = I;
    IF LAST = MAXM OR FIRST = 1 THEN CALL ZERODIST;
        ELSE CALL RESTDIST;
    END PAGE;
 
WAIT: PROCEDURE;
    /* 1/2 SECOND TIME OUT */
    DECLARE I BYTE;
        DO I = 0 TO 19;
        IF BREAK$KEY THEN GO TO RESET;
        CALL TIME(250);
        END;
    END WAIT;
 
SETFORWARD: PROCEDURE;
    DIRECTION = FORWARD;
    DISTANCE = 1;
    END SETFORWARD;
 
APPHALF: PROCEDURE;
    /* APPEND 'TIL BUFFER IS AT LEAST HALF FULL */
    CALL SETFF; /* DISTANCE = 0FFFFH */
        DO WHILE DISTNZERO;
        IF FRONT >= HMAX THEN CALL ZERODIST; ELSE
        CALL READLINE;
        END;
    END APPHALF;
 
INSCRLF: PROCEDURE;
    /* INSERT CR LF CHARACTERS */
    CHAR = CR; CALL INSERT;
    CHAR = LF; CALL INSERT;
    END INSCRLF;
 
TESTCASE: PROCEDURE;
    DECLARE T BYTE;
    /* TEST FOR UPPER OR LOWER CASE COMMAND AND SET TRANSLATE
    FLAG (USED TO DETERMINE IF CHARACTERS WHICH FOLLOW GO TO UPPER */
    TRANSLATE = TRUE;
    T = LOWERCASE(CHAR);
    CHAR = UTRAN(CHAR);
    TRANSLATE = UPPER OR NOT T;
    END TESTCASE;
 
READCTRAN: PROCEDURE;
    /* SET TRANSLATE TO FALSE AND READ NEXT CHARACTER */
    TRANSLATE = FALSE;
    CHAR = READC;
    CALL TESTCASE;
    END READCTRAN;
 
SINGLECOM: PROCEDURE(C) BYTE;
    /* RETURN TRUE IF COMMAND IS ONLY CHARACTER, NOT IN MACRO */
    DECLARE C BYTE;
    RETURN CHAR = C AND COMLEN = 1 AND MP = 0;
    END SINGLECOM;
 
SINGLERCOM: PROCEDURE(C) BYTE;
    DECLARE C BYTE;
    /* RETURN TRUE IF COMMAND IS ONLY CHARACTER, NOT IN MACRO, AND
    THE OPERATOR HAS RESPONDED WITH 'Y' TO A Y/N REQUEST */
    IF SINGLECOM(C) THEN
        DO; CALL CRLF; CALL PRINTCHAR(C);
        CALL MON1(9,.('-(Y/N)',WHAT,'$'));
        C = UCASE(READCHAR); CALL CRLF;
        IF C <> 'Y' THEN GO TO START;
        RETURN TRUE;
        END;
    RETURN FALSE;
    END SINGLERCOM;
 
 
 
 
 
 
 /* INITIALIZE THE SYSTEM */

EDCOMMAND: /* PAST LXI SP,STACK */

    ver = version;
    if low(ver) <> cpmversion or high(ver) <> mpmproduct then do;
      call print (.('Requires MP/M 2.0','$'));
      call mon1(0,0);
      end;
    /* I/O BUFFER REGION IS 1/8 AVAILABLE MEMORY */
    NBUF = SHR(MAX := MAXB - .MEMORY,SECTSHF+3) - 1;
    /* NBUF IS NUMBER OF BUFFERS - 1 */
    BUFFLENGTH = SHL(DOUBLE(NBUF+1),SECTSHF+1);
    /* NOW SET MAX AS REMAINDER OF FREE MEMORY */
    IF BUFFLENGTH + 1024 > MAX THEN
        DO; CALL PRINT(.('NO MEMORY$'));
        CALL BOOT;
        END;
    /* REMOVE BUFFER SPACE AND 00 AT END OF MEMORY VECTOR */
    MAX = MAX - BUFFLENGTH - 1;
    /* RESET BUFFER LENGTH FOR I AND O */
    BUFFLENGTH = SHR(BUFFLENGTH,1);
    SBUFFADR = MAXB - BUFFLENGTH;
    DBUFFADR = SBUFFADR - BUFFLENGTH;
    MEMORY(MAX) = 0; /* STOPS MATCH AT END OF BUFFER */
    MAXM = MAX - 1;
    HMAX = SHR(MAXM,1);
    /* NO TRANSLATE, WITH LINE NUMBERS */
    UPPER, PRINTSUPPRESS = FALSE;
    LINESET = TRUE;
    /* GET SOURCE AND DESTINATION DISKS */
    IF FCB(1) = ' ' THEN 
        call abort(.('Filename Required$'));
    IF (SDISK := FCB(0)) = 0 THEN SDISK = CSELECT; ELSE
        DO; SDISK = SDISK - 1; FCB(0) = 0; /* CLEAR DISK NAME */
        END;
    IF (DDISK := FCB(16)) = 0 THEN DDISK = SDISK; ELSE
        DDISK = DDISK - 1;
    /* CLEAR THE XFER FILE */
    CALL XCLEAR;
 
RESTART:
    CALL SETUP;
    MEMORY(0) = LF;
    FRONT = 1; BACK = MAXM;
    COLUMN = 0;
    GO TO START;
 
OVERCOUNT: FLAG = POUND; GO TO RESET;
 
BADCOM: FLAG = WHAT; GO TO RESET;
 
OVERFLOW: /* ARRIVE HERE ON OVERFLOW CONDITION (I,F,S COMMAND) */
    FLAG = '>';
 
RESET: /* ARRIVE HERE ON ERROR CONDITION */
    PRINTSUPPRESS = FALSE;
    CALL PRINT(.('BREAK "$'));
    CALL PRINTC(FLAG);
    CALL PRINTM(.('" AT $'));
    CALL PRINTC(CHAR);
    CALL CRLF;

 
START:
    READBUFF = TRUE;
    MP = 0;
 
 
    DO FOREVER; /* OR UNTIL THE POWER IS TURNED OFF */
 
    /* **************************************************************
    SIMPLE COMMANDS (CANNOT BE PRECEDED BY DIRECTION/DISTANCE):
             E      END THE EDIT NORMALLY
             H      MOVE TO HEAD OF EDITED FILE
             I      INSERT CHARACTERS
             O      RETURN TO THE ORIGINAL FILE
             R      READ FROM LIBRARY FILE
             Q      QUIT EDIT WITHOUT CHANGES TO ORIGINAL FILE
       ************************************************************** */
 
 
 
    INSERTING = FALSE;
    CALL READCTRAN;
    MI = CBP; /* SAVE STARTING ADDRESS FOR <CR> COMMAND */
    IF SINGLECOM('E') THEN
        DO; CALL TERMINATE;
        IF SDISK <> DDISK THEN /* CHANGE DISKS */
            /* USER CODE IN HIGH NIBBLE */
            BDISK = (BDISK AND 0F0H) OR (DDISK AND 0FH);
        CALL REBOOT;
        END; ELSE
 
 
    IF SINGLECOM('H') THEN /* GO TO TOP */
        DO; CALL TERMINATE;
        CHAR = DDISK; DDISK = SDISK; SDISK = CHAR;
        /* PING - PONG DISKS */
        GO TO RESTART;
        END; ELSE
 
 
    IF CHAR = 'I' THEN /* INSERT CHARACTERS */
        DO;
        IF (INSERTING := (CBP = COMLEN) AND (MP = 0)) THEN
            CALL PRINTNMBASE;
        SCOLUMN = COLUMN; /* STARTING COLUMN POSITION */
        DO WHILE SCANNING;
            DO WHILE CHAR <> 0;
            IF CHAR=CTLU OR CHAR=CTLX OR CHAR=CTLR THEN
                /* LINE DELETE OR RETYPE */
                DO;
                DISTANCE = 0; DIRECTION = BACKWARD;
                /* ELIMINATE OR REPEAT THE LINE */
                IF CHAR = CTLR THEN
                    DO; CALL CRLF;
                    CALL TYPELINES;
                    END; ELSE
                    /* LINE DELETE */
                    DO; CALL SETLIMITS; CALL SETPTRS;
                    IF CHAR = CTLU THEN
                        DO; CALL CRLF; CALL PRINTNMBASE;
                        END; ELSE
                    /* MUST BE CTLX */
                        DO WHILE COLUMN > SCOLUMN;
                        CALL BACKSPACE;
                        END;
                    END;
                END; ELSE
            IF CHAR = CTLH THEN
                DO;
                IF (TCOLUMN := COLUMN) > 0 THEN
                    CALL PRINTNMAC(' '); /* RESTORE AFT BACKSP */
                IF FRONT > 1 AND TCOLUMN > SCOLUMN THEN
                    DO;
                    IF MEMORY(FRONT-1) <> LF THEN
                        DO; /* CHARACTER CAN BE ELIMINATED */
                        CALL DECFRONT;
                        PRINTSUPPRESS = TRUE;
                        /* BACKSPACE CHARACTER ACCEPTED */
                        COLUMN = 0;
                        DISTANCE = 0; DIRECTION = BACKWARD;
                        CALL TYPELINES;
                        PRINTSUPPRESS = FALSE;
                        /* COLUMN POSITION NOW RESET */
                        IF (QCOLUMN := COLUMN) < SCOLUMN THEN
                            QCOLUMN = SCOLUMN;
                        COLUMN = TCOLUMN; /* ORIGINAL VALUE */
                            DO WHILE COLUMN > QCOLUMN;
                            CALL BACKSPACE;
                            END;
                        TCOLUMN = COLUMN;
                        END;
                    END;
                CHAR = 0;
                COLUMN = TCOLUMN;
                END; ELSE
            IF CHAR = RUBOUT THEN
                DO; IF FRONT = 1 THEN GO TO RESET;
                CALL DECFRONT; CALL PRINTC(CHAR:=MEMORY(FRONT));
                IF CHAR = LF THEN BASELINE=BASELINE-1;
                CHAR = 0;
                END; ELSE
            /* NOT A SPECIAL CASE */
                DO; IF NOT GRAPHIC(CHAR) THEN
                    DO; CALL PRINTNMAC('^');
                    CALL PRINTNMAC(CHAR + '@');
                    END;
                IF CHAR = CTLL THEN
                    CALL INSCRLF; ELSE
                    DO; /* COLUMN COUNT GOES UP IF GRAPHIC */
                    /* COMPUTE OUTPUT COLUMN POSITION */
                    IF MP = 0 THEN
                        DO; IF CHAR >= ' ' THEN
                        COLUMN = COLUMN + 1; ELSE
                        IF CHAR = TAB THEN
                        COLUMN = COLUMN + (8 - (COLUMN AND 111B));
                        END;
                    CALL INSERT;
                    END;
                END;
            IF CHAR = LF THEN CALL PRINTNMBASE;
            IF CHAR = CR THEN
                CALL PRINTNMAC(CHAR:=LF); ELSE CHAR = 0;
            END;
        END;
        IF CHAR <> ENDFILE THEN /* MUST HAVE STOPPED ON CR */
            CALL INSCRLF;
        IF INSERTING AND LINESET THEN CALL CRLF;
        END; ELSE
 
 
    IF SINGLERCOM('O') THEN /* FORGET THIS EDIT */
        GO TO RESTART; ELSE
 
 
    IF CHAR = 'R' THEN
        DO; DECLARE I BYTE;
        /* READ FROM LIB FILE */
        RBP = 1; CALL SETRDMA;
            DO WHILE SCANNING;
            IF RBP > 8 THEN GO TO OVERCOUNT;
            CALL SETRFCB;
            END;
        CHAR = ' ';
        IF (FLAG := RBP = 1) THEN /* READ FROM XFER FILE */
            DO;
            CALL MOVE(8,.XFCB(1),.RFCB(1));
            if xferon then do;
                xfcbc = xchksum;	/*  restore checksum */
                CALL CLOSE(.XFCB);
                end;
            END; ELSE /* LIB NAME SPECIFIED */
            DO WHILE RBP <= 8;
            CALL SETRFCB;
            END;
        RFCB(12), RFCB(32) = 0; /* FILL REEL, AND NEXT RECORD */
        CALL OPEN(.RFCB); RBP = SECTSIZE;
        IF DCNT = 255 THEN
            DO; FLAG = 'O'; GO TO RESET;
            END;
            DO WHILE (CHAR := READFILE) <> ENDFILE;
            CALL INSERT;
            END;
        I = 0;
        IF FLAG THEN /* MAY BE XFER DATA IN BUFFER */
            DO WHILE I < XBP;
            CHAR = XBUFF(I); I = I + 1;
            CALL INSERT;
            END;
        END; ELSE
 
 
    IF SINGLERCOM('Q') THEN
        DO; CALL DELETE(.DFCB); CALL REBOOT;
        END; ELSE
 
 
 
    /* MAY BE A COMMAND WHICH HAS AN OPTIONAL DIRECTION AND DISTANCE */
        DO; /* SCAN A SIGNED INTEGER VALUE (IF ANY) */
        DCL I BYTE;

        DIGIT: PROCEDURE BYTE;
            RETURN (I := CHAR - '0') <= 9;
            END DIGIT;

        NUMBER: PROCEDURE;
            DISTANCE = 0;
                DO WHILE DIGIT;
                DISTANCE = SHL(DISTANCE,3) +
                           SHL(DISTANCE,1) + I;
                CALL READCTRAN;
                END;
            /* RETURN WITH DISTANCE = NUMBER, CHAR = NEXT */
            END NUMBER;

        RELDISTANCE: PROCEDURE;
            IF DISTANCE > BASELINE THEN
                DO; DIRECTION = FORWARD;
                DISTANCE = DISTANCE - BASELINE;
                END; ELSE
                DO; DIRECTION = BACKWARD;
                DISTANCE = BASELINE - DISTANCE;
                END;
            END RELDISTANCE;

        CALL SETFORWARD;
 
        IF CHAR = '-' THEN
            DO; CALL READCTRAN; DIRECTION = BACKWARD;
            END;
 
        IF CHAR = POUND THEN
            DO; CALL SETFF; CALL READCTRAN;
            END; ELSE
 
        IF DIGIT THEN
            DO; CALL NUMBER;
            /* MAY BE ABSOLUTE LINE REFERENCE */
            IF CHAR = ':' THEN
                DO; CHAR = 'L';
                CALL RELDISTANCE;
                END;
            END; ELSE

        IF CHAR = ':' THEN /* LEADING COLON */
            DO; CALL READCTRAN; /* CLEAR THE COLON */
            CALL NUMBER;
            CALL RELDISTANCE;
            IF DIRECTION = FORWARD THEN
                DISTANCE = DISTANCE + 1;
            END;

        IF DISTZERO THEN DIRECTION = BACKWARD;
        /* DIRECTION AND DISTANCE ARE NOW SET */
 
 
    /* **************************************************************
    MAY BE A COMMAND WHICH HAS DIRECTION AND DISTANCE SPECIFIED:
             B      BEGINNING/BOTTOM OF BUFFER
             C      MOVE CHARACTER POSITIONS
             D      DELETE CHARACTERS
             K      KILL LINES
             L      MOVE LINE POSITION
             P      PAGE UP OR DOWN (LPP LINES AND PRINT)
             T      TYPE LINES
             U      UPPER CASE TRANSLATE
             V      VERIFY LINE NUMBERS
            <CR>    MOVE UP OR DOWN LINES AND PRINT LINE
       ************************************************************** */
 
 
        IF CHAR = 'B' THEN
            DO; DIRECTION = 1 - DIRECTION;
            FIRST = 1; LAST = MAXM; CALL MOVER;
            END; ELSE
 
 
        IF CHAR = 'C' THEN
            DO; CALL SETCLIMITS; CALL MOVER;
            END; ELSE
 
 
        IF CHAR = 'D' THEN
            DO; CALL SETCLIMITS;
            CALL SETPTRS; /* SETS BACK/FRONT */
            END; ELSE
 
 
        IF CHAR = 'K' THEN
            DO; CALL SETLIMITS;
            CALL SETPTRS;
            END; ELSE
 
 
        IF CHAR = 'L' THEN CALL MOVELINES; ELSE
 
        IF CHAR = 'P' THEN /* PAGE MODE PRINT */
            DO; IF DISTZERO THEN
                DO; DIRECTION = FORWARD;
                CALL SETLPP; CALL TYPELINES;
                END; ELSE
                DO WHILE DISTNZERO; CALL PAGE;
                CALL WAIT;
                END;
            END; ELSE
 
 
        IF CHAR = 'T' THEN
            CALL TYPELINES; ELSE
 
 
 
        IF CHAR = 'U' THEN
            UPPER = DIRECTION = FORWARD; ELSE
 
        IF CHAR = 'V' THEN
            DO; /* 0V DISPLAYS BUFFER STATE */
            IF DISTZERO THEN
                DO; CALL PRINTVALUE(BACK-FRONT);
                CALL PRINTC('/');
                CALL PRINTVALUE(MAXM);
                CALL CRLF;
                END; ELSE
            LINESET = DIRECTION = FORWARD;
            END; ELSE
 
        IF CHAR = CR THEN /* MAY BE MOVE/TYPE COMMAND */
            DO;
            IF MI = 1 AND MP = 0 THEN /* FIRST COMMAND */
                DO; CALL MOVELINES; CALL SETFORWARD; CALL TYPELINES;
                END;
            END; ELSE
 
        IF DIRECTION = FORWARD OR DISTZERO THEN
        DO;
 
    /* **************************************************************
    COMMANDS WHICH ALLOW ONLY A PRECEDING NUMBER:
             A      APPEND LINES
             F      FIND NTH OCCURRENCE
             M      APPLY MACRO
             N      SAME AS F WITH AUTOSCAN THROUGH FILE
             S      PERFORM N SUBSTITUTIONS
             W      WRITE LINES TO OUTPUT FILE
             X      TRANSFER (XFER) LINES TO TEMP FILE
             Z      SLEEP
       ************************************************************** */
 
 
 
        IF CHAR = 'A' THEN
            DO; DIRECTION = FORWARD;
            FIRST = FRONT; LAST = MAXM; CALL MOVER;
            /* ALL STORAGE FORWARD */
            IF DISTZERO THEN CALL APPHALF;
            /* DISTANCE = 0 IF APPHALF CALLED */
                DO WHILE DISTNZERO;
                CALL READLINE;
                END;
            DIRECTION = BACKWARD; CALL MOVER;
            /* POINTERS REPOSITIONED */
            END; ELSE
 
 
        IF CHAR = 'F' THEN
            DO; CALL SETFIND; /* SEARCH STRING SCANNED
            AND SETUP BETWEEN 0 AND WBP-1 IN SCRATCH */
                DO WHILE DISTNZERO; CALL CHKFOUND;
                END;
            END; ELSE
 
 
        IF CHAR = 'J' THEN /* JUXTAPOSITION OPERATION */
            DO; DECLARE T ADDRESS;
            CALL SETFIND; CALL COLLECT;
            WBJ = WBE; CALL COLLECT;
            /* SEARCH FOR STRING 0 - WBP-1, INSERT STRING WBP TO WBJ-1,
            AND THEN DELETE UP TO STRING WBJ TO WBE-1 */
            DO WHILE DISTNZERO; CALL CHKFOUND;
            /* INSERT STRING */ MI = WBP - 1;
                DO WHILE (MI := MI + 1) < WBJ;
                CHAR = SCRATCH(MI); CALL INSERT;
                END;
            T = FRONT; /* SAVE POSITION FOR DELETE */
            IF NOT FIND(WBJ,WBE) THEN GO TO OVERCOUNT;
            /* STRING FOUND, SO MOVE IT BACK */
            FIRST = FRONT - (WBE - WBJ);
            DIRECTION = BACKWARD; CALL MOVER;
            /* NOW REMOVE THE INTERMEDIATE STRING */
            FRONT = T;
            END;
        END; ELSE
 
 
        IF CHAR = 'M' AND MP = 0 THEN /* MACRO DEFINITION */
            DO; XP = 255;
            IF DISTANCE = 1 THEN CALL ZERODIST;
                DO WHILE (MACRO(XP := XP + 1) := READC) <> CR;
                END;
            MP = XP; XP = 0; MT = DISTANCE;
            END; ELSE
 
 
        IF CHAR = 'N' THEN
            DO; /* SEARCH FOR STRING WITH AUTOSCAN */
            CALL SETFIND; /* SEARCH STRING SCANNED */
                DO WHILE DISTNZERO;
                /* FIND ANOTHER OCCURRENCE OF STRING */
                    DO WHILE NOT FIND(0,WBP); /* NOT IN BUFFER */
                    IF BREAK$KEY THEN GO TO RESET;
                    CALL SAVEDIST; CALL CLEARMEM;
                    /* MEMORY BUFFER WRITTEN */
                    CALL APPHALF;
                    DIRECTION = BACKWARD; FIRST = 1; CALL MOVER;
                    CALL RESTDIST; DIRECTION = FORWARD;
                    /* MAY BE END OF FILE */
                    IF BACK >= MAXM THEN GO TO OVERCOUNT;
                    END;
                END;
            END; ELSE
 
 
        IF CHAR = 'S' THEN /* SUBSTITUTE COMMAND */
            DO; CALL SETFIND;
            CALL COLLECT;
            /* FIND STRING FROM 0 TO WBP-1, SUBSTITUTE STRING
            BETWEEN WBP AND WBE-1 IN SCRATCH */
                DO WHILE DISTNZERO;
                CALL CHKFOUND;
                /* FRONT AND BACK NOW POSITIONED AT FOUND
                STRING - REPLACE IT */
                FRONT = FRONT - (MI := WBP); /* BACKED UP */
                    DO WHILE MI < WBE;
                    CHAR = SCRATCH(MI);
                    MI = MI + 1; CALL INSERT;
                    END;
                 END;
            END; ELSE
 
 
        IF CHAR = 'W' THEN
            CALL WRITEOUT; ELSE
 
        IF CHAR = 'X' THEN /* TRANSFER LINES */
            DO;
            CALL SETXDMA;
            IF DISTZERO THEN /* CLEAR THE FILE */
                DO; CALL XCLEAR;
                CALL DELETE(.XFCB);
                xchksum = xfcbc;   /* save checksum */
                END; ELSE
            /* TRANSFER LINES */
                DO; DECLARE I ADDRESS;
                IF NOT XFERON THEN /* CREATE XFER FILE */
                    DO; CALL XCLEAR;
                    XFERON = TRUE;
                    CALL DELETE(.XFCB); /* OLD VERSION GONE */
                    CALL MAKE(.XFCB);
                    xchksum = xfcbc;	/* save checksum */
                    IF DCNT = 255 THEN CALL FERR;
                    END;
                CALL SETLIMITS;
                    DO I = FIRST TO LAST;
                    CALL PUTXFER(MEMORY(I));
                    END;
                END;
            END; ELSE

        IF CHAR = 'Z' THEN /* SLEEP */
            DO;
            IF DISTZERO THEN
                DO; IF READCHAR = ENDFILE THEN GO TO RESET;
                END;
                DO WHILE DISTNZERO; CALL WAIT;
                END;
            END; ELSE
        IF CHAR <> 0 THEN /* NOT BREAK LEFT OVER FROM STOP */
        /* DIRECTION FORWARD, BUT NOT ONE OF THE ABOVE */
        GO TO BADCOM;
 
 
        END; ELSE /* DIRECTION NOT FORWARD */
            GO TO BADCOM;
        END;
    END;
END;
