CP/M/CPM_CDROM.iso/simtel/cpmug/cpmug030.ark/RUN.PLM

Text File | 1984-04-29 | 65.9 KB | 2,293 lines

BASINT:
DO; /* ORIGINALLY ORG'ED AT 0C00H ABOVE FP PACKAGE */
    /*
         ********************************************************
         *                                                      *
         *                 BASIC-E INTERPRETER                  *
         *                                                      *
         *            U. S. NAVY POSTGRADUATE SCHOOL            *
         *                 MONTEREY, CALIFORNIA                 *
         *                                                      *
         *            WRITTEN BY GORDON EUBANKS, JR.            *
         *                                                      *
         *                   CPM VERSION 2.0                    *
         *                       MAY 1977                       *
         *                                                      *
         ********************************************************
    */

    /*
         ********************************************************
         *                                                      *
         *     THE BASIC-E INTERPRETER IS PASSED CONTROL        *
         *      FROM THE BUILD PROGRAM.  THE FDA, CODE AND      *
         *      DATA AREA ARE MOVED DOWN TO RESIDE AT THE       *
         *      .MEMORY FOR THIS PROGRAM, AND THEN THE STACK    *
         *      PRT AND MACHINE REGISTERS ARE INITIALIZED       *
         *      THE INTERPRETER THEN EXECUTES THE BASIC-E       *
         *      MACHINE CODE.                                   *
         *                                                      *
         ********************************************************
    */

    /*
         ********************************************************
         *                                                      *
         *                   GLOBAL LITERALS                    *
         *                                                      *
         ********************************************************
    */
DECLARE
         LIT       LITERALLY 'LITERALLY',
         FOREVER   LIT       'WHILE TRUE',
         TRUE      LIT       '1',
         FALSE     LIT       '0',
         LF        LIT       '10',
         CR        LIT       '13',
         NULLCHAR  LIT       '0H',
         CONTZ     LIT       '1AH',
         QUOTE     LIT       '22H',
         WHAT      LIT       '63';               /*QUESTION MARK*/

    /*
         ********************************************************
         *                                                      *
         *               EXTERNAL ENTRY POINTS                  *
         *     THESE ENTRY POINTS ASSUME THE USE OF CP/M        *
         *                                                      *
         ********************************************************
    */
DECLARE
         SYSBEGIN     ADDRESS  INITIAL(6H),
         PARAM1       ADDRESS PUBLIC,     /* SET BY BUILD PROGRAM */
         PARAM2       ADDRESS PUBLIC,
         PARAM3       ADDRESS PUBLIC,
         PARAM4       ADDRESS PUBLIC,
         OFFSET       ADDRESS PUBLIC,     /* AMOUNT TO MOVE IMAGE DOWN */
         SEED         ADDRESS  EXTERNAL,   /* SEED FOR RAND GENERATOR */
         BEGIN        ADDRESS EXTERNAL,   /* START OF BUILD MODULE */
         OVERFLOW     LITERALLY 'OVER',
         OVER         ADDRESS  EXTERNAL;

    /*
         ********************************************************
         *                                                      *
         *            SYSTEM PARAMETERS WHICH MAY               *
         *            REQUIRE MODIFICATION BY USERS             *
         *                                                      *
         ********************************************************
    */
DECLARE
         EOLCHAR       LIT       '0DH',
         EOFFILLER     LIT       '1AH',
         INTRECSIZE    LIT       '128',
         DISKRECSIZE   LIT       '128',
         STRINGDELIM   LIT       '22H',
         CONBUFFSIZE   LIT        '80',
         NUMFILES      LIT         '20',  /* MAX NUMBER USER FILES */
         NRSTACK       LIT        '96';  /* STACK SIZE TIMES 4 */

    /*
         ********************************************************
         *                                                      *
         *                   GLOBAL VARIABLES                   *
         *                                                      *
         ********************************************************
    */

DECLARE
         RA        ADDRESS,  /* ADDRESS OF REG A */
         RB        ADDRESS,  /* ADDRESS OF REG B */
         RC        ADDRESS,  /* ADDRESS OF REGISTER C */
         C         BASED     RC BYTE, /* BYTE OF CODE */
         CV        BASED     RC(2) BYTE, /* VERSION OF C WITH SUBSCRIPT */
         TWOBYTEOPRAND BASED RC ADDRESS,  /* TWO BYTES CODE */
         SB        ADDRESS,  /* BOTTOM OF STACK */
         ST        ADDRESS, /* TOP OF STACK */
         BRA       BASED     RA(4)     BYTE,
         BRAZ      BASED     RA        BYTE,
         ARA       BASED     RA        ADDRESS,
         ARB       BASED     RB        ADDRESS,
         BRB       BASED     RB(4)     BYTE,
         BRBZ      BASED     RB        BYTE,
         MPR       ADDRESS,  /* BASE ADDRESS OF PRT */
         MDA       ADDRESS,  /* BASE OF DATA AREA */
         MCD       ADDRESS,  /* BASE OF CODE AREA */
         LOCALSEED ADDRESS,  /* USED TO SET SEED */
         CURRENTLINE ADDRESS INITIAL(0),  /* SOURCE LINE BEING EXEC */
         DATAAREAPTR ADDRESS,  /* CURRENT LOCATION IN DATA AREA */
         MBASE     ADDRESS;  /* BEGINNING OF FREE STORAGE AREA */

DECLARE
         INPUTBUFFER       BYTE INITIAL(CONBUFFSIZE), /* USED WITH SPACE */
         SPACE(CONBUFFSIZE) BYTE,  /* INPUT BUFFER FOR CON AND DISK */
         INPUTINDEX        BYTE,
         CONBUFFPTR        ADDRESS,
         INPUTPTR          ADDRESS,
         PRINTBUFFLENGTH   LIT       '132',
         PRINTBUFFERLOC    LIT      '80H',
         TABPOS1           LIT      '142', /* ABSOLUTE ADDR REL TO */
         TABPOS2           LIT      '156', /*   PRINTBUFFLOC  */
         TABPOS3           LIT      '170',
         TABPOS4           LIT      '184',
         PRINTBUFFER       ADDRESS  INITIAL(PRINTBUFFERLOC),
         PRINTPOS          BASED    PRINTBUFFER   BYTE,
         PRINTBUFFEND      LIT      '0103H', /* ABSOLUTE ADDRESS */
         PRINTWORKAREA(14) BYTE,  /* FOR CONV FROM FP TO ASCII */
         REREADADDR        ADDRESS,  /* TO RECOVER FROM READ ERROR */
         INPUTTYPE         BYTE;

DECLARE
         FILEADDR            ADDRESS, /*CURRENT FCB POINTER BASE */
         FCB                 BASED     FILEADDR(33)  BYTE,
         FCBADD              BASED     FILEADDR(33)  ADDRESS,
         EOFADDR             ADDRESS,
         FILES(NUMFILES)     ADDRESS,  /*POINTER ARRAY TO FCBS */
         EOFBRANCH(NUMFILES) ADDRESS,
         BUFFER$END          ADDRESS,
         RECORD$POINTER      ADDRESS,
         BUFFER              ADDRESS,
         NEXTDISKCHAR        BASED     RECORD$POINTER BYTE,
         BLOCKSIZE           ADDRESS,
         BYTES$WRITTEN       ADDRESS,
         FIRSTFIELD          BYTE,
         EOFRA               ADDRESS,
         EOFRB               ADDRESS;

DECLARE
         DECIMAL(4) ADDRESS DATA(1000,100,10,1),
         ONEHALF(4) BYTE DATA(80H,0,0,0),
         PLUSONE(4)  BYTE DATA(81H,0,0,0),
         MINUSONE(4) BYTE DATA(81H,80H,0,0),
         MAXNUM(4) BYTE DATA(0FFH,07FH,0FFH,0FFH),
         MAXPOSNUM BYTE DATA (4),
         POSITION(9) ADDRESS DATA(TABPOS1,TABPOS2,TABPOS3,TABPOS4,
               PRINTBUFFEND),
         SCALE(4) BYTE DATA(90H,7FH,0FFH,0);


    /*
         ********************************************************
         *                                                      *
         *       SYSTEM DEPENDENT ROUTINES AND VARIABLES        *
         *           THE FOLLOWING ROUTINES ARE USED            *
         *           BY THE INTERPRETER TO ACCESS DISK          *
         *           FILES AND FOR CONSOLE I/O.                 *
         *           THE ROUTINES ASSUME THE USE OF THE         *
         *           CP/M OPERATING SYSTEM.                     *
         *                                                      *
         ********************************************************
    */


MON1: PROCEDURE(FUNC,PARM) EXTERNAL;
    DECLARE FUNC BYTE,
    PARM ADDRESS;
END MON1;

MON2: PROCEDURE(FUNC,PARM) BYTE EXTERNAL;
    DECLARE FUNC BYTE,
    PARM ADDRESS;
END MON2;

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

MOVEA: PROCEDURE(A) EXTERNAL;
    DECLARE A ADDRESS;
    END MOVEA;

MOVE4: PROCEDURE(S,D) EXTERNAL;
    DECLARE (S,D) ADDRESS;
    END MOVE4;

PRINTCHAR: PROCEDURE(CHAR) PUBLIC;
    DECLARE CHAR BYTE;
    CALL MON1(2,CHAR);
END PRINTCHAR;


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




READ: PROCEDURE(A);
    DECLARE A ADDRESS;
    /*
       FIRST WAIT FOR FIRST CHAR AND SET LOCALSEED
       SO IT CAN BE USED TO SEED RANDOM NUMBER GENERATOR
    */
    DO WHILE NOT MON2(11,0);
         LOCALSEED = LOCALSEED + 1;
         END;
    /* READ INTO BUFFER AT A+2 */
    CALL MON1(10,A);
END READ;


OPEN: PROCEDURE BYTE;
    RETURN MON2(15,FILEADDR);
END OPEN;


CLOSE: PROCEDURE BYTE;
    RETURN MON2(16,FILEADDR);
END CLOSE;


DISKREAD: PROCEDURE BYTE;
    RETURN MON2(20,FILEADDR);
END DISKREAD;


DISKWRITE: PROCEDURE BYTE;
    RETURN MON2(21,FILEADDR);
END DISKWRITE;


CREATE: PROCEDURE BYTE;
      RETURN MON2(22,FILEADDR);
END CREATE;

MAKE: PROCEDURE BYTE;
    CALL MON1(19,FILEADDR);
    RETURN CREATE;
END MAKE;


SETDMA: PROCEDURE;  /* SET DMA ADDRESS FOR DISK I/O */
    CALL MON1(26,BUFFER);
END SETDMA;


PRINT: PROCEDURE(LOCATION) PUBLIC;
    DECLARE LOCATION ADDRESS;
    /* PRINT THE STRING STARTING AT ADDRESS LOCATION UNTIL THE
    NEXT DOLLAR SIGN IS ENCOUNTERED */
    CALL MON1(9,LOCATION);
END PRINT;


    /*
         ********************************************************
         *                                                      *
         *        GENERAL PURPOSE INTERPRETER ROUTINES          *
         *                                                      *
         ********************************************************
    */
TIMES4: PROCEDURE(N) ADDRESS;
    DECLARE N ADDRESS;
    RETURN SHL(N,2);
END TIMES4;

PRINT$DEC: PROCEDURE(VALUE);
    DECLARE VALUE ADDRESS,
            I BYTE,
            COUNT BYTE;
    DO I = 0 TO 3;
         COUNT = 30H;
         DO WHILE VALUE >= DECIMAL(I);
              VALUE = VALUE - DECIMAL(I);
              COUNT = COUNT + 1;
              END;
         CALL PRINTCHAR(COUNT);
    END;
END PRINT$DEC;


MOVE: PROCEDURE(SOURCE,DEST,N);

    /*MOVE N BYTES FROM SOURCE TO DEST */
    DECLARE (SOURCE,DEST,N) ADDRESS;
    CALL MOVEA(.SOURCE);
END MOVE;

FILL: PROCEDURE(DEST,CHAR,N);
    /*FILL LOCATIONS STARTING AT DEST WITH CHAR FOR N BYTES */
    DECLARE
            DEST   ADDRESS,
            N      ADDRESS,
            D      BASED    DEST   BYTE,
            CHAR   BYTE;
    DO WHILE (N:=N-1) <> 0FFFFH;
         D = CHAR;
         DEST = DEST + 1;
    END;
END FILL;



OUTPUT$MSG: PROCEDURE(MSG);
    DECLARE MSG ADDRESS;
    CALL PRINT$CHAR(HIGH(MSG));
    CALL PRINT$CHAR(LOW(MSG));
    IF CURRENTLINE > 0 THEN
         DO;
              CALL PRINT(.(' IN LINE $'));
         CALL PRINT$DEC(CURRENTLINE);
         END;
    CALL CRLF;
END OUTPUT$MSG;


ERROR: PROCEDURE(E);
    DECLARE E ADDRESS;
    CALL CRLF;
    CALL PRINT(.('ERROR $'));
    CALL OUTPUTMSG(E);
    CALL MON3;
END ERROR;


WARNING: PROCEDURE(W);
    DECLARE W ADDRESS;
    CALL CRLF;
    CALL PRINT(.('WARNING $'));
    CALL OUTPUTMSG(W);
    RETURN;
END WARNING;


    /*
         ********************************************************
         *                                                      *
         *            STACK MANIPULATION ROUTINES               *
         *                                                      *
         ********************************************************
    */

STEP$INS$CNT: PROCEDURE;
    RC=RC+1;
END STEP$INS$CNT;

POP$STACK: PROCEDURE;
    RA = RB;
    IF(RB := RB - 4) < SB THEN
         RB = ST - 4;
END POP$STACK;

PUSH$STACK: PROCEDURE;
    RB = RA;
    IF(RA := RA + 4) >= ST THEN
         RA = SB;
END PUSH$STACK;


IN$FSA: PROCEDURE(LOCATION) BYTE;
     /*
          RETURNS TRUE IF LOCATION IS IN FSA
     */
    DECLARE LOCATION ADDRESS;
    RETURN LOCATION > ST;
END IN$FSA;


SET$DATA$ADDR: PROCEDURE(PTR);
    DECLARE PTR ADDRESS, A BASED PTR ADDRESS;
    IF NOT IN$FSA(A) THEN
         A = MPR + TIMES4(A);
END SET$DATA$ADDR;


MOVE$RA$RB: PROCEDURE;
    CALL MOVE4(RA,RB);
END MOVE$RA$RB;


MOVE$RB$RA:  PROCEDURE;
    CALL MOVE4(RB,RA);
         END MOVERBRA;


FLIP: PROCEDURE;
    DECLARE TEMP(4) BYTE;
    CALL MOVE4(RA,.TEMP);
    CALL MOVE$RB$RA;
    CALL MOVE4(.TEMP,RB);
         END FLIP;


LOAD$RA: PROCEDURE;
    CALL SET$DATA$ADDR(RA);
    CALL MOVE4(ARA,RA);
    END LOADRA;

RA$ZERO: PROCEDURE BYTE;
    RETURN BRAZ = 0;
END RA$ZERO;


RB$ZERO: PROCEDURE BYTE;
    RETURN BRBZ = 0;
END RB$ZERO;


RA$ZERO$ADDRESS: PROCEDURE BYTE;
    RETURN ARA = 0;
END RA$ZERO$ADDRESS;


RB$ZERO$ADDRESS: PROCEDURE BYTE;
    RETURN ARB = 0;
END RB$ZERO$ADDRESS;


RA$NEGATIVE: PROCEDURE BYTE;
    RETURN ROL(BRA(1),1);
END RA$NEGATIVE;


RB$NEGATIVE: PROCEDURE BYTE;
    RETURN ROL(BRB(1),1);
END RB$NEGATIVE;


FLAG$STRING$ADDR: PROCEDURE(X);
    DECLARE X BYTE;
    BRA(2) = X;
END FLAG$STRING$ADDR;


    /*
         ********************************************************
         *                                                      *
         *           FLOATING POINT INTERFACE ROUTINES          *
         *                                                      *
         *       ALL FLOATING POINT OPERATIONS ARE PERFORMED    *
         *       BY CALLING ROUTINES IN THIS SECTION.  THE      *
         *       FLOATING POINT PACKAGE IS ACCESSED BY THE      *
         *       FOLLOWING SIX ROUTINES:                        *
         *           (1)  CONV$TO$BINARY                        *
         *           (2)  CONV$TO$FP                            *
         *           (3)  FP$INPUT                              *
         *           (4)  FP$OUT                                *
         *           (5)  FP$OP$RETURN                          *
         *           (6)  FP$OP                                 *
         *       CHECK$OVERFLOW DOES JUST THAT!!                *
         *       THE REMAINING ROUTINES USE THE ABOVE           *
         *       PROCEDURES TO ACCOMPLISH COMMON ROUTINES       *
         *                                                      *
         *       CONV$TO$BIN$ADDR AND OTHER ROUTINES WHICH      *
         *       REFER TO AN ADDRESS PLACE THE RESULTS IN       *
         *       THE FIRST TWO BYTES OF THE STACK AS AN 8080    *
         *       ADDRESS QUANTITY WITH LOW ORDER BYTE FIRST     *
         *                                                      *
         *                                                      *
         *                                                      *
         ********************************************************
    */

DECLARE
         FINIT     LIT       '0',                /* INITIALIZE*/
         FSTR      LIT       '1',                /* STORE (ACCUM)*/
         FLOD      LIT       '2',                /* LOAD ACCUM */
         FADD      LIT       '3',                /* ADD TO ACCUM */
         FSUB      LIT       '4',                /* SUB FROM ACCUM*/
         FMUL      LIT       '5',                /* MUL BY ACCUM*/
         FDIV      LIT       '6',                /* DIVIDE INTO ACCUM*/
         FABS      LIT       '7',                /* ABS VALUE OF ACCUM*/
         FZRO      LIT       '8',                /* ZERO ACCUM*/
         FTST      LIT       '9',                /* TEST SIGN OF ACCUM*/
         FCHS      LIT       '10',               /* COMPL. ACCUM*/
         SQRT      LIT       '11',               /* SQRT OF ACCUM*/
         COS       LIT       '12',               /* COS ACCUM*/
         SIN       LIT       '13',               /* SIN ACCUM*/
         ATAN      LIT       '14',               /* ARCTAN ACCUM */
         COSH      LIT       '15',               /* COSH ACCUM*/
         SINH      LIT       '16',               /* SINH ACCUM*/
         EXP       LIT       '17',               /* EXPONENTIAL ACCUM*/
         LOG       LIT       '18';               /* LOG ACCUM*/

DECLARE /* EXTERNAL NAMES FOR SUBROUTINES */
         CONV$TO$BINARY LIT 'CBIN',
         CONV$TO$FP     LIT 'CFLT',
         FP$INPUT       LIT 'FLTINP',
         FP$OUT         LIT 'FLTOUT',
         FP$OP$RETURN   LIT 'FLTRET',
         FP$OP          LIT 'FLTOP';

CHECK$OVERFLOW: PROCEDURE;
    IF OVERFLOW THEN
         DO;
              CALL WARNING('OF');
              CALL MOVE4(.MAXNUM,RA);
              OVERFLOW = 0;
         END;
END CHECK$OVERFLOW;


CONV$TO$BINARY: PROCEDURE(A) EXTERNAL;  /*CONVERTS FP NUM AT A TO BINARY
         AND RETURNS RESULT TO A  */
    DECLARE A ADDRESS;
END CONV$TO$BINARY;

CONV$TO$FP: PROCEDURE(A) EXTERNAL;  /* CONVERTS BINARY NUM AT A TO FP AND
         LEAVES IT AT A  */
    DECLARE A ADDRESS;
END CONV$TO$FP;

FP$INPUT: PROCEDURE(LENGTH,A) EXTERNAL;  /* CONVERTS STRING AT A LENGTH LENGTH
         TO FP AND LEAVES RESULT IN FP ACCUM   */
    DECLARE LENGTH BYTE, A ADDRESS;
END FP$INPUT;


FP$OUT: PROCEDURE(A) EXTERNAL;  /* CONVERTS FP ACCUM TO STRING AND PUTS IT
         AT A  */
    DECLARE A ADDRESS;
END FP$OUT;


FP$OP$RETURN: PROCEDURE(FUNC,A) EXTERNAL; /* PERFORMS FUNC AND RETURNS VALUE
         TO A  */
    DECLARE FUNC BYTE, A ADDRESS;
END FP$OP$RETURN;


FP$OP: PROCEDURE(FUNC,A) EXTERNAL;  /* PERFORMS FUNC POSSIBLY USEING
         FP NUM ADDRESSED BY A . NOTHING IS RETURNED TO A */
    DECLARE FUNC BYTE, A ADDRESS;
END FP$OP;

CONV$TO$BIN$ADDR: PROCEDURE;
    CALL CONV$TO$BINARY(RA);
    BRA(0) = BRA(3);
    BRA(1) = BRA(2);
END CONV$TO$BIN$ADDR;

INPUT: PROCEDURE(PORT) BYTE EXTERNAL;
    DECLARE PORT BYTE;
    END INPUT;

OUTPUT: PROCEDURE(PORT,VALUE) EXTERNAL;
    DECLARE (PORT,VALUE) BYTE;
    END OUTPUT;

RANDOM: PROCEDURE EXTERNAL;
    END RANDOM;


ONE$VALUE$OPS: PROCEDURE(A);
         DECLARE A BYTE;
         CALL FP$OP(FLOD,RA);
         CALL FP$OP$RETURN(A,RA);
    CALL CHECK$OVERFLOW;
END ONE$VALUE$OPS;

TWO$VALUE$OPS: PROCEDURE(TYPE);
    DECLARE TYPE BYTE;
         CALL FP$OP(FLOD,RA);
         CALL FP$OP$RETURN(TYPE,RB);
    CALL POP$STACK;
    CALL CHECK$OVERFLOW;
END TWO$VALUE$OPS;

ROUND$CONV$BIN: PROCEDURE;
    CALL PUSH$STACK;
    CALL MOVE4(.ONEHALF,RA);
    CALL TWO$VALUE$OPS(FADD);
    CALL CONV$TO$BIN$ADDR;
END ROUND$CONV$BIN;

FLOAT$ADDR: PROCEDURE(V);
    DECLARE V ADDRESS;
    ARA=0;
    BRA(2)=HIGH(V); BRA(3)=LOW(V);
    CALL CONV$TO$FP(RA);
END FLOAT$ADDR;

COMPARE$FP: PROCEDURE BYTE;
   /* 1=LESS 2=GREATER 3=EQUAL  */
         CALL FP$OP(FLOD,RB);
         CALL FP$OP$RETURN(FSUB,RA);
         IF RA$ZERO THEN
                DO;
                     CALL POP$STACK;
                     RETURN 3;
                END;
         IF RA$NEGATIVE THEN
              DO;
                    CALL POP$STACK;
                    RETURN 1;
              END;
         CALL POP$STACK;
         RETURN 2;
END COMPARE$FP;


    /*
         ********************************************************
         *                                                      *
         *         DYNAMIC STORAGE ALLOCATION PROCEDURES        *
         *                                                      *
         ********************************************************
    */
AVAILABLE: PROCEDURE(NBYTES) ADDRESS;
    DECLARE
            NBYTES   ADDRESS,
            POINT    ADDRESS,
            TEMP     ADDRESS,
            TOTAL    ADDRESS,
            HERE     BASED POINT   ADDRESS,
            SWITCH   BASED POINT(5)   BYTE;
    POINT = MBASE;
    TOTAL = 0;
    DO WHILE POINT <> 0;
         IF SWITCH(4) = 0 THEN
           DO;
              TOTAL = TOTAL + (TEMP := HERE - POINT - 5);
              IF NBYTES <> 0 THEN
                DO;
                   IF NBYTES + 5 <= TEMP THEN
                        RETURN POINT;
                END;
           END;
           POINT = HERE;
    END;
    IF NBYTES <> 0 THEN
         CALL ERROR('NM');
    RETURN TOTAL;
END AVAILABLE;

GETSPACE: PROCEDURE(NBYTES) ADDRESS;
    DECLARE
            NBYTES  ADDRESS,
            SPACE   ADDRESS,
            POINT   ADDRESS,
            HERE    BASED POINT   ADDRESS,
            TEMP    ADDRESS,
            TEMP1   ADDRESS,
            TEMP2   ADDRESS,
            ADR1    BASED TEMP1   ADDRESS,
            ADR2    BASED TEMP2   ADDRESS,
            SWITCH  BASED POINT(5)   BYTE,
            SWITCH2 BASED TEMP1(5)   BYTE;
    IF NBYTES = 0 THEN
         RETURN 0;
    POINT = AVAILABLE(NBYTES);
    /*LINK UP THE SPACE*/
    SWITCH(4)=1;  /* SET SWITCH ON*/
        TEMP1=POINT+NBYTES+5;
         ADR1=HERE;
         TEMP2=HERE + 2;
        HERE,ADR2 = TEMP1;
        SWITCH2(4)=0; /*SET REMAINDER AS AVAIL*/
       TEMP1 = TEMP1 + 2;
       ADR1 = POINT;
    CALL FILL(POINT := POINT + 5,0,NBYTES);
    RETURN POINT;
END GETSPACE;

RELEASE: PROCEDURE(SPACE);
    DECLARE
            SPACE      ADDRESS,
            HOLD       ADDRESS,
            NEXT$AREA  BASED     HOLD    ADDRESS,
            SWITCH     BASED     SPACE(5)   BYTE,
            HERE       BASED     SPACE   ADDRESS,
            TEMP       ADDRESS,
            ADRS       BASED     TEMP    ADDRESS,
            LOOK       BASED     TEMP(5)    BYTE;

    UNLINK: PROCEDURE;
        TEMP=HERE;
        IF ADRS<>0 THEN      /*NOT AT TOP OF FSA */
         DO;
            IF LOOK(4)=0 THEN   /*SPACE ABOVE IS FREE*/
              DO;
                   TEMP=(HERE:=ADRS) + 2;
                   ADRS=SPACE;
              END;
         END;
    END UNLINK;

    HOLD,SPACE=SPACE-5;
    SWITCH(4)=0;    /* RELEASES THE SPACE */
    /* COMBINE WITH SPACE ABOVE AND BELOW IF POSSIBLE*/
    CALL UNLINK;
    SPACE=SPACE+2;  /* LOOK AT PREVIOUS BLOCK*/
    IF (SPACE:=HERE)<>0 THEN
    DO;
        IF SWITCH(4)=0 THEN
        DO;
            CALL UNLINK;
           HOLD=SPACE;
        END;
    END;
END RELEASE;

    /*
         ********************************************************
         *                                                      *
         *            ARRAY ADDRESSING PROCEDURES               *
         *                                                      *
         *     CALC$ROW SETS UP AN ARRAY IN THE FSA IN ROW      *
         *     MAJOR ORDER.  THE BYTE OF CODE FOLLOWING THE     *
         *     OPERATOR IS THE NUMBER OF DIMENSIONS.  THE       *
         *     STACK CONTAINS THE UPPER BOUND OF EACH DIMENSION *
         *     RA HOLDS DIMENSION N, RB DIMENSION N-1 ETC.      *
         *     THE LOWER BOUND IS ALWAYS ZERO.                  *
         *                                                      *
         *     CALC$SUB PERFORMS A SUBSCRIPT CALCULATION FOR    *
         *     THE ARRAY REFERENCED BY RA.  THE VALUE OF EACH   *
         *     DIMENSION IS ON THE STACK BELOW THE ARRAY        *
         *     ADDRESS STARTING WITH THE NTH DIMENSION          *
         *     A CHECK IS MADE TO SEE IF THE SELECTED ELEMENT   *
         *     IS OUTSIDE THE AREA ASIGNED TO THE ARRAY         *
         *                                                      *
         ********************************************************
    */

CALC$ROW: PROCEDURE;
    DECLARE
            ASIZE       ADDRESS,
            I           BYTE,
            SAVERA      ADDRESS,
            SAVERB      ADDRESS,
            ARRAYADDR   ADDRESS,
            NUMDIM      BASED RC BYTE,
            ARRAYPOS    BASED ARRAYADDR ADDRESS;

    ASIZE = 1;  /* INITIAL VALUE */
    CALL STEP$INS$CNT;  /* POINT RC TO NUMDIM */
    SAVERA = RA;  /* SAVE CURRENT STACK POINTER */
    SAVERB = RB;
    DO I = 1 TO NUMDIM; /* FIRST PASS ON ARRAY DIMENSIONS */
         ARA,ASIZE = ASIZE * (ARA + 1); /* DISPLACEMENT AND TOTAL */
         CALL POP$STACK;  /* NEXT DIMENSION */
         END;
    RA = SAVERA;  /* BACK TO ORIGINAL STACK POSITION */
    RB = SAVERB;
    SAVERA,ARRAYADDR = GETSPACE(TIMES4(ASIZE) + SHL(NUMDIM+1,1));
    ARRAYPOS = NUMDIM;  /* STORE NUMBER OF DIM */
    DO I = 1 TO NUMDIM;  /* STORE DISPLACEMENTS */
         ARRAYADDR = ARRAYADDR + 2;
         ARRAYPOS = ARA;
         CALL POP$STACK;
         END;
    CALL PUSH$STACK;  /* NOW PUT ADDRESS OF ARRAY ON STACK */
    ARA = SAVERA;
END CALC$ROW;


CALC$SUB: PROCEDURE;
    DECLARE
            ARRAYADDR ADDRESS,
            ARRAYPOS  BASED ARRAYADDR ADDRESS,
            I         BYTE,
            NUMDIM    BYTE,
            LOCATION  ADDRESS;

    INC$ARRAYADDR: PROCEDURE;
         ARRAYADDR = ARRAYADDR + 1 + 1;
    END INC$ARRAYADDR;

    ARRAYADDR = ARA;
    CALL POP$STACK;
    LOCATION = ARA;
    NUMDIM = ARRAYPOS;
    DO I = 2 TO NUMDIM;
         CALL POP$STACK;
         CALL INC$ARRAYADDR;
         LOCATION = ARA * ARRAYPOS + LOCATION;
         END;
    CALL INC$ARRAYADDR;
    IF LOCATION >= ARRAYPOS THEN
         CALL ERROR('SB');
    ARA = ARRAYADDR + 2 + TIMES4(LOCATION);
END CALC$SUB;
    /*
         ********************************************************
         *                                                      *
         *     STORE PLACES RA IN THE PRT LOCATION REFERENCED   *
         *     BY RB.  RA MAY CONTAIN A FLOATING POINT NUMBER   *
         *     OR A REFERENCE TO A STRING.                      *
         *     IN THE CASE OF A STRING THE FOLLOWING IS ALSO    *
         *     PERFORMED:                                       *
         *         (1)  IF THE PRT CELL ALREADY CONTAINS A      *
         *         REFERENCE TO A STRING IN THE FSA THAT        *
         *         STRING'S COUNTER IS DECREMENTED AND IF       *
         *         EQUAL TO 1 THEN THE SPACE IS FREED           *
         *         (2)  THE NEW STRINGS COUNTER IS INCREMENTED  *
         *         IF IT IS ALREADY 255 THEN A COPY IS MADE     *
         *         AND THE NEW COUNTER SET TO 2.                *
         *                                                      *
         ********************************************************
    */

STORE: PROCEDURE(TYPE);
    DECLARE
            TYPE       BYTE,
            PTRADDR    ADDRESS,
            PTR        ADDRESS,
            STRINGADDR BASED PTRADDR  ADDRESS,
            COUNTER    BASED PTR      BYTE;
    CALL SET$DATA$ADDR(RB);
    IF TYPE THEN  /* STORE STRING */
         DO;
              CALL FLAG$STRING$ADDR(0);  /* SET TEMP STRING OFF */
         PTRADDR = ARB;  /* CAN WE FREE STRING DESTINATION POINTED TO */
              IF IN$FSA(STRINGADDR) THEN   /* IN FSA ? */
                   DO;
                        PTR = STRINGADDR - 1;
                        IF(COUNTER := COUNTER - 1) = 1 THEN
                             CALL RELEASE(STRINGADDR);
                   END;
              IF IN$FSA(PTR := ARA - 1) THEN   /* INC COUNTER */
                   DO;
                   IF COUNTER = 255 THEN  /* ALREADY POINTED TO BY
                                             254 VARIABLES */
                        DO;
                             PTR = PTR + 1;
                             CALL MOVE(PTR,ARA := GETSPACE(COUNTER + 1),
                                       COUNTER + 1);
                             PTR = ARA - 1;
                        END;
                   COUNTER = COUNTER + 1;
                   END;
         END;
    CALL MOVE4(RA,ARB);
END STORE;
    /*
         ********************************************************
         *                                                      *
         *                  BRANCHING ROUTINES                  *
         *                                                      *
         ********************************************************
    */

UNCOND$BRANCH: PROCEDURE;
    RC = RC + ARA - 1;
    CALL POP$STACK;
END UNCOND$BRANCH;


COND$BRANCH: PROCEDURE;
    IF RB$ZERO THEN
         CALL UNCOND$BRANCH;
    ELSE
         CALL POP$STACK;
    CALL POP$STACK;
END COND$BRANCH;


ABSOLUTE$BRANCH: PROCEDURE;
    CALL STEP$INS$CNT;
    RC = TWOBYTEOPRAND;
    RETURN;
END ABSOLUTE$BRANCH;
    /*
         ********************************************************
         *                                                      *
         *             GLOBAL STRING HANDLING ROUTINES          *
         *                                                      *
         ********************************************************
    */

CHECK$STRING$ADDR: PROCEDURE BYTE;
    RETURN BRA(2);
END CHECK$STRING$ADDR;

STRING$FREE: PROCEDURE;
    IF CHECK$STRING$ADDR THEN
         CALL RELEASE(ARA);
END STRING$FREE;


GET$STRING$LEN: PROCEDURE(STRINGLOC) BYTE;
    DECLARE
            STRINGLOC     ADDRESS,
            A     BASED STRINGLOC    BYTE;
    IF STRINGLOC = 0 THEN
         RETURN 0;
    RETURN A;
END GET$STRING$LEN;

COMP$FIX: PROCEDURE(FLAG);
    DECLARE FLAG     BYTE;
    IF FLAG THEN
         CALL MOVE4(.MINUSONE,RA);
    ELSE
         BRAZ = 0;
END COMP$FIX;


CONCATENATE: PROCEDURE;
    /*
         ********************************************************
         *                                                      *
         *    THE STRING POINTED TO BY RA IS CONCATENATED       *
         *    TO THE STRING POINTED TO BY RB AND THE POINTER    *
         *    TO THE RESULT IS PLACED IN RB. THE STACK IS POPPED*
         *    AND THE RESULT IS FLAGGED AS A TEMPORARY          *
         *    STRING.                                           *
         *                                                      *
         ********************************************************
    */
    DECLARE FIRSTSTRINGLENGTH  BYTE,
            SECONDSTRINGLENGTH BYTE,
            NEWSTRINGLENGTH    BYTE,
            NEWSTRINGADDRESS   ADDRESS,
            LENGTH             BASED NEWSTRINGADDRESS BYTE;
    CHKCARRY: PROCEDURE;
        IF CARRY THEN CALL ERROR('SL');
        END CHKCARRY;

    IF RA$ZERO$ADDRESS THEN  /* IT DOESNT MATTER WHAT RB IS */
         DO;
              CALL POP$STACK;
              RETURN;
         END;
    IF RB$ZERO$ADDRESS THEN /* AS ABOVE BUT RESULT IS RA */
         DO;
              CALL MOVE$RA$RB;
              CALL POP$STACK;
              RETURN;
         END;
    FIRSTSTRINGLENGTH = GETSTRINGLEN(ARB) + 1;
    CALL CHKCARRY;
    SECONDSTRINGLENGTH = GETSTRINGLEN(ARA);
    NEWSTRINGLENGTH = FIRSTSTRINGLENGTH + SECONDSTRINGLENGTH;
    CALL CHKCARRY;
    CALL MOVE(ARB,NEWSTRINGADDRESS := GETSPACE(NEWSTRINGLENGTH),
              FIRSTSTRINGLENGTH);
    CALL MOVE(ARA + 1,NEWSTRINGADDRESS + FIRSTSTRINGLENGTH,
              SECONDSTRINGLENGTH);
    CALL STRINGFREE;
    CALL POPSTACK;
    CALL STRINGFREE;
    ARA = NEWSTRINGADDRESS;
    LENGTH = NEWSTRINGLENGTH - 1;
    CALL FLAG$STRING$ADDR(TRUE);
END CONCATENATE;


COMPARE$STRING: PROCEDURE BYTE;
    /*
         ********************************************************
         *                                                      *
         *    THE STRING POINTED TO BY RB IS COMPARED TO        *
         *    THE STRING POINTED TO BY RA.                      *
         *                 RB RELATION RA                       *
         *    IF RB < RA THEN RETURN 1                          *
         *    IF RB > RA THE RETURN 2                           *
         *    IF RB = RA THEN RETURN 3                          *
         *    TWO STRINGS ARE EQUAL IF AND ONLY IF THE TWO      *
         *    STRINGS HAVE THE SAME LENGTH AND CONTAIN          *
         *    IDENTICAL CHARACTERS. THE ASCII COLLATING         *
         *    SEQUENCE IS USED TO DETERMINE THE RELATIONSHIP    *
         *    BETWEEN EQUAL LENGTH STRINGS. IF TWO STRINGS      *
         *    ARE NOT OF EQUAL LENGTH THE SHORTER IS ALWAYS     *
         *    LESS THEN THE LONGER ONE. ALL NULL STRINGS ARE    *
         *    EQUAL AND LESS THEN ANY OTHER STRING.             *
         *                                                      *
         ********************************************************
    */
    DECLARE FIRSTSTRING ADDRESS,
            SECONDSTRING ADDRESS,
            I            BYTE,
            TEMPLENGTH   BYTE,
            CHARSTRING1  BASED FIRSTSTRING BYTE,
            CHARSTRING2  BASED SECONDSTRING BYTE;

     FIXSTACK: PROCEDURE;
            CALL STRING$FREE;
            CALL POP$STACK;
            CALL STRING$FREE;
       END FIXSTACK;

    /* FIRST HANDLE NULL STRINGS REPRESENTED BY RA AND OR RB
    EQUAL TO ZERO */
    IF RA$ZERO$ADDRESS THEN
         SECONDSTRING= RA;
    ELSE
         SECONDSTRING = ARA;
    IF RB$ZERO$ADDRESS THEN
         FIRSTSTRING = RB;
    ELSE
         FIRSTSTRING = ARB;
    TEMPLENGTH = CHARSTRING1;
    DO I = 0 TO TEMPLENGTH;
         IF CHARSTRING1 < CHARSTRING2 THEN
              DO;
                     CALL FIXSTACK;
                     RETURN 1;
                END;
         IF CHARSTRING1 > CHARSTRING2 THEN
            DO;
                   CALL FIXSTACK;
                   RETURN 2;
              END;
         FIRSTSTRING = FIRSTSTRING + 1;
         SECONDSTRING = SECONDSTRING + 1;
        END;
    CALL FIXSTACK;
    RETURN 3;
END COMPARE$STRING;

STRING$SEGMENT: PROCEDURE(TYPE);
    DECLARE /* POSSIBLE TYPES */
            LEFT  LIT '0',
            RIGHT LIT '1',
            MID   LIT '2';

    DECLARE
            TYPE    BYTE,
            TEMPA   ADDRESS,
            TEMPA2  ADDRESS,
            LNG     BASED TEMPA BYTE,
            TEMPB1  BYTE,
            LNG2    BYTE;

    INC$BRA: PROCEDURE BYTE;
         RETURN BRAZ + 1;
    END INC$BRA;

    TEMPB1 = 0;
    IF TYPE = MID THEN
         DO;
              CALL FLIP;
              IF RA$NEGATIVE OR RA$ZERO THEN
                   CALL ERROR('SS');
              CALL CONV$TO$BIN$ADDR;
              TEMPB1 = BRAZ;
              CALL POP$STACK;
         END;
     IF RA$NEGATIVE OR (TEMPB1 > GETSTRING$LEN(ARB)) OR RA$ZERO THEN
         DO;
              CALL POP$STACK;
              CALL STRINGFREE;
              ARA = 0;
              RETURN;
         END;
    CALL CONV$TO$BIN$ADDR;
    IF BRAZ > (LNG2 := GETSTRING$LEN(ARB) - TEMPB1) THEN
         DO;
              IF TYPE=MID THEN
                   BRAZ = LNG2 + 1;
              ELSE
                   BRAZ = LNG2;
         END;
    IF TYPE = LEFT THEN
         TEMPA2 = ARB;
    ELSE
         IF TYPE = RIGHT THEN
              TEMPA2 = ARB + LNG2 - BRAZ;
         ELSE
              TEMPA2 = ARB + TEMPB1 - 1;
    CALL MOVE(TEMPA2,(TEMPA := GETSPACE(INC$BRA)),INC$BRA);
    LNG = BRAZ;
    CALL POP$STACK;
    CALL STRINGFREE;
    ARA = TEMPA;
    CALL FLAG$STRING$ADDR(TRUE);
END STRING$SEGMENT;



LOGICAL: PROCEDURE(TYPE);
    DECLARE
            TYPE   BYTE,
            I      BYTE;
    CALL CONV$TO$BINARY(RA);
    IF TYPE > 0 THEN
         CALL CONV$TO$BINARY(RB);
    DO I = 0 TO 3;
         DO CASE TYPE;
              BRA(I) = NOT BRA(I);
              BRB(I) = BRA(I) AND BRB(I);
              BRB(I) = BRA(I) OR BRB(I);
              BRB(I) = BRA(I) XOR BRB(I);
         END;
    END; /* OF DO TWICE */
    IF TYPE > 0 THEN
         CALL POP$STACK;
    CALL CONV$TO$FP(RA);
END LOGICAL;


    /*
         ********************************************************
         *                                                      *
         *                CONSOLE OUTPUT ROUTINES               *
         *                                                      *
         ********************************************************
    */
NUMERIC$OUT: PROCEDURE;
    /*
         ********************************************************
         *                                                      *
         *    THE FLOATING POINT NUMBER IN RA IS CONVERTED TO   *
         *    AN ASCII CHARACTER STRING AND THEN PLACED         *
         *    IN THE WORKBUFFER.  THE LENGTH OF THE STRING      *
         *    SET TO THE FIRST BYTE OF THE BUFFER               *
         *                                                      *
         ********************************************************
    */
    DECLARE
             I      BYTE;  /* INDEX */
    CALL FP$OP(FLOD,RA);  /* LOAD FP ACCUM WITH NUMBER FROM RA */
    CALL FP$OUT(.PRINTWORKAREA(1));  /* CONVERT IT TO ASCII  */
            /* RESULT IN PRINTWORKAREA PLUS 1 */
     I = 0;
     DO WHILE PRINTWORKAREA(I := I + 1) <> ' ';
          END;
     ARA = .PRINTWORKAREA;
     PRINTWORKAREA(0) = I;
END NUMERIC$OUT;


CLEAR$PRINT$BUFF: PROCEDURE;
    CALL FILL((PRINTBUFFER := PRINTBUFFERLOC),' ',PRINTBUFFLENGTH);
END CLEAR$PRINT$BUFF;


DUMP$PRINT$BUFF: PROCEDURE;
    DECLARE
            TEMP  ADDRESS,
            CHAR  BASED TEMP BYTE;
    TEMP=PRINTBUFFEND;
    DO WHILE CHAR = ' ';
        TEMP=TEMP - 1;
         END;
    CALL CRLF;
    DO PRINTBUFFER = PRINTBUFFERLOC TO TEMP;
        CALL PRINTCHAR(PRINTPOS);
         END;
    CALL CLEAR$PRINT$BUFF;
END DUMP$PRINT$BUFF;

WRITE$TO$CONSOLE: PROCEDURE;
     DECLARE
             HOLD     ADDRESS,
             H        BASED     HOLD(1)    BYTE,
             INDEX    BYTE;
     IF (HOLD := ARA) <> 0 THEN  /* MAY BE NULL STRING */
          DO INDEX = 1 TO H(0);
               PRINTPOS = H(INDEX);
               IF (PRINTBUFFER := PRINTBUFFER + 1) >
                              PRINTBUFFEND THEN
                    CALL DUMPPRINTBUFF;
           END;
END WRITE$TO$CONSOLE;


    /*
         ********************************************************
         *                                                      *
         *      FILE PROCESSING ROUTINES FOR USE WITH CP/M      *
         *                                                      *
         ********************************************************
    */
INITIALIZE$DISK$BUFFER: PROCEDURE;
    CALL FILL(BUFFER,EOFFILLER,128);
END INITIALIZE$DISK$BUFFER;


BUFFER$STATUS$BYTE: PROCEDURE BYTE;
    RETURN FCB(33);
END BUFFER$STATUS$BYTE;

SET$BUFFER$STATUS$BYTE: PROCEDURE(STATUS);
    DECLARE STATUS BYTE;
    FCB(33) = STATUS;
END SET$BUFFER$STATUS$BYTE;


WRITE$MARK: PROCEDURE BYTE;
    RETURN BUFFER$STATUS$BYTE;
END WRITE$MARK;


SET$WRITE$MARK: PROCEDURE;
    CALL SET$BUFFER$STATUS$BYTE(BUFFER$STATUS$BYTE OR 01H);
END SET$WRITEMARK;


CLEAR$WRITE$MARK: PROCEDURE;
    CALL SET$BUFFER$STATUS$BYTE(BUFFER$STATUS$BYTE AND 0FEH);
END CLEAR$WRITE$MARK;


ACTIVE$BUFFER: PROCEDURE BYTE;
    RETURN SHR(BUFFER$STATUS$BYTE,1);
END ACTIVE$BUFFER;

SET$BUFFER$INACTIVE: PROCEDURE;
    CALL SET$BUFFER$STATUS$BYTE(BUFFER$STATUS$BYTE AND 0F9H);
END SET$BUFFER$INACTIVE;

SET$BUFFER$ACTIVE: PROCEDURE;
    CALL SET$BUFFER$STATUS$BYTE(BUFFER$STATUS$BYTE OR 02H);
END SET$BUFFER$ACTIVE;


SET$RANDOM$MODE: PROCEDURE;
    CALL SET$BUFFER$STATUS$BYTE(BUFFER$STATUS$BYTE OR 80H);
END SET$RANDOM$MODE;

RANDOM$MODE: PROCEDURE BYTE;
    RETURN ROL(BUFFER$STATUS$BYTE,1);
END RANDOM$MODE;


STORE$REC$PTR: PROCEDURE;
    FCBADD(18) = RECORDPOINTER;
END STORE$REC$PTR;

DISK$EOF: PROCEDURE;
         IF EOFADDR = 0 THEN
              CALL ERROR('EF');
         RC = EOFADDR + 1;
         RA = EOFRA;
         RB = EOFRB;
         IF RECORD$POINTER <> BUFFER THEN
                CALL SET$BUFFER$STATUS$BYTE(BUFFER$STATUS$BYTE OR 04H);
           RECORD$POINTER = RECORD$POINTER - 1;
         CALL STORE$REC$PTR;
         GOTO EOFEXIT;  /* DROP OUT TO OUTER LOOP */;
END DISK$EOF;


FILL$FILE$BUFFER: PROCEDURE;
    IF DISKREAD = 0 THEN
         DO;
              CALL SET$BUFFER$ACTIVE;
              RETURN;
         END;
    IF NOT RANDOM$MODE THEN
         DO;
             CALL DISK$EOF;
             RETURN;
         END;
    CALL INITIALIZE$DISK$BUFFER;
    CALL SET$BUFFER$ACTIVE;
    FCB(32) = FCB(32) + 1;
    RETURN;
END FILL$FILE$BUFFER;


WRITE$DISK$IF$REQ: PROCEDURE;
    IF WRITE$MARK THEN
    DO;
         IF SHR(BUFFER$STATUS$BYTE,2) THEN
              DO;
                   IF FCB(32) > 0 THEN
                        FCB(32) = FCB(32) - 1;
                   CALL SET$BUFFER$STATUS$BYTE(BUFFER$STATUS$BYTE AND 0FBH);
              END;
         IF DISKWRITE <> 0 THEN
              CALL ERROR('DW');
         CALL CLEAR$WRITE$MARK;
         IF RANDOM$MODE THEN
              CALL SET$BUFFER$INACTIVE;
         ELSE
              CALL INITIALIZE$DISK$BUFFER;
    END;
    RECORD$POINTER = BUFFER;
END WRITE$DISK$IF$REQ;


AT$END$DISK$BUFFER: PROCEDURE BYTE;
    RETURN (RECORD$POINTER := RECORD$POINTER + 1) >= BUFFER$END;
END AT$END$DISK$BUFFER;

VAR$BLOCK$SIZE: PROCEDURE BYTE;
    RETURN BLOCKSIZE <> 0;
END VAR$BLOCKSIZE;


WRITE$A$BYTE: PROCEDURE(CHAR);
    DECLARE CHAR BYTE;
    IF VAR$BLOCK$SIZE AND (BYTESWRITTEN := BYTESWRITTEN + 1)
               > BLOCKSIZE THEN
         CALL ERROR('ER');
    IF AT$END$DISK$BUFFER THEN
         CALL WRITE$DISK$IF$REQ;
    IF NOT ACTIVE$BUFFER AND RANDOM$MODE THEN
         DO;
              CALL FILL$FILE$BUFFER;
              FCB(32) = FCB(32) - 1;  /* RESET RECORD NO */
         END;
    NEXTDISKCHAR = CHAR;
    CALL SET$WRITE$MARK;
END WRITE$A$BYTE;


GET$FILE$NUMBER: PROCEDURE BYTE;
    IF BRAZ > NUMFILES THEN
         CALL ERROR('MF');
    RETURN BRAZ;
END GET$FILE$NUMBER;


SET$FILE$ADDR: PROCEDURE;
    IF (FILEADDR := FILES(GET$FILE$NUMBER))
                                = 0 THEN
         CALL ERROR('FU');
    EOFADDR = EOFBRANCH(BRAZ);
END SET$FILE$ADDR;


SET$FILE$POINTERS: PROCEDURE;
    BUFFER$END = (BUFFER := FILEADDR + 38) + DISKRECSIZE;
    RECORDPOINTER = FCBADD(18);
    BLOCKSIZE = FCBADD(17);
    CALL SETDMA;
END SET$FILE$POINTERS;


SETUP$FILE$EXTENT: PROCEDURE;
    IF OPEN = 255 THEN
         DO;
              IF CREATE = 255 THEN
                   CALL ERROR('ME');
         END;
END SETUP$FILE$EXTENT;


DISK$OPEN: PROCEDURE;
    /*OPENS THE FILE - RA CONTAINS THE ADDRESS OF THE FILE NAME
    AND RB CONTAINS THE BLOCK SIZE.
    THE ARRAY FILES WILL HOLD THE ADDRESS OF THE FILE CONTROL BLOCK
    IN THE FSA.  THE FCB IS FOLLOWED BY 3 FLAGS - BLOCKSIZE(ADDR)
    RECORD POINTER(ADDR), WRITE FLAG(BYTE).  THIS IS FOLLOWED BY THE
    128 BYTE BUFFER TO DO FILE I/O.*/

    DECLARE
            FILENAME ADDRESS,
            NEXTFILE BYTE,
            BUFF     ADDRESS,
            CHAR     BASED BUFF(128) BYTE,
            I        BYTE,
            J        BYTE;

    INC$J: PROCEDURE BYTE;
         RETURN (J := J + 1);
    END INC$J;

    NEXTFILE = 0;
    DO WHILE FILES(NEXTFILE := NEXTFILE + 1) <> 0;
         END;
    FILEADDR,FILES(NEXTFILE) = GETSPACE(166);
    BUFFER = FILEADDR + 38;
    CALL SETDMA;
    CALL FILL((FILENAME:=FILEADDR+1),' ',11);
    BUFF=ARA;
    IF CHAR(2) = ':' THEN
         DO;
              FCB(0) = CHAR(1) AND 0FH;
              I = CHAR(0) - 2;
              BUFF = BUFF + 2;
         END;
    ELSE
         I = CHAR(0);
    IF I > 12 THEN
         I = 12;
    BUFF=BUFF+1;
    J = 255;
    DO WHILE(CHAR(INC$J) <> '.') AND (J < I);
         END;
    CALL MOVE(BUFF,FILENAME,J);
    IF I > INC$J THEN
         CALL MOVE (.CHAR(J),FILENAME + 8, I - J);
    CALL SETUP$FILE$EXTENT;
    CALL INITIALIZE$DISK$BUFFER;
    FCBADD(18)=FILEADDR+256;
    CALL POP$STACK;
    FCBADD(17) = ARA;
    CALL POP$STACK;
END DISK$OPEN;


SET$EOF$STACK: PROCEDURE;
     EOFRA = RA;
     EOFRB = RB;
END SET$EOF$STACK;

SETUP$DISK$IO: PROCEDURE;

    CALL SET$FILE$ADDR;
    CALL SET$FILE$POINTERS;
    BYTES$WRITTEN=0;
    FIRSTFIELD = TRUE;
    CALL POP$STACK;
END SETUP$DISK$IO;


RANDOM$SETUP: PROCEDURE;
    DECLARE
            TEMP1     ADDRESS,
            TEMP2   ADDRESS,
            TEMP3     ADDRESS,
            BYTECOUNT ADDRESS,
            RECORD    ADDRESS,
            EXTENT    BYTE;

    IF NOT VAR$BLOCK$SIZE THEN
         CALL ERROR('RU');
    IF RA$ZERO$ADDRESS OR RA$NEGATIVE THEN
         CALL ERROR('IR');
    ARA = ARA - 1;
    CALL SET$RANDOM$MODE;
    CALL SET$BUFFER$INACTIVE;
    CALL WRITE$DISK$IF$REQ;
    TEMP2 = LOW(BLOCKSIZE)*HIGH(ARA) + LOW(ARA)*HIGH(BLOCKSIZE);
    TEMP1 = LOW(BLOCKSIZE) * BRAZ;
    BYTECOUNT = SHL(TEMP2,8) + TEMP1;
    TEMP3 = HIGH(BLOCKSIZE) * BRA(1);
    EXTENT = SHL(LOW(TEMP3) ,2) +
               SHR((HIGH(TEMP1) + TEMP2),6);
    RECORDPOINTER = (BYTECOUNT AND 7FH) + BUFFER - 1;
    CALL STORE$REC$PTR;
    RECORD = SHR(BYTECOUNT,7);
    IF EXTENT<>FCB(12) THEN
         DO;
              IF CLOSE = 255 THEN
                   CALL ERROR('CE');
              FCB(12) = EXTENT;
              CALL SETUP$FILE$EXTENT;
         END;
    FCB(32) = LOW(RECORD) AND 7FH;
    CALL POP$STACK;
END RANDOM$SETUP;


GET$DISK$CHAR: PROCEDURE BYTE;
     IF AT$END$DISK$BUFFER THEN
         DO;
              CALL WRITE$DISK$IF$REQ;
              CALL FILL$FILE$BUFFER;
         END;
    IF NOT ACTIVE$BUFFER THEN
         CALL FILL$FILE$BUFFER;
    IF NEXTDISKCHAR = EOFFILLER THEN
         CALL DISK$EOF;
    RETURN NEXTDISKCHAR;
END GET$DISK$CHAR;


WRITE$TO$FILE: PROCEDURE(TYPE);
    /* TYPE 0 MEANS WRITE A NUMBER, 1 MEANS A STRING*/
    DECLARE
            I       BYTE,
            POINT   ADDRESS,
            CHAR    BASED     POINT  BYTE,
            COUNT   BYTE,
            TYPE    BYTE,
            NUMERIC LIT       '0',
            STRING  LIT       '1';

    INC$POINT: PROCEDURE;
         POINT = POINT + 1;
    END INC$POINT;

    IF TYPE = NUMERIC THEN /* CONVERT TO ASCII STRING */
         CALL NUMERICOUT;
    IF NOT FIRSTFIELD THEN /* SEPARATE FIELDS WITH COMMAS */
         CALL WRITE$A$BYTE(',');
    ELSE
         FIRSTFIELD = FALSE;
    POINT = ARA; /* ARA POINTS TO CHAR STRING */
    COUNT = CHAR;
    IF TYPE = NUMERIC THEN /* ELIM TRAILING BLANK */
         COUNT = COUNT - 1;
    ELSE
         CALL WRITE$A$BYTE(QUOTE); /* STRINGS PUT IN QUOTES */
    CALL INC$POINT; /* POINT TO FIRST CHAR */
    DO I = 1 TO COUNT;
         IF CHAR = QUOTE THEN
              CALL ERROR('QE');
         CALL WRITE$A$BYTE(CHAR);
         CALL INC$POINT;
         END;
    IF TYPE = STRING THEN
         DO;
              CALL WRITE$A$BYTE(QUOTE); /* ADD TRAILING QUOTE */
              CALL STRING$FREE; /* MAY BE A TEMP STRING */
         END;
    CALL POP$STACK;
END WRITE$TO$FILE;


DISK$CLOSE: PROCEDURE;
    CALL SET$FILE$POINTERS;
    CALL WRITE$DISK$IF$REQ;
    IF CLOSE = 255 THEN
         CALL ERROR('CE');
    CALL RELEASE(FILEADDR);
END DISK$CLOSE;

CLOSEFILES:  PROCEDURE;
    DECLARE I BYTE;
    I = 0;
    DO WHILE(I:=I+1) <= NUMFILES;
         IF(FILEADDR := FILES(I)) <> 0 THEN
              CALL DISKCLOSE;
         END;
END CLOSEFILES;

    /*
         ********************************************************
         *                                                      *
         *                 ROUTINE TO EXIT INTERP               *
         *                                                      *
         ********************************************************
    */
EXIT$INTERP: PROCEDURE;
    CALL CLOSEFILES;
    CALL DUMP$PRINT$BUFF;
    CALL CRLF;
    CALL MON3;
END EXIT$INTERP;


    /*
         ********************************************************
         *                                                      *
         *               GENERALIZED INPUT ROUTINES             *
         *                                                      *
         ********************************************************
    */

CONSOLE$READ: PROCEDURE;
    CALL PRINTCHAR(WHAT);
    CALL PRINTCHAR(' ');
    CALL READ(.INPUTBUFFER);
    IF SPACE(1) = CONTZ THEN
         CALL EXIT$INTERP;
    CONBUFFPTR = .SPACE;
    SPACE(SPACE(0)+1)=EOLCHAR;
END CONSOLE$READ;

MORE$CON$INPUT: PROCEDURE BYTE;
    RETURN CONBUFFPTR < .SPACE(SPACE(0));
END MORE$CON$INPUT;


CONSOLE$INPUT$ERROR: PROCEDURE;
    CALL POPSTACK;
    RC = REREADADDR;  /* RESET PROGRAM COUNTER */
    CALL WARNING('II');
    GOTO ERROR$EXIT;  /* RETURN TO OUTER LEVEL */
END CONSOLE$INPUT$ERROR;


GET$DATA$CHAR: PROCEDURE BYTE;
    DECLARE CHAR BASED DATAAREAPTR BYTE;
    IF(DATAAREAPTR := DATAAREAPTR + 1) >= SB THEN
         CALL ERROR('OD');
    RETURN CHAR;
END GET$DATA$CHAR;


GET$CON$CHAR: PROCEDURE BYTE;
    DECLARE CHAR BASED CONBUFFPTR BYTE;
    CONBUFFPTR = CONBUFFPTR + 1;
    RETURN CHAR;
END GET$CON$CHAR;


NEXT$INPUT$CHAR: PROCEDURE BYTE;
    IF INPUTTYPE = 0 THEN /* READ FROM DISK */
         DO FOREVER;
              IF INPUTINDEX >CONBUFFSIZE THEN
                     CALL ERROR('DB');
              IF(SPACE(INPUTINDEX):= GETDISKCHAR) = LF THEN
                   DO;
                        IF VAR$BLOCKSIZE THEN
                             CALL ERROR('RE');
                   END;
              ELSE
                   RETURN NEXTDISKCHAR;
         END;
    IF INPUTTYPE = 1 THEN /* INPUT FROM CONSOLE */
         RETURN GETCONCHAR;
    IF INPUTTYPE = 2 THEN /* READ FROM DATA STATEMENT */
         RETURN GETDATACHAR;
END NEXT$INPUT$CHAR;


COUNT$INPUT: PROCEDURE;
     /*
        DETERMINE EXTENT OF NEXT FIELD AND COLLECT
        THE FIELD IN THE APPROPRIATE BUFFER
     */
    DECLARE
            HOLD  BYTE,
            DELIM BYTE;
    INPUT$INDEX = 0;
    DO WHILE (HOLD := NEXT$INPUT$CHAR) = ' ';
         END;
    IF INPUTTYPE = 0 THEN
         INPUTPTR = .SPACE;
    IF INPUTTYPE = 1 THEN
         INPUTPTR = CONBUFFPTR;

    IF INPUTTYPE =2 THEN
         INPUTPTR = DATAAREAPTR;
    IF HOLD <> QUOTE THEN
         DELIM = ',';
    ELSE
         DO;
              DELIM = QUOTE;
              IF INPUTTYPE <> 0 THEN
                   INPUTPTR = INPUTPTR + 1;
              HOLD = NEXT$INPUT$CHAR;
         END;
    DO WHILE (HOLD <> DELIM) AND (HOLD <> EOLCHAR);
         INPUTINDEX = INPUTINDEX + 1;
         HOLD = NEXT$INPUT$CHAR;
         END;
    IF DELIM = QUOTE THEN
         DO WHILE((HOLD := NEXT$INPUT$CHAR) <> ',') AND (HOLD <> EOLCHAR);
              END;
    CALL PUSH$STACK;
END COUNT$INPUT;


GET$STRING$FIELD: PROCEDURE;
    DECLARE
            TEMP ADDRESS,
            LNG  BASED TEMP BYTE;
    CALL COUNT$INPUT;
    CALL MOVE(INPUTPTR,(TEMP:=GETSPACE(INPUTINDEX + 1))+1,INPUTINDEX);
    ARA = TEMP;
    CALL FLAG$STRING$ADDR(0);
    LNG = INPUTINDEX;  /* SET LENGTH IN NEW STRING */
END GET$STRING$FIELD;


GET$NUMERIC$FIELD: PROCEDURE;
    CALL COUNT$INPUT;
    IF INPUTINDEX > 0 THEN
    DO;
    CALL FP$INPUT(INPUTINDEX,INPUTPTR);
    CALL FP$OP$RETURN(9,RA);
    CALL CHECK$OVERFLOW;
    END;
      ELSE
           IF INPUTTYPE = 1 THEN
                CALL CONSOLE$INPUT$ERROR;
           ELSE
                BRAZ = 0;
END GET$NUMERIC$FIELD;



    /*
         ********************************************************
         *                                                      *
         *          INTERPRETER INITIALIZATION ROUTINES         *
         *                                                      *
         ********************************************************
    */


INITIALIZE$EXECUTE: PROCEDURE;
    GET$PARAMETERS: PROCEDURE;
        MCD,RC = PARAM1;
        DATAAREAPTR = (MDA := PARAM2) - 1;
        MPR=PARAM3;
        MBASE,ST = (SB := PARAM4) + NRSTACK;
        RA = (RB := SB) + 4;
    END GET$PARAMETERS;

    INITMEM: PROCEDURE;
        DECLARE BASE ADDRESS,
                A BASED BASE(2) ADDRESS,
                TOP BASED SYSBEGIN ADDRESS;
        CALL MOVE(BEGIN+OFFSET,BEGIN,MPR-BEGIN);
        CALL FILL(MPR,0,MBASE-MPR);
        BASE=ST;
        A(0)=TOP-4;
        A(1),A(2) = 0;
        BASE=A(0);
        A(0) = 0;
        A(1) = ST;
    END INITMEM;


    CALL GET$PARAMETERS;
    CALL INITMEM;
    CALL FILL(.FILES,0,TIMES4(NUMFILES));
    CALL CLEAR$PRINT$BUFF;
END INITIALIZE$EXECUTE;


 /* ***** EXECUTIVE ROUTINE STARTS HERE ***** */
    /*
         ********************************************************
         *                                                      *
         ********************************************************
    */
EXECUTE:  PROCEDURE;
     DO FOREVER;
    IF ROL(C,1) THEN    /* MUST BE LIT OR LIT-LOD*/
    DO;
         CALL PUSH$STACK;
        BRA(0)=CV(1);       /* LOAD IN REVERSE ORDER */
        BRA(1)= C AND 3FH;
        IF ROL(C,2) THEN CALL LOAD$RA;   /*LIT-LOD*/
         CALL STEP$INS$CNT;
        END;
    ELSE
         DO CASE C;

 /*0  FAD: RB = RA+ RB  */
        CALL TWO$VALUE$OPS(FADD);

 /*1  FMI  RB = RB-RA; */
         DO;
              CALL FLIP;
        CALL TWO$VALUE$OPS(FSUB);
         END;

 /*2 FMU  RB= RA*RB    */
        CALL TWO$VALUE$OPS(FMUL);

 /*3  FDI  RB = RA/RB  */
         DO;
              IF RA$ZERO THEN
                   CALL WARNING('DZ');
              CALL FLIP;
              CALL TWO$VALUE$OPS(FDIV);
         END;

 /*4  EXP  RA=RB**RA    */
         DO;
              IF RB$ZERO THEN
                 DO;
                   IF RA$ZERO THEN
                       CALL MOVE4(.PLUSONE,RB);
                 END;
              ELSE
                   IF RB$NEGATIVE THEN
                        CALL ERROR('NE');
                   ELSE
                        DO;
                             CALL FP$OP(FLOD,RB);
                             CALL FP$OP(LOG,0);
                             CALL FP$OP(FMUL,RA);
                             CALL FP$OP$RETURN(EXP,RB);
                        END;
                CALL POP$STACK;
                CALL CHECK$OVERFLOW;
         END;

 /* 5 LSS, LESS THEN */
         CALL COMP$FIX(COMPARE$FP=1);

 /* 6 GTR, GREATER THEN */
         CALL COMP$FIX(COMPARE$FP=2);

 /* 7  EQU, EQUAL TO */
         CALL COMP$FIX(COMPARE$FP=3);

 /* 8  NEQ, NOT EQUAL TO */
         CALL COMP$FIX(NOT(COMPARE$FP=3));

 /* 9  GEQ, GREATER THEN OR EQUAL TO */
         CALL COMP$FIX(NOT(COMPARE$FP=1));

 /*10  LEQ, LESS THEN OR EQUAL TO */
         CALL COMP$FIX(NOT(COMPARE$FP=2));

 /*11  NOT*/
         CALL LOGICAL(0);

 /*12  AND*/
         CALL LOGICAL(1);

 /*13  BOR */
         CALL LOGICAL(2);

 /* 14 LOD*/
            CALL LOAD$RA;

 /* 15 STO */
         DO;
              CALL STORE(0);
              CALL MOVE$RA$RB;
              CALL POP$STACK;
         END;

 /* 16 XIT */
         RETURN;

 /* 17 DEL */
         CALL POP$STACK;

 /* 18 DUP */
         DO;
              CALL PUSH$STACK;
         CALL MOVE$RB$RA;
      END;

 /* 19 XCH */
         CALL FLIP;

 /* 20 STD */
         DO;
              CALL STORE(0);
              CALL POP$STACK;
              CALL POP$STACK;
         END;

 /* 21 SLT */
         CALL COMP$FIX(COMPARE$STRING = 1);

 /* 22 SGT */
         CALL COMP$FIX(COMPARE$STRING = 2);

 /* 23 SEQ */
         CALL COMP$FIX(COMPARE$STRING = 3);

 /* 24 SNE */
         CALL COMP$FIX(NOT(COMPARE$STRING = 3));

 /* 25 SGE */
         CALL COMP$FIX(NOT(COMPARE$STRING = 1));
 /* 26 SLE */
         CALL COMP$FIX(NOT(COMPARE$STRING = 2));

 /* 27  STS */
         DO;
              CALL STORE(1);
              CALL POP$STACK;
              CALL POP$STACK;
      END;

 /* 28 ILS */
         DO;
              CALL PUSH$STACK;
              CALL STEP$INS$CNT;
              RC = (ARA := RC) + C;
              CALL FLAG$STRING$ADDR(FALSE);
         END;

 /* 29 CAT */
         CALL CONCATENATE;
 /* 30 PRO */
         DO;
              CALL STEP$INS$CNT;
              CALL PUSH$STACK;
              ARA = RC + 1 + 1;
              RC = TWOBYTEOPRAND;
         END;

 /* 31 RTN */
         DO;
              RC = ARA - 1;
              CALL POP$STACK;
         END;

 /*32 ROW, CALCULATES SPACE REQUIREMENTS FOR ARRAYS*/
         CALL CALC$ROW;

 /* 33, SUB */
 /*   SUB,CALCULATES SUBSCRIPT ADDRESSES */
         CALL CALC$SUB;


 /* RDV  READS A NUMBER FROM THE CONSOLE  */
         DO;
              IF NOT MORE$CON$INPUT THEN
                    CALL CONSOLE$INPUT$ERROR;
              CALL GET$NUMERIC$FIELD;
         END;

 /* 35, WRV : PRINTS THE NUMBER ON THE TOP OF THE STACK */
         DO;
              CALL NUMERIC$OUT;
              CALL WRITE$TO$CONSOLE;
              CALL POP$STACK;
         END;

 /* 36 WST: PRINTS THE STRING WHOSE ADDRESS IS ON TOPOF THE STACK*/
          DO;
               CALL WRITE$TO$CONSOLE;
              CALL STRING$FREE;
              CALL POP$STACK;
         END;

 /* 37, RDF */
    /* RDF - PROCEDURE TO READY A RANDOM BLOCK */
         DO;
              CALL SETUP$DISK$IO;
              CALL RANDOM$SETUP;
              CALL SET$EOF$STACK;
         END;

 /* 38, RDB */
    /* RDB - READY NEXT SEQUENTIAL BLOCK */
          DO;
              CALL SETUP$DISK$IO;
              CALL SET$EOF$STACK;
          END;

 /* 39, ECR */
          IF MORE$CON$INPUT THEN
               DO;
               CALL PUSHSTACK;
               CALL CONSOLE$INPUT$ERROR;
            END;

 /* 40, OUT */
          DO;
               CALL OUTPUT(BRAZ,BRBZ);
               CALL POP$STACK;
               CALL POP$STACK;
          END;

    /*41 RDN - READ A NUMBER FROM DISK*/
         DO;
              INPUTTYPE = 0;
              CALL GET$NUMERIC$FIELD;
         END;

    /*42 RDS - READ A STRING FROM DISK*/
         DO;
              INPUTTYPE = 0;
              CALL GET$STRING$FIELD;
         END;

    /*43 WRN WRITE A NUMBER TO DISK*/
         CALL WRITE$TO$FILE(0);

    /*44 WRS - WRITE A STRING TO DISK */
         CALL WRITE$TO$FILE(1);

 /* 45, OPN */
 /*OPN:   PROCEDURE TO CREATE FCBS FOR ALL INPUT FILES */
        CALL DISK$OPEN;

 /* 46 CON */
         DO;
              CALL PUSH$STACK;
              CALL STEP$INS$CNT;
              CALL MOVE4(TWOBYTEOPRAND,RA);
              CALL STEP$INS$CNT;
         END;

 /* 47, RST: PUTS POINTER TO THE BEGINNING OF THE DATA AREA*/
              DATAAREAPTR = MDA - 1;

 /*48  NEG, NEGATIVE */
         CALL ONE$VALUE$OPS(FCHS);

 /* 49 , RES : READ STRING */
         DO;
              IF NOT MORE$CON$INPUT THEN
                   CALL CONSOLE$INPUT$ERROR;
              CALL GET$STRING$FIELD;
         END;

 /* 50 NOP */
;

 /* 51 DAT */
  ;

 /* 52 DBF */
         CALL DUMPPRINTBUFF;

 /* 53 NSP */
         DO;
              DECLARE I BYTE;
              I=0;
              DO WHILE PRINTBUFFER > POSITION(I);
                   I = I + 1;
                   END;
              IF I = MAXPOSNUM THEN
                   CALL DUMP$PRINT$BUFF;
              ELSE
                   PRINTBUFFER = POSITION(I);
         END;

 /* 54 BRS */
         CALL ABSOLUTE$BRANCH;

 /* 55 BRC */
         DO;
              IF RA$ZERO THEN
                   CALL ABSOLUTE$BRANCH;
              ELSE
                   RC = RC + 1 + 1;
              CALL POP$STACK;
         END;

 /* 56 BFC */
         CALL COND$BRANCH;

 /* 57 BFN */
         CALL UNCOND$BRANCH;

 /* 58 CBA */
         CALL CONV$TO$BINARY(RA);

 /* 59 RCN */
         DO;
              INPUTTYPE = 1;
               REREADADDR = RC;
              CALL CONSOLE$READ;
         END;

 /* 60 DRS READ STRING FROM DATA AREA */
         DO;
              INPUTTYPE = 2;
              CALL GET$STRING$FIELD;
         END;

 /* 61 DRF READ F/P NUMBER FROM DATA AREA */
         DO;
              INPUTTYPE = 2;
              CALL GET$NUMERIC$FIELD;
         END;

    /*62 EDR - END OF RECORD FOR READ*/
    /*ADVANCES TO NEXT LINE FEED*/
         DO;
              IF VAR$BLOCK$SIZE THEN
                   DO WHILE GET$DISK$CHAR <> LF;
                        END;
              CALL STORE$REC$PTR;
         END;

    /*63 EDW - END OF RECORD FOR WRITE*/
         DO;
              IF VAR$BLOCK$SIZE THEN
                    DO WHILE BYTES$WRITTEN < (BLOCKSIZE - 2);
                         CALL WRITE$A$BYTE(' ');
                         END;
              CALL WRITE$A$BYTE(CR);
              CALL WRITE$A$BYTE(LF);
              CALL STORE$REC$PTR;
         END;
    /*64 CLS - CLOSE A FILE*/
         DO;
              CALL SET$FILE$ADDR;
              CALL DISK$CLOSE;
              FILES(BRAZ),EOFBRANCH(BRAZ) = 0;
              CALL POP$STACK;
         END;

 /* 65 ABSOLUTE */
         BRA(1) = BRA(1) AND 7FH;

 /* 66 INTEGER */
         DO;
              CALL CONV$TO$BINARY(RA);
              CALL CONV$TO$FP(RA);
         END;

 /* 67 RANDOM NUMBER GENERATOR */
         DO;
              CALL RANDOM;
              CALL PUSH$STACK;
              CALL MOVE4(.SCALE,RA);
              CALL PUSH$STACK;
              CALL FLOAT$ADDR(SEED);
              CALL TWO$VALUE$OPS(FDIV);
         END;

 /* 68 SGN */
         DO;
              DECLARE FLAG BYTE;
              FLAG = NOT RA$NEGATIVE;
              CALL COMP$FIX(NOT RA$ZERO);
              IF FLAG THEN
                   CALL ONE$VALUE$OPS(FCHS);
         END;

 /* 69 SINE */
         CALL ONE$VALUE$OPS(SIN);

 /* 70 COSINE */
         CALL ONE$VALUE$OPS(COS);

 /* 71 ARCTANGENT */
         CALL ONE$VALUE$OPS(ATAN);

 /* 72 TANGENT */
         DO;
              CALL PUSH$STACK;
              CALL MOVE$RB$RA;
              CALL ONE$VALUE$OPS(SIN);
              CALL POP$STACK;
              CALL ONE$VALUE$OPS(COS);
              CALL PUSH$STACK;
              IF RB$ZERO THEN
                   CALL ERROR('TZ');
              CALL TWO$VALUE$OPS(FDIV);
         END;

 /* 73 SQUAREROOT */
         CALL ONE$VALUE$OPS(SQRT);

 /* 74 TAB */
         DO;
              CALL ROUND$CONV$BIN;
              DO WHILE ARA > PRINTBUFFLENGTH;
                   ARA = ARA - PRINTBUFFLENGTH;
                   END;
              IF ((ARA := ARA - 1 + PRINTBUFFERLOC) <= PRINTBUFFER)
                     AND (PRINTBUFFER <> PRINTBUFFERLOC) THEN
                   CALL DUMP$PRINT$BUFF;
              PRINTBUFFER = ARA;
         CALL POP$STACK;
         END;

 /* 75 EXPONENTATION */
         CALL ONE$VALUE$OPS(EXP);

 /* 76 FREE AREA IN FSA */
          DO;
               CALL PUSH$STACK;
               CALL FLOAT$ADDR(AVAILABLE(0));
          END;

 /* 77  IRN  */
         SEED = LOCALSEED;

 /* 78 LOG */
         CALL ONE$VALUE$OPS(LOG);

 /* 79 POSITION OF PRINT BUFFER PTR */
          DO;
               CALL PUSH$STACK;
               CALL FLOAT$ADDR(PRINTBUFFER - (PRINTBUFFERLOC - 1));
          END;

 /* 80 INP */
          DO;
               CALL ROUND$CONV$BIN;
               CALL FLOAT$ADDR(INPUT(BRAZ));
          END;

 /* 81 ASCII CONVERSION */
          DO;
               DECLARE
                       HOLD ADDRESS,
                       TEMP BYTE,
                       H    BASED    HOLD(1)   BYTE;
               IF (HOLD := ARA) = 0 OR H(0) = 0 THEN
                    CALL ERROR('AC');
               TEMP = H(1);
               CALL STRING$FREE;
               CALL FLOAT$ADDR(TEMP);
          END;

 /* 82 CHR CONVERTS TO ASCII */
         DO;
              DECLARE HOLD ADDRESS,
                      LOC BASED HOLD(1) BYTE;
              CALL CONV$TO$BIN$ADDR;
              HOLD = GETSPACE(2);
              LOC(0) = 1;
              LOC(1) = BRA(0);
              ARA = HOLD;
              CALL FLAGSTRINGADDR(TRUE);
         END;

 /* 83 LEFT END OF STRING */
         CALL STRING$SEGMENT(0);

 /* 84 LENGTH OF STRING */
       DO;
            DECLARE LENGTH BYTE;
            LENGTH = GET$STRING$LEN(ARA);
            CALL STRING$FREE;
            CALL FLOAT$ADDR(LENGTH);
       END;

 /* 85 MIDDLE OF STRING */
         CALL STRING$SEGMENT(2);

 /* 86 RIGHT END OF STRING */
         CALL STRING$SEGMENT(1);

 /* 87 CONVERSION TO STRING */
          DO;
               CALL NUMERIC$OUT;
               CALL MOVE(.PRINTWORKAREA,ARA :=
                     GETSPACE(PRINTWORKAREA(0) + 1),PRINTWORKAREA(0) + 1);
               CALL FLAG$STRING$ADDR(TRUE);
          END;

 /* 88 VALUE  */
       DO;
       CALL FP$INPUT(GET$STRING$LEN(ARA),ARA+1);
       CALL STRING$FREE;
         CALL FP$OP$RETURN(9,RA);
       END;

 /* 89 COSH */
         CALL ONE$VALUE$OPS(COSH);

 /* 90 SINH */
         CALL ONE$VALUE$OPS(SINH);

 /* 91 RON  */
         CALL ROUND$CONV$BIN;

 /* 92 CKO  */
         /* RA CONTAINS MAX NUMBER OF LABELS IN THE ON STATEMENT
            RB CONTAINS SELECTED LABEL.
            CHECK TO INSURE SELECTED LABEL EXISTS. IF NOT AN ERROR
            HAS OCCURED */
         DO;
              IF (BRBZ := BRBZ - 1) > BRAZ - 1 THEN
                   CALL ERROR('OI');
              CALL POP$STACK;
               BRAZ = SHL(BRAZ,1) + BRAZ + 1;
         END;
 /* 93 EXR  */
         CALL LOGICAL(3);


 /* 94 DEF  */
         DO;
              CALL STEP$INS$CNT;
              EOFBRANCH(GET$FILE$NUMBER) = TWOBYTEOPRAND;
              CALL STEP$INS$CNT;
              CALL POPSTACK;
         END;


 /* 95  BOL */
         DO;
              CURRENTLINE = ARA;
              CALL POP$STACK;
         END;

 /* 96  ADJ */
         ARA = ARA + MCD;

         END;  /* END CASE */
    CALL STEP$INS$CNT;
    END;   /* OF DO FOREVER  */



END EXECUTE;
    /*
         ********************************************************
         *                                                      *
         ********************************************************
    */

MAINLINE:
    CALL CRLF;
    CALL INITIALIZE$EXECUTE;
EOFEXIT:  /* ON END OF FILE OF CURRENT DISK FILE COME HERE */
ERROR$EXIT:  /* REGROUP ON CONSOLE INPUT ERROR */
    CALL EXECUTE;
    CALL EXIT$INTERP;
END;