home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / SIMTEL / CPMUG / CPMUG030.ARK / RUN.PLM < prev   
Text File  |  1984-04-29  |  68KB  |  2,293 lines
  1. BASINT:
  2. DO; /* ORIGINALLY ORG'ED AT 0C00H ABOVE FP PACKAGE */
  3.     /*
  4.          ********************************************************
  5.          *                                                      *
  6.          *                 BASIC-E INTERPRETER                  *
  7.          *                                                      *
  8.          *            U. S. NAVY POSTGRADUATE SCHOOL            *
  9.          *                 MONTEREY, CALIFORNIA                 *
  10.          *                                                      *
  11.          *            WRITTEN BY GORDON EUBANKS, JR.            *
  12.          *                                                      *
  13.          *                   CPM VERSION 2.0                    *
  14.          *                       MAY 1977                       *
  15.          *                                                      *
  16.          ********************************************************
  17.     */
  18.  
  19.     /*
  20.          ********************************************************
  21.          *                                                      *
  22.          *     THE BASIC-E INTERPRETER IS PASSED CONTROL        *
  23.          *      FROM THE BUILD PROGRAM.  THE FDA, CODE AND      *
  24.          *      DATA AREA ARE MOVED DOWN TO RESIDE AT THE       *
  25.          *      .MEMORY FOR THIS PROGRAM, AND THEN THE STACK    *
  26.          *      PRT AND MACHINE REGISTERS ARE INITIALIZED       *
  27.          *      THE INTERPRETER THEN EXECUTES THE BASIC-E       *
  28.          *      MACHINE CODE.                                   *
  29.          *                                                      *
  30.          ********************************************************
  31.     */
  32.  
  33.     /*
  34.          ********************************************************
  35.          *                                                      *
  36.          *                   GLOBAL LITERALS                    *
  37.          *                                                      *
  38.          ********************************************************
  39.     */
  40. DECLARE
  41.          LIT       LITERALLY 'LITERALLY',
  42.          FOREVER   LIT       'WHILE TRUE',
  43.          TRUE      LIT       '1',
  44.          FALSE     LIT       '0',
  45.          LF        LIT       '10',
  46.          CR        LIT       '13',
  47.          NULLCHAR  LIT       '0H',
  48.          CONTZ     LIT       '1AH',
  49.          QUOTE     LIT       '22H',
  50.          WHAT      LIT       '63';               /*QUESTION MARK*/
  51.  
  52.     /*
  53.          ********************************************************
  54.          *                                                      *
  55.          *               EXTERNAL ENTRY POINTS                  *
  56.          *     THESE ENTRY POINTS ASSUME THE USE OF CP/M        *
  57.          *                                                      *
  58.          ********************************************************
  59.     */
  60. DECLARE
  61.          SYSBEGIN     ADDRESS  INITIAL(6H),
  62.          PARAM1       ADDRESS PUBLIC,     /* SET BY BUILD PROGRAM */
  63.          PARAM2       ADDRESS PUBLIC,
  64.          PARAM3       ADDRESS PUBLIC,
  65.          PARAM4       ADDRESS PUBLIC,
  66.          OFFSET       ADDRESS PUBLIC,     /* AMOUNT TO MOVE IMAGE DOWN */
  67.          SEED         ADDRESS  EXTERNAL,   /* SEED FOR RAND GENERATOR */
  68.          BEGIN        ADDRESS EXTERNAL,   /* START OF BUILD MODULE */
  69.          OVERFLOW     LITERALLY 'OVER',
  70.          OVER         ADDRESS  EXTERNAL;
  71.  
  72.     /*
  73.          ********************************************************
  74.          *                                                      *
  75.          *            SYSTEM PARAMETERS WHICH MAY               *
  76.          *            REQUIRE MODIFICATION BY USERS             *
  77.          *                                                      *
  78.          ********************************************************
  79.     */
  80. DECLARE
  81.          EOLCHAR       LIT       '0DH',
  82.          EOFFILLER     LIT       '1AH',
  83.          INTRECSIZE    LIT       '128',
  84.          DISKRECSIZE   LIT       '128',
  85.          STRINGDELIM   LIT       '22H',
  86.          CONBUFFSIZE   LIT        '80',
  87.          NUMFILES      LIT         '20',  /* MAX NUMBER USER FILES */
  88.          NRSTACK       LIT        '96';  /* STACK SIZE TIMES 4 */
  89.  
  90.     /*
  91.          ********************************************************
  92.          *                                                      *
  93.          *                   GLOBAL VARIABLES                   *
  94.          *                                                      *
  95.          ********************************************************
  96.     */
  97.  
  98. DECLARE
  99.          RA        ADDRESS,  /* ADDRESS OF REG A */
  100.          RB        ADDRESS,  /* ADDRESS OF REG B */
  101.          RC        ADDRESS,  /* ADDRESS OF REGISTER C */
  102.          C         BASED     RC BYTE, /* BYTE OF CODE */
  103.          CV        BASED     RC(2) BYTE, /* VERSION OF C WITH SUBSCRIPT */
  104.          TWOBYTEOPRAND BASED RC ADDRESS,  /* TWO BYTES CODE */
  105.          SB        ADDRESS,  /* BOTTOM OF STACK */
  106.          ST        ADDRESS, /* TOP OF STACK */
  107.          BRA       BASED     RA(4)     BYTE,
  108.          BRAZ      BASED     RA        BYTE,
  109.          ARA       BASED     RA        ADDRESS,
  110.          ARB       BASED     RB        ADDRESS,
  111.          BRB       BASED     RB(4)     BYTE,
  112.          BRBZ      BASED     RB        BYTE,
  113.          MPR       ADDRESS,  /* BASE ADDRESS OF PRT */
  114.          MDA       ADDRESS,  /* BASE OF DATA AREA */
  115.          MCD       ADDRESS,  /* BASE OF CODE AREA */
  116.          LOCALSEED ADDRESS,  /* USED TO SET SEED */
  117.          CURRENTLINE ADDRESS INITIAL(0),  /* SOURCE LINE BEING EXEC */
  118.          DATAAREAPTR ADDRESS,  /* CURRENT LOCATION IN DATA AREA */
  119.          MBASE     ADDRESS;  /* BEGINNING OF FREE STORAGE AREA */
  120.  
  121. DECLARE
  122.          INPUTBUFFER       BYTE INITIAL(CONBUFFSIZE), /* USED WITH SPACE */
  123.          SPACE(CONBUFFSIZE) BYTE,  /* INPUT BUFFER FOR CON AND DISK */
  124.          INPUTINDEX        BYTE,
  125.          CONBUFFPTR        ADDRESS,
  126.          INPUTPTR          ADDRESS,
  127.          PRINTBUFFLENGTH   LIT       '132',
  128.          PRINTBUFFERLOC    LIT      '80H',
  129.          TABPOS1           LIT      '142', /* ABSOLUTE ADDR REL TO */
  130.          TABPOS2           LIT      '156', /*   PRINTBUFFLOC  */
  131.          TABPOS3           LIT      '170',
  132.          TABPOS4           LIT      '184',
  133.          PRINTBUFFER       ADDRESS  INITIAL(PRINTBUFFERLOC),
  134.          PRINTPOS          BASED    PRINTBUFFER   BYTE,
  135.          PRINTBUFFEND      LIT      '0103H', /* ABSOLUTE ADDRESS */
  136.          PRINTWORKAREA(14) BYTE,  /* FOR CONV FROM FP TO ASCII */
  137.          REREADADDR        ADDRESS,  /* TO RECOVER FROM READ ERROR */
  138.          INPUTTYPE         BYTE;
  139.  
  140. DECLARE
  141.          FILEADDR            ADDRESS, /*CURRENT FCB POINTER BASE */
  142.          FCB                 BASED     FILEADDR(33)  BYTE,
  143.          FCBADD              BASED     FILEADDR(33)  ADDRESS,
  144.          EOFADDR             ADDRESS,
  145.          FILES(NUMFILES)     ADDRESS,  /*POINTER ARRAY TO FCBS */
  146.          EOFBRANCH(NUMFILES) ADDRESS,
  147.          BUFFER$END          ADDRESS,
  148.          RECORD$POINTER      ADDRESS,
  149.          BUFFER              ADDRESS,
  150.          NEXTDISKCHAR        BASED     RECORD$POINTER BYTE,
  151.          BLOCKSIZE           ADDRESS,
  152.          BYTES$WRITTEN       ADDRESS,
  153.          FIRSTFIELD          BYTE,
  154.          EOFRA               ADDRESS,
  155.          EOFRB               ADDRESS;
  156.  
  157. DECLARE
  158.          DECIMAL(4) ADDRESS DATA(1000,100,10,1),
  159.          ONEHALF(4) BYTE DATA(80H,0,0,0),
  160.          PLUSONE(4)  BYTE DATA(81H,0,0,0),
  161.          MINUSONE(4) BYTE DATA(81H,80H,0,0),
  162.          MAXNUM(4) BYTE DATA(0FFH,07FH,0FFH,0FFH),
  163.          MAXPOSNUM BYTE DATA (4),
  164.          POSITION(9) ADDRESS DATA(TABPOS1,TABPOS2,TABPOS3,TABPOS4,
  165.                PRINTBUFFEND),
  166.          SCALE(4) BYTE DATA(90H,7FH,0FFH,0);
  167.  
  168.  
  169.     /*
  170.          ********************************************************
  171.          *                                                      *
  172.          *       SYSTEM DEPENDENT ROUTINES AND VARIABLES        *
  173.          *           THE FOLLOWING ROUTINES ARE USED            *
  174.          *           BY THE INTERPRETER TO ACCESS DISK          *
  175.          *           FILES AND FOR CONSOLE I/O.                 *
  176.          *           THE ROUTINES ASSUME THE USE OF THE         *
  177.          *           CP/M OPERATING SYSTEM.                     *
  178.          *                                                      *
  179.          ********************************************************
  180.     */
  181.  
  182.  
  183. MON1: PROCEDURE(FUNC,PARM) EXTERNAL;
  184.     DECLARE FUNC BYTE,
  185.     PARM ADDRESS;
  186. END MON1;
  187.  
  188. MON2: PROCEDURE(FUNC,PARM) BYTE EXTERNAL;
  189.     DECLARE FUNC BYTE,
  190.     PARM ADDRESS;
  191. END MON2;
  192.  
  193. MON3: PROCEDURE EXTERNAL;
  194.     /* REBOOT SYSTEM */
  195. END MON3;
  196.  
  197. MOVEA: PROCEDURE(A) EXTERNAL;
  198.     DECLARE A ADDRESS;
  199.     END MOVEA;
  200.  
  201. MOVE4: PROCEDURE(S,D) EXTERNAL;
  202.     DECLARE (S,D) ADDRESS;
  203.     END MOVE4;
  204.  
  205. PRINTCHAR: PROCEDURE(CHAR) PUBLIC;
  206.     DECLARE CHAR BYTE;
  207.     CALL MON1(2,CHAR);
  208. END PRINTCHAR;
  209.  
  210.  
  211. CRLF: PROCEDURE;
  212.     CALL PRINTCHAR(CR);
  213.     CALL PRINTCHAR(LF);
  214. END CRLF;
  215.  
  216.  
  217.  
  218.  
  219. READ: PROCEDURE(A);
  220.     DECLARE A ADDRESS;
  221.     /*
  222.        FIRST WAIT FOR FIRST CHAR AND SET LOCALSEED
  223.        SO IT CAN BE USED TO SEED RANDOM NUMBER GENERATOR
  224.     */
  225.     DO WHILE NOT MON2(11,0);
  226.          LOCALSEED = LOCALSEED + 1;
  227.          END;
  228.     /* READ INTO BUFFER AT A+2 */
  229.     CALL MON1(10,A);
  230. END READ;
  231.  
  232.  
  233. OPEN: PROCEDURE BYTE;
  234.     RETURN MON2(15,FILEADDR);
  235. END OPEN;
  236.  
  237.  
  238. CLOSE: PROCEDURE BYTE;
  239.     RETURN MON2(16,FILEADDR);
  240. END CLOSE;
  241.  
  242.  
  243. DISKREAD: PROCEDURE BYTE;
  244.     RETURN MON2(20,FILEADDR);
  245. END DISKREAD;
  246.  
  247.  
  248. DISKWRITE: PROCEDURE BYTE;
  249.     RETURN MON2(21,FILEADDR);
  250. END DISKWRITE;
  251.  
  252.  
  253. CREATE: PROCEDURE BYTE;
  254.       RETURN MON2(22,FILEADDR);
  255. END CREATE;
  256.  
  257. MAKE: PROCEDURE BYTE;
  258.     CALL MON1(19,FILEADDR);
  259.     RETURN CREATE;
  260. END MAKE;
  261.  
  262.  
  263. SETDMA: PROCEDURE;  /* SET DMA ADDRESS FOR DISK I/O */
  264.     CALL MON1(26,BUFFER);
  265. END SETDMA;
  266.  
  267.  
  268. PRINT: PROCEDURE(LOCATION) PUBLIC;
  269.     DECLARE LOCATION ADDRESS;
  270.     /* PRINT THE STRING STARTING AT ADDRESS LOCATION UNTIL THE
  271.     NEXT DOLLAR SIGN IS ENCOUNTERED */
  272.     CALL MON1(9,LOCATION);
  273. END PRINT;
  274.  
  275.  
  276.     /*
  277.          ********************************************************
  278.          *                                                      *
  279.          *        GENERAL PURPOSE INTERPRETER ROUTINES          *
  280.          *                                                      *
  281.          ********************************************************
  282.     */
  283. TIMES4: PROCEDURE(N) ADDRESS;
  284.     DECLARE N ADDRESS;
  285.     RETURN SHL(N,2);
  286. END TIMES4;
  287.  
  288. PRINT$DEC: PROCEDURE(VALUE);
  289.     DECLARE VALUE ADDRESS,
  290.             I BYTE,
  291.             COUNT BYTE;
  292.     DO I = 0 TO 3;
  293.          COUNT = 30H;
  294.          DO WHILE VALUE >= DECIMAL(I);
  295.               VALUE = VALUE - DECIMAL(I);
  296.               COUNT = COUNT + 1;
  297.               END;
  298.          CALL PRINTCHAR(COUNT);
  299.     END;
  300. END PRINT$DEC;
  301.  
  302.  
  303. MOVE: PROCEDURE(SOURCE,DEST,N);
  304.  
  305.     /*MOVE N BYTES FROM SOURCE TO DEST */
  306.     DECLARE (SOURCE,DEST,N) ADDRESS;
  307.     CALL MOVEA(.SOURCE);
  308. END MOVE;
  309.  
  310. FILL: PROCEDURE(DEST,CHAR,N);
  311.     /*FILL LOCATIONS STARTING AT DEST WITH CHAR FOR N BYTES */
  312.     DECLARE
  313.             DEST   ADDRESS,
  314.             N      ADDRESS,
  315.             D      BASED    DEST   BYTE,
  316.             CHAR   BYTE;
  317.     DO WHILE (N:=N-1) <> 0FFFFH;
  318.          D = CHAR;
  319.          DEST = DEST + 1;
  320.     END;
  321. END FILL;
  322.  
  323.  
  324.  
  325. OUTPUT$MSG: PROCEDURE(MSG);
  326.     DECLARE MSG ADDRESS;
  327.     CALL PRINT$CHAR(HIGH(MSG));
  328.     CALL PRINT$CHAR(LOW(MSG));
  329.     IF CURRENTLINE > 0 THEN
  330.          DO;
  331.               CALL PRINT(.(' IN LINE $'));
  332.          CALL PRINT$DEC(CURRENTLINE);
  333.          END;
  334.     CALL CRLF;
  335. END OUTPUT$MSG;
  336.  
  337.  
  338. ERROR: PROCEDURE(E);
  339.     DECLARE E ADDRESS;
  340.     CALL CRLF;
  341.     CALL PRINT(.('ERROR $'));
  342.     CALL OUTPUTMSG(E);
  343.     CALL MON3;
  344. END ERROR;
  345.  
  346.  
  347. WARNING: PROCEDURE(W);
  348.     DECLARE W ADDRESS;
  349.     CALL CRLF;
  350.     CALL PRINT(.('WARNING $'));
  351.     CALL OUTPUTMSG(W);
  352.     RETURN;
  353. END WARNING;
  354.  
  355.  
  356.     /*
  357.          ********************************************************
  358.          *                                                      *
  359.          *            STACK MANIPULATION ROUTINES               *
  360.          *                                                      *
  361.          ********************************************************
  362.     */
  363.  
  364. STEP$INS$CNT: PROCEDURE;
  365.     RC=RC+1;
  366. END STEP$INS$CNT;
  367.  
  368. POP$STACK: PROCEDURE;
  369.     RA = RB;
  370.     IF(RB := RB - 4) < SB THEN
  371.          RB = ST - 4;
  372. END POP$STACK;
  373.  
  374. PUSH$STACK: PROCEDURE;
  375.     RB = RA;
  376.     IF(RA := RA + 4) >= ST THEN
  377.          RA = SB;
  378. END PUSH$STACK;
  379.  
  380.  
  381. IN$FSA: PROCEDURE(LOCATION) BYTE;
  382.      /*
  383.           RETURNS TRUE IF LOCATION IS IN FSA
  384.      */
  385.     DECLARE LOCATION ADDRESS;
  386.     RETURN LOCATION > ST;
  387. END IN$FSA;
  388.  
  389.  
  390. SET$DATA$ADDR: PROCEDURE(PTR);
  391.     DECLARE PTR ADDRESS, A BASED PTR ADDRESS;
  392.     IF NOT IN$FSA(A) THEN
  393.          A = MPR + TIMES4(A);
  394. END SET$DATA$ADDR;
  395.  
  396.  
  397. MOVE$RA$RB: PROCEDURE;
  398.     CALL MOVE4(RA,RB);
  399. END MOVE$RA$RB;
  400.  
  401.  
  402. MOVE$RB$RA:  PROCEDURE;
  403.     CALL MOVE4(RB,RA);
  404.          END MOVERBRA;
  405.  
  406.  
  407. FLIP: PROCEDURE;
  408.     DECLARE TEMP(4) BYTE;
  409.     CALL MOVE4(RA,.TEMP);
  410.     CALL MOVE$RB$RA;
  411.     CALL MOVE4(.TEMP,RB);
  412.          END FLIP;
  413.  
  414.  
  415. LOAD$RA: PROCEDURE;
  416.     CALL SET$DATA$ADDR(RA);
  417.     CALL MOVE4(ARA,RA);
  418.     END LOADRA;
  419.  
  420. RA$ZERO: PROCEDURE BYTE;
  421.     RETURN BRAZ = 0;
  422. END RA$ZERO;
  423.  
  424.  
  425. RB$ZERO: PROCEDURE BYTE;
  426.     RETURN BRBZ = 0;
  427. END RB$ZERO;
  428.  
  429.  
  430. RA$ZERO$ADDRESS: PROCEDURE BYTE;
  431.     RETURN ARA = 0;
  432. END RA$ZERO$ADDRESS;
  433.  
  434.  
  435. RB$ZERO$ADDRESS: PROCEDURE BYTE;
  436.     RETURN ARB = 0;
  437. END RB$ZERO$ADDRESS;
  438.  
  439.  
  440. RA$NEGATIVE: PROCEDURE BYTE;
  441.     RETURN ROL(BRA(1),1);
  442. END RA$NEGATIVE;
  443.  
  444.  
  445. RB$NEGATIVE: PROCEDURE BYTE;
  446.     RETURN ROL(BRB(1),1);
  447. END RB$NEGATIVE;
  448.  
  449.  
  450. FLAG$STRING$ADDR: PROCEDURE(X);
  451.     DECLARE X BYTE;
  452.     BRA(2) = X;
  453. END FLAG$STRING$ADDR;
  454.  
  455.  
  456.     /*
  457.          ********************************************************
  458.          *                                                      *
  459.          *           FLOATING POINT INTERFACE ROUTINES          *
  460.          *                                                      *
  461.          *       ALL FLOATING POINT OPERATIONS ARE PERFORMED    *
  462.          *       BY CALLING ROUTINES IN THIS SECTION.  THE      *
  463.          *       FLOATING POINT PACKAGE IS ACCESSED BY THE      *
  464.          *       FOLLOWING SIX ROUTINES:                        *
  465.          *           (1)  CONV$TO$BINARY                        *
  466.          *           (2)  CONV$TO$FP                            *
  467.          *           (3)  FP$INPUT                              *
  468.          *           (4)  FP$OUT                                *
  469.          *           (5)  FP$OP$RETURN                          *
  470.          *           (6)  FP$OP                                 *
  471.          *       CHECK$OVERFLOW DOES JUST THAT!!                *
  472.          *       THE REMAINING ROUTINES USE THE ABOVE           *
  473.          *       PROCEDURES TO ACCOMPLISH COMMON ROUTINES       *
  474.          *                                                      *
  475.          *       CONV$TO$BIN$ADDR AND OTHER ROUTINES WHICH      *
  476.          *       REFER TO AN ADDRESS PLACE THE RESULTS IN       *
  477.          *       THE FIRST TWO BYTES OF THE STACK AS AN 8080    *
  478.          *       ADDRESS QUANTITY WITH LOW ORDER BYTE FIRST     *
  479.          *                                                      *
  480.          *                                                      *
  481.          *                                                      *
  482.          ********************************************************
  483.     */
  484.  
  485. DECLARE
  486.          FINIT     LIT       '0',                /* INITIALIZE*/
  487.          FSTR      LIT       '1',                /* STORE (ACCUM)*/
  488.          FLOD      LIT       '2',                /* LOAD ACCUM */
  489.          FADD      LIT       '3',                /* ADD TO ACCUM */
  490.          FSUB      LIT       '4',                /* SUB FROM ACCUM*/
  491.          FMUL      LIT       '5',                /* MUL BY ACCUM*/
  492.          FDIV      LIT       '6',                /* DIVIDE INTO ACCUM*/
  493.          FABS      LIT       '7',                /* ABS VALUE OF ACCUM*/
  494.          FZRO      LIT       '8',                /* ZERO ACCUM*/
  495.          FTST      LIT       '9',                /* TEST SIGN OF ACCUM*/
  496.          FCHS      LIT       '10',               /* COMPL. ACCUM*/
  497.          SQRT      LIT       '11',               /* SQRT OF ACCUM*/
  498.          COS       LIT       '12',               /* COS ACCUM*/
  499.          SIN       LIT       '13',               /* SIN ACCUM*/
  500.          ATAN      LIT       '14',               /* ARCTAN ACCUM */
  501.          COSH      LIT       '15',               /* COSH ACCUM*/
  502.          SINH      LIT       '16',               /* SINH ACCUM*/
  503.          EXP       LIT       '17',               /* EXPONENTIAL ACCUM*/
  504.          LOG       LIT       '18';               /* LOG ACCUM*/
  505.  
  506. DECLARE /* EXTERNAL NAMES FOR SUBROUTINES */
  507.          CONV$TO$BINARY LIT 'CBIN',
  508.          CONV$TO$FP     LIT 'CFLT',
  509.          FP$INPUT       LIT 'FLTINP',
  510.          FP$OUT         LIT 'FLTOUT',
  511.          FP$OP$RETURN   LIT 'FLTRET',
  512.          FP$OP          LIT 'FLTOP';
  513.  
  514. CHECK$OVERFLOW: PROCEDURE;
  515.     IF OVERFLOW THEN
  516.          DO;
  517.               CALL WARNING('OF');
  518.               CALL MOVE4(.MAXNUM,RA);
  519.               OVERFLOW = 0;
  520.          END;
  521. END CHECK$OVERFLOW;
  522.  
  523.  
  524. CONV$TO$BINARY: PROCEDURE(A) EXTERNAL;  /*CONVERTS FP NUM AT A TO BINARY
  525.          AND RETURNS RESULT TO A  */
  526.     DECLARE A ADDRESS;
  527. END CONV$TO$BINARY;
  528.  
  529. CONV$TO$FP: PROCEDURE(A) EXTERNAL;  /* CONVERTS BINARY NUM AT A TO FP AND
  530.          LEAVES IT AT A  */
  531.     DECLARE A ADDRESS;
  532. END CONV$TO$FP;
  533.  
  534. FP$INPUT: PROCEDURE(LENGTH,A) EXTERNAL;  /* CONVERTS STRING AT A LENGTH LENGTH
  535.          TO FP AND LEAVES RESULT IN FP ACCUM   */
  536.     DECLARE LENGTH BYTE, A ADDRESS;
  537. END FP$INPUT;
  538.  
  539.  
  540. FP$OUT: PROCEDURE(A) EXTERNAL;  /* CONVERTS FP ACCUM TO STRING AND PUTS IT
  541.          AT A  */
  542.     DECLARE A ADDRESS;
  543. END FP$OUT;
  544.  
  545.  
  546. FP$OP$RETURN: PROCEDURE(FUNC,A) EXTERNAL; /* PERFORMS FUNC AND RETURNS VALUE
  547.          TO A  */
  548.     DECLARE FUNC BYTE, A ADDRESS;
  549. END FP$OP$RETURN;
  550.  
  551.  
  552. FP$OP: PROCEDURE(FUNC,A) EXTERNAL;  /* PERFORMS FUNC POSSIBLY USEING
  553.          FP NUM ADDRESSED BY A . NOTHING IS RETURNED TO A */
  554.     DECLARE FUNC BYTE, A ADDRESS;
  555. END FP$OP;
  556.  
  557. CONV$TO$BIN$ADDR: PROCEDURE;
  558.     CALL CONV$TO$BINARY(RA);
  559.     BRA(0) = BRA(3);
  560.     BRA(1) = BRA(2);
  561. END CONV$TO$BIN$ADDR;
  562.  
  563. INPUT: PROCEDURE(PORT) BYTE EXTERNAL;
  564.     DECLARE PORT BYTE;
  565.     END INPUT;
  566.  
  567. OUTPUT: PROCEDURE(PORT,VALUE) EXTERNAL;
  568.     DECLARE (PORT,VALUE) BYTE;
  569.     END OUTPUT;
  570.  
  571. RANDOM: PROCEDURE EXTERNAL;
  572.     END RANDOM;
  573.  
  574.  
  575. ONE$VALUE$OPS: PROCEDURE(A);
  576.          DECLARE A BYTE;
  577.          CALL FP$OP(FLOD,RA);
  578.          CALL FP$OP$RETURN(A,RA);
  579.     CALL CHECK$OVERFLOW;
  580. END ONE$VALUE$OPS;
  581.  
  582. TWO$VALUE$OPS: PROCEDURE(TYPE);
  583.     DECLARE TYPE BYTE;
  584.          CALL FP$OP(FLOD,RA);
  585.          CALL FP$OP$RETURN(TYPE,RB);
  586.     CALL POP$STACK;
  587.     CALL CHECK$OVERFLOW;
  588. END TWO$VALUE$OPS;
  589.  
  590. ROUND$CONV$BIN: PROCEDURE;
  591.     CALL PUSH$STACK;
  592.     CALL MOVE4(.ONEHALF,RA);
  593.     CALL TWO$VALUE$OPS(FADD);
  594.     CALL CONV$TO$BIN$ADDR;
  595. END ROUND$CONV$BIN;
  596.  
  597. FLOAT$ADDR: PROCEDURE(V);
  598.     DECLARE V ADDRESS;
  599.     ARA=0;
  600.     BRA(2)=HIGH(V); BRA(3)=LOW(V);
  601.     CALL CONV$TO$FP(RA);
  602. END FLOAT$ADDR;
  603.  
  604. COMPARE$FP: PROCEDURE BYTE;
  605.    /* 1=LESS 2=GREATER 3=EQUAL  */
  606.          CALL FP$OP(FLOD,RB);
  607.          CALL FP$OP$RETURN(FSUB,RA);
  608.          IF RA$ZERO THEN
  609.                 DO;
  610.                      CALL POP$STACK;
  611.                      RETURN 3;
  612.                 END;
  613.          IF RA$NEGATIVE THEN
  614.               DO;
  615.                     CALL POP$STACK;
  616.                     RETURN 1;
  617.               END;
  618.          CALL POP$STACK;
  619.          RETURN 2;
  620. END COMPARE$FP;
  621.  
  622.  
  623.     /*
  624.          ********************************************************
  625.          *                                                      *
  626.          *         DYNAMIC STORAGE ALLOCATION PROCEDURES        *
  627.          *                                                      *
  628.          ********************************************************
  629.     */
  630. AVAILABLE: PROCEDURE(NBYTES) ADDRESS;
  631.     DECLARE
  632.             NBYTES   ADDRESS,
  633.             POINT    ADDRESS,
  634.             TEMP     ADDRESS,
  635.             TOTAL    ADDRESS,
  636.             HERE     BASED POINT   ADDRESS,
  637.             SWITCH   BASED POINT(5)   BYTE;
  638.     POINT = MBASE;
  639.     TOTAL = 0;
  640.     DO WHILE POINT <> 0;
  641.          IF SWITCH(4) = 0 THEN
  642.            DO;
  643.               TOTAL = TOTAL + (TEMP := HERE - POINT - 5);
  644.               IF NBYTES <> 0 THEN
  645.                 DO;
  646.                    IF NBYTES + 5 <= TEMP THEN
  647.                         RETURN POINT;
  648.                 END;
  649.            END;
  650.            POINT = HERE;
  651.     END;
  652.     IF NBYTES <> 0 THEN
  653.          CALL ERROR('NM');
  654.     RETURN TOTAL;
  655. END AVAILABLE;
  656.  
  657. GETSPACE: PROCEDURE(NBYTES) ADDRESS;
  658.     DECLARE
  659.             NBYTES  ADDRESS,
  660.             SPACE   ADDRESS,
  661.             POINT   ADDRESS,
  662.             HERE    BASED POINT   ADDRESS,
  663.             TEMP    ADDRESS,
  664.             TEMP1   ADDRESS,
  665.             TEMP2   ADDRESS,
  666.             ADR1    BASED TEMP1   ADDRESS,
  667.             ADR2    BASED TEMP2   ADDRESS,
  668.             SWITCH  BASED POINT(5)   BYTE,
  669.             SWITCH2 BASED TEMP1(5)   BYTE;
  670.     IF NBYTES = 0 THEN
  671.          RETURN 0;
  672.     POINT = AVAILABLE(NBYTES);
  673.     /*LINK UP THE SPACE*/
  674.     SWITCH(4)=1;  /* SET SWITCH ON*/
  675.         TEMP1=POINT+NBYTES+5;
  676.          ADR1=HERE;
  677.          TEMP2=HERE + 2;
  678.         HERE,ADR2 = TEMP1;
  679.         SWITCH2(4)=0; /*SET REMAINDER AS AVAIL*/
  680.        TEMP1 = TEMP1 + 2;
  681.        ADR1 = POINT;
  682.     CALL FILL(POINT := POINT + 5,0,NBYTES);
  683.     RETURN POINT;
  684. END GETSPACE;
  685.  
  686. RELEASE: PROCEDURE(SPACE);
  687.     DECLARE
  688.             SPACE      ADDRESS,
  689.             HOLD       ADDRESS,
  690.             NEXT$AREA  BASED     HOLD    ADDRESS,
  691.             SWITCH     BASED     SPACE(5)   BYTE,
  692.             HERE       BASED     SPACE   ADDRESS,
  693.             TEMP       ADDRESS,
  694.             ADRS       BASED     TEMP    ADDRESS,
  695.             LOOK       BASED     TEMP(5)    BYTE;
  696.  
  697.     UNLINK: PROCEDURE;
  698.         TEMP=HERE;
  699.         IF ADRS<>0 THEN      /*NOT AT TOP OF FSA */
  700.          DO;
  701.             IF LOOK(4)=0 THEN   /*SPACE ABOVE IS FREE*/
  702.               DO;
  703.                    TEMP=(HERE:=ADRS) + 2;
  704.                    ADRS=SPACE;
  705.               END;
  706.          END;
  707.     END UNLINK;
  708.  
  709.     HOLD,SPACE=SPACE-5;
  710.     SWITCH(4)=0;    /* RELEASES THE SPACE */
  711.     /* COMBINE WITH SPACE ABOVE AND BELOW IF POSSIBLE*/
  712.     CALL UNLINK;
  713.     SPACE=SPACE+2;  /* LOOK AT PREVIOUS BLOCK*/
  714.     IF (SPACE:=HERE)<>0 THEN
  715.     DO;
  716.         IF SWITCH(4)=0 THEN
  717.         DO;
  718.             CALL UNLINK;
  719.            HOLD=SPACE;
  720.         END;
  721.     END;
  722. END RELEASE;
  723.  
  724.     /*
  725.          ********************************************************
  726.          *                                                      *
  727.          *            ARRAY ADDRESSING PROCEDURES               *
  728.          *                                                      *
  729.          *     CALC$ROW SETS UP AN ARRAY IN THE FSA IN ROW      *
  730.          *     MAJOR ORDER.  THE BYTE OF CODE FOLLOWING THE     *
  731.          *     OPERATOR IS THE NUMBER OF DIMENSIONS.  THE       *
  732.          *     STACK CONTAINS THE UPPER BOUND OF EACH DIMENSION *
  733.          *     RA HOLDS DIMENSION N, RB DIMENSION N-1 ETC.      *
  734.          *     THE LOWER BOUND IS ALWAYS ZERO.                  *
  735.          *                                                      *
  736.          *     CALC$SUB PERFORMS A SUBSCRIPT CALCULATION FOR    *
  737.          *     THE ARRAY REFERENCED BY RA.  THE VALUE OF EACH   *
  738.          *     DIMENSION IS ON THE STACK BELOW THE ARRAY        *
  739.          *     ADDRESS STARTING WITH THE NTH DIMENSION          *
  740.          *     A CHECK IS MADE TO SEE IF THE SELECTED ELEMENT   *
  741.          *     IS OUTSIDE THE AREA ASIGNED TO THE ARRAY         *
  742.          *                                                      *
  743.          ********************************************************
  744.     */
  745.  
  746. CALC$ROW: PROCEDURE;
  747.     DECLARE
  748.             ASIZE       ADDRESS,
  749.             I           BYTE,
  750.             SAVERA      ADDRESS,
  751.             SAVERB      ADDRESS,
  752.             ARRAYADDR   ADDRESS,
  753.             NUMDIM      BASED RC BYTE,
  754.             ARRAYPOS    BASED ARRAYADDR ADDRESS;
  755.  
  756.     ASIZE = 1;  /* INITIAL VALUE */
  757.     CALL STEP$INS$CNT;  /* POINT RC TO NUMDIM */
  758.     SAVERA = RA;  /* SAVE CURRENT STACK POINTER */
  759.     SAVERB = RB;
  760.     DO I = 1 TO NUMDIM; /* FIRST PASS ON ARRAY DIMENSIONS */
  761.          ARA,ASIZE = ASIZE * (ARA + 1); /* DISPLACEMENT AND TOTAL */
  762.          CALL POP$STACK;  /* NEXT DIMENSION */
  763.          END;
  764.     RA = SAVERA;  /* BACK TO ORIGINAL STACK POSITION */
  765.     RB = SAVERB;
  766.     SAVERA,ARRAYADDR = GETSPACE(TIMES4(ASIZE) + SHL(NUMDIM+1,1));
  767.     ARRAYPOS = NUMDIM;  /* STORE NUMBER OF DIM */
  768.     DO I = 1 TO NUMDIM;  /* STORE DISPLACEMENTS */
  769.          ARRAYADDR = ARRAYADDR + 2;
  770.          ARRAYPOS = ARA;
  771.          CALL POP$STACK;
  772.          END;
  773.     CALL PUSH$STACK;  /* NOW PUT ADDRESS OF ARRAY ON STACK */
  774.     ARA = SAVERA;
  775. END CALC$ROW;
  776.  
  777.  
  778. CALC$SUB: PROCEDURE;
  779.     DECLARE
  780.             ARRAYADDR ADDRESS,
  781.             ARRAYPOS  BASED ARRAYADDR ADDRESS,
  782.             I         BYTE,
  783.             NUMDIM    BYTE,
  784.             LOCATION  ADDRESS;
  785.  
  786.     INC$ARRAYADDR: PROCEDURE;
  787.          ARRAYADDR = ARRAYADDR + 1 + 1;
  788.     END INC$ARRAYADDR;
  789.  
  790.     ARRAYADDR = ARA;
  791.     CALL POP$STACK;
  792.     LOCATION = ARA;
  793.     NUMDIM = ARRAYPOS;
  794.     DO I = 2 TO NUMDIM;
  795.          CALL POP$STACK;
  796.          CALL INC$ARRAYADDR;
  797.          LOCATION = ARA * ARRAYPOS + LOCATION;
  798.          END;
  799.     CALL INC$ARRAYADDR;
  800.     IF LOCATION >= ARRAYPOS THEN
  801.          CALL ERROR('SB');
  802.     ARA = ARRAYADDR + 2 + TIMES4(LOCATION);
  803. END CALC$SUB;
  804.     /*
  805.          ********************************************************
  806.          *                                                      *
  807.          *     STORE PLACES RA IN THE PRT LOCATION REFERENCED   *
  808.          *     BY RB.  RA MAY CONTAIN A FLOATING POINT NUMBER   *
  809.          *     OR A REFERENCE TO A STRING.                      *
  810.          *     IN THE CASE OF A STRING THE FOLLOWING IS ALSO    *
  811.          *     PERFORMED:                                       *
  812.          *         (1)  IF THE PRT CELL ALREADY CONTAINS A      *
  813.          *         REFERENCE TO A STRING IN THE FSA THAT        *
  814.          *         STRING'S COUNTER IS DECREMENTED AND IF       *
  815.          *         EQUAL TO 1 THEN THE SPACE IS FREED           *
  816.          *         (2)  THE NEW STRINGS COUNTER IS INCREMENTED  *
  817.          *         IF IT IS ALREADY 255 THEN A COPY IS MADE     *
  818.          *         AND THE NEW COUNTER SET TO 2.                *
  819.          *                                                      *
  820.          ********************************************************
  821.     */
  822.  
  823. STORE: PROCEDURE(TYPE);
  824.     DECLARE
  825.             TYPE       BYTE,
  826.             PTRADDR    ADDRESS,
  827.             PTR        ADDRESS,
  828.             STRINGADDR BASED PTRADDR  ADDRESS,
  829.             COUNTER    BASED PTR      BYTE;
  830.     CALL SET$DATA$ADDR(RB);
  831.     IF TYPE THEN  /* STORE STRING */
  832.          DO;
  833.               CALL FLAG$STRING$ADDR(0);  /* SET TEMP STRING OFF */
  834.          PTRADDR = ARB;  /* CAN WE FREE STRING DESTINATION POINTED TO */
  835.               IF IN$FSA(STRINGADDR) THEN   /* IN FSA ? */
  836.                    DO;
  837.                         PTR = STRINGADDR - 1;
  838.                         IF(COUNTER := COUNTER - 1) = 1 THEN
  839.                              CALL RELEASE(STRINGADDR);
  840.                    END;
  841.               IF IN$FSA(PTR := ARA - 1) THEN   /* INC COUNTER */
  842.                    DO;
  843.                    IF COUNTER = 255 THEN  /* ALREADY POINTED TO BY
  844.                                              254 VARIABLES */
  845.                         DO;
  846.                              PTR = PTR + 1;
  847.                              CALL MOVE(PTR,ARA := GETSPACE(COUNTER + 1),
  848.                                        COUNTER + 1);
  849.                              PTR = ARA - 1;
  850.                         END;
  851.                    COUNTER = COUNTER + 1;
  852.                    END;
  853.          END;
  854.     CALL MOVE4(RA,ARB);
  855. END STORE;
  856.     /*
  857.          ********************************************************
  858.          *                                                      *
  859.          *                  BRANCHING ROUTINES                  *
  860.          *                                                      *
  861.          ********************************************************
  862.     */
  863.  
  864. UNCOND$BRANCH: PROCEDURE;
  865.     RC = RC + ARA - 1;
  866.     CALL POP$STACK;
  867. END UNCOND$BRANCH;
  868.  
  869.  
  870. COND$BRANCH: PROCEDURE;
  871.     IF RB$ZERO THEN
  872.          CALL UNCOND$BRANCH;
  873.     ELSE
  874.          CALL POP$STACK;
  875.     CALL POP$STACK;
  876. END COND$BRANCH;
  877.  
  878.  
  879. ABSOLUTE$BRANCH: PROCEDURE;
  880.     CALL STEP$INS$CNT;
  881.     RC = TWOBYTEOPRAND;
  882.     RETURN;
  883. END ABSOLUTE$BRANCH;
  884.     /*
  885.          ********************************************************
  886.          *                                                      *
  887.          *             GLOBAL STRING HANDLING ROUTINES          *
  888.          *                                                      *
  889.          ********************************************************
  890.     */
  891.  
  892. CHECK$STRING$ADDR: PROCEDURE BYTE;
  893.     RETURN BRA(2);
  894. END CHECK$STRING$ADDR;
  895.  
  896. STRING$FREE: PROCEDURE;
  897.     IF CHECK$STRING$ADDR THEN
  898.          CALL RELEASE(ARA);
  899. END STRING$FREE;
  900.  
  901.  
  902. GET$STRING$LEN: PROCEDURE(STRINGLOC) BYTE;
  903.     DECLARE
  904.             STRINGLOC     ADDRESS,
  905.             A     BASED STRINGLOC    BYTE;
  906.     IF STRINGLOC = 0 THEN
  907.          RETURN 0;
  908.     RETURN A;
  909. END GET$STRING$LEN;
  910.  
  911. COMP$FIX: PROCEDURE(FLAG);
  912.     DECLARE FLAG     BYTE;
  913.     IF FLAG THEN
  914.          CALL MOVE4(.MINUSONE,RA);
  915.     ELSE
  916.          BRAZ = 0;
  917. END COMP$FIX;
  918.  
  919.  
  920. CONCATENATE: PROCEDURE;
  921.     /*
  922.          ********************************************************
  923.          *                                                      *
  924.          *    THE STRING POINTED TO BY RA IS CONCATENATED       *
  925.          *    TO THE STRING POINTED TO BY RB AND THE POINTER    *
  926.          *    TO THE RESULT IS PLACED IN RB. THE STACK IS POPPED*
  927.          *    AND THE RESULT IS FLAGGED AS A TEMPORARY          *
  928.          *    STRING.                                           *
  929.          *                                                      *
  930.          ********************************************************
  931.     */
  932.     DECLARE FIRSTSTRINGLENGTH  BYTE,
  933.             SECONDSTRINGLENGTH BYTE,
  934.             NEWSTRINGLENGTH    BYTE,
  935.             NEWSTRINGADDRESS   ADDRESS,
  936.             LENGTH             BASED NEWSTRINGADDRESS BYTE;
  937.     CHKCARRY: PROCEDURE;
  938.         IF CARRY THEN CALL ERROR('SL');
  939.         END CHKCARRY;
  940.  
  941.     IF RA$ZERO$ADDRESS THEN  /* IT DOESNT MATTER WHAT RB IS */
  942.          DO;
  943.               CALL POP$STACK;
  944.               RETURN;
  945.          END;
  946.     IF RB$ZERO$ADDRESS THEN /* AS ABOVE BUT RESULT IS RA */
  947.          DO;
  948.               CALL MOVE$RA$RB;
  949.               CALL POP$STACK;
  950.               RETURN;
  951.          END;
  952.     FIRSTSTRINGLENGTH = GETSTRINGLEN(ARB) + 1;
  953.     CALL CHKCARRY;
  954.     SECONDSTRINGLENGTH = GETSTRINGLEN(ARA);
  955.     NEWSTRINGLENGTH = FIRSTSTRINGLENGTH + SECONDSTRINGLENGTH;
  956.     CALL CHKCARRY;
  957.     CALL MOVE(ARB,NEWSTRINGADDRESS := GETSPACE(NEWSTRINGLENGTH),
  958.               FIRSTSTRINGLENGTH);
  959.     CALL MOVE(ARA + 1,NEWSTRINGADDRESS + FIRSTSTRINGLENGTH,
  960.               SECONDSTRINGLENGTH);
  961.     CALL STRINGFREE;
  962.     CALL POPSTACK;
  963.     CALL STRINGFREE;
  964.     ARA = NEWSTRINGADDRESS;
  965.     LENGTH = NEWSTRINGLENGTH - 1;
  966.     CALL FLAG$STRING$ADDR(TRUE);
  967. END CONCATENATE;
  968.  
  969.  
  970. COMPARE$STRING: PROCEDURE BYTE;
  971.     /*
  972.          ********************************************************
  973.          *                                                      *
  974.          *    THE STRING POINTED TO BY RB IS COMPARED TO        *
  975.          *    THE STRING POINTED TO BY RA.                      *
  976.          *                 RB RELATION RA                       *
  977.          *    IF RB < RA THEN RETURN 1                          *
  978.          *    IF RB > RA THE RETURN 2                           *
  979.          *    IF RB = RA THEN RETURN 3                          *
  980.          *    TWO STRINGS ARE EQUAL IF AND ONLY IF THE TWO      *
  981.          *    STRINGS HAVE THE SAME LENGTH AND CONTAIN          *
  982.          *    IDENTICAL CHARACTERS. THE ASCII COLLATING         *
  983.          *    SEQUENCE IS USED TO DETERMINE THE RELATIONSHIP    *
  984.          *    BETWEEN EQUAL LENGTH STRINGS. IF TWO STRINGS      *
  985.          *    ARE NOT OF EQUAL LENGTH THE SHORTER IS ALWAYS     *
  986.          *    LESS THEN THE LONGER ONE. ALL NULL STRINGS ARE    *
  987.          *    EQUAL AND LESS THEN ANY OTHER STRING.             *
  988.          *                                                      *
  989.          ********************************************************
  990.     */
  991.     DECLARE FIRSTSTRING ADDRESS,
  992.             SECONDSTRING ADDRESS,
  993.             I            BYTE,
  994.             TEMPLENGTH   BYTE,
  995.             CHARSTRING1  BASED FIRSTSTRING BYTE,
  996.             CHARSTRING2  BASED SECONDSTRING BYTE;
  997.  
  998.      FIXSTACK: PROCEDURE;
  999.             CALL STRING$FREE;
  1000.             CALL POP$STACK;
  1001.             CALL STRING$FREE;
  1002.        END FIXSTACK;
  1003.  
  1004.     /* FIRST HANDLE NULL STRINGS REPRESENTED BY RA AND OR RB
  1005.     EQUAL TO ZERO */
  1006.     IF RA$ZERO$ADDRESS THEN
  1007.          SECONDSTRING= RA;
  1008.     ELSE
  1009.          SECONDSTRING = ARA;
  1010.     IF RB$ZERO$ADDRESS THEN
  1011.          FIRSTSTRING = RB;
  1012.     ELSE
  1013.          FIRSTSTRING = ARB;
  1014.     TEMPLENGTH = CHARSTRING1;
  1015.     DO I = 0 TO TEMPLENGTH;
  1016.          IF CHARSTRING1 < CHARSTRING2 THEN
  1017.               DO;
  1018.                      CALL FIXSTACK;
  1019.                      RETURN 1;
  1020.                 END;
  1021.          IF CHARSTRING1 > CHARSTRING2 THEN
  1022.             DO;
  1023.                    CALL FIXSTACK;
  1024.                    RETURN 2;
  1025.               END;
  1026.          FIRSTSTRING = FIRSTSTRING + 1;
  1027.          SECONDSTRING = SECONDSTRING + 1;
  1028.         END;
  1029.     CALL FIXSTACK;
  1030.     RETURN 3;
  1031. END COMPARE$STRING;
  1032.  
  1033. STRING$SEGMENT: PROCEDURE(TYPE);
  1034.     DECLARE /* POSSIBLE TYPES */
  1035.             LEFT  LIT '0',
  1036.             RIGHT LIT '1',
  1037.             MID   LIT '2';
  1038.  
  1039.     DECLARE
  1040.             TYPE    BYTE,
  1041.             TEMPA   ADDRESS,
  1042.             TEMPA2  ADDRESS,
  1043.             LNG     BASED TEMPA BYTE,
  1044.             TEMPB1  BYTE,
  1045.             LNG2    BYTE;
  1046.  
  1047.     INC$BRA: PROCEDURE BYTE;
  1048.          RETURN BRAZ + 1;
  1049.     END INC$BRA;
  1050.  
  1051.     TEMPB1 = 0;
  1052.     IF TYPE = MID THEN
  1053.          DO;
  1054.               CALL FLIP;
  1055.               IF RA$NEGATIVE OR RA$ZERO THEN
  1056.                    CALL ERROR('SS');
  1057.               CALL CONV$TO$BIN$ADDR;
  1058.               TEMPB1 = BRAZ;
  1059.               CALL POP$STACK;
  1060.          END;
  1061.      IF RA$NEGATIVE OR (TEMPB1 > GETSTRING$LEN(ARB)) OR RA$ZERO THEN
  1062.          DO;
  1063.               CALL POP$STACK;
  1064.               CALL STRINGFREE;
  1065.               ARA = 0;
  1066.               RETURN;
  1067.          END;
  1068.     CALL CONV$TO$BIN$ADDR;
  1069.     IF BRAZ > (LNG2 := GETSTRING$LEN(ARB) - TEMPB1) THEN
  1070.          DO;
  1071.               IF TYPE=MID THEN
  1072.                    BRAZ = LNG2 + 1;
  1073.               ELSE
  1074.                    BRAZ = LNG2;
  1075.          END;
  1076.     IF TYPE = LEFT THEN
  1077.          TEMPA2 = ARB;
  1078.     ELSE
  1079.          IF TYPE = RIGHT THEN
  1080.               TEMPA2 = ARB + LNG2 - BRAZ;
  1081.          ELSE
  1082.               TEMPA2 = ARB + TEMPB1 - 1;
  1083.     CALL MOVE(TEMPA2,(TEMPA := GETSPACE(INC$BRA)),INC$BRA);
  1084.     LNG = BRAZ;
  1085.     CALL POP$STACK;
  1086.     CALL STRINGFREE;
  1087.     ARA = TEMPA;
  1088.     CALL FLAG$STRING$ADDR(TRUE);
  1089. END STRING$SEGMENT;
  1090.  
  1091.  
  1092.  
  1093. LOGICAL: PROCEDURE(TYPE);
  1094.     DECLARE
  1095.             TYPE   BYTE,
  1096.             I      BYTE;
  1097.     CALL CONV$TO$BINARY(RA);
  1098.     IF TYPE > 0 THEN
  1099.          CALL CONV$TO$BINARY(RB);
  1100.     DO I = 0 TO 3;
  1101.          DO CASE TYPE;
  1102.               BRA(I) = NOT BRA(I);
  1103.               BRB(I) = BRA(I) AND BRB(I);
  1104.               BRB(I) = BRA(I) OR BRB(I);
  1105.               BRB(I) = BRA(I) XOR BRB(I);
  1106.          END;
  1107.     END; /* OF DO TWICE */
  1108.     IF TYPE > 0 THEN
  1109.          CALL POP$STACK;
  1110.     CALL CONV$TO$FP(RA);
  1111. END LOGICAL;
  1112.  
  1113.  
  1114.     /*
  1115.          ********************************************************
  1116.          *                                                      *
  1117.          *                CONSOLE OUTPUT ROUTINES               *
  1118.          *                                                      *
  1119.          ********************************************************
  1120.     */
  1121. NUMERIC$OUT: PROCEDURE;
  1122.     /*
  1123.          ********************************************************
  1124.          *                                                      *
  1125.          *    THE FLOATING POINT NUMBER IN RA IS CONVERTED TO   *
  1126.          *    AN ASCII CHARACTER STRING AND THEN PLACED         *
  1127.          *    IN THE WORKBUFFER.  THE LENGTH OF THE STRING      *
  1128.          *    SET TO THE FIRST BYTE OF THE BUFFER               *
  1129.          *                                                      *
  1130.          ********************************************************
  1131.     */
  1132.     DECLARE
  1133.              I      BYTE;  /* INDEX */
  1134.     CALL FP$OP(FLOD,RA);  /* LOAD FP ACCUM WITH NUMBER FROM RA */
  1135.     CALL FP$OUT(.PRINTWORKAREA(1));  /* CONVERT IT TO ASCII  */
  1136.             /* RESULT IN PRINTWORKAREA PLUS 1 */
  1137.      I = 0;
  1138.      DO WHILE PRINTWORKAREA(I := I + 1) <> ' ';
  1139.           END;
  1140.      ARA = .PRINTWORKAREA;
  1141.      PRINTWORKAREA(0) = I;
  1142. END NUMERIC$OUT;
  1143.  
  1144.  
  1145. CLEAR$PRINT$BUFF: PROCEDURE;
  1146.     CALL FILL((PRINTBUFFER := PRINTBUFFERLOC),' ',PRINTBUFFLENGTH);
  1147. END CLEAR$PRINT$BUFF;
  1148.  
  1149.  
  1150. DUMP$PRINT$BUFF: PROCEDURE;
  1151.     DECLARE
  1152.             TEMP  ADDRESS,
  1153.             CHAR  BASED TEMP BYTE;
  1154.     TEMP=PRINTBUFFEND;
  1155.     DO WHILE CHAR = ' ';
  1156.         TEMP=TEMP - 1;
  1157.          END;
  1158.     CALL CRLF;
  1159.     DO PRINTBUFFER = PRINTBUFFERLOC TO TEMP;
  1160.         CALL PRINTCHAR(PRINTPOS);
  1161.          END;
  1162.     CALL CLEAR$PRINT$BUFF;
  1163. END DUMP$PRINT$BUFF;
  1164.  
  1165. WRITE$TO$CONSOLE: PROCEDURE;
  1166.      DECLARE
  1167.              HOLD     ADDRESS,
  1168.              H        BASED     HOLD(1)    BYTE,
  1169.              INDEX    BYTE;
  1170.      IF (HOLD := ARA) <> 0 THEN  /* MAY BE NULL STRING */
  1171.           DO INDEX = 1 TO H(0);
  1172.                PRINTPOS = H(INDEX);
  1173.                IF (PRINTBUFFER := PRINTBUFFER + 1) >
  1174.                               PRINTBUFFEND THEN
  1175.                     CALL DUMPPRINTBUFF;
  1176.            END;
  1177. END WRITE$TO$CONSOLE;
  1178.  
  1179.  
  1180.     /*
  1181.          ********************************************************
  1182.          *                                                      *
  1183.          *      FILE PROCESSING ROUTINES FOR USE WITH CP/M      *
  1184.          *                                                      *
  1185.          ********************************************************
  1186.     */
  1187. INITIALIZE$DISK$BUFFER: PROCEDURE;
  1188.     CALL FILL(BUFFER,EOFFILLER,128);
  1189. END INITIALIZE$DISK$BUFFER;
  1190.  
  1191.  
  1192. BUFFER$STATUS$BYTE: PROCEDURE BYTE;
  1193.     RETURN FCB(33);
  1194. END BUFFER$STATUS$BYTE;
  1195.  
  1196. SET$BUFFER$STATUS$BYTE: PROCEDURE(STATUS);
  1197.     DECLARE STATUS BYTE;
  1198.     FCB(33) = STATUS;
  1199. END SET$BUFFER$STATUS$BYTE;
  1200.  
  1201.  
  1202. WRITE$MARK: PROCEDURE BYTE;
  1203.     RETURN BUFFER$STATUS$BYTE;
  1204. END WRITE$MARK;
  1205.  
  1206.  
  1207. SET$WRITE$MARK: PROCEDURE;
  1208.     CALL SET$BUFFER$STATUS$BYTE(BUFFER$STATUS$BYTE OR 01H);
  1209. END SET$WRITEMARK;
  1210.  
  1211.  
  1212. CLEAR$WRITE$MARK: PROCEDURE;
  1213.     CALL SET$BUFFER$STATUS$BYTE(BUFFER$STATUS$BYTE AND 0FEH);
  1214. END CLEAR$WRITE$MARK;
  1215.  
  1216.  
  1217. ACTIVE$BUFFER: PROCEDURE BYTE;
  1218.     RETURN SHR(BUFFER$STATUS$BYTE,1);
  1219. END ACTIVE$BUFFER;
  1220.  
  1221. SET$BUFFER$INACTIVE: PROCEDURE;
  1222.     CALL SET$BUFFER$STATUS$BYTE(BUFFER$STATUS$BYTE AND 0F9H);
  1223. END SET$BUFFER$INACTIVE;
  1224.  
  1225. SET$BUFFER$ACTIVE: PROCEDURE;
  1226.     CALL SET$BUFFER$STATUS$BYTE(BUFFER$STATUS$BYTE OR 02H);
  1227. END SET$BUFFER$ACTIVE;
  1228.  
  1229.  
  1230. SET$RANDOM$MODE: PROCEDURE;
  1231.     CALL SET$BUFFER$STATUS$BYTE(BUFFER$STATUS$BYTE OR 80H);
  1232. END SET$RANDOM$MODE;
  1233.  
  1234. RANDOM$MODE: PROCEDURE BYTE;
  1235.     RETURN ROL(BUFFER$STATUS$BYTE,1);
  1236. END RANDOM$MODE;
  1237.  
  1238.  
  1239. STORE$REC$PTR: PROCEDURE;
  1240.     FCBADD(18) = RECORDPOINTER;
  1241. END STORE$REC$PTR;
  1242.  
  1243. DISK$EOF: PROCEDURE;
  1244.          IF EOFADDR = 0 THEN
  1245.               CALL ERROR('EF');
  1246.          RC = EOFADDR + 1;
  1247.          RA = EOFRA;
  1248.          RB = EOFRB;
  1249.          IF RECORD$POINTER <> BUFFER THEN
  1250.                 CALL SET$BUFFER$STATUS$BYTE(BUFFER$STATUS$BYTE OR 04H);
  1251.            RECORD$POINTER = RECORD$POINTER - 1;
  1252.          CALL STORE$REC$PTR;
  1253.          GOTO EOFEXIT;  /* DROP OUT TO OUTER LOOP */;
  1254. END DISK$EOF;
  1255.  
  1256.  
  1257. FILL$FILE$BUFFER: PROCEDURE;
  1258.     IF DISKREAD = 0 THEN
  1259.          DO;
  1260.               CALL SET$BUFFER$ACTIVE;
  1261.               RETURN;
  1262.          END;
  1263.     IF NOT RANDOM$MODE THEN
  1264.          DO;
  1265.              CALL DISK$EOF;
  1266.              RETURN;
  1267.          END;
  1268.     CALL INITIALIZE$DISK$BUFFER;
  1269.     CALL SET$BUFFER$ACTIVE;
  1270.     FCB(32) = FCB(32) + 1;
  1271.     RETURN;
  1272. END FILL$FILE$BUFFER;
  1273.  
  1274.  
  1275. WRITE$DISK$IF$REQ: PROCEDURE;
  1276.     IF WRITE$MARK THEN
  1277.     DO;
  1278.          IF SHR(BUFFER$STATUS$BYTE,2) THEN
  1279.               DO;
  1280.                    IF FCB(32) > 0 THEN
  1281.                         FCB(32) = FCB(32) - 1;
  1282.                    CALL SET$BUFFER$STATUS$BYTE(BUFFER$STATUS$BYTE AND 0FBH);
  1283.               END;
  1284.          IF DISKWRITE <> 0 THEN
  1285.               CALL ERROR('DW');
  1286.          CALL CLEAR$WRITE$MARK;
  1287.          IF RANDOM$MODE THEN
  1288.               CALL SET$BUFFER$INACTIVE;
  1289.          ELSE
  1290.               CALL INITIALIZE$DISK$BUFFER;
  1291.     END;
  1292.     RECORD$POINTER = BUFFER;
  1293. END WRITE$DISK$IF$REQ;
  1294.  
  1295.  
  1296. AT$END$DISK$BUFFER: PROCEDURE BYTE;
  1297.     RETURN (RECORD$POINTER := RECORD$POINTER + 1) >= BUFFER$END;
  1298. END AT$END$DISK$BUFFER;
  1299.  
  1300. VAR$BLOCK$SIZE: PROCEDURE BYTE;
  1301.     RETURN BLOCKSIZE <> 0;
  1302. END VAR$BLOCKSIZE;
  1303.  
  1304.  
  1305. WRITE$A$BYTE: PROCEDURE(CHAR);
  1306.     DECLARE CHAR BYTE;
  1307.     IF VAR$BLOCK$SIZE AND (BYTESWRITTEN := BYTESWRITTEN + 1)
  1308.                > BLOCKSIZE THEN
  1309.          CALL ERROR('ER');
  1310.     IF AT$END$DISK$BUFFER THEN
  1311.          CALL WRITE$DISK$IF$REQ;
  1312.     IF NOT ACTIVE$BUFFER AND RANDOM$MODE THEN
  1313.          DO;
  1314.               CALL FILL$FILE$BUFFER;
  1315.               FCB(32) = FCB(32) - 1;  /* RESET RECORD NO */
  1316.          END;
  1317.     NEXTDISKCHAR = CHAR;
  1318.     CALL SET$WRITE$MARK;
  1319. END WRITE$A$BYTE;
  1320.  
  1321.  
  1322. GET$FILE$NUMBER: PROCEDURE BYTE;
  1323.     IF BRAZ > NUMFILES THEN
  1324.          CALL ERROR('MF');
  1325.     RETURN BRAZ;
  1326. END GET$FILE$NUMBER;
  1327.  
  1328.  
  1329. SET$FILE$ADDR: PROCEDURE;
  1330.     IF (FILEADDR := FILES(GET$FILE$NUMBER)) 
  1331.                                 = 0 THEN
  1332.          CALL ERROR('FU');
  1333.     EOFADDR = EOFBRANCH(BRAZ);
  1334. END SET$FILE$ADDR;
  1335.  
  1336.  
  1337. SET$FILE$POINTERS: PROCEDURE;
  1338.     BUFFER$END = (BUFFER := FILEADDR + 38) + DISKRECSIZE;
  1339.     RECORDPOINTER = FCBADD(18);
  1340.     BLOCKSIZE = FCBADD(17);
  1341.     CALL SETDMA;
  1342. END SET$FILE$POINTERS;
  1343.  
  1344.  
  1345. SETUP$FILE$EXTENT: PROCEDURE;
  1346.     IF OPEN = 255 THEN
  1347.          DO;
  1348.               IF CREATE = 255 THEN
  1349.                    CALL ERROR('ME');
  1350.          END;
  1351. END SETUP$FILE$EXTENT;
  1352.  
  1353.  
  1354. DISK$OPEN: PROCEDURE;
  1355.     /*OPENS THE FILE - RA CONTAINS THE ADDRESS OF THE FILE NAME
  1356.     AND RB CONTAINS THE BLOCK SIZE.
  1357.     THE ARRAY FILES WILL HOLD THE ADDRESS OF THE FILE CONTROL BLOCK
  1358.     IN THE FSA.  THE FCB IS FOLLOWED BY 3 FLAGS - BLOCKSIZE(ADDR)
  1359.     RECORD POINTER(ADDR), WRITE FLAG(BYTE).  THIS IS FOLLOWED BY THE
  1360.     128 BYTE BUFFER TO DO FILE I/O.*/
  1361.  
  1362.     DECLARE
  1363.             FILENAME ADDRESS,
  1364.             NEXTFILE BYTE,
  1365.             BUFF     ADDRESS,
  1366.             CHAR     BASED BUFF(128) BYTE,
  1367.             I        BYTE,
  1368.             J        BYTE;
  1369.  
  1370.     INC$J: PROCEDURE BYTE;
  1371.          RETURN (J := J + 1);
  1372.     END INC$J;
  1373.  
  1374.     NEXTFILE = 0;
  1375.     DO WHILE FILES(NEXTFILE := NEXTFILE + 1) <> 0;
  1376.          END;
  1377.     FILEADDR,FILES(NEXTFILE) = GETSPACE(166);
  1378.     BUFFER = FILEADDR + 38;
  1379.     CALL SETDMA;
  1380.     CALL FILL((FILENAME:=FILEADDR+1),' ',11);
  1381.     BUFF=ARA;
  1382.     IF CHAR(2) = ':' THEN
  1383.          DO;
  1384.               FCB(0) = CHAR(1) AND 0FH;
  1385.               I = CHAR(0) - 2;
  1386.               BUFF = BUFF + 2;
  1387.          END;
  1388.     ELSE
  1389.          I = CHAR(0);
  1390.     IF I > 12 THEN
  1391.          I = 12;
  1392.     BUFF=BUFF+1;
  1393.     J = 255;
  1394.     DO WHILE(CHAR(INC$J) <> '.') AND (J < I);
  1395.          END;
  1396.     CALL MOVE(BUFF,FILENAME,J);
  1397.     IF I > INC$J THEN
  1398.          CALL MOVE (.CHAR(J),FILENAME + 8, I - J);
  1399.     CALL SETUP$FILE$EXTENT;
  1400.     CALL INITIALIZE$DISK$BUFFER;
  1401.     FCBADD(18)=FILEADDR+256;
  1402.     CALL POP$STACK;
  1403.     FCBADD(17) = ARA;
  1404.     CALL POP$STACK;
  1405. END DISK$OPEN;
  1406.  
  1407.  
  1408. SET$EOF$STACK: PROCEDURE;
  1409.      EOFRA = RA;
  1410.      EOFRB = RB;
  1411. END SET$EOF$STACK;
  1412.  
  1413. SETUP$DISK$IO: PROCEDURE;
  1414.  
  1415.     CALL SET$FILE$ADDR;
  1416.     CALL SET$FILE$POINTERS;
  1417.     BYTES$WRITTEN=0;
  1418.     FIRSTFIELD = TRUE;
  1419.     CALL POP$STACK;
  1420. END SETUP$DISK$IO;
  1421.  
  1422.  
  1423. RANDOM$SETUP: PROCEDURE;
  1424.     DECLARE
  1425.             TEMP1     ADDRESS,
  1426.             TEMP2   ADDRESS,
  1427.             TEMP3     ADDRESS,
  1428.             BYTECOUNT ADDRESS,
  1429.             RECORD    ADDRESS,
  1430.             EXTENT    BYTE;
  1431.  
  1432.     IF NOT VAR$BLOCK$SIZE THEN
  1433.          CALL ERROR('RU');
  1434.     IF RA$ZERO$ADDRESS OR RA$NEGATIVE THEN
  1435.          CALL ERROR('IR');
  1436.     ARA = ARA - 1;
  1437.     CALL SET$RANDOM$MODE;
  1438.     CALL SET$BUFFER$INACTIVE;
  1439.     CALL WRITE$DISK$IF$REQ;
  1440.     TEMP2 = LOW(BLOCKSIZE)*HIGH(ARA) + LOW(ARA)*HIGH(BLOCKSIZE);
  1441.     TEMP1 = LOW(BLOCKSIZE) * BRAZ;
  1442.     BYTECOUNT = SHL(TEMP2,8) + TEMP1;
  1443.     TEMP3 = HIGH(BLOCKSIZE) * BRA(1);
  1444.     EXTENT = SHL(LOW(TEMP3) ,2) +
  1445.                SHR((HIGH(TEMP1) + TEMP2),6);
  1446.     RECORDPOINTER = (BYTECOUNT AND 7FH) + BUFFER - 1;
  1447.     CALL STORE$REC$PTR;
  1448.     RECORD = SHR(BYTECOUNT,7);
  1449.     IF EXTENT<>FCB(12) THEN
  1450.          DO;
  1451.               IF CLOSE = 255 THEN
  1452.                    CALL ERROR('CE');
  1453.               FCB(12) = EXTENT;
  1454.               CALL SETUP$FILE$EXTENT;
  1455.          END;
  1456.     FCB(32) = LOW(RECORD) AND 7FH;
  1457.     CALL POP$STACK;
  1458. END RANDOM$SETUP;
  1459.  
  1460.  
  1461. GET$DISK$CHAR: PROCEDURE BYTE;
  1462.      IF AT$END$DISK$BUFFER THEN
  1463.          DO;
  1464.               CALL WRITE$DISK$IF$REQ;
  1465.               CALL FILL$FILE$BUFFER;
  1466.          END;
  1467.     IF NOT ACTIVE$BUFFER THEN
  1468.          CALL FILL$FILE$BUFFER;
  1469.     IF NEXTDISKCHAR = EOFFILLER THEN
  1470.          CALL DISK$EOF;
  1471.     RETURN NEXTDISKCHAR;
  1472. END GET$DISK$CHAR;
  1473.  
  1474.  
  1475. WRITE$TO$FILE: PROCEDURE(TYPE);
  1476.     /* TYPE 0 MEANS WRITE A NUMBER, 1 MEANS A STRING*/
  1477.     DECLARE
  1478.             I       BYTE,
  1479.             POINT   ADDRESS,
  1480.             CHAR    BASED     POINT  BYTE,
  1481.             COUNT   BYTE,
  1482.             TYPE    BYTE,
  1483.             NUMERIC LIT       '0',
  1484.             STRING  LIT       '1';
  1485.  
  1486.     INC$POINT: PROCEDURE;
  1487.          POINT = POINT + 1;
  1488.     END INC$POINT;
  1489.  
  1490.     IF TYPE = NUMERIC THEN /* CONVERT TO ASCII STRING */
  1491.          CALL NUMERICOUT;
  1492.     IF NOT FIRSTFIELD THEN /* SEPARATE FIELDS WITH COMMAS */
  1493.          CALL WRITE$A$BYTE(',');
  1494.     ELSE
  1495.          FIRSTFIELD = FALSE;
  1496.     POINT = ARA; /* ARA POINTS TO CHAR STRING */
  1497.     COUNT = CHAR;
  1498.     IF TYPE = NUMERIC THEN /* ELIM TRAILING BLANK */
  1499.          COUNT = COUNT - 1;
  1500.     ELSE
  1501.          CALL WRITE$A$BYTE(QUOTE); /* STRINGS PUT IN QUOTES */
  1502.     CALL INC$POINT; /* POINT TO FIRST CHAR */
  1503.     DO I = 1 TO COUNT;
  1504.          IF CHAR = QUOTE THEN
  1505.               CALL ERROR('QE');
  1506.          CALL WRITE$A$BYTE(CHAR);
  1507.          CALL INC$POINT;
  1508.          END;
  1509.     IF TYPE = STRING THEN
  1510.          DO;
  1511.               CALL WRITE$A$BYTE(QUOTE); /* ADD TRAILING QUOTE */
  1512.               CALL STRING$FREE; /* MAY BE A TEMP STRING */
  1513.          END;
  1514.     CALL POP$STACK;
  1515. END WRITE$TO$FILE;
  1516.  
  1517.  
  1518. DISK$CLOSE: PROCEDURE;
  1519.     CALL SET$FILE$POINTERS;
  1520.     CALL WRITE$DISK$IF$REQ;
  1521.     IF CLOSE = 255 THEN
  1522.          CALL ERROR('CE');
  1523.     CALL RELEASE(FILEADDR);
  1524. END DISK$CLOSE;
  1525.  
  1526. CLOSEFILES:  PROCEDURE;
  1527.     DECLARE I BYTE;
  1528.     I = 0;
  1529.     DO WHILE(I:=I+1) <= NUMFILES;
  1530.          IF(FILEADDR := FILES(I)) <> 0 THEN
  1531.               CALL DISKCLOSE;
  1532.          END;
  1533. END CLOSEFILES;
  1534.  
  1535.     /*
  1536.          ********************************************************
  1537.          *                                                      *
  1538.          *                 ROUTINE TO EXIT INTERP               *
  1539.          *                                                      *
  1540.          ********************************************************
  1541.     */
  1542. EXIT$INTERP: PROCEDURE;
  1543.     CALL CLOSEFILES;
  1544.     CALL DUMP$PRINT$BUFF;
  1545.     CALL CRLF;
  1546.     CALL MON3;
  1547. END EXIT$INTERP;
  1548.  
  1549.  
  1550.     /*
  1551.          ********************************************************
  1552.          *                                                      *
  1553.          *               GENERALIZED INPUT ROUTINES             *
  1554.          *                                                      *
  1555.          ********************************************************
  1556.     */
  1557.  
  1558. CONSOLE$READ: PROCEDURE;
  1559.     CALL PRINTCHAR(WHAT);
  1560.     CALL PRINTCHAR(' ');
  1561.     CALL READ(.INPUTBUFFER);
  1562.     IF SPACE(1) = CONTZ THEN
  1563.          CALL EXIT$INTERP;
  1564.     CONBUFFPTR = .SPACE;
  1565.     SPACE(SPACE(0)+1)=EOLCHAR;
  1566. END CONSOLE$READ;
  1567.  
  1568. MORE$CON$INPUT: PROCEDURE BYTE;
  1569.     RETURN CONBUFFPTR < .SPACE(SPACE(0));
  1570. END MORE$CON$INPUT;
  1571.  
  1572.  
  1573. CONSOLE$INPUT$ERROR: PROCEDURE;
  1574.     CALL POPSTACK;
  1575.     RC = REREADADDR;  /* RESET PROGRAM COUNTER */
  1576.     CALL WARNING('II');
  1577.     GOTO ERROR$EXIT;  /* RETURN TO OUTER LEVEL */
  1578. END CONSOLE$INPUT$ERROR;
  1579.  
  1580.  
  1581. GET$DATA$CHAR: PROCEDURE BYTE;
  1582.     DECLARE CHAR BASED DATAAREAPTR BYTE;
  1583.     IF(DATAAREAPTR := DATAAREAPTR + 1) >= SB THEN
  1584.          CALL ERROR('OD');
  1585.     RETURN CHAR;
  1586. END GET$DATA$CHAR;
  1587.  
  1588.  
  1589. GET$CON$CHAR: PROCEDURE BYTE;
  1590.     DECLARE CHAR BASED CONBUFFPTR BYTE;
  1591.     CONBUFFPTR = CONBUFFPTR + 1;
  1592.     RETURN CHAR;
  1593. END GET$CON$CHAR;
  1594.  
  1595.  
  1596. NEXT$INPUT$CHAR: PROCEDURE BYTE;
  1597.     IF INPUTTYPE = 0 THEN /* READ FROM DISK */
  1598.          DO FOREVER;
  1599.               IF INPUTINDEX >CONBUFFSIZE THEN
  1600.                      CALL ERROR('DB');
  1601.               IF(SPACE(INPUTINDEX):= GETDISKCHAR) = LF THEN
  1602.                    DO;
  1603.                         IF VAR$BLOCKSIZE THEN
  1604.                              CALL ERROR('RE');
  1605.                    END;
  1606.               ELSE
  1607.                    RETURN NEXTDISKCHAR;
  1608.          END;
  1609.     IF INPUTTYPE = 1 THEN /* INPUT FROM CONSOLE */
  1610.          RETURN GETCONCHAR;
  1611.     IF INPUTTYPE = 2 THEN /* READ FROM DATA STATEMENT */
  1612.          RETURN GETDATACHAR;
  1613. END NEXT$INPUT$CHAR;
  1614.  
  1615.  
  1616. COUNT$INPUT: PROCEDURE;
  1617.      /*
  1618.         DETERMINE EXTENT OF NEXT FIELD AND COLLECT
  1619.         THE FIELD IN THE APPROPRIATE BUFFER
  1620.      */
  1621.     DECLARE
  1622.             HOLD  BYTE,
  1623.             DELIM BYTE;
  1624.     INPUT$INDEX = 0;
  1625.     DO WHILE (HOLD := NEXT$INPUT$CHAR) = ' ';
  1626.          END;
  1627.     IF INPUTTYPE = 0 THEN
  1628.          INPUTPTR = .SPACE;
  1629.     IF INPUTTYPE = 1 THEN
  1630.          INPUTPTR = CONBUFFPTR;                               
  1631.  
  1632.     IF INPUTTYPE =2 THEN
  1633.          INPUTPTR = DATAAREAPTR;
  1634.     IF HOLD <> QUOTE THEN
  1635.          DELIM = ',';
  1636.     ELSE
  1637.          DO;
  1638.               DELIM = QUOTE;
  1639.               IF INPUTTYPE <> 0 THEN
  1640.                    INPUTPTR = INPUTPTR + 1;
  1641.               HOLD = NEXT$INPUT$CHAR;
  1642.          END;
  1643.     DO WHILE (HOLD <> DELIM) AND (HOLD <> EOLCHAR);
  1644.          INPUTINDEX = INPUTINDEX + 1;
  1645.          HOLD = NEXT$INPUT$CHAR;
  1646.          END;
  1647.     IF DELIM = QUOTE THEN
  1648.          DO WHILE((HOLD := NEXT$INPUT$CHAR) <> ',') AND (HOLD <> EOLCHAR);
  1649.               END;
  1650.     CALL PUSH$STACK;
  1651. END COUNT$INPUT;
  1652.  
  1653.  
  1654. GET$STRING$FIELD: PROCEDURE;
  1655.     DECLARE
  1656.             TEMP ADDRESS,
  1657.             LNG  BASED TEMP BYTE;
  1658.     CALL COUNT$INPUT;
  1659.     CALL MOVE(INPUTPTR,(TEMP:=GETSPACE(INPUTINDEX + 1))+1,INPUTINDEX);
  1660.     ARA = TEMP;
  1661.     CALL FLAG$STRING$ADDR(0);
  1662.     LNG = INPUTINDEX;  /* SET LENGTH IN NEW STRING */
  1663. END GET$STRING$FIELD;
  1664.  
  1665.  
  1666. GET$NUMERIC$FIELD: PROCEDURE;
  1667.     CALL COUNT$INPUT;
  1668.     IF INPUTINDEX > 0 THEN
  1669.     DO;
  1670.     CALL FP$INPUT(INPUTINDEX,INPUTPTR);
  1671.     CALL FP$OP$RETURN(9,RA);
  1672.     CALL CHECK$OVERFLOW;
  1673.     END;
  1674.       ELSE
  1675.            IF INPUTTYPE = 1 THEN
  1676.                 CALL CONSOLE$INPUT$ERROR;
  1677.            ELSE
  1678.                 BRAZ = 0;
  1679. END GET$NUMERIC$FIELD;
  1680.  
  1681.  
  1682.  
  1683.     /*
  1684.          ********************************************************
  1685.          *                                                      *
  1686.          *          INTERPRETER INITIALIZATION ROUTINES         *
  1687.          *                                                      *
  1688.          ********************************************************
  1689.     */
  1690.  
  1691.  
  1692. INITIALIZE$EXECUTE: PROCEDURE;
  1693.     GET$PARAMETERS: PROCEDURE;
  1694.         MCD,RC = PARAM1;
  1695.         DATAAREAPTR = (MDA := PARAM2) - 1;
  1696.         MPR=PARAM3;
  1697.         MBASE,ST = (SB := PARAM4) + NRSTACK;
  1698.         RA = (RB := SB) + 4;
  1699.     END GET$PARAMETERS;
  1700.  
  1701.     INITMEM: PROCEDURE;
  1702.         DECLARE BASE ADDRESS,
  1703.                 A BASED BASE(2) ADDRESS,
  1704.                 TOP BASED SYSBEGIN ADDRESS;
  1705.         CALL MOVE(BEGIN+OFFSET,BEGIN,MPR-BEGIN);
  1706.         CALL FILL(MPR,0,MBASE-MPR);
  1707.         BASE=ST;
  1708.         A(0)=TOP-4;
  1709.         A(1),A(2) = 0;
  1710.         BASE=A(0);
  1711.         A(0) = 0;
  1712.         A(1) = ST;
  1713.     END INITMEM;
  1714.  
  1715.  
  1716.     CALL GET$PARAMETERS;
  1717.     CALL INITMEM;
  1718.     CALL FILL(.FILES,0,TIMES4(NUMFILES));
  1719.     CALL CLEAR$PRINT$BUFF;
  1720. END INITIALIZE$EXECUTE;
  1721.  
  1722.  
  1723.  /* ***** EXECUTIVE ROUTINE STARTS HERE ***** */
  1724.     /*
  1725.          ********************************************************
  1726.          *                                                      *
  1727.          ********************************************************
  1728.     */
  1729. EXECUTE:  PROCEDURE;
  1730.      DO FOREVER;
  1731.     IF ROL(C,1) THEN    /* MUST BE LIT OR LIT-LOD*/
  1732.     DO;
  1733.          CALL PUSH$STACK;
  1734.         BRA(0)=CV(1);       /* LOAD IN REVERSE ORDER */
  1735.         BRA(1)= C AND 3FH;
  1736.         IF ROL(C,2) THEN CALL LOAD$RA;   /*LIT-LOD*/
  1737.          CALL STEP$INS$CNT;
  1738.         END;
  1739.     ELSE
  1740.          DO CASE C;
  1741.  
  1742.  /*0  FAD: RB = RA+ RB  */
  1743.         CALL TWO$VALUE$OPS(FADD);
  1744.  
  1745.  /*1  FMI  RB = RB-RA; */
  1746.          DO;
  1747.               CALL FLIP;
  1748.         CALL TWO$VALUE$OPS(FSUB);
  1749.          END;
  1750.  
  1751.  /*2 FMU  RB= RA*RB    */
  1752.         CALL TWO$VALUE$OPS(FMUL);
  1753.  
  1754.  /*3  FDI  RB = RA/RB  */
  1755.          DO;
  1756.               IF RA$ZERO THEN
  1757.                    CALL WARNING('DZ');
  1758.               CALL FLIP;
  1759.               CALL TWO$VALUE$OPS(FDIV);
  1760.          END;
  1761.  
  1762.  /*4  EXP  RA=RB**RA    */
  1763.          DO;
  1764.               IF RB$ZERO THEN
  1765.                  DO;
  1766.                    IF RA$ZERO THEN
  1767.                        CALL MOVE4(.PLUSONE,RB);
  1768.                  END;
  1769.               ELSE
  1770.                    IF RB$NEGATIVE THEN
  1771.                         CALL ERROR('NE');
  1772.                    ELSE
  1773.                         DO;
  1774.                              CALL FP$OP(FLOD,RB);
  1775.                              CALL FP$OP(LOG,0);
  1776.                              CALL FP$OP(FMUL,RA);
  1777.                              CALL FP$OP$RETURN(EXP,RB);
  1778.                         END;
  1779.                 CALL POP$STACK;
  1780.                 CALL CHECK$OVERFLOW;
  1781.          END;
  1782.  
  1783.  /* 5 LSS, LESS THEN */
  1784.          CALL COMP$FIX(COMPARE$FP=1);
  1785.  
  1786.  /* 6 GTR, GREATER THEN */
  1787.          CALL COMP$FIX(COMPARE$FP=2);
  1788.  
  1789.  /* 7  EQU, EQUAL TO */
  1790.          CALL COMP$FIX(COMPARE$FP=3);
  1791.  
  1792.  /* 8  NEQ, NOT EQUAL TO */
  1793.          CALL COMP$FIX(NOT(COMPARE$FP=3));
  1794.  
  1795.  /* 9  GEQ, GREATER THEN OR EQUAL TO */
  1796.          CALL COMP$FIX(NOT(COMPARE$FP=1));
  1797.  
  1798.  /*10  LEQ, LESS THEN OR EQUAL TO */
  1799.          CALL COMP$FIX(NOT(COMPARE$FP=2));
  1800.  
  1801.  /*11  NOT*/
  1802.          CALL LOGICAL(0);
  1803.  
  1804.  /*12  AND*/
  1805.          CALL LOGICAL(1);
  1806.  
  1807.  /*13  BOR */
  1808.          CALL LOGICAL(2);
  1809.  
  1810.  /* 14 LOD*/
  1811.             CALL LOAD$RA;
  1812.  
  1813.  /* 15 STO */
  1814.          DO;
  1815.               CALL STORE(0);
  1816.               CALL MOVE$RA$RB;
  1817.               CALL POP$STACK;
  1818.          END;
  1819.  
  1820.  /* 16 XIT */
  1821.          RETURN;
  1822.  
  1823.  /* 17 DEL */
  1824.          CALL POP$STACK;
  1825.  
  1826.  /* 18 DUP */
  1827.          DO;
  1828.               CALL PUSH$STACK;
  1829.          CALL MOVE$RB$RA;
  1830.       END;
  1831.  
  1832.  /* 19 XCH */
  1833.          CALL FLIP;
  1834.  
  1835.  /* 20 STD */
  1836.          DO;
  1837.               CALL STORE(0);
  1838.               CALL POP$STACK;
  1839.               CALL POP$STACK;
  1840.          END;
  1841.  
  1842.  /* 21 SLT */
  1843.          CALL COMP$FIX(COMPARE$STRING = 1);
  1844.  
  1845.  /* 22 SGT */
  1846.          CALL COMP$FIX(COMPARE$STRING = 2);
  1847.  
  1848.  /* 23 SEQ */
  1849.          CALL COMP$FIX(COMPARE$STRING = 3);
  1850.  
  1851.  /* 24 SNE */
  1852.          CALL COMP$FIX(NOT(COMPARE$STRING = 3));
  1853.  
  1854.  /* 25 SGE */
  1855.          CALL COMP$FIX(NOT(COMPARE$STRING = 1));
  1856.  /* 26 SLE */
  1857.          CALL COMP$FIX(NOT(COMPARE$STRING = 2));
  1858.  
  1859.  /* 27  STS */
  1860.          DO;
  1861.               CALL STORE(1);
  1862.               CALL POP$STACK;
  1863.               CALL POP$STACK;
  1864.       END;
  1865.  
  1866.  /* 28 ILS */
  1867.          DO;
  1868.               CALL PUSH$STACK;
  1869.               CALL STEP$INS$CNT;
  1870.               RC = (ARA := RC) + C;
  1871.               CALL FLAG$STRING$ADDR(FALSE);
  1872.          END;
  1873.  
  1874.  /* 29 CAT */
  1875.          CALL CONCATENATE;
  1876.  /* 30 PRO */
  1877.          DO;
  1878.               CALL STEP$INS$CNT;
  1879.               CALL PUSH$STACK;
  1880.               ARA = RC + 1 + 1;
  1881.               RC = TWOBYTEOPRAND;
  1882.          END;
  1883.  
  1884.  /* 31 RTN */
  1885.          DO;
  1886.               RC = ARA - 1;
  1887.               CALL POP$STACK;
  1888.          END;
  1889.  
  1890.  /*32 ROW, CALCULATES SPACE REQUIREMENTS FOR ARRAYS*/
  1891.          CALL CALC$ROW;
  1892.  
  1893.  /* 33, SUB */
  1894.  /*   SUB,CALCULATES SUBSCRIPT ADDRESSES */
  1895.          CALL CALC$SUB;
  1896.  
  1897.  
  1898.  /* RDV  READS A NUMBER FROM THE CONSOLE  */
  1899.          DO;
  1900.               IF NOT MORE$CON$INPUT THEN
  1901.                     CALL CONSOLE$INPUT$ERROR;
  1902.               CALL GET$NUMERIC$FIELD;
  1903.          END;
  1904.  
  1905.  /* 35, WRV : PRINTS THE NUMBER ON THE TOP OF THE STACK */
  1906.          DO;
  1907.               CALL NUMERIC$OUT;
  1908.               CALL WRITE$TO$CONSOLE;
  1909.               CALL POP$STACK;
  1910.          END;
  1911.  
  1912.  /* 36 WST: PRINTS THE STRING WHOSE ADDRESS IS ON TOPOF THE STACK*/
  1913.           DO;
  1914.                CALL WRITE$TO$CONSOLE;
  1915.               CALL STRING$FREE;
  1916.               CALL POP$STACK;
  1917.          END;
  1918.  
  1919.  /* 37, RDF */
  1920.     /* RDF - PROCEDURE TO READY A RANDOM BLOCK */
  1921.          DO;
  1922.               CALL SETUP$DISK$IO;
  1923.               CALL RANDOM$SETUP;
  1924.               CALL SET$EOF$STACK;
  1925.          END;
  1926.  
  1927.  /* 38, RDB */
  1928.     /* RDB - READY NEXT SEQUENTIAL BLOCK */
  1929.           DO;
  1930.               CALL SETUP$DISK$IO;
  1931.               CALL SET$EOF$STACK;
  1932.           END;
  1933.  
  1934.  /* 39, ECR */
  1935.           IF MORE$CON$INPUT THEN
  1936.                DO;
  1937.                CALL PUSHSTACK;
  1938.                CALL CONSOLE$INPUT$ERROR;
  1939.             END;
  1940.  
  1941.  /* 40, OUT */
  1942.           DO;
  1943.                CALL OUTPUT(BRAZ,BRBZ);
  1944.                CALL POP$STACK;
  1945.                CALL POP$STACK;
  1946.           END;
  1947.  
  1948.     /*41 RDN - READ A NUMBER FROM DISK*/
  1949.          DO;
  1950.               INPUTTYPE = 0;
  1951.               CALL GET$NUMERIC$FIELD;
  1952.          END;
  1953.  
  1954.     /*42 RDS - READ A STRING FROM DISK*/
  1955.          DO;
  1956.               INPUTTYPE = 0;
  1957.               CALL GET$STRING$FIELD;
  1958.          END;
  1959.  
  1960.     /*43 WRN WRITE A NUMBER TO DISK*/
  1961.          CALL WRITE$TO$FILE(0);
  1962.  
  1963.     /*44 WRS - WRITE A STRING TO DISK */
  1964.          CALL WRITE$TO$FILE(1);
  1965.  
  1966.  /* 45, OPN */
  1967.  /*OPN:   PROCEDURE TO CREATE FCBS FOR ALL INPUT FILES */
  1968.         CALL DISK$OPEN;
  1969.  
  1970.  /* 46 CON */
  1971.          DO;
  1972.               CALL PUSH$STACK;
  1973.               CALL STEP$INS$CNT;
  1974.               CALL MOVE4(TWOBYTEOPRAND,RA);
  1975.               CALL STEP$INS$CNT;
  1976.          END;
  1977.  
  1978.  /* 47, RST: PUTS POINTER TO THE BEGINNING OF THE DATA AREA*/
  1979.               DATAAREAPTR = MDA - 1;
  1980.  
  1981.  /*48  NEG, NEGATIVE */
  1982.          CALL ONE$VALUE$OPS(FCHS);
  1983.  
  1984.  /* 49 , RES : READ STRING */
  1985.          DO;
  1986.               IF NOT MORE$CON$INPUT THEN
  1987.                    CALL CONSOLE$INPUT$ERROR;
  1988.               CALL GET$STRING$FIELD;
  1989.          END;
  1990.  
  1991.  /* 50 NOP */
  1992. ;
  1993.  
  1994.  /* 51 DAT */
  1995.   ;
  1996.  
  1997.  /* 52 DBF */
  1998.          CALL DUMPPRINTBUFF;
  1999.  
  2000.  /* 53 NSP */
  2001.          DO;
  2002.               DECLARE I BYTE;
  2003.               I=0;
  2004.               DO WHILE PRINTBUFFER > POSITION(I);
  2005.                    I = I + 1;
  2006.                    END;
  2007.               IF I = MAXPOSNUM THEN
  2008.                    CALL DUMP$PRINT$BUFF;
  2009.               ELSE
  2010.                    PRINTBUFFER = POSITION(I);
  2011.          END;
  2012.  
  2013.  /* 54 BRS */
  2014.          CALL ABSOLUTE$BRANCH;
  2015.  
  2016.  /* 55 BRC */
  2017.          DO;
  2018.               IF RA$ZERO THEN
  2019.                    CALL ABSOLUTE$BRANCH;
  2020.               ELSE
  2021.                    RC = RC + 1 + 1;
  2022.               CALL POP$STACK;
  2023.          END;
  2024.  
  2025.  /* 56 BFC */
  2026.          CALL COND$BRANCH;
  2027.  
  2028.  /* 57 BFN */
  2029.          CALL UNCOND$BRANCH;
  2030.  
  2031.  /* 58 CBA */
  2032.          CALL CONV$TO$BINARY(RA);
  2033.  
  2034.  /* 59 RCN */
  2035.          DO;
  2036.               INPUTTYPE = 1;
  2037.                REREADADDR = RC;
  2038.               CALL CONSOLE$READ;
  2039.          END;
  2040.  
  2041.  /* 60 DRS READ STRING FROM DATA AREA */
  2042.          DO;
  2043.               INPUTTYPE = 2;
  2044.               CALL GET$STRING$FIELD;
  2045.          END;
  2046.  
  2047.  /* 61 DRF READ F/P NUMBER FROM DATA AREA */
  2048.          DO;
  2049.               INPUTTYPE = 2;
  2050.               CALL GET$NUMERIC$FIELD;
  2051.          END;
  2052.  
  2053.     /*62 EDR - END OF RECORD FOR READ*/
  2054.     /*ADVANCES TO NEXT LINE FEED*/
  2055.          DO;
  2056.               IF VAR$BLOCK$SIZE THEN
  2057.                    DO WHILE GET$DISK$CHAR <> LF;
  2058.                         END;
  2059.               CALL STORE$REC$PTR;
  2060.          END;
  2061.  
  2062.     /*63 EDW - END OF RECORD FOR WRITE*/
  2063.          DO;
  2064.               IF VAR$BLOCK$SIZE THEN
  2065.                     DO WHILE BYTES$WRITTEN < (BLOCKSIZE - 2);
  2066.                          CALL WRITE$A$BYTE(' ');
  2067.                          END;
  2068.               CALL WRITE$A$BYTE(CR);
  2069.               CALL WRITE$A$BYTE(LF);
  2070.               CALL STORE$REC$PTR;
  2071.          END;
  2072.     /*64 CLS - CLOSE A FILE*/
  2073.          DO;
  2074.               CALL SET$FILE$ADDR;
  2075.               CALL DISK$CLOSE;
  2076.               FILES(BRAZ),EOFBRANCH(BRAZ) = 0;
  2077.               CALL POP$STACK;
  2078.          END;
  2079.  
  2080.  /* 65 ABSOLUTE */
  2081.          BRA(1) = BRA(1) AND 7FH;
  2082.  
  2083.  /* 66 INTEGER */
  2084.          DO;
  2085.               CALL CONV$TO$BINARY(RA);
  2086.               CALL CONV$TO$FP(RA);
  2087.          END;
  2088.  
  2089.  /* 67 RANDOM NUMBER GENERATOR */
  2090.          DO;
  2091.               CALL RANDOM;
  2092.               CALL PUSH$STACK;
  2093.               CALL MOVE4(.SCALE,RA);
  2094.               CALL PUSH$STACK;
  2095.               CALL FLOAT$ADDR(SEED);
  2096.               CALL TWO$VALUE$OPS(FDIV);
  2097.          END;
  2098.  
  2099.  /* 68 SGN */
  2100.          DO;
  2101.               DECLARE FLAG BYTE;
  2102.               FLAG = NOT RA$NEGATIVE;
  2103.               CALL COMP$FIX(NOT RA$ZERO);
  2104.               IF FLAG THEN
  2105.                    CALL ONE$VALUE$OPS(FCHS);
  2106.          END;
  2107.  
  2108.  /* 69 SINE */
  2109.          CALL ONE$VALUE$OPS(SIN);
  2110.  
  2111.  /* 70 COSINE */
  2112.          CALL ONE$VALUE$OPS(COS);
  2113.  
  2114.  /* 71 ARCTANGENT */
  2115.          CALL ONE$VALUE$OPS(ATAN);
  2116.  
  2117.  /* 72 TANGENT */
  2118.          DO;
  2119.               CALL PUSH$STACK;
  2120.               CALL MOVE$RB$RA;
  2121.               CALL ONE$VALUE$OPS(SIN);
  2122.               CALL POP$STACK;
  2123.               CALL ONE$VALUE$OPS(COS);
  2124.               CALL PUSH$STACK;
  2125.               IF RB$ZERO THEN
  2126.                    CALL ERROR('TZ');
  2127.               CALL TWO$VALUE$OPS(FDIV);
  2128.          END;
  2129.  
  2130.  /* 73 SQUAREROOT */
  2131.          CALL ONE$VALUE$OPS(SQRT);
  2132.  
  2133.  /* 74 TAB */
  2134.          DO;
  2135.               CALL ROUND$CONV$BIN;
  2136.               DO WHILE ARA > PRINTBUFFLENGTH;
  2137.                    ARA = ARA - PRINTBUFFLENGTH;
  2138.                    END;
  2139.               IF ((ARA := ARA - 1 + PRINTBUFFERLOC) <= PRINTBUFFER)
  2140.                      AND (PRINTBUFFER <> PRINTBUFFERLOC) THEN
  2141.                    CALL DUMP$PRINT$BUFF;
  2142.               PRINTBUFFER = ARA;
  2143.          CALL POP$STACK;
  2144.          END;
  2145.  
  2146.  /* 75 EXPONENTATION */
  2147.          CALL ONE$VALUE$OPS(EXP);
  2148.  
  2149.  /* 76 FREE AREA IN FSA */
  2150.           DO;
  2151.                CALL PUSH$STACK;
  2152.                CALL FLOAT$ADDR(AVAILABLE(0));
  2153.           END;
  2154.  
  2155.  /* 77  IRN  */
  2156.          SEED = LOCALSEED;
  2157.  
  2158.  /* 78 LOG */
  2159.          CALL ONE$VALUE$OPS(LOG);
  2160.  
  2161.  /* 79 POSITION OF PRINT BUFFER PTR */
  2162.           DO;
  2163.                CALL PUSH$STACK;
  2164.                CALL FLOAT$ADDR(PRINTBUFFER - (PRINTBUFFERLOC - 1));
  2165.           END;
  2166.  
  2167.  /* 80 INP */
  2168.           DO;
  2169.                CALL ROUND$CONV$BIN;
  2170.                CALL FLOAT$ADDR(INPUT(BRAZ));
  2171.           END;
  2172.  
  2173.  /* 81 ASCII CONVERSION */
  2174.           DO;
  2175.                DECLARE
  2176.                        HOLD ADDRESS,
  2177.                        TEMP BYTE,
  2178.                        H    BASED    HOLD(1)   BYTE;
  2179.                IF (HOLD := ARA) = 0 OR H(0) = 0 THEN
  2180.                     CALL ERROR('AC');
  2181.                TEMP = H(1);
  2182.                CALL STRING$FREE;
  2183.                CALL FLOAT$ADDR(TEMP);
  2184.           END;
  2185.  
  2186.  /* 82 CHR CONVERTS TO ASCII */
  2187.          DO;
  2188.               DECLARE HOLD ADDRESS,
  2189.                       LOC BASED HOLD(1) BYTE;
  2190.               CALL CONV$TO$BIN$ADDR;
  2191.               HOLD = GETSPACE(2);
  2192.               LOC(0) = 1;
  2193.               LOC(1) = BRA(0);
  2194.               ARA = HOLD;
  2195.               CALL FLAGSTRINGADDR(TRUE);
  2196.          END;
  2197.  
  2198.  /* 83 LEFT END OF STRING */
  2199.          CALL STRING$SEGMENT(0);
  2200.  
  2201.  /* 84 LENGTH OF STRING */
  2202.        DO;
  2203.             DECLARE LENGTH BYTE;
  2204.             LENGTH = GET$STRING$LEN(ARA);
  2205.             CALL STRING$FREE;
  2206.             CALL FLOAT$ADDR(LENGTH);
  2207.        END;
  2208.  
  2209.  /* 85 MIDDLE OF STRING */
  2210.          CALL STRING$SEGMENT(2);
  2211.  
  2212.  /* 86 RIGHT END OF STRING */
  2213.          CALL STRING$SEGMENT(1);
  2214.  
  2215.  /* 87 CONVERSION TO STRING */
  2216.           DO;
  2217.                CALL NUMERIC$OUT;
  2218.                CALL MOVE(.PRINTWORKAREA,ARA :=
  2219.                      GETSPACE(PRINTWORKAREA(0) + 1),PRINTWORKAREA(0) + 1);
  2220.                CALL FLAG$STRING$ADDR(TRUE);
  2221.           END;
  2222.  
  2223.  /* 88 VALUE  */
  2224.        DO;
  2225.        CALL FP$INPUT(GET$STRING$LEN(ARA),ARA+1);
  2226.        CALL STRING$FREE;
  2227.          CALL FP$OP$RETURN(9,RA);
  2228.        END;
  2229.  
  2230.  /* 89 COSH */
  2231.          CALL ONE$VALUE$OPS(COSH);
  2232.  
  2233.  /* 90 SINH */
  2234.          CALL ONE$VALUE$OPS(SINH);
  2235.  
  2236.  /* 91 RON  */
  2237.          CALL ROUND$CONV$BIN;
  2238.  
  2239.  /* 92 CKO  */
  2240.          /* RA CONTAINS MAX NUMBER OF LABELS IN THE ON STATEMENT
  2241.             RB CONTAINS SELECTED LABEL.
  2242.             CHECK TO INSURE SELECTED LABEL EXISTS. IF NOT AN ERROR
  2243.             HAS OCCURED */
  2244.          DO;
  2245.               IF (BRBZ := BRBZ - 1) > BRAZ - 1 THEN
  2246.                    CALL ERROR('OI');
  2247.               CALL POP$STACK;
  2248.                BRAZ = SHL(BRAZ,1) + BRAZ + 1;
  2249.          END;
  2250.  /* 93 EXR  */
  2251.          CALL LOGICAL(3);
  2252.  
  2253.  
  2254.  /* 94 DEF  */
  2255.          DO;
  2256.               CALL STEP$INS$CNT;
  2257.               EOFBRANCH(GET$FILE$NUMBER) = TWOBYTEOPRAND;
  2258.               CALL STEP$INS$CNT;
  2259.               CALL POPSTACK;
  2260.          END;
  2261.  
  2262.  
  2263.  /* 95  BOL */
  2264.          DO;
  2265.               CURRENTLINE = ARA;
  2266.               CALL POP$STACK;
  2267.          END;
  2268.  
  2269.  /* 96  ADJ */
  2270.          ARA = ARA + MCD;
  2271.  
  2272.          END;  /* END CASE */
  2273.     CALL STEP$INS$CNT;
  2274.     END;   /* OF DO FOREVER  */
  2275.  
  2276.  
  2277.  
  2278. END EXECUTE;
  2279.     /*
  2280.          ********************************************************
  2281.          *                                                      *
  2282.          ********************************************************
  2283.     */
  2284.  
  2285. MAINLINE:
  2286.     CALL CRLF;
  2287.     CALL INITIALIZE$EXECUTE;
  2288. EOFEXIT:  /* ON END OF FILE OF CURRENT DISK FILE COME HERE */
  2289. ERROR$EXIT:  /* REGROUP ON CONSOLE INPUT ERROR */
  2290.     CALL EXECUTE;
  2291.     CALL EXIT$INTERP;
  2292. END;
  2293.