home *** CD-ROM | disk | FTP | other *** search
/ norge.freeshell.org (192.94.73.8) / 192.94.73.8.tar / 192.94.73.8 / pub / computers / cpm / alphatronic / DRIPAK.ZIP / CPM_3-0 / SOURCES / ED.PLM < prev    next >
Text File  |  1982-12-31  |  82KB  |  2,648 lines
  1. $ TITLE(' CP/M-80 3.0 --- ED')
  2. ED:
  3. DO;
  4.     /* MODIFIED FOR .PRL OPERATION MAY, 1979 */
  5.     /* MODIFIED FOR OPERATION WITH CP/M 2.0 AUGUST 1979 */
  6.     /* modified for MP/M 2.0 June 1981 */
  7.     /* modified for CP/M 1.1 Oct  1981 */
  8.     /* modified for CONCURRENT CP/M 1.0 Jul 1982 */
  9.     /* modified for CP/M 3.0 July 1982 */
  10.     /* modified for CP/M 3.0 SEPT 1982 */
  11.  
  12. /* MODIFICATION LOG:
  13.  *   July 1982 whf: some code cleanup (grouped logicals, declared BOOL);
  14.  *        fixed disk full error handling; fixed read from null files;
  15.  *        fixed (some) of the dirty fcb handling (shouldn't use settype
  16.  *        function on open fcbs!).
  17.  *   July 1982 dh: installed patches to change macro abort command from
  18.  *        ^C to ^Y and to not print error message when trying to delete
  19.  *        a file that doesn't exist.  Added PERROR: PROCEDURE to print
  20.  *        error messages in a consistant format and modified error 
  21.  *        message handler at RESET: entry point.  Also corrected Invalid
  22.  *        filename error to not abort ED if parsing a R or X command.
  23.  *        Modified start (at PLM:) and SETDEST: to prompt for missing 
  24.  *        filenames.  Modified parse$fcb & parse$lib to set a global 
  25.  *        flag and break if it got an invalid filename for X or R commands.
  26.  *        Start sets page size from the system control block (SCB) if 
  27.  *        ED is running under CP/M-80 (high(ver)=0).
  28.  *        The H command now works with new files. (sets newfile=false)
  29.  *    Sept 82
  30.  *        Corrected bug in which ED file b: didn't work. Changed PLM:
  31.  *        and SETDEST: routines.
  32.  *    Nov  82
  33.  *        Corrected bug in parse$fcb where filenames of 9 characters and
  34.  *        types of 4 characters where accepted as valid and truncated.
  35.  */
  36.  
  37. $include (copyrt.lit)
  38.  
  39. declare
  40.     mpmproduct literally '01h', /* requires mp/m */
  41.     cpm3       literally '30h'; /* requires 3.0 cp/m */
  42.  
  43. declare plm label public;  /* entry point for plm86 interface */
  44.  
  45. /*  THE FOLLOWING COMMANDS CREATE ED.COM AND ED.CMD:
  46.  
  47.     wm $1.plm
  48.     attach b 5
  49.     b:seteof $1.plm
  50.     vax $1.plm $$san\batch smpmcmd $1 date($2 Oct 81)\
  51.     b:is14
  52.     ERA $1.MOD
  53.     era $1
  54.     era $1.obj
  55.     :f1:PLM80 $1.PLM debug PAGEWIDTH(132) $3
  56.     :f1:link $101.obj,$1.obj,:f1:plm80.lib to $1.mod 
  57.     :f1:locate $1.mod code(0100H) stacksize(100) map print($1.tra)
  58.     :f1:cpm
  59.     b:objcpm $1
  60.     attach b 1
  61.     
  62.  
  63. the following VAX commands were used to create ED.CMD
  64.  
  65.  $ asm86 scd1.a86 debug xref
  66.  ! scd1 does a jump to the plm code
  67.  $ plm86 'p1'.plm 'p2' 'p3' 'p4' optimize(3) debug
  68.  $ link86 scd1.obj,'p1'.obj  to 'p1'.lnk
  69.  $ loc86 'p1'.lnk od(sm(dats,code,data,stack,const)) ad(sm(code(0)))  ss(stack(+16))
  70.  $ h86 'p1'
  71.  
  72.    followed by the gencmd command 
  73.    gencmd ed data[b1E3,m80,xFFF]
  74.    where 1E2 is the start of the constant area / 16 from ED.MP2
  75.  
  76. */
  77.  
  78. /* DECLARE                            8080 Interface
  79.     JMP EDCOMMAND - 3 (TO ADDRESS LXI SP) 
  80.     EDJMP BYTE DATA(0C3H),
  81.     EDADR ADDRESS DATA(.EDCOMMAND-3); */
  82.  
  83.  
  84.   /**************************************
  85.    *                                    *
  86.    *       B D O S   INTERFACE          *
  87.    *                                    *
  88.    **************************************/
  89.  
  90.  
  91.   mon1:
  92.     procedure (func,info) external;
  93.       declare func byte;
  94.       declare info address;
  95.     end mon1;
  96.  
  97.   mon2:
  98.     procedure (func,info) byte external;
  99.       declare func byte;
  100.       declare info address;
  101.     end mon2;
  102.  
  103.   mon3:
  104.     procedure (func,info) address external;
  105.       declare func byte;
  106.       declare info address;
  107.     end mon3;
  108.  
  109.   declare fcb (1)   byte    external;    /* 1st default fcb    */
  110.   declare fcb16 (1) byte    external;    /* 2nd default fcb    */
  111.   declare tbuff (1) byte    external;    /* default dma buffer */
  112.  
  113.  
  114. DECLARE
  115.     MAXB      ADDRESS EXTERNAL, /* MAX BASE 0006H */
  116.     BUFF (128)BYTE    EXTERNAL, /* BUFFER 0080H */
  117.     SECTSHF   LITERALLY '7',    /* SHL(1,SECTSHF) = SECTSIZE */
  118.     SECTSIZE  LITERALLY '80H';  /* SECTOR SIZE */
  119.  
  120. BOOT: PROCEDURE ;
  121.     call mon1(0,0);          /* changed for MP/M-86 version */
  122.     /* SYSTEM REBOOT */
  123.     END BOOT;
  124. $ eject
  125.  
  126.   /*  E D  :   T H E   C P / M   C O N T E X T    E D I T O R  */
  127.  
  128.     /*      COPYRIGHT (C) 1976, 1977, 1978, 1979, 1980, 1981, 1982
  129.             DIGITAL RESEARCH
  130.             BOX 579 PACIFIC GROVE
  131.             CALIFORNIA 93950
  132.  
  133.             Revised:
  134.               07 April 81  by Thomas Rolander
  135.               21 July  81  by Doug Huskey
  136.               29 Oct   81  by Doug Huskey
  137.               10 Nov   81  by Doug Huskey
  138.               08 July  82  by Bill Fitler
  139.               26 July  82  by Doug Huskey
  140.     */
  141. /* DECLARE COPYRIGHT(*) BYTE DATA
  142.    (' COPYRIGHT (C) 1982, DIGITAL RESEARCH '); 
  143.    **** this message should be in the header ***
  144. */
  145. declare date(*) byte data ('8/82');
  146.  
  147.  /* COMMAND           FUNCTION
  148.     -------           --------
  149.      A            APPEND LINES OF TEXT TO BUFFER
  150.      B            MOVE TO BEGINNING OR END OF TEXT
  151.      C            SKIP CHARACTERS
  152.      D            DELETE CHARACTERS
  153.      E            END OF EDIT
  154.      F            FIND STRING IN CURRENT BUFFER
  155.      H            MOVE TO TOP OF FILE (HEAD)
  156.      I            INSERT   CHARACTERS FROM KEYBOARD
  157.                   UP TO NEXT <ENDFILE>
  158.      J            JUXTAPOSITION OPERATION - SEARCH FOR FIRST STRING,
  159.                   INSERT SECOND STRING, DELETE UNTIL THIRD STRING
  160.      K            DELETE LINES
  161.      L            SKIP LINES
  162.      M            MACRO DEFINITION (SEE COMMENT BELOW)
  163.      N            FIND NEXT OCCURRENCE OF STRING
  164.                   WITH AUTO SCAN THROUGH FILE
  165.      O            RE-EDIT OLD FILE
  166.      P            PAGE AND DISPLAY (MOVES UP OR DOWN 24 LINES AND
  167.                   DISPLAYS 24 LINES)
  168.      Q            QUIT EDIT WITHOUT UPDATING THE FILE
  169.      R<FILENAME>  READ FROM FILE <FILENAME> UNTIL <ENDFILE> AND
  170.                   INSERT INTO TEXT
  171.      S            SEARCH FOR FIRST STRING, REPLACE BY SECOND STRING
  172.      T            TYPE LINES
  173.      U            TRANSLATE TO UPPER CASE (-U CHANGES TO NO TRANSLATE)
  174.      W            WRITE LINES OF TEXT TO FILE
  175.      X<FILENAME>  TRANSFER (XFER) LINES TO FILE <FILENAME> 
  176.      Z            SLEEP FOR 1/2 SECOND (USED IN MACROS TO STOP DISPLAY)
  177.      <CR>         MOVE UP OR DOWN AND PRINT ONE LINE
  178.  
  179.  
  180.     IN GENERAL, THE EDITOR ACCEPTS SINGLE LETTER COMMANDS WITH OPTIONAL
  181. INTEGER VALUES PRECEDING THE COMMAND.  THE EDITOR ACCEPTS BOTH UPPER AND LOWER
  182. CASE COMMANDS AND VALUES, AND PERFORMS TRANSLATION TO UPPER CASE UNDER THE FOL-
  183. LOWING CONDITIONS.  IF THE COMMAND IS TYPED IN UPPER CASE, THEN THE DATA WHICH
  184. FOLLOWS IS TRANSLATED TO UPPER CASE.  THUS, IF THE "I" COMMAND IS TYPED IN
  185. UPPER CASE, THEN ALL INPUT IS AUTOMATICALLY TRANSLATED (ALTHOUGH ECHOED IN
  186. LOWER CASE, AS TYPED).  IF THE "A" COMMAND IS TYPED IN UPPER CASE, THEN ALL
  187. INPUT IS TRANSLATED AS READ FROM THE DISK.  GLOBAL TRANSLATION TO UPPER CASE
  188. CAN BE CONTROLLED BY THE "U" COMMAND (-U TO NEGATE ITS EFFECT).  IF YOU ARE
  189. OPERATING WITH AN UPPER CASE ONLY TERMINAL, THEN OPERATION IS AUTOMATIC.
  190. SIMILARLY, IF YOU ARE OPERATING WITH A LOWER CASE TERMINAL, AND TRANSLATION
  191. TO UPPER CASE IS NOT SPECIFIED, THEN LOWER CASE CHARACTERS CAN BE ENTERED.
  192.  
  193.      A NUMBER OF COMMANDS CAN BE PRECEDED BY A POSITIVE OR
  194.      NEGATIVE INTEGER BETWEEN 0 AND 65535 (1 IS DEFAULT IF NO VALUE
  195.      IS SPECIFIED).  THIS VALUE DETERMINES THE NUMBER OF TIMES THE
  196.      COMMAND IS APPLIED BEFORE RETURNING FOR ANOTHER COMMAND.
  197.          THE COMMANDS
  198.                        C D K L T P U  <CR>
  199.      CAN BE PRECEDED BY AN UNSIGNED, POSITIVE, OR NEGATIVE NUMBER,
  200.      THE COMMANDS
  201.                        A F J N W Z
  202.      CAN BE PRECEDED BY AN UNSIGNED OR POSITIVE NUMBER,
  203.      THE COMMANDS
  204.                        E H O Q
  205.      CANNOT BE PRECEDED BY A NUMBER.  THE COMMANDS
  206.                        F I J M R S
  207.      ARE ALL FOLLOWED BY ONE OR MORE STRINGS OF CHARACTERS WHICH CAN
  208.      BE OPTIONALLY SEPARATED OR TERMINATED BY EITHER <ENDFILE> OR <CR>.
  209.      THE <ENDFILE> IS GENERALLY USED TO SEPARATE THE SEARCH STRINGS
  210.      IN THE S AND J COMMANDS, AND IS USED AT THE END OF THE COMMANDS IF
  211.      ADDITIONAL COMMANDS FOLLOW.  FOR EXAMPLE, THE FOLLOWING COMMAND
  212.      SEQUENCE SEARCHES FOR  THE STRING 'GAMMA', SUBSTITUTES THE STRING
  213.      'DELTA', AND THEN TYPES THE FIRST PART OF THE LINE WHERE THE
  214.      CHANGE OCCURRED, FOLLOWED BY THE REMAINDER OF THE LINE WHICH WAS
  215.      CHANGED:
  216.                  SGAMMA<ENDFILE>DELTA<ENDFILE>0TT<CR>
  217.  
  218.      THE CONTROL-L CHARACTER IN SEARCH AND SUBSTITUTE STRINGS IS
  219.      REPLACED ON INPUT BY <CR><LF> CHARACTERS.  THE CONTROL-I KEY
  220.      IS TAKEN AS A TAB CHARACTER.
  221.  
  222.         THE COMMANDS R & X MUST BE FOLLOWED BY A FILE NAME (WITH default 
  223.      FILE TYPE OF 'LIB') WITH A TRAILING <CR> OR <ENDFILE>.  THE COMMAND
  224.      I IS FOLLOWED BY A STRING OF SYMBOLS TO INSERT, TERMINATED BY
  225.      A <CR> OR <ENDFILE>.  IF SEVERAL LINES OF TEXT ARE TO BE INSERTED,
  226.      THE I CAN BE DIRECTLY FOLLOWED BY AN <ENDFILE> OR <CR> IN WHICH
  227.      CASE THE EDITOR ACCEPTS LINES OF INPUT TO THE NEXT <ENDFILE>.
  228.      THE COMMAND 0T PRINTS THE FIRST PART OF THE CURRENT LINE,
  229.      AND THE COMMAND 0L MOVES THE REFERENCE TO THE BEGINNING OF THE
  230.      CURRENT LINE.  THE COMMAND 0P PRINTS THE CURRENT PAGE ONLY, WHILE
  231.      THE COMMAND 0Z READS THE CONSOLE RATHER THAN WAITING (THIS IS USED
  232.      AGAIN WITHIN MACROS TO STOP THE DISPLAY - THE MACRO EXPANSION
  233.      STOPS UNTIL A CHARACTER IS READ.  IF THE CHARACTER IS NOT A BREAK
  234.      THEN THE MACRO EXPANSION CONTINUES NORMALLY).
  235.  
  236.         NOTE THAT A POUND SIGN IS TAKEN AS THE NUMBER 65535, ALL
  237.      UNSIGNED NUMBERS ARE ASSUMED POSITIVE, AND A SINGLE - IS ASSUMED -1
  238.  
  239.      A NUMBER OF COMMANDS CAN BE GROUPED TOGETHER AND EXECUTED
  240.      REPETITIVELY USING THE MACRO COMMAND WHICH TAKES THE FORM
  241.  
  242.              <NUMBER>MC1C2...CN<DELIMITER>
  243.  
  244.      WHERE <NUMBER> IS A NON-NEGATIVE INTEGER N, AND <DELIMITER> IS
  245.      <ENDFILE> OR <CR>.  THE COMMANDS C1 ... CN  FOLLOWING THE M ARE
  246.      EXECUTED N TIMES, STARTING AT THE CURRENT POSITION IN THE BUFFER.
  247.      IF N IS 0, 1, OR OMITTED, THE COMMANDS ARE EXECUTED UNTIL THE END
  248.      IF THE BUFFER IS ENCOUNTERED.
  249.  
  250.      THE FOLLOWING MACRO, FOR EXAMPLE, CHANGES ALL OCCURRENCES OF
  251.      THE NAME 'GAMMA' TO 'DELTA', AND PRINTS THE LINES WHICH
  252.      WERE CHANGED:
  253.  
  254.                  MFGAMMA<ENDFILE>-5DIDELTA<ENDFILE>0LT<CR>
  255.  
  256.     (NOTE: AN <ENDFILE> IS THE CP/M END OF FILE MARK - CONTROL-Z)
  257.  
  258.     IF ANY KEY IS DEPRESSED DURING TYPING OR MACRO EXPANSION, THE
  259.     FUNCTION IS CONSIDERED TERMINATED, AND CONTROL RETURNS TO THE
  260.     OPERATOR.
  261.  
  262.     ERROR CONDITIONS ARE INDICATED BY PRINTING ONE OF THE CHARACTERS:
  263.  
  264.      SYMBOL                    ERROR CONDITION
  265.      ------      ----------------------------------------------------
  266.      GREATER     FREE MEMORY IS EXHAUSTED - ANY COMMAND CAN BE ISSUED
  267.                  WHICH DOES NOT INCREASE MEMORY REQUIREMENTS.
  268.      QUESTION    UNRECOGNIZED COMMAND OR ILLEGAL NUMERIC FIELD
  269.      POUND       CANNOT APPLY THE COMMAND THE NUMBER OF TIMES SPECFIED
  270.                  (OCCURS IF SEARCH STRING CANNOT BE FOUND)
  271.      LETTER O    CANNOT OPEN <FILENAME>.LIB IN R COMMAND
  272.  
  273.      THE ERROR CHARACTER IS ALSO ACCOMPANIED BY THE LAST CHARACTER
  274.      SCANNED WHEN THE ERROR OCCURRED.                      */
  275.  
  276. $ eject
  277.  
  278. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  279.  
  280.  
  281.                   * * *  GLOBAL VARIABLES * * *
  282.  
  283.  
  284.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  285.  
  286. DECLARE LIT LITERALLY 'LITERALLY',
  287.     DCL LIT 'DECLARE',
  288.     PROC LIT 'PROCEDURE',
  289.     ADDR LIT 'ADDRESS',
  290.     BOOLEAN LIT 'BYTE',
  291.     CTLL LIT '0CH',
  292.     CTLR LIT '12H',                /* REPEAT LINE IN INSERT MODE */
  293.     CTLU LIT '15H',                /* LINE DELETE IN INSERT MODE */
  294.     CTLX LIT '18H',                /* EQUIVALENT TO CTLU */
  295.     CTLH LIT '08H',                /* BACKSPACE */
  296.     TAB LIT '09H',                 /* TAB CHARACTER */
  297.     LCA  LIT '110$0001B',          /* LOWER CASE A */
  298.     LCZ  LIT '111$1010B',          /* LOWER CASE Z */
  299.     ESC  LIT '1BH',                /* ESCAPE CHARACTER */
  300.     ENDFILE LIT '1AH';             /* CP/M END OF FILE */
  301.  
  302. DECLARE 
  303.     TRUE LITERALLY '1', 
  304.     FALSE LITERALLY '0',
  305.     FOREVER LITERALLY 'WHILE TRUE',
  306.     CTRL$Y LITERALLY '19h',
  307.     CR LITERALLY '13',
  308.     LF LITERALLY '10',
  309.     WHAT LITERALLY '63';
  310.  
  311. DECLARE
  312.     MAX ADDRESS,                   /* .MEMORY(MAX)=0 (END) */
  313.     MAXM ADDRESS,                  /* MINUS 1 */
  314.     HMAX ADDRESS;                  /* = MAX/2 */
  315.  
  316. declare
  317.     i  byte;                       /* used by command parsing */
  318.  
  319. DECLARE
  320.     us literally '8',              /* file from user 0   */
  321.     RO LITERALLY '9',              /* R/O FILE INDICATOR */
  322.     SY LITERALLY '10',             /* SYSTEM FILE ATTRIBUTE */
  323.     EX LITERALLY '12',             /* EXTENT NUMBER POSITION */
  324.     UB LITERALLY '13',             /* UNFILLED BYTES */
  325.     ck LITERALLY '13',             /* checksum */
  326.     MD LITERALLY '14',             /* MODULE NUMBER POSITION */
  327.     NR LITERALLY '32',             /* NEXT RECORD FIELD */
  328.     FS LITERALLY '33',             /* FCB SIZE */
  329.     RFCB (FS) BYTE                 /* READER FILE CONTROL BLOCK */
  330.         INITIAL(0, /* FILE NAME */ '        ',
  331.                    /* FILE TYPE */ 'LIB',0,0,0),
  332.     RBP BYTE,                      /* READ BUFFER POINTER */
  333.     XFCB (FS) BYTE                 /* XFER FILE CONTROL BLOCK */
  334.         INITIAL(0, 'X$$$$$$$','LIB',0,0,0,0,0,0,0),
  335.     XFCBE BYTE AT(.XFCB(EX)),      /* XFCB EXTENT */
  336.     XFCBR BYTE AT(.XFCB(NR)),      /* XFCB RECORD # */
  337.     xfcbext byte initial(0),       /* save xfcb extent for appends */
  338.     xfcbrec byte initial(0),       /* save xfcb record for appends */
  339.     XBUFF (SECTSIZE) BYTE,         /* XFER BUFFER */
  340.     XBP BYTE,                      /* XFER POINTER */
  341.  
  342.     NBUF BYTE,                     /* NUMBER OF BUFFERS */
  343.     BUFFLENGTH ADDRESS,            /* NBUF * SECTSIZE */
  344.     SFCB (FS) BYTE AT(.FCB),       /* SOURCE FCB = DEFAULT FCB */
  345.     SDISK BYTE AT (.FCB),          /* SOURCE DISK */
  346.     SBUFFADR ADDRESS,              /* SOURCE BUFFER ADDRESS */
  347.     SBUFF BASED SBUFFADR (128) BYTE, /* SOURCE BUFFER */
  348.     password (16) byte initial(0), /* source password */
  349.  
  350.     DFCB (FS) BYTE,                /* DEST FILE CONTROL BLOCK */
  351.     DDISK BYTE AT (.DFCB),         /* DESTINATION DISK */
  352.     DBUFFADR ADDRESS,              /* DESTINATION BUFFER ADDRESS */
  353.     DBUFF BASED DBUFFADR (128) BYTE, /* DEST BUFFER */
  354.     NSOURCE ADDRESS,               /* NEXT SOURCE CHARACTER */
  355.     NDEST   ADDRESS,               /* NEXT DESTINATION CHAR */
  356.  
  357.     tmpfcb (FS) BYTE;              /* temporary fcb for rename & deletes */
  358.  
  359. DECLARE                                      /**** some of the logicals *****/ 
  360.     newfile      BOOLEAN initial (false), /* true if no source file */
  361.     onefile      BOOLEAN initial (true),  /* true if output file=input file */
  362.     XFERON       BOOLEAN initial (false), /* TRUE IF XFER ACTIVE */
  363.     reading      BOOLEAN initial (false), /* TRUE IF reading RFCB */
  364.     PRINTSUPPRESS BOOLEAN initial (false),/* TRUE IF PRINT SUPPRESSED */
  365.     sys          BOOLEAN initial (false), /* true if system file */
  366.     protection      BOOLEAN initial (false), /* password protection mode */
  367.     INSERTING    BOOLEAN,                /* TRUE IF INSERTING CHARACTERS */
  368.     READBUFF     BOOLEAN,                /* TRUE IF END OF READ BUFFER */
  369.     TRANSLATE    BOOLEAN initial (false), /* TRUE IF XLATION TO UPPER CASE */
  370.     UPPER        BOOLEAN initial (false), /* TRUE IF GLOBALLY XLATING TO UC */
  371.     LINESET      BOOLEAN initial (true),  /* TRUE IF LINE #'S PRINTED */
  372.     has$bdos3    BOOLEAN initial (false), /* true if BDOS version >= 3.0 */
  373.     tail BOOLEAN initial (true),  /* true if readiing from cmd tail */
  374.     dot$found    BOOLEAN initial (false); /* true if dot found in fname parse*/
  375.  
  376. DECLARE
  377.     dtype  (3)  byte,                /* destination file type */
  378.     libfcb (12) byte initial(0,'X$$$$$$$LIB'),/* default lib name */
  379.     tempfl (3)  byte initial('$$$'), /* temporary file type */
  380.     backup (3)  byte initial('BAK'); /* backup file type */
  381.  
  382. declare
  383.    error$code address;
  384.  
  385. DECLARE
  386.     COLUMN  BYTE initial(0),  /* CONSOLE COLUMN POSITION */
  387.     SCOLUMN BYTE INITIAL(8),  /* STARTING COLUMN IN "I" MODE */
  388.     TCOLUMN BYTE,             /* TEMP DURING BACKSPACE */
  389.     QCOLUMN BYTE;             /* TEMP DURING BACKSPACE */
  390.  
  391. DECLARE DCNT BYTE;          /* RETURN CODE FROM MON? CALLS */
  392.  
  393. /* COMMAND BUFFER */
  394. DECLARE (MAXLEN,COMLEN) BYTE, COMBUFF(128) BYTE,
  395.     CBP BYTE initial(0);
  396.  
  397. DECLARE /* LINE COUNTERS */
  398.     BASELINE ADDRESS,        /* CURRENT LINE */
  399.     RELLINE  ADDRESS;        /* RELATIVE LINE IN TYPEOUT */
  400.  
  401. DECLARE
  402.     FORWARD LIT '1',
  403.     BACKWARD LIT '0',
  404.     RUBOUT LIT '07FH',
  405.     POUND LIT '23H',
  406.     MACSIZE LIT '128',       /* MAX MACRO SIZE */
  407.     SCRSIZE LIT '100',       /* SCRATCH BUFFER SIZE */
  408.     COMSIZE LIT 'ADDRESS';   /* DETERMINES MAX COMMAND NUMBER*/
  409.  
  410. DCL MACRO(MACSIZE) BYTE,
  411.     SCRATCH(SCRSIZE) BYTE,     /* SCRATCH BUFFER FOR F,N,S */
  412.     (WBP, WBE, WBJ)  BYTE,     /* END OF F STRING, S STRING, J STRING */
  413.     (FLAG, MP, MI, XP) BYTE,
  414.     MT COMSIZE;
  415.  
  416. DCL (START, RESTART, OVERCOUNT, OVERFLOW, 
  417.      disk$err, dir$err, RESET, BADCOM) LABEL;
  418.  
  419. /* global variables used by file parsing routines */
  420. dcl ncmd byte initial(0);
  421.    
  422.  
  423. DCL (DISTANCE, TDIST) COMSIZE,
  424.     (DIRECTION, CHAR) BYTE,
  425.     ( FRONT, BACK, FIRST, LASTC) ADDR;
  426.  
  427. dcl LPP byte initial(23);          /* LINES PER PAGE */
  428.  
  429. /* the following stucture is used near plm: to set
  430.    the lines per page from the BDOS 3 SCB */
  431. declare
  432.     pb (2) byte data (28,0);
  433.  
  434. declare 
  435.     ver address;                   /* VERSION NUMBER */
  436.  
  437. declare
  438.     err$msg         address initial(0),
  439.     invalid (*)     byte data ('Invalid Filename$'),
  440.     dirfull (*)     byte data ('DIRECTORY FULL$'),
  441.     diskfull (*)    byte data ('DISK FULL$'),
  442.     password$err(*) byte data ('Creating Password$'),
  443.     not$found (*)   byte data ('File not found$'),
  444.     notavail (*)    byte data ('File not available$');
  445. $ eject
  446.  
  447. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  448.  
  449.  
  450.                * * *  CP/M INTERFACE ROUTINES * * *
  451.  
  452.  
  453.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  454.  
  455.  
  456.  /* IO SECTION */
  457.  
  458. READCHAR: PROCEDURE BYTE; RETURN MON2(1,0);
  459.     END READCHAR;
  460.  
  461.   conin: 
  462.     procedure byte;
  463.     return mon2(6,0fdh);
  464.     end conin;
  465.  
  466. PRINTCHAR: PROCEDURE(CHAR);
  467.     DECLARE CHAR BYTE;
  468.     IF PRINTSUPPRESS THEN RETURN;
  469.     CALL MON1(2,CHAR);
  470.     END PRINTCHAR;
  471.  
  472. TTYCHAR: PROCEDURE(CHAR);
  473.     DECLARE CHAR BYTE;
  474.     IF CHAR >= ' ' THEN COLUMN = COLUMN + 1;
  475.     IF CHAR = LF THEN COLUMN = 0;
  476.     CALL PRINTCHAR(CHAR);
  477.     END TTYCHAR;
  478.  
  479. BACKSPACE: PROCEDURE;
  480.     /* MOVE BACK ONE POSITION */
  481.     IF COLUMN = 0 THEN RETURN;
  482.     CALL TTYCHAR(CTLH); /* COLUMN = COLUMN - 1 */
  483.     CALL TTYCHAR(' ' ); /* COLUMN = COLUMN + 1 */
  484.     CALL TTYCHAR(CTLH); /* COLUMN = COLUMN - 1 */
  485.     COLUMN = COLUMN - 2;
  486.     END BACKSPACE;
  487.  
  488. PRINTABS: PROCEDURE(CHAR);
  489.     DECLARE (CHAR,I,J) BYTE;
  490.     I = CHAR = TAB AND 7 - (COLUMN AND 7);
  491.     IF CHAR = TAB THEN CHAR = ' ';
  492.         DO J = 0 TO I;
  493.         CALL TTYCHAR(CHAR);
  494.         END;
  495.     END PRINTABS;
  496.  
  497. GRAPHIC: PROCEDURE(C) BOOLEAN;
  498.     DECLARE C BYTE;
  499.     /* RETURN TRUE IF GRAPHIC CHARACTER */
  500.     IF C >= ' ' THEN RETURN TRUE;
  501.     RETURN C = CR OR C = LF OR C = TAB;
  502.     END GRAPHIC;
  503.  
  504. PRINTC: PROCEDURE(C);
  505.     DECLARE C BYTE;
  506.     IF NOT GRAPHIC(C) THEN
  507.         DO; CALL PRINTABS('^');
  508.         C = C + '@';
  509.         END;
  510.     CALL PRINTABS(C);
  511.     END PRINTC;
  512.  
  513. CRLF: PROCEDURE;
  514.     CALL PRINTC(CR); CALL PRINTC(LF);
  515.     END CRLF;
  516.  
  517. PRINTM: PROCEDURE(A);
  518.     DECLARE A ADDRESS;
  519.     CALL MON1(9,A);
  520.     END PRINTM;
  521.  
  522. PRINT: PROCEDURE(A);
  523.     DECLARE A ADDRESS;
  524.     CALL CRLF;
  525.     CALL PRINTM(A);
  526.     END PRINT;
  527.  
  528. perror: procedure(a);
  529.     declare a address;
  530.     call print(.(tab,'ERROR - $'));
  531.     call printm(A);
  532.     call crlf;
  533.     end perror;
  534.  
  535. READ: PROCEDURE(A);
  536.     DECLARE A ADDRESS;
  537.     CALL MON1(10,A);
  538.     END READ;
  539.  
  540.         /* used for library files */
  541. OPEN: PROCEDURE(FCB);
  542.      DECLARE FCB ADDRESS;
  543.      if MON2(15,FCB) = 255 then do;
  544.         flag = 'O';
  545.     err$msg = .not$found;
  546.         go to reset;
  547.         end;
  548.      END OPEN;
  549.  
  550.         /* used for main source file */
  551. OPEN$FILE: PROCEDURE(FCB) ADDRESS;
  552.      DECLARE FCB ADDRESS;
  553.      RETURN MON3(15,FCB);
  554.      END OPEN$FILE;
  555.  
  556. CLOSE: PROCEDURE(FCB);
  557.     DECLARE FCB ADDRESS;
  558.     DCNT = MON2(16,FCB);
  559.     END CLOSE;
  560.  
  561. DELETE: PROCEDURE(FCB);
  562.     DECLARE FCB ADDRESS;
  563.     DCNT = MON2(19,FCB);
  564.     END DELETE;
  565.  
  566. DISKREAD: PROCEDURE(FCB) BYTE;
  567.     DECLARE FCB ADDRESS;
  568.     RETURN MON2(20,FCB);
  569.     END DISKREAD;
  570.  
  571. DISKWRITE: PROCEDURE(FCB) BYTE;
  572.     DECLARE FCB ADDRESS;
  573.     RETURN MON2(21,FCB);
  574.     END DISKWRITE;
  575.  
  576. RENAME: PROCEDURE(FCB);
  577.     DECLARE FCB ADDRESS;
  578.     CALL MON1(23,FCB);
  579.     END RENAME;
  580.  
  581. READCOM: PROCEDURE;
  582.     MAXLEN = 128; CALL READ(.MAXLEN);
  583.     END READCOM;
  584.  
  585. BREAK$KEY: PROCEDURE BOOLEAN;
  586.     IF MON2(11,0) THEN
  587.         DO; /* CLEAR CHAR */
  588.         IF MON2(1,0) = CTRL$Y THEN 
  589.             RETURN TRUE;
  590.         END;
  591.     RETURN FALSE;
  592.     END BREAK$KEY;
  593.  
  594. CSELECT: PROCEDURE BYTE;
  595.     /* RETURN CURRENT DRIVE NUMBER */
  596.     RETURN MON2(25,0);
  597.     END CSELECT;
  598.  
  599. SETDMA: PROCEDURE(A);
  600.     DECLARE A ADDRESS;
  601.     /* SET DMA ADDRESS */
  602.     CALL MON1(26,A);
  603.     END SETDMA;
  604.  
  605. set$attribute: procedure(FCB);
  606.     declare fcb address;
  607.     call MON1(30,FCB);
  608.     end set$attribute;
  609.  
  610. /* The PL/M built-in procedure "MOVE" can be used to move storage,
  611.    its definition is:  
  612.  
  613. MOVE: PROCEDURE(COUNT,SOURCE,DEST);
  614.         DECLARE (COUNT,SOURCE,DEST) ADDRESS;
  615.         / MOVE DATA FROM SOURCE TO DEST ADDRESSES, FOR COUNT BYTES /
  616.         END MOVE;
  617.   */
  618.                   /* this routine is included solely for 
  619.                      enconomy of space over the use of the
  620.                      equivalent (in-line) code generated by
  621.                      the built-in function */
  622. move:   proc(c,s,d);
  623.     dcl (s,d) addr, c byte;
  624.     dcl a based s byte, b based d byte;
  625.  
  626.         do while (c:=c-1)<>255;
  627.         b=a; s=s+1; d=d+1;
  628.         end;
  629.     end move;
  630.  
  631. write$xfcb: PROCEDURE(FCB);
  632.     DECLARE FCB ADDRESS;
  633.     call move(8,.password,.password(8));
  634.     if MON2(103,FCB)= 0ffh then
  635.        call perror(.password$err);
  636.     END write$xfcb;
  637.  
  638. read$xfcb: PROCEDURE(FCB);
  639.     DECLARE FCB ADDRESS;
  640.     call MON1(102,FCB);
  641.     END read$xfcb;
  642.  
  643.   /* 0ff => return BDOS errors */
  644. return$errors:
  645.     procedure(mode);
  646.     declare mode byte;
  647.       call mon1 (45,mode);    
  648.     end return$errors;
  649.  
  650. REBOOT: PROCEDURE;
  651.     IF XFERON THEN 
  652.         CALL DELETE(.libfcb);
  653.     CALL BOOT;
  654.     END REBOOT;
  655.  
  656. version: procedure address;
  657.     /* returns current cp/m version # */
  658.     return mon3(12,0);
  659.     end version;
  660. $ eject
  661.  
  662. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  663.  
  664.  
  665.                   * * *  SUBROUTINES  * * *
  666.  
  667.  
  668.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  669.  
  670.  
  671.   /*  INPUT / OUTPUT BUFFERING ROUTINES */
  672.  
  673.  
  674.  
  675.                   /* abort ED and print error message */
  676. ABORT: PROCEDURE(A);
  677.     DECLARE A ADDRESS;
  678.     CALL perror(A);
  679.     CALL REBOOT;
  680.     END ABORT;
  681. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  682.  
  683.  
  684.                   /* fatal file error */
  685. FERR: PROCEDURE;
  686.     CALL CLOSE(.DFCB); /* ATTEMPT TO CLOSE FILE FOR LATER RECOVERY */
  687.     CALL ABORT (.dirfull);
  688.     END FERR;
  689. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  690.  
  691.  
  692.                   /* set password if cpm 3*/
  693. setpassword: procedure;
  694.     if has$bdos3 then
  695.         call setdma(.password);
  696.     end setpassword;
  697. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  698.  
  699.  
  700.                   /* delete file at afcb */
  701. delete$file: procedure(afcb);
  702.     declare afcb address;
  703.     call setpassword;
  704.     call delete(afcb);
  705.     end delete$file;
  706. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  707.  
  708.  
  709.                   /* rename file at afcb */
  710. rename$file: procedure(afcb);
  711.     declare afcb address;
  712.     call delete$file(afcb+16);     /* delete new file */
  713.     call setpassword;
  714.     call rename(afcb);
  715.     end rename$file;
  716. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  717.  
  718.  
  719.                   /* make file at afcb */
  720. make$file: procedure(afcb);
  721.     declare afcb address;
  722.     call delete$file(afcb);     /* delete file */
  723.     call setpassword;
  724.     DCNT = MON2(22,afcb);       /* create file */
  725.     end make$file;
  726. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  727.  
  728.  
  729.                   /* fill string @ s for c bytes with f */
  730. fill:   proc(s,f,c);
  731.     dcl s addr,
  732.         (f,c) byte,
  733.         a based s byte;
  734.  
  735.         do while (c:=c-1)<>255;
  736.         a = f;
  737.         s = s+1;
  738.         end;
  739.     end fill;
  740.  
  741.  
  742.  
  743.  
  744. $ eject
  745.  
  746. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  747.  
  748.  
  749.                 * * *  FILE HANDLING ROUTINES  * * *
  750.  
  751.  
  752.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  753.  
  754.  
  755.  
  756.                   /* set destination file type to type at A */
  757. SETTYPE: PROCEDURE(afcb,A);
  758.     DECLARE (afcb, A) ADDRESS;
  759.     CALL MOVE(3,A,aFCB+9);
  760.     END SETTYPE;
  761. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  762.  
  763.  
  764.                   /* set dma to xfer buffer */
  765. SETXDMA: PROCEDURE;
  766.     CALL SETDMA(.XBUFF);
  767.     END SETXDMA;
  768. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  769.  
  770.  
  771.                   /* fill primary source buffer  */
  772. FILLSOURCE: PROCEDURE;
  773.     DECLARE I BYTE;
  774.     ZN: PROCEDURE;
  775.         NSOURCE = 0;
  776.         END ZN;
  777.  
  778.      CALL ZN;
  779.         DO I = 0 TO NBUF;
  780.         CALL SETDMA(SBUFFADR+NSOURCE);
  781.         IF (DCNT := DISKREAD(.FCB)) <> 0 THEN
  782.             DO; IF DCNT > 1 THEN CALL FERR;
  783.             SBUFF(NSOURCE) = ENDFILE;
  784.             I = NBUF;
  785.             END;
  786.         ELSE
  787.             NSOURCE = NSOURCE + SECTSIZE;
  788.         END;
  789.     CALL ZN;
  790.     END FILLSOURCE;
  791. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  792.  
  793.  
  794.                   /* get next character in source file */
  795. GETSOURCE: PROCEDURE BYTE;
  796.     DECLARE B BYTE;
  797.     if newfile then return endfile;   /* in case they try to #a */
  798.     IF NSOURCE >= BUFFLENGTH THEN CALL FILLSOURCE;
  799.     IF (B := SBUFF(NSOURCE)) <> ENDFILE THEN
  800.         NSOURCE = NSOURCE + 1;
  801.     RETURN B;
  802.     END GETSOURCE;
  803. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  804.  
  805.  
  806.                   /* try to free space by erasing backup */
  807. erase$bak: PROCEDURE BOOLEAN;
  808.  
  809.     if onefile then 
  810.         if newfile then do;
  811.             call move(fs,.dfcb,.tmpfcb);  /* can't diddle with open fcb */
  812.             CALL SETTYPE(.tmpfcb,.BACKUP);
  813.             CALL DELETE$file(.tmpfcb);
  814.             if dcnt <> 255 then
  815.                 return true;
  816.             end;
  817.     return false;
  818.     end erase$bak;
  819.  
  820.  
  821. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  822.  
  823.  
  824.                   /* write output buffer up to (not including)
  825.                      ndest  (low 7 bits of ndest are 0  */
  826. WRITEDEST: PROCEDURE;
  827.     DECLARE (I,N,save$ndest) BYTE;
  828.  
  829.     n = shr(ndest,sectshf);   /* calculate number sectors to write */
  830.     if n=0 then return;       /* no need to write if we haven't filled sector*/
  831.     save$ndest = ndest;       /* save for error recovery */
  832.     ndest = 0;
  833.         DO I = 1 TO N;
  834. retry:
  835.         CALL SETDMA(DBUFFADR+NDEST);
  836.         IF DISKWRITE(.DFCB) <> 0 THEN 
  837.             if erase$bak then
  838.                 go to retry;
  839.             else do;    /* reset buffer, let them take action (delete files) */
  840.                 if ndest <> 0 then
  841.                     call move(save$ndest-ndest, dbuffadr+ndest, dbuffadr);
  842.                 ndest = save$ndest-ndest;
  843.                 go to disk$err;
  844.                 end;
  845.         NDEST = NDEST + SECTSIZE;
  846.         END;
  847.     ndest = 0;
  848.     END WRITEDEST;
  849. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  850.  
  851.  
  852.                   /* put a character in output buffer */
  853. PUTDEST: PROCEDURE(B);
  854.     DECLARE B BYTE;
  855.     IF NDEST >= BUFFLENGTH THEN CALL WRITEDEST;
  856.     DBUFF(NDEST) = B;
  857.     NDEST = NDEST + 1;
  858.     END PUTDEST;
  859. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  860.  
  861.  
  862.                   /* put a character in the xfer buffer */
  863. PUTXFER: PROCEDURE(C);
  864.     DECLARE C BYTE;
  865.     IF XBP >= SECTSIZE THEN /* BUFFER OVERFLOW */
  866.         DO; 
  867. retry:
  868.         CALL SETXDMA;
  869.         xfcbext = xfcbe;               /* save for appends */
  870.         xfcbrec = xfcbr; 
  871.         IF DISKWRITE(.XFCB) <> 0 THEN 
  872.             if erase$bak then
  873.                 go to retry;
  874.             else do;
  875. /********       call close(.xfcb);   ***  commented out whf 8/82 !!!! ********/
  876.                 go to disk$err;
  877.                 end;
  878.         XBP = 0;
  879.         END;
  880.     XBUFF(XBP) = C; XBP = XBP + 1;
  881.     END PUTXFER;
  882. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  883.  
  884.  
  885.                   /* empty xfer buffer and close file.
  886.                      This routine is added to allow saving lib
  887.                      files for future edits - DH 10/18/81 */
  888. close$xfer: procedure;
  889.     dcl i byte;
  890.  
  891.         do i = xbp to sectsize;
  892.         call putxfer(ENDFILE);
  893.         end;
  894.     call close(.xfcb);
  895.     end close$xfer;
  896. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  897.  
  898.  
  899.                   /* compare xfcb and rfcb to see if same */
  900. compare$xfer: procedure BOOLEAN;
  901.     dcl i byte;
  902.  
  903.     i = 12;
  904.         do while (i:=i-1) <> -1;
  905.         if xfcb(i) <> rfcb(i) then
  906.             return false;
  907.         end;
  908.     return true;
  909.     end compare$xfer;
  910. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  911.  
  912.  
  913.                   /* restore xfer file extent and current 
  914.                      record, read record and set xfer pointer
  915.                      to first ENDFILE */
  916. append$xfer: procedure;
  917.  
  918.     xfcbe = xfcbext;
  919.     call open(.xfcb);
  920.     xfcbr = xfcbrec;
  921.     call setxdma;
  922.     if diskread(.xfcb) = 0 then do;
  923.         xfcbr = xfcbrec;                /* write same record */
  924.             do xbp = 0 to sectsize;
  925.             if xbuff(xbp) = ENDFILE then
  926.                 return;
  927.             end;
  928.         end; 
  929.     end append$xfer;
  930. $ eject
  931. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  932.  
  933.                   * * *  END EDIT ROUTINE * * *
  934.  
  935.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  936.  
  937.                   /* finish edit, close files, rename */
  938. FINIS: PROCEDURE;
  939.     MOVEUP: PROCEDURE(afcb);
  940.     dcl afcb address;
  941.     /* set second filename (new name) for rename function */
  942.     CALL MOVE(16,aFCB,aFCB+16);
  943.     END MOVEUP;
  944.  
  945.     /* * * * * * * *  WRITE OUTPUT BUFFER  * * * * * * * * */
  946.     /* SET UNFILLED BYTES - USED FOR ISIS-II COMPATIBILITY */
  947.     /*  DFUB = 0 ; <<<< REMOVE FOR MP/M 2 , CP/M 3 */
  948.         DO WHILE (LOW(NDEST) AND 7FH) <> 0;
  949.         /* COUNTS UNFILLED BYTES IN LAST RECORD */
  950.         /* DFUB = DFUB + 1; */
  951.         CALL PUTDEST(ENDFILE);
  952.         END;
  953.     CALL WRITEDEST;
  954.  
  955.     if not newfile then
  956.         call close(.sfcb);    /* close this to clean up for mp/m environs */
  957.  
  958.     /* * * * * *  CLOSE TEMPORARY DESTINATION FILE  * * * * * */
  959.     CALL CLOSE(.DFCB);
  960.     IF DCNT = 255 THEN CALL FERR;
  961.     if sys then do;
  962.         dfcb(sy)=dfcb(sy) or 80h;
  963.         call setpassword;
  964.         call set$attribute(.dfcb);
  965.         end;
  966.  
  967.     /* * * * * *  RENAME SOURCE TO BACKUP IF ONE FILE  * * * * * */
  968.     if onefile then do;
  969.         call moveup(.sfcb);
  970.         CALL SETTYPE(.sfcb+16,.BACKUP);   /* set new type to BAK */
  971.         CALL RENAME$FILE(.SFCB);
  972.         end;
  973.  
  974.     /* * * * * *  RENAME TEMPORARY DESTINATION FILE  * * * * * */
  975.     CALL MOVEUP(.DFCB);
  976.     CALL SETTYPE(.DFCB+16,.DTYPE);
  977.     CALL RENAME$FILE(.DFCB);
  978.  
  979.     END FINIS;
  980. $ eject
  981.  
  982. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  983.  
  984.  
  985.                   * * *  COMMAND ROUTINES * * *
  986.  
  987.  
  988.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  989.  
  990.  
  991.  
  992.                   /* print a character if not macro expansion */
  993. PRINTNMAC: PROCEDURE(CHAR);
  994.     DECLARE CHAR BYTE;
  995.     IF MP <> 0 THEN RETURN;
  996.     CALL PRINTC(CHAR);
  997.     END PRINTNMAC;
  998. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  999.  
  1000.  
  1001.                   /* return true if lower case character */
  1002. LOWERCASE: PROCEDURE(C) BOOLEAN;
  1003.     DECLARE C BYTE;
  1004.     RETURN C >= LCA AND C <= LCZ;
  1005.     END LOWERCASE;
  1006. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1007.  
  1008.  
  1009.                   /* translate character to upper case */
  1010. UCASE: PROCEDURE(C) BYTE;
  1011.     DECLARE C BYTE;
  1012.     IF LOWERCASE(C) THEN RETURN C AND 5FH;
  1013.     RETURN C;
  1014.     END UCASE;
  1015. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1016.  
  1017.  
  1018.                   /* get password and place at fcb + 16 */
  1019. getpasswd:   proc;
  1020.     dcl (i,c) byte;
  1021.  
  1022.     call crlf;
  1023.     call print(.('Password ? ','$'));
  1024. retry:
  1025.     call fill(.password,' ',8);
  1026.         do i = 0 to 7;
  1027. nxtchr:
  1028.         if (c:=ucase(conin)) >= ' ' then 
  1029.             password(i)=c;
  1030.         if c = cr then
  1031.             go to exit;
  1032.         if c = CTLX then
  1033.             goto retry;
  1034.         if c = CTLH then do;
  1035.             if i<1 then
  1036.                 goto retry;
  1037.             else do;
  1038.                 password(i:=i-1)=' ';
  1039.                 goto nxtchr;
  1040.                 end;
  1041.             end;
  1042.         if c = 3 then
  1043.             call reboot;
  1044.         end;
  1045. exit:
  1046.     c = break$key;     /* clear raw I/O mode */
  1047.     end getpasswd;
  1048. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1049.  
  1050.  
  1051.                   /* translate to upercase if translate flag
  1052.                      is on (also translate ESC to ENDFILE) */
  1053. UTRAN: PROCEDURE(C) BYTE;
  1054.     DECLARE C BYTE;
  1055.     IF C = ESC THEN C = ENDFILE;
  1056.     IF TRANSLATE THEN RETURN UCASE(C);
  1057.     RETURN C;
  1058.     END UTRAN;
  1059. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1060.  
  1061.  
  1062.                   /* print the line number */
  1063. PRINTVALUE: PROCEDURE(V);
  1064.     /* PRINT THE LINE VALUE V */
  1065.     DECLARE D BYTE,
  1066.     ZERO BOOLEAN,
  1067.         (K,V) ADDRESS;
  1068.     K = 10000;
  1069.     ZERO = FALSE;
  1070.         DO WHILE K <> 0;
  1071.         D = LOW(V/K); V = V MOD K;
  1072.         K = K / 10;
  1073.         IF ZERO OR  D <> 0 THEN
  1074.             DO; ZERO = TRUE;
  1075.             CALL PRINTC('0'+D);
  1076.             END; 
  1077.         ELSE
  1078.             CALL PRINTC(' ');
  1079.         END;
  1080.     END PRINTVALUE;
  1081. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1082.  
  1083.  
  1084.                   /* print line with number V */
  1085. PRINTLINE: PROCEDURE(V);
  1086.     DECLARE V ADDRESS;
  1087.     IF NOT LINESET THEN RETURN;
  1088.     CALL PRINTVALUE(V);
  1089.     CALL PRINTC(':');
  1090.     CALL PRINTC(' ');
  1091.     IF INSERTING THEN 
  1092.         CALL PRINTC(' '); 
  1093.     ELSE
  1094.         CALL PRINTC('*');
  1095.     END PRINTLINE;
  1096. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1097.  
  1098.  
  1099.                   /* print current line (baseline) */
  1100. PRINTBASE: PROCEDURE;
  1101.     CALL PRINTLINE(BASELINE);
  1102.     END PRINTBASE;
  1103. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1104.  
  1105.  
  1106.                   /* print current line if not in a macro */
  1107. PRINTNMBASE: PROCEDURE;
  1108.     IF MP <> 0 THEN RETURN;
  1109.     CALL PRINTBASE;
  1110.     END PRINTNMBASE;
  1111. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1112.  
  1113.  
  1114.                   /* get next character from command tail */
  1115. getcmd: proc byte;
  1116.      if buff(ncmd+1) <> 0 then
  1117.         return buff(ncmd := ncmd + 1);
  1118.      return cr;
  1119.     end getcmd;
  1120. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1121.  
  1122.  
  1123.           /* read next char from command buffer */
  1124. READC: PROCEDURE BYTE;
  1125.     /* MAY BE MACRO EXPANSION */
  1126.     IF MP > 0 THEN
  1127.         DO;
  1128.         IF BREAK$KEY THEN GO TO OVERCOUNT;
  1129.         IF XP >= MP THEN
  1130.             DO; /* START AGAIN */
  1131.             IF MT <> 0 THEN
  1132.                 DO; IF (MT:=MT-1) = 0 THEN
  1133.                     GO TO OVERCOUNT;
  1134.                 END;
  1135.             XP = 0;
  1136.             END;
  1137.         RETURN UTRAN(MACRO((XP := XP + 1) - 1));
  1138.         END;
  1139.     IF INSERTING THEN RETURN UTRAN(READCHAR);
  1140.  
  1141.     /* GET COMMAND LINE */
  1142.     IF READBUFF THEN
  1143.         DO; READBUFF = FALSE;
  1144.         IF LINESET AND COLUMN = 0 THEN
  1145.             DO;
  1146.             IF BACK >= MAXM THEN
  1147.                 CALL PRINTLINE(0); 
  1148.             ELSE
  1149.                 CALL PRINTBASE;
  1150.             END; 
  1151.         ELSE
  1152.             CALL PRINTC('*');
  1153.         CALL READCOM; CBP = 0;
  1154.         CALL PRINTC(LF);
  1155.         COLUMN = 0;
  1156.         END;
  1157.     IF (READBUFF := CBP = COMLEN ) THEN 
  1158.         COMBUFF(CBP) = CR;
  1159.     RETURN UTRAN(COMBUFF((CBP := CBP +1) -1));
  1160.     END READC;
  1161. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1162.  
  1163.  
  1164.                   /* get upper case character from command 
  1165.                      buffer or command line */
  1166. get$uc: proc;
  1167.     if tail then 
  1168.         char = ucase(getcmd);
  1169.     else
  1170.         char = ucase(readc);
  1171.     end get$uc;
  1172. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1173.  
  1174.  
  1175.                   /* parse file name 
  1176.                      this routine requires a routine to get 
  1177.                      the next character and put it in a byte
  1178.                      variable */
  1179. parse$fcb: proc(fcbadr) byte;
  1180.     dcl fcbadr addr;
  1181.     dcl afcb based fcbadr (33) byte;
  1182.     dcl drive lit 'afcb(0)';
  1183.     dcl (i,delimiter) byte;
  1184.     dcl pflag boolean;
  1185.  
  1186.     putc: proc;
  1187.        afcb(i := i + 1) = char;
  1188.        pflag = true;
  1189.     end putc;
  1190.  
  1191.     delim: proc boolean;
  1192.        dcl del(*) byte data (CR,ENDFILE,' ,.;=:<>_[]*?');
  1193.                          /*   0 1        2345678901234 */
  1194.           do delimiter = 0 to last(del);
  1195.           if char = del(delimiter) then do;
  1196.              if delimiter > 12 then     /* * or ? */
  1197.                 call perror(.('Cannot Edit Wildcard Filename$'));
  1198.              return (true);
  1199.              end;
  1200.           end;
  1201.        return (false);
  1202.     end delim;
  1203.  
  1204.  
  1205.     pflag = false;
  1206.     flag = true;    /* global flag set to false if invalid filename */
  1207.     dot$found = false;  /* allow null extensions in 'parse$lib' */
  1208.     call get$uc;
  1209.     if char <> CR then 
  1210.         if char <> ENDFILE then do;
  1211.                         /* initialize fcb to srce fcb type & drive */
  1212.             call fill(fcbadr+12,0,21);
  1213.             call fill(fcbadr+1,' ',11);
  1214.                         /* clear leading blanks */
  1215.                 do while char = ' ';
  1216.                 call get$uc;
  1217.                 end;
  1218.                         /* parse loop */
  1219.                 do while not delim;
  1220.                 i = 0;
  1221.                     /* get name */
  1222.                     do while not delim;
  1223.                     if i > 7 then
  1224.                         go to err;        /* too long */
  1225.                     call putc;
  1226.                     call get$uc;
  1227.                     end;
  1228.                 if char = ':' then do;
  1229.                     /* get drive from afcb(1) */
  1230.                     if i <> 1 then
  1231.                         go to err;        /* invalid : */
  1232.                     if (drive := afcb(1) - 'A' + 1) > 16 then
  1233.                         go to err;        /* invalid drive */
  1234.                     afcb(1) = ' ';
  1235.                     call get$uc;
  1236.                     end;
  1237.                 if char = '.' then do;
  1238.                     /* get file type */
  1239.                     i = 8;
  1240.                     dot$found = true;         /* .ext specified (may be null)*/
  1241.                     call get$uc;
  1242.                         do while not delim;
  1243.                         if i > 10 then
  1244.                             go to err;        /* too long */
  1245.                         call putc;
  1246.                         call get$uc;
  1247.                         end;
  1248.                     end;
  1249.         if char = ';' then do;
  1250.             /* get password */
  1251.             call fill(fcbadr+16,' ',8);    /* where fn #152 puts passwd */
  1252.             i = 15;            /* passwd is last field */
  1253.             call get$uc;
  1254.             do while not delim;
  1255.             if i > 23 then
  1256.                 go to err;
  1257.             call putc;
  1258.             call get$uc;
  1259.             end;
  1260.             call move(8,fcbadr+16,.password); /* where ed wants it */
  1261.             end;
  1262.                 end;                /* parse loop */
  1263.             /* delimiter must be a comma or space */
  1264.             if delimiter > 3 then   /* not a CR,ENDFILE,SPACE,COMMA */
  1265.                 go to err;
  1266.             if not pflag then
  1267.                 go to err;
  1268.             end;
  1269.  
  1270.     return (pflag);
  1271.  
  1272. err:
  1273.     call perror(.invalid);
  1274.     return (flag:=false);
  1275.     end parse$fcb;
  1276. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1277.  
  1278.  
  1279.                   /* set up destination FCB */
  1280. setdest: PROCEDURE;
  1281.     dcl i byte;
  1282.  
  1283.     /* onefile = true; (initialized) */
  1284.     if not tail then do;
  1285.         call print(.('Enter Output file: $'));
  1286.         call readcom;
  1287.         cbp,readbuff = 0;
  1288.         call crlf;
  1289.         call crlf;
  1290.         end;
  1291.     if parse$fcb(.dfcb) then do;
  1292.         onefile = false;
  1293.         if dfcb(1) = ' ' then
  1294.             call move(15,.sfcb+1,.dfcb+1);
  1295.         end;
  1296.     else
  1297.         CALL MOVE(16,.SFCB,.DFCB);
  1298.     call move(3,.dfcb(9),.dtype);   /* save destination type */
  1299.     end setdest;
  1300. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1301.  
  1302.  
  1303.                   /* set read lib file DMA address */
  1304. SETRDMA: PROCEDURE;
  1305.     CALL SETDMA(.BUFF);
  1306.     END SETRDMA;
  1307. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1308.  
  1309.  
  1310.                   /* read lib file routine */
  1311. READFILE: PROCEDURE BYTE;
  1312.     IF RBP >= SECTSIZE THEN
  1313.         DO; CALL SETRDMA;
  1314.         IF DISKREAD(.RFCB) <> 0 THEN RETURN ENDFILE;
  1315.         RBP = 0;
  1316.         END;
  1317.     RETURN UTRAN(BUFF((RBP := RBP + 1) - 1));
  1318.     END READFILE;
  1319. $ eject
  1320.  
  1321. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  1322.  
  1323.  
  1324.                   * * *  INITIALIZATION  * * *
  1325.  
  1326.  
  1327.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  1328.  
  1329. SETUP: PROCEDURE;
  1330.  
  1331.     /* * * * * * * * *  OPEN SOURCE FILE  * * * * * * * * */
  1332.  
  1333.     sfcb(ex), sfcb(md), sfcb(nr) = 0;
  1334.     if has$bdos3 then do;
  1335.         call return$errors(0FEh);            /* set error mode */
  1336.         call setpassword;
  1337.         end;
  1338.     error$code = open$file (.SFCB);
  1339.     if has$bdos3 then do;                    /* extended bdos errors */
  1340.         call return$errors(0);               /* reset error mode */
  1341.         if low(error$code) = 0FFh and high(error$code) = 7 then do; 
  1342.             call getpasswd;                  /* let them enter password */
  1343.             call crlf;
  1344.             call crlf;
  1345.             call setpassword;                /* set dma to password */
  1346.             error$code = open$file(.fcb);    /* reset error$code */
  1347.             end;
  1348.         if low(error$code)=0FFh and high(error$code)<>0 then 
  1349.                 call abort(.notavail);       /* abort anything but not found */
  1350.         end;
  1351.     dcnt=low(error$code);
  1352.     if onefile then do;
  1353.         IF ROL(FCB(RO),1) THEN
  1354.             CALL abort(.('FILE IS READ/ONLY$'));
  1355.         else IF ROL(FCB(SY),1) THEN   /* system attribute */
  1356.             do;
  1357.             if rol(FCB(us),1) then
  1358.                 dcnt = 255;          /* user 0 file so create */
  1359.             else
  1360.                 sys = true;
  1361.             end;
  1362.         end;
  1363.  
  1364.     /* * * * * *  NEW FILE IF NO SOURCE FILE  * * * * * */
  1365.  
  1366.     IF DCNT = 255 THEN do;
  1367.         if not onefile then
  1368.             call abort(.not$found);
  1369.         newfile = true;
  1370.         CALL PRINT(.('NEW FILE$'));
  1371.         CALL CRLF;
  1372.         END; 
  1373.  
  1374.     /* * * * * *  MAKE TEMPORARY DESTINATION FILE  * * * * * */
  1375.  
  1376.     CALL SETTYPE(.dfcb,.tempfl);
  1377.     DFCB(EX)=0;
  1378.     CALL MAKE$file(.DFCB);
  1379.     if dcnt = 255 then
  1380.         call ferr;
  1381.     /* THE TEMP FILE IS NOW CREATED */
  1382.  
  1383.     /* now create the password if any */
  1384.     if protection <> 0 then do;
  1385.         dfcb(ex) = protection or 1;  /* set password */
  1386.         call setpassword;
  1387.         call write$xfcb(.dfcb);
  1388.         end;
  1389.     dfcb(ex),DFCB(32) = 0;  /* NEXT RECORD IS ZERO */
  1390.  
  1391.     /* * * * * * * * *  RESET BUFFER  * * * * * * * * */
  1392.  
  1393.     NSOURCE = BUFFLENGTH; 
  1394.     NDEST = 0;
  1395.     BASELINE = 1;           /* START WITH LINE 1 */
  1396.     END SETUP;
  1397.  
  1398.  
  1399.  
  1400.  
  1401. $ eject
  1402.  
  1403. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  1404.  
  1405.  
  1406.                   * * *  BUFFER MANAGEMENT * * *
  1407.  
  1408.  
  1409.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  1410.  
  1411.  
  1412.  
  1413.                   /* DISTANCE is the number of lines prefix 
  1414.                      to a command */
  1415.                   /* set maximum distance (0FFFFH) */
  1416. SETFF: PROCEDURE;
  1417.     DISTANCE = 0FFFFH;
  1418.     END SETFF;
  1419. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1420.  
  1421.  
  1422.                   /* return true if distance is zero */
  1423. DISTZERO: PROCEDURE BOOLEAN;
  1424.     RETURN DISTANCE = 0;
  1425.     END DISTZERO;
  1426. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1427.  
  1428.  
  1429.                   /* set distance to zero */
  1430. ZERODIST: PROCEDURE;
  1431.     DISTANCE = 0;
  1432.     END ZERODIST;
  1433. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1434.  
  1435.  
  1436.                   /* check for zero distance and decrement */
  1437. DISTNZERO: PROCEDURE BOOLEAN;
  1438.     IF NOT DISTZERO THEN
  1439.         DO; DISTANCE = DISTANCE - 1;
  1440.         RETURN TRUE;
  1441.         END;
  1442.     RETURN FALSE;
  1443.     END DISTNZERO;
  1444. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1445.  
  1446.  
  1447.                   /* set memory limits of command from 
  1448.                      distance and direction */
  1449. SETLIMITS: PROC;
  1450.     DCL (I,K,L,M) ADDR, (MIDDLE,LOOPING) BYTE;
  1451.     RELLINE = 1; /* RELATIVE LINE COUNT */
  1452.     IF DIRECTION = BACKWARD THEN
  1453.         DO; DISTANCE = DISTANCE+1; I = FRONT; L = 0; K = 0FFFFH;
  1454.         END; 
  1455.     ELSE
  1456.         DO; I = BACK; L = MAXM; K = 1;
  1457.         END;
  1458.  
  1459.     LOOPING = TRUE;
  1460.         DO WHILE LOOPING;
  1461.             DO WHILE (MIDDLE := I <> L) AND
  1462.                 MEMORY(M:=I+K) <> LF;
  1463.             I = M;
  1464.             END;
  1465.         LOOPING = (DISTANCE := DISTANCE - 1) <> 0;
  1466.         IF NOT MIDDLE THEN
  1467.             DO; LOOPING = FALSE;
  1468.             I = I - K;
  1469.             END; 
  1470.         ELSE do;
  1471.             RELLINE = RELLINE - 1;
  1472.             IF LOOPING THEN 
  1473.                 I = M;
  1474.             end;
  1475.         END;
  1476.  
  1477.     IF DIRECTION = BACKWARD THEN
  1478.         DO; FIRST = I; LASTC = FRONT - 1;
  1479.         END; 
  1480.     ELSE
  1481.         DO; FIRST = BACK + 1; LASTC = I + 1;
  1482.         END;
  1483.     END SETLIMITS;
  1484. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1485.  
  1486.  
  1487.                   /* increment current position */
  1488. INCBASE: PROCEDURE;
  1489.     BASELINE = BASELINE + 1;
  1490.     END INCBASE;
  1491. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1492.  
  1493.  
  1494.                   /* decrement current position */
  1495. DECBASE: PROCEDURE;
  1496.     BASELINE = BASELINE - 1;
  1497.     END DECBASE;
  1498. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1499.  
  1500.  
  1501.                   /* increment limits */
  1502. INCFRONT: PROC; FRONT = FRONT + 1;
  1503.     END INCFRONT;
  1504. INCBACK: PROCEDURE; BACK = BACK + 1;
  1505.     END INCBACK;
  1506. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1507.  
  1508.  
  1509.                   /* decrement limits */
  1510. DECFRONT: PROC; FRONT = FRONT - 1;
  1511.     IF MEMORY(FRONT) = LF THEN 
  1512.         CALL DECBASE;
  1513.     END DECFRONT;
  1514. DECBACK: PROC; BACK = BACK - 1;
  1515.     END DECBACK;
  1516. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1517.  
  1518.  
  1519.                   /* move current page in memory if move flag 
  1520.                      true otherwise delete it */
  1521. MEM$MOVE: PROC(MOVEFLAG);
  1522.     DECLARE (MOVEFLAG,C) BYTE;
  1523.     /* MOVE IF MOVEFLAG IS TRUE */
  1524.     IF DIRECTION = FORWARD THEN
  1525.         DO WHILE BACK < LASTC; CALL INCBACK;
  1526.         IF MOVEFLAG THEN
  1527.             DO;
  1528.             IF (C := MEMORY(BACK)) = LF THEN CALL INCBASE;
  1529.             MEMORY(FRONT) = C; CALL INCFRONT;
  1530.             END;
  1531.         END; 
  1532.     ELSE
  1533.         DO WHILE FRONT > FIRST; CALL DECFRONT;
  1534.         IF MOVEFLAG THEN
  1535.             DO; MEMORY(BACK) = memory(front); CALL DECBACK;
  1536.             END;
  1537.         END;
  1538.     END MEM$MOVE;
  1539. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1540.  
  1541.  
  1542.                   /* force a memory move */
  1543. MOVER: PROC;
  1544.     CALL MEM$MOVE(TRUE);
  1545.     END MOVER;
  1546. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1547.  
  1548.  
  1549.                   /* reset memory limit pointers, deleting
  1550.                      characters (used by D command) */
  1551. SETPTRS: PROC;
  1552.     CALL MEM$MOVE(FALSE);
  1553.     END SETPTRS;
  1554. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1555.  
  1556.  
  1557.                   /* set limits and force a move */
  1558. MOVELINES: PROC;
  1559.     CALL SETLIMITS;
  1560.     CALL MOVER;
  1561.     END MOVELINES;
  1562. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1563.  
  1564.  
  1565.                   /* set front to lower value deleteing
  1566.                      characters (used by S and J commands) */
  1567. setfront: proc(newfront);
  1568.     dcl newfront addr;
  1569.  
  1570.         do while front <> newfront;
  1571.         call decfront;
  1572.         end;
  1573.     end setfront;
  1574. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1575.  
  1576.  
  1577.                   /* set limits for memory move */
  1578. SETCLIMITS: PROC;
  1579.     IF DIRECTION = BACKWARD THEN
  1580.         DO; LASTC = BACK;
  1581.         IF DISTANCE > FRONT THEN
  1582.             FIRST = 1; 
  1583.         ELSE 
  1584.             FIRST = FRONT - DISTANCE;
  1585.         END; 
  1586.     ELSE
  1587.         DO; FIRST = FRONT;
  1588.         IF DISTANCE >= MAX - BACK THEN
  1589.             LASTC = MAXM; 
  1590.         ELSE 
  1591.             LASTC = BACK + DISTANCE;
  1592.         END;
  1593.     END SETCLIMITS;
  1594. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1595.  
  1596.  
  1597.                   /* read another line of input */
  1598. READLINE: PROCEDURE;
  1599.     DECLARE B BYTE;
  1600.     /* READ ANOTHER LINE OF INPUT */
  1601.     CTRAN: PROCEDURE(B) BYTE;
  1602.         DECLARE B BYTE;
  1603.         /* CONDITIONALLY TRANSLATE TO UPPER CASE ON INPUT */
  1604.         IF UPPER THEN RETURN UTRAN(B);
  1605.         RETURN B;
  1606.         END CTRAN;
  1607.     DO FOREVER;
  1608.     IF FRONT >= BACK THEN GO TO OVERFLOW;
  1609.     IF (B := CTRAN(GETSOURCE)) = ENDFILE THEN
  1610.         DO; CALL ZERODIST; RETURN;
  1611.         END;
  1612.     MEMORY(FRONT) = B;
  1613.     CALL INCFRONT;
  1614.     IF B = LF THEN
  1615.         DO; CALL INCBASE;
  1616.         RETURN;
  1617.         END;
  1618.     END;
  1619.     END READLINE;
  1620. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1621.  
  1622.  
  1623.                   /* write one line out */
  1624. WRITELINE: PROCEDURE;
  1625.     DECLARE B BYTE;
  1626.         DO FOREVER;
  1627.         IF BACK >= MAXM THEN /* EMPTY */
  1628.             DO; CALL ZERODIST; RETURN;
  1629.             END;
  1630.         CALL INCBACK;
  1631.         CALL PUTDEST(B:=MEMORY(BACK));
  1632.         IF B = LF THEN
  1633.             DO; CALL INCBASE;
  1634.             RETURN;
  1635.             END;
  1636.         END;
  1637.     END WRITELINE;
  1638. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1639.  
  1640.  
  1641.                   /* write lines until at least half the
  1642.                      the buffer is empty */
  1643. WRHALF: PROCEDURE;
  1644.     CALL SETFF;
  1645.         DO WHILE DISTNZERO;
  1646.         IF HMAX >= (MAXM - BACK) THEN 
  1647.             CALL ZERODIST; 
  1648.         ELSE
  1649.             CALL WRITELINE;
  1650.         END;
  1651.     END WRHALF;
  1652. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1653.  
  1654.  
  1655.                   /* write lines determined by distance 
  1656.                      called from W and E commands */
  1657. WRITEOUT: PROCEDURE;
  1658.     DIRECTION = BACKWARD; FIRST = 1; LASTC = BACK;
  1659.     CALL MOVER;
  1660.     IF DISTZERO THEN CALL WRHALF;
  1661.     /* DISTANCE = 0 IF CALL WRHALF */
  1662.         DO WHILE DISTNZERO;
  1663.         CALL WRITELINE;
  1664.         END;
  1665.     IF BACK < LASTC THEN
  1666.         DO; DIRECTION = FORWARD; CALL MOVER;
  1667.         END;
  1668.     END WRITEOUT;
  1669. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1670.  
  1671.  
  1672.                   /* clear memory buffer */
  1673. CLEARMEM: PROCEDURE;
  1674.     CALL SETFF;
  1675.     CALL WRITEOUT;
  1676.     END CLEARMEM;
  1677. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1678.  
  1679.  
  1680.                   /* clear buffers, terminate edit */
  1681. TERMINATE: PROCEDURE;
  1682.     CALL CLEARMEM;
  1683.     if not newfile then
  1684.         DO WHILE (CHAR := GETSOURCE) <> ENDFILE;
  1685.         CALL PUTDEST(CHAR);
  1686.         END;
  1687.     CALL FINIS;
  1688.     END TERMINATE;
  1689.  
  1690.  
  1691.  
  1692.  
  1693. $ eject
  1694.  
  1695. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  1696.  
  1697.  
  1698.                   * * *  COMMAND PRIMITIVES  * * *
  1699.  
  1700.  
  1701.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  1702.  
  1703.  
  1704.  
  1705.  
  1706.                   /* insert char into memory buffer */
  1707. INSERT: PROCEDURE;
  1708.     IF FRONT = BACK THEN GO TO OVERFLOW;
  1709.     MEMORY(FRONT) = CHAR; CALL INCFRONT;
  1710.     IF CHAR = LF THEN CALL INCBASE;
  1711.     END INSERT;
  1712. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1713.  
  1714.  
  1715.                   /* read a character and check for endfile
  1716.                      or CR  */
  1717. SCANNING: PROCEDURE BYTE;
  1718.     RETURN NOT ((CHAR := READC) = ENDFILE OR
  1719.                    (CHAR = CR AND NOT INSERTING));
  1720.     END SCANNING;
  1721. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1722.  
  1723.  
  1724.                   /* read command buffer and insert characters
  1725.                      into scratch 'til next endfile or CR for
  1726.                      find, next, juxt, or substitute commands
  1727.                      fill at WBE and increment WBE so it 
  1728.                      addresses the next empty position of scratch */
  1729. COLLECT: PROCEDURE;
  1730.  
  1731.     SETSCR: PROCEDURE;
  1732.         SCRATCH(WBE) = CHAR;
  1733.         IF (WBE := WBE + 1) >= SCRSIZE THEN GO TO OVERFLOW;
  1734.         END SETSCR;
  1735.  
  1736.         DO WHILE SCANNING;
  1737.         IF CHAR = CTLL THEN
  1738.             DO; CHAR = CR; CALL SETSCR;
  1739.             CHAR = LF;
  1740.             END;
  1741.         IF CHAR = 0 THEN GO TO BADCOM;
  1742.         CALL SETSCR;
  1743.         END;
  1744.     END COLLECT;
  1745. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1746.  
  1747.  
  1748.                   /* find the string in scratch starting at
  1749.                      PA and ending at PB */
  1750. FIND: PROCEDURE(PA,PB) BYTE;
  1751.     DECLARE (PA,PB) BYTE;
  1752.     DECLARE J ADDRESS,
  1753.         (K, MATCH) BYTE;
  1754.     J = BACK ;
  1755.     MATCH = FALSE;
  1756.         DO WHILE NOT MATCH AND (MAXM > J);
  1757.         LASTC,J = J + 1; /* START SCAN AT J */
  1758.         K = PA ; /* ATTEMPT STRING MATCH AT K */
  1759.             DO WHILE SCRATCH(K) = MEMORY(LASTC) AND
  1760.                 NOT (MATCH := K = PB);
  1761.             /* MATCHED ONE MORE CHARACTER */
  1762.             K = K + 1; LASTC = LASTC + 1;
  1763.             END;
  1764.         END;
  1765.     IF MATCH THEN /* MOVE STORAGE */
  1766.         DO; LASTC = LASTC - 1; CALL MOVER;
  1767.         END;
  1768.     RETURN MATCH;
  1769.     END FIND;
  1770. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1771.  
  1772.  
  1773.                   /* set up the search string for F, N, and
  1774.                      S commands  */
  1775. SETFIND: PROCEDURE;
  1776.     WBE = 0; CALL COLLECT; WBP = WBE;
  1777.     END SETFIND;
  1778. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1779.  
  1780.  
  1781.                   /* check for found string in F and S commands */
  1782. CHKFOUND: PROCEDURE;
  1783.     IF NOT FIND(0,WBP) THEN /* NO MATCH */ GO TO OVERCOUNT;
  1784.     END CHKFOUND;
  1785. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1786.  
  1787.  
  1788.                   /* parse read / xfer lib FCB */
  1789. parse$lib: procedure(fcbadr) byte;
  1790.     dcl fcbadr address;
  1791.     dcl afcb based fcbadr (33) byte;
  1792.     dcl b byte;
  1793.  
  1794.     b = parse$fcb(fcbadr);    
  1795.     /* flag = false if invalid */
  1796.     if not flag then do;
  1797.         flag = 'O';
  1798.         goto reset;
  1799.         end;
  1800.     if afcb(9) = ' ' and not dot$found then
  1801.         call move(3,.libfcb(9),fcbadr+9);
  1802.     if afcb(1) = ' ' then
  1803.         call move(8,.libfcb(1),fcbadr+1);
  1804.     return b;
  1805.     end parse$lib;
  1806. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1807.  
  1808.  
  1809.                   /* print relative position */
  1810. PRINTREL: PROCEDURE;
  1811.     CALL PRINTLINE(BASELINE+RELLINE);
  1812.     END PRINTREL;
  1813. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1814.  
  1815.  
  1816.                   /* type lines command */
  1817. TYPELINES: PROCEDURE;
  1818.     DCL I ADDR;
  1819.     DCL C BYTE;
  1820.     CALL SETLIMITS;
  1821.     /* DISABLE THE * PROMPT */
  1822.     INSERTING = TRUE;
  1823.     IF DIRECTION = FORWARD THEN
  1824.         DO; RELLINE = 0; I = FRONT;
  1825.         END; 
  1826.     ELSE
  1827.         I = FIRST;
  1828.     IF (C := MEMORY(I-1)) = LF then  do;
  1829.         if COLUMN <> 0 THEN
  1830.             CALL CRLF;
  1831.         end;
  1832.     else
  1833.         relline = relline + 1;
  1834.  
  1835.         DO I = FIRST TO LASTC;
  1836.         IF C = LF THEN
  1837.             DO;
  1838.             CALL PRINTREL;
  1839.             RELLINE = RELLINE + 1;
  1840.             IF BREAK$KEY THEN GO TO OVERCOUNT;
  1841.             END;
  1842.         CALL PRINTC(C:=MEMORY(I));
  1843.         END;
  1844.     END TYPELINES;
  1845. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1846.  
  1847.  
  1848.                   /* set distance to lines per page (LPP) */
  1849. SETLPP: PROCEDURE;
  1850.     DISTANCE = LPP;
  1851.     END SETLPP;
  1852. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1853.  
  1854.  
  1855.                   /* save distance in TDIST */
  1856. SAVEDIST: PROCEDURE;
  1857.     TDIST = DISTANCE;
  1858.     END SAVEDIST;
  1859. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1860.  
  1861.  
  1862.                   /* Restore distance from TDIST */
  1863. RESTDIST: PROCEDURE;
  1864.     DISTANCE = TDIST;
  1865.     END RESTDIST;
  1866. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1867.  
  1868.  
  1869.                   /* page command (move n pages and print) */
  1870. PAGE: PROCEDURE;
  1871.     DECLARE I BYTE;
  1872.     CALL SAVEDIST;
  1873.     CALL SETLPP;
  1874.     CALL MOVELINES;
  1875.     I = DIRECTION;
  1876.     DIRECTION = FORWARD;
  1877.     CALL SETLPP;
  1878.     CALL TYPELINES;
  1879.     DIRECTION = I;
  1880.     IF LASTC = MAXM OR FIRST = 1 THEN 
  1881.         CALL ZERODIST;
  1882.     ELSE 
  1883.         CALL RESTDIST;
  1884.     END PAGE;
  1885. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1886.  
  1887.  
  1888.                   /* wait command (1/2 second time-out) */
  1889. WAIT: PROCEDURE;
  1890.     DECLARE I BYTE;
  1891.         DO I = 0 TO 19;
  1892.         IF BREAK$KEY THEN GO TO RESET;
  1893.         CALL TIME(250);
  1894.         END;
  1895.     END WAIT;
  1896. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1897.  
  1898.  
  1899.                   /* set direction to forward */
  1900. SETFORWARD: PROCEDURE;
  1901.     DIRECTION = FORWARD;
  1902.     DISTANCE = 1;
  1903.     END SETFORWARD;
  1904. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1905.  
  1906.  
  1907.                   /* append 'til buffer is at least half full */
  1908. APPHALF: PROCEDURE;
  1909.     CALL SETFF; /* DISTANCE = 0FFFFH */
  1910.         DO WHILE DISTNZERO;
  1911.         IF FRONT >= HMAX THEN 
  1912.             CALL ZERODIST; 
  1913.         ELSE
  1914.             CALL READLINE;
  1915.         END;
  1916.     END APPHALF;
  1917. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1918.  
  1919.  
  1920.                   /* insert CR LF characters */
  1921. INSCRLF: PROCEDURE;
  1922.     /* INSERT CR LF CHARACTERS */
  1923.     CHAR = CR; CALL INSERT;
  1924.     CHAR = LF; CALL INSERT;
  1925.     END INSCRLF;
  1926. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1927.  
  1928.  
  1929.                   /* test if invalid delete or
  1930.                      backspace at beginning of inserting */
  1931. ins$error$chk: procedure;
  1932.     if (tcolumn = 255) or (front = 1) then
  1933.         go to reset;
  1934.     end ins$error$chk;
  1935. $ eject
  1936.  
  1937. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  1938.  
  1939.  
  1940.                   * * *  COMMAND PARSING * * *
  1941.  
  1942.  
  1943.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  1944.  
  1945.  
  1946.  
  1947.  
  1948.                   /* test for upper or lower case command
  1949.                      set translate flag (used to determine
  1950.                      if following characters should be translated
  1951.                      to upper case */
  1952. TESTCASE: PROCEDURE;
  1953.     DECLARE T BYTE;
  1954.     TRANSLATE = TRUE;
  1955.     T = LOWERCASE(CHAR);
  1956.     CHAR = UTRAN(CHAR);
  1957.     TRANSLATE = UPPER OR NOT T;
  1958.     END TESTCASE;
  1959. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1960.  
  1961.  
  1962.                   /* set translate to false and read next 
  1963.                      character */
  1964. READCTRAN: PROCEDURE;
  1965.     TRANSLATE = FALSE;
  1966.     CHAR = READC;
  1967.     CALL TESTCASE;
  1968.     END READCTRAN;
  1969. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1970.  
  1971.  
  1972.                   /* return true if command is only character
  1973.                      not in macro or combination on a line */
  1974. SINGLECOM: PROCEDURE(C) BOOLEAN;
  1975.     DECLARE C BYTE;
  1976.     RETURN CHAR = C AND COMLEN = 1 AND MP = 0;
  1977.     END SINGLECOM;
  1978. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1979.  
  1980.  
  1981.                   /* return true if command is only character
  1982.                      not in macro or combination on a line, and
  1983.                      the operator has responded with a 'Y' to a
  1984.                      Y/N request */
  1985. SINGLERCOM: PROCEDURE(C) BOOLEAN;
  1986.     DECLARE (C,i) BYTE;
  1987.     IF SINGLECOM(C) THEN
  1988.         DO forever; 
  1989.         CALL CRLF; CALL PRINTCHAR(C);
  1990.         CALL MON1(9,.('-(Y/N)',WHAT,'$'));
  1991.         i = UCASE(READCHAR); CALL CRLF;
  1992.         IF i = 'N' THEN GO TO START;
  1993.         if i = 'Y' then 
  1994.             RETURN TRUE;
  1995.         END;
  1996.     RETURN FALSE;
  1997.     END SINGLERCOM;
  1998. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1999.  
  2000.  
  2001.                   /* return true if char is a digit */
  2002. DIGIT: PROCEDURE BOOLEAN;
  2003.     RETURN (I := CHAR - '0') <= 9;
  2004.     END DIGIT;
  2005. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2006.  
  2007.  
  2008.                   /* return with distance = number char = 
  2009.                      next command */
  2010. NUMBER: PROCEDURE;
  2011.     DISTANCE = 0;
  2012.         DO WHILE DIGIT;
  2013.         DISTANCE = SHL(DISTANCE,3) +
  2014.                    SHL(DISTANCE,1) + I;
  2015.         CALL READCTRAN;
  2016.         END;
  2017.     END NUMBER;
  2018. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2019.  
  2020.  
  2021.                   /* set distance to distance relative to
  2022.                      the current line */
  2023. RELDISTANCE: PROCEDURE;
  2024.     IF DISTANCE > BASELINE THEN
  2025.         DO; DIRECTION = FORWARD;
  2026.         DISTANCE = DISTANCE - BASELINE;
  2027.         END; 
  2028.     ELSE
  2029.         DO; DIRECTION = BACKWARD;
  2030.         DISTANCE = BASELINE - DISTANCE;
  2031.         END;
  2032.     END RELDISTANCE;
  2033.  
  2034.  
  2035.  
  2036. $ eject
  2037.  
  2038. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  2039.  
  2040.  
  2041.                   * * *  MAIN PROGRAM * * *
  2042.  
  2043.  
  2044.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  2045.  
  2046.  
  2047. plm:              /* entry of MP/M-86 Interface */  
  2048.  
  2049.  /* INITIALIZE THE SYSTEM */
  2050.  
  2051.     ver = version;
  2052.     if low(ver) >= cpm3 then 
  2053.         has$bdos3 = true;      /* handles passwords & xfcbs */
  2054.  
  2055.     /* * * * * * * SET UP MEMORY BUFFER * * * * * * * * * */
  2056.  
  2057.     /* I/O BUFFER REGION IS 1/8 AVAILABLE MEMORY */
  2058.     NBUF = SHR(MAX := MAXB - .MEMORY,SECTSHF+3) - 1;
  2059.     /* NBUF IS NUMBER OF BUFFERS - 1 */
  2060.     BUFFLENGTH = SHL(DOUBLE(NBUF+1),SECTSHF+1);
  2061.     /* NOW SET MAX AS REMAINDER OF FREE MEMORY */
  2062.     IF BUFFLENGTH + 1024 > MAX THEN
  2063.         DO; CALL perror(.('Insufficient memory$'));
  2064.         CALL BOOT;
  2065.         END;
  2066.     /* REMOVE BUFFER SPACE AND 00 AT END OF MEMORY VECTOR */
  2067.     MAX = MAX - BUFFLENGTH - 1;
  2068.     /* RESET BUFFER LENGTH FOR I AND O */
  2069.     BUFFLENGTH = SHR(BUFFLENGTH,1);
  2070.     SBUFFADR = MAXB - BUFFLENGTH;
  2071.     DBUFFADR = SBUFFADR - BUFFLENGTH;
  2072.     MEMORY(MAX) = 0; /* STOPS MATCH AT END OF BUFFER */
  2073.     MAXM = MAX - 1;
  2074.     HMAX = SHR(MAXM,1);
  2075.  
  2076.     /* * * * * *  SET UP SOURCE & DESTINATION FILES  * * * * * */
  2077.  
  2078.     if fcb(1)=' ' then do;
  2079.         call print(.('Enter Input  file: $'));
  2080.         call readcom;
  2081.         call crlf;
  2082.         tail = false;
  2083.         end;
  2084.     if not parse$fcb(.SFCB) then     /* parse source fcb */
  2085.         call reboot;
  2086.  
  2087.     if has$bdos3 then do;
  2088.         call read$xfcb(.sfcb);       /* get prot from source */
  2089.         protection = sfcb(ex);       /* password protection mode */
  2090.         sfcb(ex) = 0;
  2091.         if high(ver) = 0 then        /* CP/M-80 */
  2092.             if (lpp:=mon2(49,.pb)) = 0 then
  2093.                 lpp = 23;            /* get lines per page from SCB */
  2094.         end;
  2095.     call setdest;                    /* parse destination file */
  2096.     tail = false;                    /* parse$fcb from ED command */
  2097.  
  2098.     /* SOURCE AND DESTINATION DISKS SET */
  2099.  
  2100.     /* IF SOURCE AND DESTINATION DISKS DIFFER, CHECK FOR
  2101.     AN EXISTING SOURCE FILE ON THE DESTINATION DISK - THERE
  2102.     COULD BE A FATAL ERROR CONDITION WHICH COULD DESTROY A
  2103.     FILE IF THE USER HAPPENED TO BE ADDRESSING THE WRONG
  2104.     DISK */
  2105.     IF (SDISK <> DDISK) or not onefile THEN
  2106.         IF mon2(15,.dfcb) <> 255 THEN   /* try to open */
  2107.             /* SOURCE FILE PRESENT ON DEST DISK */
  2108.             CALL ABORT(.('Output File Exists, Erase It$'));
  2109.  
  2110.  
  2111.  
  2112. RESTART:
  2113.     CALL SETUP;
  2114.     MEMORY(0) = LF;
  2115.     FRONT = 1; BACK = MAXM;
  2116.     COLUMN = 0;
  2117.     GO TO START;
  2118.  
  2119. OVERCOUNT: FLAG = POUND; GO TO RESET;
  2120.  
  2121. BADCOM: FLAG = WHAT; GO TO RESET;
  2122.  
  2123. OVERFLOW: /* ARRIVE HERE ON OVERFLOW CONDITION (I,F,S COMMAND) */
  2124.     FLAG = '>'; go to reset;
  2125.  
  2126. disk$err:
  2127.     flag = 'F';
  2128.     err$msg = .diskfull;
  2129.     go to reset;
  2130.  
  2131. dir$err:
  2132.     flag = 'F';
  2133.     err$msg = .dirfull;
  2134.  
  2135. RESET: /* ARRIVE HERE ON ERROR CONDITION */
  2136.     PRINTSUPPRESS = FALSE;
  2137.     CALL PRINT(.(tab,'BREAK "$'));
  2138.     CALL PRINTC(FLAG);
  2139.     CALL PRINTM(.('" AT $'));
  2140.     if char = CR or char = LF then
  2141.         call printm(.('END OF LINE$'));
  2142.     else
  2143.         CALL PRINTC(CHAR);
  2144.     if err$msg <> 0 then do;
  2145.         call perror(err$msg);
  2146.         err$msg = 0;
  2147.         end;
  2148.     CALL CRLF;
  2149.  
  2150.  
  2151. START:
  2152.     READBUFF = TRUE;
  2153.     MP = 0;
  2154.  
  2155.  
  2156.  
  2157. $ eject
  2158.  
  2159.     DO FOREVER; /* OR UNTIL THE POWER IS TURNED OFF */
  2160.  
  2161.     /* **************************************************************
  2162.     SIMPLE COMMANDS (CANNOT BE PRECEDED BY DIRECTION/DISTANCE):
  2163.              E      END THE EDIT NORMALLY
  2164.              H      MOVE TO HEAD OF EDITED FILE
  2165.              I      INSERT CHARACTERS
  2166.              O      RETURN TO THE ORIGINAL FILE
  2167.              R      READ FROM LIBRARY FILE
  2168.              Q      QUIT EDIT WITHOUT CHANGES TO ORIGINAL FILE
  2169.        ************************************************************** */
  2170.  
  2171.  
  2172.  
  2173.     INSERTING = FALSE;
  2174.     CALL READCTRAN;
  2175.     FLAG = 'E';
  2176.     MI = CBP; /* SAVE STARTING ADDRESS FOR <CR> COMMAND */
  2177.     IF SINGLECOM('E') THEN
  2178.         DO; CALL TERMINATE;
  2179.         CALL REBOOT;
  2180.         END; 
  2181.  
  2182.     ELSE IF SINGLECOM('H') THEN /* GO TO TOP */
  2183.         DO; CALL TERMINATE;
  2184.         newfile = false;
  2185.         if onefile then do;
  2186.             /* PING - PONG DISKS */
  2187.             CHAR  = DDISK; 
  2188.             DDISK = SDISK; 
  2189.             SDISK = CHAR;
  2190.             end;
  2191.         else do;
  2192.             call settype(.dfcb,.dtype);
  2193.             call move (16,.dfcb,.sfcb); /* source = destination */
  2194.             onefile = true;
  2195.             end;
  2196.         GO TO RESTART;
  2197.         END; 
  2198.  
  2199.     ELSE IF CHAR = 'I' THEN /* INSERT CHARACTERS */
  2200.         DO;
  2201.         IF (INSERTING := (CBP = COMLEN) AND (MP = 0)) THEN do;
  2202.             tcolumn = 255;           /* tested in ins$error$chk routine */
  2203.             distance = 0; 
  2204.             direction = backward;
  2205.             if memory(front-1) = LF then 
  2206.                 call printbase;
  2207.             else 
  2208.                 call typelines;
  2209.             end;
  2210.         DO WHILE SCANNING;
  2211.             DO WHILE CHAR <> 0;
  2212.             IF CHAR=CTLU OR CHAR=CTLX OR CHAR=CTLR THEN
  2213.                 /* LINE DELETE OR RETYPE */
  2214.                 DO;
  2215.                 /* ELIMINATE OR REPEAT THE LINE */
  2216.                 IF CHAR = CTLR THEN
  2217.                     DO; CALL CRLF;
  2218.                     CALL TYPELINES;
  2219.                     END; 
  2220.                 ELSE
  2221.                     /* LINE DELETE */
  2222.                     DO; CALL SETLIMITS; CALL SETPTRS;
  2223.                     IF CHAR = CTLU THEN
  2224.                         DO; CALL CRLF; CALL PRINTNMBASE;
  2225.                         END; 
  2226.                     ELSE
  2227.                         /* MUST BE CTLX */
  2228.                         DO WHILE COLUMN > SCOLUMN;
  2229.                         CALL BACKSPACE;
  2230.                         END;
  2231.                     END;
  2232.                 END; 
  2233.             ELSE IF CHAR = CTLH THEN
  2234.                 DO;
  2235.                 call ins$error$chk;
  2236.                 IF (TCOLUMN := COLUMN) > 0 THEN
  2237.                     CALL PRINTNMAC(' '); /* RESTORE AFT BACKSP */
  2238.                 call decfront;
  2239.                 if tcolumn > scolumn then
  2240.                     DO; /* CHARACTER CAN BE ELIMINATED */
  2241.                     PRINTSUPPRESS = TRUE;
  2242.                     /* BACKSPACE CHARACTER ACCEPTED */
  2243.                     COLUMN = 0;
  2244.                     CALL TYPELINES;
  2245.                     PRINTSUPPRESS = FALSE;
  2246.                     /* COLUMN POSITION NOW RESET */
  2247.                     IF (QCOLUMN := COLUMN) < SCOLUMN THEN
  2248.                         QCOLUMN = SCOLUMN;
  2249.                     COLUMN = TCOLUMN; /* ORIGINAL VALUE */
  2250.                         DO WHILE COLUMN > QCOLUMN;
  2251.                         CALL BACKSPACE;
  2252.                         END;
  2253.                     END;
  2254.                 else
  2255.                     do;
  2256.                     if memory(front-1) = CR then
  2257.                         call decfront;
  2258.                     call crlf;
  2259.                     call typelines;
  2260.                     end;
  2261.                 CHAR = 0;
  2262.                 END; 
  2263.             ELSE IF CHAR = RUBOUT THEN
  2264.                 DO; call ins$error$chk;
  2265.                 CALL DECFRONT; CALL PRINTC(CHAR:=MEMORY(FRONT));
  2266.                 CHAR = 0;
  2267.                 END; 
  2268.             else if char = LF and memory(front-1) <> CR then
  2269.                 do;
  2270.                 call printc(CR);
  2271.                 call inscrlf;
  2272.                 end;  
  2273.             ELSE
  2274.                 /* NOT A SPECIAL CASE */
  2275.                 DO; 
  2276.                 IF NOT GRAPHIC(CHAR) THEN
  2277.                     DO; 
  2278.                     CALL PRINTNMAC('^');
  2279.                     CALL PRINTNMAC(CHAR + '@');
  2280.                     end;
  2281.                     /* COLUMN COUNT GOES UP IF GRAPHIC */
  2282.                     /* COMPUTE OUTPUT COLUMN POSITION */
  2283.                 if char = CTLL and not inserting then
  2284.                     call inscrlf;
  2285.                 else do;
  2286.                     IF MP = 0 THEN
  2287.                         DO; 
  2288.                         IF CHAR >= ' ' THEN
  2289.                             COLUMN = COLUMN + 1; 
  2290.                         ELSE IF CHAR = TAB THEN
  2291.                             COLUMN = COLUMN + (8 - (COLUMN AND 111B));
  2292.                         END;
  2293.                     CALL INSERT;
  2294.                     END;
  2295.                 end;
  2296.             IF CHAR = LF THEN CALL PRINTNMBASE;
  2297.             IF CHAR = CR THEN
  2298.                 CALL PRINTNMAC(CHAR:=LF); 
  2299.             ELSE 
  2300.                 CHAR = 0;
  2301.             tcolumn = 0;
  2302.             END; /* of while char <> 0 */
  2303.         END; /* of while scanning */
  2304.         IF CHAR <> ENDFILE THEN do; /* MUST HAVE STOPPED ON CR */
  2305.             CALL INSCRLF;
  2306.             column = 0;
  2307.             end;
  2308.         IF INSERTING AND LINESET THEN CALL CRLF;
  2309.         END; 
  2310.  
  2311.  
  2312.     ELSE IF SINGLERCOM('O') THEN /* FORGET THIS EDIT */
  2313.         do;
  2314.         call close(.sfcb);
  2315.         GO TO RESTART; 
  2316.         end; 
  2317.  
  2318.  
  2319.     ELSE IF CHAR = 'R' THEN
  2320.         DO; DECLARE I BYTE;
  2321.         /* READ FROM LIB FILE */
  2322.         CALL SETRDMA;
  2323.         IF (FLAG := parse$lib(.rfcb)) THEN 
  2324.             reading = false;
  2325.         if not reading then do;
  2326.             if not flag then 
  2327.                 /* READ FROM XFER FILE */
  2328.                 CALL MOVE(12,.XFCB,.RFCB);
  2329.             RFCB(12), RFCB(32) = 0; /* zero extent, next record */
  2330.             rbp = sectsize;
  2331.             CALL open(.RFCB); 
  2332.             reading = true;
  2333.             end;
  2334.     
  2335.             DO WHILE (CHAR := READFILE) <> ENDFILE;
  2336.             CALL INSERT;
  2337.             END;
  2338.         reading = false;
  2339.         call close (.rfcb);
  2340.         END; 
  2341.  
  2342.  
  2343.     ELSE IF SINGLERCOM('Q') THEN
  2344.         DO; 
  2345.         CALL DELETE$file(.DFCB); 
  2346.         if newfile or not onefile then do;
  2347.             call settype(.dfcb,.dtype);
  2348.             call delete$file(.dfcb);
  2349.             end;
  2350.         CALL REBOOT;
  2351.         END; 
  2352.  
  2353.  
  2354.     ELSE 
  2355.         /* MAY BE A COMMAND WHICH HAS AN OPTIONAL DIRECTION AND DISTANCE */
  2356.         DO; /* SCAN A SIGNED INTEGER VALUE (IF ANY) */
  2357.         DCL I BYTE;
  2358.  
  2359.         CALL SETFORWARD;
  2360.  
  2361.         IF CHAR = '-' THEN
  2362.             DO; CALL READCTRAN; DIRECTION = BACKWARD;
  2363.             END;
  2364.  
  2365.         IF CHAR = POUND THEN
  2366.             DO; CALL SETFF; CALL READCTRAN;
  2367.             END; 
  2368.  
  2369.         ELSE IF DIGIT THEN
  2370.             DO; CALL NUMBER;
  2371.             /* MAY BE ABSOLUTE LINE REFERENCE */
  2372.             IF CHAR = ':' THEN
  2373.                 DO; CHAR = 'L';
  2374.                 CALL RELDISTANCE;
  2375.                 END;
  2376.             END; 
  2377.  
  2378.         ELSE IF CHAR = ':' THEN /* LEADING COLON */
  2379.             DO; CALL READCTRAN; /* CLEAR THE COLON */
  2380.             CALL NUMBER;
  2381.             CALL RELDISTANCE;
  2382.             IF DIRECTION = FORWARD THEN
  2383.                 DISTANCE = DISTANCE + 1;
  2384.             END;
  2385.  
  2386.  
  2387. $ eject
  2388.  
  2389.         IF DISTZERO THEN 
  2390.             DIRECTION = BACKWARD;
  2391.         /* DIRECTION AND DISTANCE ARE NOW SET */
  2392.  
  2393.  
  2394.     /* **************************************************************
  2395.     MAY BE A COMMAND WHICH HAS DIRECTION AND DISTANCE SPECIFIED:
  2396.              B      BEGINNING/BOTTOM OF BUFFER
  2397.              C      MOVE CHARACTER POSITIONS
  2398.              D      DELETE CHARACTERS
  2399.              K      KILL LINES
  2400.              L      MOVE LINE POSITION
  2401.              P      PAGE UP OR DOWN (LPP LINES AND PRINT)
  2402.              T      TYPE LINES
  2403.              U      UPPER CASE TRANSLATE
  2404.              V      VERIFY LINE NUMBERS
  2405.             <CR>    MOVE UP OR DOWN LINES AND PRINT LINE
  2406.        ************************************************************** */
  2407.  
  2408.  
  2409.         IF CHAR = 'B' THEN
  2410.             DO; DIRECTION = 1 - DIRECTION;
  2411.             FIRST = 1; LASTC = MAXM; CALL MOVER;
  2412.             END; 
  2413.  
  2414.  
  2415.         ELSE IF CHAR = 'C' THEN
  2416.             DO; CALL SETCLIMITS; CALL MOVER;
  2417.             END; 
  2418.  
  2419.  
  2420.         ELSE IF CHAR = 'D' THEN
  2421.             DO; CALL SETCLIMITS;
  2422.             CALL SETPTRS; /* SETS BACK/FRONT */
  2423.             END; 
  2424.  
  2425.  
  2426.         ELSE IF CHAR = 'K' THEN
  2427.             DO; CALL SETLIMITS;
  2428.             CALL SETPTRS;
  2429.             END; 
  2430.  
  2431.  
  2432.        ELSE IF CHAR = 'L' THEN 
  2433.             CALL MOVELINES; 
  2434.  
  2435.  
  2436.        ELSE IF CHAR = 'P' THEN /* PAGE MODE PRINT */
  2437.             DO; 
  2438.             IF DISTZERO THEN
  2439.                 DO; DIRECTION = FORWARD;
  2440.                 CALL SETLPP; CALL TYPELINES;
  2441.                 END; 
  2442.             ELSE
  2443.                 DO WHILE DISTNZERO; CALL PAGE;
  2444.                 CALL WAIT;
  2445.                 END;
  2446.             END; 
  2447.  
  2448.  
  2449.         ELSE IF CHAR = 'T' THEN
  2450.             CALL TYPELINES; 
  2451.  
  2452.  
  2453.         ELSE IF CHAR = 'U' THEN
  2454.             UPPER = DIRECTION = FORWARD; 
  2455.  
  2456.  
  2457.         ELSE IF CHAR = 'V' THEN
  2458.             DO; /* 0V DISPLAYS BUFFER STATE */
  2459.             IF DISTZERO THEN
  2460.                 DO; CALL PRINTVALUE(BACK-FRONT);
  2461.                 CALL PRINTC('/');
  2462.                 CALL PRINTVALUE(MAXM);
  2463.                 CALL CRLF;
  2464.                 END; 
  2465.             ELSE if (LINESET := DIRECTION = FORWARD) then
  2466.                 scolumn = 8;
  2467.             else
  2468.                 scolumn = 0;
  2469.             END;
  2470.  
  2471.  
  2472.  
  2473.         ELSE IF CHAR = CR THEN /* MAY BE MOVE/TYPE COMMAND */
  2474.             DO;
  2475.             IF MI = 1 AND MP = 0 THEN /* FIRST COMMAND */
  2476.                 DO; CALL MOVELINES; CALL SETFORWARD; CALL TYPELINES;
  2477.                 END;
  2478.             END; 
  2479.  
  2480.  
  2481. $ eject
  2482.  
  2483.         ELSE IF DIRECTION = FORWARD OR DISTZERO THEN
  2484.             DO;
  2485.  
  2486.     /* **************************************************************
  2487.     COMMANDS WHICH ALLOW ONLY A PRECEDING NUMBER:
  2488.              A      APPEND LINES
  2489.              F      FIND NTH OCCURRENCE
  2490.              M      APPLY MACRO
  2491.              N      SAME AS F WITH AUTOSCAN THROUGH FILE
  2492.              S      PERFORM N SUBSTITUTIONS
  2493.              W      WRITE LINES TO OUTPUT FILE
  2494.              X      TRANSFER (XFER) LINES TO TEMP FILE
  2495.              Z      SLEEP
  2496.        ************************************************************** */
  2497.  
  2498.  
  2499.  
  2500.         IF CHAR = 'A' THEN
  2501.             DO; DIRECTION = FORWARD;
  2502.             FIRST = FRONT; LASTC = MAXM; CALL MOVER;
  2503.             /* ALL STORAGE FORWARD */
  2504.             IF DISTZERO THEN CALL APPHALF;
  2505.             /* DISTANCE = 0 IF APPHALF CALLED */
  2506.                 DO WHILE DISTNZERO;
  2507.                 CALL READLINE;
  2508.                 END;
  2509.             DIRECTION = BACKWARD; CALL MOVER;
  2510.             /* POINTERS REPOSITIONED */
  2511.             END; 
  2512.  
  2513.  
  2514.         ELSE IF CHAR = 'F' THEN
  2515.             DO; CALL SETFIND; /* SEARCH STRING SCANNED
  2516.             AND SETUP BETWEEN 0 AND WBP-1 IN SCRATCH */
  2517.                 DO WHILE DISTNZERO; CALL CHKFOUND;
  2518.                 END;
  2519.             END; 
  2520.  
  2521.  
  2522.         ELSE IF CHAR = 'J' THEN /* JUXTAPOSITION OPERATION */
  2523.             DO; DECLARE T ADDRESS;
  2524.             CALL SETFIND; CALL COLLECT;
  2525.             WBJ = WBE; CALL COLLECT;
  2526.             /* SEARCH FOR STRING 0 - WBP-1, INSERT STRING WBP TO WBJ-1,
  2527.             AND THEN DELETE UP TO STRING WBJ TO WBE-1 */
  2528.             DO WHILE DISTNZERO; CALL CHKFOUND;
  2529.             /* INSERT STRING */ MI = WBP - 1;
  2530.                 DO WHILE (MI := MI + 1) < WBJ;
  2531.                 CHAR = SCRATCH(MI); CALL INSERT;
  2532.                 END;
  2533.             T = FRONT; /* SAVE POSITION FOR DELETE */
  2534.             IF NOT FIND(WBJ,WBE) THEN GO TO OVERCOUNT;
  2535.             /* STRING FOUND, SO MOVE IT BACK */
  2536.             FIRST = FRONT - (WBE - WBJ);
  2537.             DIRECTION = BACKWARD; CALL MOVER;
  2538.             /* NOW REMOVE THE INTERMEDIATE STRING */
  2539.             call setfront(t);
  2540.             END;
  2541.         END; 
  2542.  
  2543.  
  2544.         ELSE IF CHAR = 'M' AND MP = 0 THEN /* MACRO DEFINITION */
  2545.             DO; XP = 255;
  2546.             IF DISTANCE = 1 THEN CALL ZERODIST;
  2547.                 DO WHILE (MACRO(XP := XP + 1) := READC) <> CR;
  2548.                 END;
  2549.             MP = XP; XP = 0; MT = DISTANCE;
  2550.             END; 
  2551.  
  2552.  
  2553.         ELSE IF CHAR = 'N' THEN
  2554.             DO; /* SEARCH FOR STRING WITH AUTOSCAN */
  2555.             CALL SETFIND; /* SEARCH STRING SCANNED */
  2556.                 DO WHILE DISTNZERO;
  2557.                 /* FIND ANOTHER OCCURRENCE OF STRING */
  2558.                     DO WHILE NOT FIND(0,WBP); /* NOT IN BUFFER */
  2559.                     IF BREAK$KEY THEN GO TO RESET;
  2560.                     CALL SAVEDIST; CALL CLEARMEM;
  2561.                     /* MEMORY BUFFER WRITTEN */
  2562.                     CALL APPHALF;
  2563.                     DIRECTION = BACKWARD; FIRST = 1; CALL MOVER;
  2564.                     CALL RESTDIST; DIRECTION = FORWARD;
  2565.                     /* MAY BE END OF FILE */
  2566.                     IF BACK >= MAXM THEN GO TO OVERCOUNT;
  2567.                     END;
  2568.                 END;
  2569.             END; 
  2570.  
  2571.  
  2572.         ELSE IF CHAR = 'S' THEN /* SUBSTITUTE COMMAND */
  2573.             DO; CALL SETFIND;
  2574.             CALL COLLECT;
  2575.             /* FIND STRING FROM 0 TO WBP-1, SUBSTITUTE STRING
  2576.             BETWEEN WBP AND WBE-1 IN SCRATCH */
  2577.                 DO WHILE DISTNZERO;
  2578.                 CALL CHKFOUND;
  2579.                 /* FRONT AND BACK NOW POSITIONED AT FOUND
  2580.                 STRING - REPLACE IT */
  2581.                 call setfront(FRONT - (MI := WBP)); /* BACKED UP */
  2582.                     DO WHILE MI < WBE;
  2583.                     CHAR = SCRATCH(MI);
  2584.                     MI = MI + 1; CALL INSERT;
  2585.                     END;
  2586.                  END;
  2587.             END; 
  2588.  
  2589.  
  2590.         ELSE IF CHAR = 'W' THEN
  2591.             CALL WRITEOUT; 
  2592.  
  2593.  
  2594.         ELSE IF CHAR = 'X' THEN /* TRANSFER LINES */
  2595.             DO;
  2596.             flag = parse$lib(.rfcb);
  2597.             xbp = 0;
  2598.             IF DISTZERO THEN  
  2599.                 DO;             /* delete the file */
  2600.                 xferon  = false;
  2601.                 CALL DELETE(.rfcb);
  2602.                 if dcnt = 255 then
  2603.                     call perror(.not$found);    
  2604.                 END; 
  2605.             ELSE 
  2606.                 do;             /* transfer lines */
  2607.                 declare i address;
  2608.  
  2609.                 if xferon and compare$xfer then
  2610.                     call append$xfer;
  2611.                 else
  2612.                     DO;         
  2613.                     XFERON = TRUE;
  2614.                     call move(12,.rfcb,.xfcb);
  2615.                     xfcbext, xfcbrec, xfcbe, xfcbr = 0;
  2616.                     CALL MAKE$file(.XFCB);
  2617.                     IF DCNT = 255 THEN 
  2618.                         goto dir$err;
  2619.                     END;
  2620.                 CALL SETLIMITS;
  2621.                     DO I = FIRST TO LASTC;
  2622.                     CALL PUTXFER(MEMORY(I));
  2623.                     END;
  2624.                 call close$xfer;
  2625.                 END;
  2626.             END; 
  2627.  
  2628.  
  2629.         ELSE IF CHAR = 'Z' THEN /* SLEEP */
  2630.             DO;
  2631.             IF DISTZERO THEN
  2632.                 DO; IF READCHAR = ENDFILE THEN GO TO RESET;
  2633.                 END;
  2634.                 DO WHILE DISTNZERO; CALL WAIT;
  2635.                 END;
  2636.             END; 
  2637.         ELSE IF CHAR <> 0 THEN /* NOT BREAK LEFT OVER FROM STOP */
  2638.         /* DIRECTION FORWARD, BUT NOT ONE OF THE ABOVE */
  2639.         GO TO BADCOM;
  2640.  
  2641.  
  2642.         END; 
  2643.         ELSE /* DIRECTION NOT FORWARD */
  2644.             GO TO BADCOM;
  2645.         END;
  2646.     END;
  2647. END;
  2648.