BASCOM:
DO;

         /* BASIC - E COMPILER MODIFIED FOR RESIDENT OPERATION
         BY GARY A. KILDALL, DIGITAL RESEARCH, PACIFIC GROVE, CA.
         VERSION 1.4  - ORIGINAL DISTRIBUTION BY EUBANKS, NPS,
         VERSION 1.5  - FIXES UNINITIALIZED STORAGE PROBLEMS
                           WFCB(32) = 0,  RFCB(12) = 0, CONT = 0
                           HASHTABLE = 0...0
                        ALLOWS $ PARAMETERS IN CALL, RATHER THAN PROGRAM
          */

    DECLARE JMPTOMAIN (3) BYTE DATA(0C3H,0,0); /* FILLED WITH DDT */


        /*
         *********************************************************
         *                                                       *
         *                   BASIC-E COMPILER                    *
         *                                                       *
         *             U. S. NAVY POSTGRADUATE SCHOOL            *
         *                  MONTEREY, CALIFORNIA                 *
         *                                                       *
         *             WRITTEN BY GORDON EUBANKS, JR.            *
         *                                                       *
         *                    CPM VERSION 1.4                    *
         *                                                       *
         *                     DECEMBER 1976                     *
         *                                                       *
         *********************************************************
        */

        /*
         *********************************************************
         *                                                       *
         *    THE BASIC-E COMPILER IS DIVIDED INTO THE FOLLOW-   *
         *     ING MAJOR SECTIONS:                               *
         *            (1) GLOBAL DECLERATIONS AND LITERAL        *
         *                DEFINITIONS                            *
         *            (2) SYSTEM INPUT OUTPUT ROUTINES AND       *
         *                ASSOCIATED VARIABLE DECLERATIONS       *
         *            (3) SCANNER                                *
         *            (4) SYMBOL TABLE ROUTINES                  *
         *            (5) PARSER AND CODE GENERATION             *
         *                                                       *
         *    BASIC-E REQUIRES A SOURCE PROGRAM AVAILABLE ON     *
         *     AN INPUT DEVICE AND WILL WRITE A BINARY OUTPUT    *
         *     FILE WHICH MAY BE EXECUTED BY THE RUN TIME        *
         *     MONITOR.  THE SOURCE MUST BE READ TWICE.          *
         *     THE NORMAL OUTPUT DEVICE IS THE CONSOLE.          *
         *                                                       *
         *     MODIFICATION OF THE COMPILER FOR OTHER OPERATING  *
         *     SYSTEMS WILL REQUIRE MODIFICATIONS TO SECTION     *
         *     (2) AND IN SECTION 1 REDEFINITION OF LITERALS IN  *
         *     SECTIONS "SYSTEM PARAMETERS WHICH MAY REQUIRE     *
         *     MODIFICATION BY USERS" AND "EXTERNAL ENTRY        *
         *     POINTS".  OTHER CHANGES SHOULD NOT BE REQUIRED    *
         *                                                       *
         *********************************************************
        */


        /*
         **********************************************************
         *                                                        *
         *          ****     SECTION   1     ****                 *
         *                                                        *
         **********************************************************
        */
        /*
         *********************************************************
         *                                                       *
         *                   GLOBAL LITERALS                     *
         *                                                       *
         *********************************************************
        */

$INCLUDE(:F1:BASCOM.LIT)

        /*
         *********************************************************
         *                                                       *
         *                EXTERNAL ENTRY POINTS                  *
         *    THESE ENTRY POINTS ALLOW INTERFACING WITH CP/M     *
         *                                                       *
         *********************************************************
        */

DECLARE
        BDOS    LIT            '05H',  /* ENTRY POINT TO CP/M */
        PARMS   LIT            '6DH',  /* $ PARAMETERS */
        BOOT    LIT            '0H';   /* RETURN TO SYSTEM */


MON1: PROCEDURE(F,A);
    DECLARE F BYTE, A ADDRESS;
    /* PATCHED WITH JMP 0005 */
    L: GO TO L;
    END MON1;

MON2: PROCEDURE(F,A) BYTE;
    DECLARE F BYTE, A ADDRESS;
    /* PATCHED WITH JMP 0005 */
    L: GO TO L;
    RETURN 0;
    END MON2;

MON3: PROCEDURE PUBLIC;
    /* USED TO RETURN TO CP/M */
    DECLARE A ADDRESS; A = BOOT;
    CALL A;
    END MON3;


        /*
         *********************************************************
         *                                                       *
         *                  GLOBAL VARIABLES                     *
         *                                                       *
         *********************************************************
        */
DECLARE
        PASS1  BYTE PUBLIC INITIAL(TRUE),     /* PASS1 FLAG */
        PASS2  BYTE PUBLIC INITIAL(FALSE),      /* PASS2 FLAG */
               /*
                  COMPILER TOGGLES
               */
        LISTPROD     BYTE PUBLIC INITIAL(FALSE),
        LISTSOURCE   BYTE PUBLIC INITIAL(FALSE),
        DEBUGLN      BYTE PUBLIC INITIAL(FALSE),
        LOWERTOUPPER BYTE INITIAL(TRUE),
        NOINTFILE    BYTE INITIAL(FALSE),
        LSTFLAG      BYTE INITIAL(FALSE),  /* LST DEVICE IF 'F' */
        ERRSET       BYTE INITIAL(FALSE),
        ERRORCOUNT   ADDRESS PUBLIC INITIAL(0),
        COMPILING    BYTE PUBLIC,
        DATACT       ADDRESS PUBLIC, /* COUNTS SIZE OF DATA AREA */


  /*   FLAGS USED DURING CODE GENERATION */
        FORSTMT      BYTE PUBLIC,
        RANDOMFILE   BYTE PUBLIC,
        FILEIO       BYTE PUBLIC,
        INPUTSTMT    BYTE PUBLIC,
        GOSUBSTMT    BYTE PUBLIC,

  /*   THE FOLLOWING GLOBAL VARIABLES ARE USED BY THE SCANNER      */

        TOKEN     BYTE PUBLIC,  /* TYPE OF TOKEN JUST SCANNED */
        SUBTYPE   BYTE PUBLIC,  /* SUBTYPE OF CURRENT TOKEN */
        FUNCOP    BYTE PUBLIC,  /* IF TOKEN FUNC THEN THIS IS FUNC NUMBER */
        HASHCODE  BYTE PUBLIC,  /* HASH VALUE OF CURRENT TOKEN */
        NEXTCHAR  BYTE PUBLIC,  /* CURRENT CHARACTER FROM GETCHAR */
        ACCUM(IDENTSIZE)     BYTE PUBLIC,  /* HOLDS CURRENT TOKEN */
        ACCLEN BYTE PUBLIC AT(.ACCUM(0)),   /* ACCUM 0 IS LENGTH */
        CONT    BYTE PUBLIC,  /* INDICATES ACCUM WAS FULL, STILL MORE */
        COLUMN  BYTE INITIAL(0),  /* CURRENT COLUMN */

            /*
             **************************************************
             *                                                *
             *  THE FOLLOWING LITERAL DEFINITIONS ESTABLISH   *
             *  MNEMONIC NAMES FOR THE TOKENS WHICH ARE THE   *
             *  OUTPUT OF THE LALR PARSER PROGRAM.            *
             *                                                *
             **************************************************
            */
        POUND LIT '12', LPARN LIT '02', RPARN  LIT '05',
        ASTRK LIT '04', TPLUS LIT '03', TMINUS LIT '07',
        LESST LIT '01', TCOLIN LIT '11', SCOLN  LIT '06',
        EXPON LIT '14', EQUAL LIT '13', GTRT   LIT '10',
        TDATA LIT '99', TAND  LIT '24', TCR    LIT '23',
        TELSE LIT '34', TDEF  LIT '25', TDIM   LIT '26',
        TFOR  LIT '28', TEND  LIT '27', TFILE  LIT '35',
        TIF   LIT '17', TGOSB LIT '43', TGOTO  LIT '36',
        TNEXT LIT '37', TINPT LIT '44', TLET   LIT '29',
        SLASH LIT '08', TNOT  LIT '30', TON    LIT '20',
        TOR   LIT '21', TPRNT LIT '45', TREAD  LIT '38',
        TREST LIT '48', TRETN LIT '46', TSTEP  LIT '39',
        TSTOP LIT '40', TTHEN LIT '41', TTO    LIT '22',
        FUNCT LIT '53', TGEQ  LIT '15', TSUB   LIT '32',
        TLEQ  LIT '18', COMMA LIT '09', TGO    LIT '16',
        TNE   LIT '19', TCLOS LIT '42', TXOR   LIT '33',
        TOUT  LIT '31', TIRN LIT '51',  STRING LIT '50',
        IDENTIFIER LIT '52',            FLOATPT LIT '49',
        UDFUNCT LIT '54',               TREM LIT '0';

        /*
         *********************************************************
         *                                                       *
         *       ****       SECTION    2       ****              *
         *                                                       *
         *      SYSTEM DEPENDENT ROUTINES AND VARIABLES          *
         *                                                       *
         *            THE FOLLOWING ROUTINES ARE USED            *
         *            BY THE COMPILER TO ACCESS DISK             *
         *            FILES AND THE CONSOLE.  THESE              *
         *            ROUTINES ASSUME THE USE OF THE             *
         *            CP/M DISK OPERATING SYSTEM.                *
         *                                                       *
         *      THE FCB'S ARE USED BY THE SYSTEM TO MAINTAIN     *
         *      INFORMATION ON OPEN FILES.  THEY ARE ONLY USED   *
         *      BY PROCEDURES IN THIS SECTION.  THE BUFFERS      *
         *      AND POINTERS TO THE BUFFERS ARE USED BY THE      *
         *      REMAINDER OF THE PROGRAM BUT THEIR SIZE MAY      *
         *      BE VARIED TO SUIT THE DISK SYSTEM BEING USED     *
         *                                                       *
         *********************************************************
        */

DECLARE
        PARMLIST(9) BYTE INITIAL('         '),  /* $ PARAMS SAVED HERE */
        RFCBADDR    ADDRESS INITIAL(5CH),
            /* NOTE: CP/M PROVIES 5CH AS FCB AREA AND 80H AS A
                     BUFFER FOR PROGRAM USE */
        RFCB BASED RFCBADDR(33)    BYTE,  /* SOURCE FCB */
        WFCB(33)                   BYTE  /* INTERMEDIATE FILE FCB */
                                   INITIAL(0,'        ','INT',0,0,0,0),
        SBLOC                      ADDRESS INITIAL(80H),
        SOURCEBUFF BASED SBLOC(SOURCERECSIZE)BYTE,  /* SOURCE BUFFER */
        SOURCEPTR       BYTE INITIAL(SOURCERECSIZE), /* BUFFER INDEX */
        CURSOURCERECSIZE BYTE INITIAL(SOURCERECSIZE),
        DISKOUTBUFF(INTRECSIZE)      BYTE,
        BUFFPTR            BYTE INITIAL(255), /* BUFFER INDEX */
        LINEBUFF(CONBUFFSIZE)        BYTE,  /* CONSOLE OUT BUFFER */
        LINEPTR            BYTE INITIAL(0), /* BUFFER INDEX */
        LINENO ADDRESS PUBLIC,    /* CURRENT LINE NUMBER */
        SEPARATOR BYTE   PUBLIC INITIAL(COLIN);

          DECLARE
                  PCHAR    LIT    '2',  /* CHAR TO CONSOLE */
                  PBUFF    LIT    '9',  /* BUFFER TO CONSOLE */
                  RCHAR    LIT    '1',  /* CHAR FROM CONSOLE */
                  RBUFF    LIT   '10',  /* BUFFER FROM CONSOLE */
                  OFILE    LIT   '15',  /* OPEN FILE */
                  CFILE    LIT   '16',   /* CLOSE FILE */
                  DFILE    LIT   '19',  /* DELETE FILE */
                  RFILE    LIT   '20',  /* READ FILE */
                  WFILE    LIT   '21',  /* WRITE FILE */
                  MFILE    LIT   '22',  /* MAKE FILE */
                  SDMA     LIT   '26',  /* SET DMA */
                  FILEERR  LIT  '255',  /* ERROR RTN CODE */
                  FILEEOF  LIT    '1';  /* EOF RTN CODE */

MOVE: PROCEDURE (SOURCE,DEST,COUNT) PUBLIC;
    DECLARE
            SOURCE ADDRESS,
            DEST   ADDRESS,
            COUNT     BYTE,
            SCHAR BASED SOURCE BYTE,
            DCHAR BASED DEST   BYTE;

    DO WHILE(COUNT := COUNT -1) <> 255;
         DCHAR = SCHAR;
         SOURCE = SOURCE + 1;
         DEST = DEST + 1;
         END;
    RETURN;
END MOVE;

FILL: PROCEDURE (DEST,CHAR,COUNT) PUBLIC;
      /* MOVE CHAR TO A N TIMES */
    DECLARE
            DEST        ADDRESS,
            CHAR        BYTE,
            COUNT       BYTE,
            DCHAR       BASED     DEST     BYTE;
     DO WHILE (COUNT := COUNT -1) <> 255;
          DCHAR = CHAR;
          DEST = DEST + 1;
          END;
    RETURN;
END FILL;


CHAROUT: PROCEDURE(CHAR);
    DECLARE CHAR BYTE;
    IF LSTFLAG THEN /* GO TO THE LIST DEVICE */
        CALL MON1(5,CHAR); ELSE CALL MON1(2,CHAR);
    END CHAROUT;

PRINTCHAR: PROCEDURE(CHAR);
    DECLARE CHAR BYTE;
    /* CHECK FOR TABS AND END OF LINE */
    IF CHAR = TAB THEN /* EXPAND TO NEXT COLUMN */
        DO WHILE ((COLUMN := COLUMN + 1) AND 7) <> 0;
        CALL CHAROUT(' ');
        END; ELSE
        DO; COLUMN = COLUMN + 1; CALL CHAROUT(CHAR);
        IF CHAR = LF THEN COLUMN = 0;
        END;
END PRINTCHAR;

PRINT: PROCEDURE(A) PUBLIC;
    DECLARE A ADDRESS;
    DECLARE MSG BASED A BYTE;
        DO WHILE MSG <> '$';
        CALL PRINTCHAR(MSG);
        A = A + 1;
        END;
END PRINT;


DISKERR: PROCEDURE;
    CALL PRINT(.('DE    $'));
    CALL MON3;  /* RETURN TO SYSTEM */
    RETURN;
END DISKERR;

OPEN$SOURCEFILE: PROCEDURE;
    /*  SETS UP THE FCB FOR THE SOURCE PROGRAM
        WHICH MUST BE OF TYPE 'BAS' AND THEN OPENS
        THE FILE.  CP/M PUTS THE NAME USED AS A
        PARAMETER WHEN THE COMPILER IS EXECUTED, AT
        5CH.
    */

    CALL MOVE(.('BAS'),RFCBADDR+9,3);
    RFCB(32),RFCB(12) = 0;
    IF MON2(OFILE,RFCBADDR) = FILEERR THEN
         DO;
              CALL PRINT(.('NS $'));
              CALL MON3;  /* RETURN TO SYSTEM */
         END;
END OPEN$SOURCEFILE;


REWIND$SOURCE$FILE: PROCEDURE PUBLIC;
    /* CP/M DOES NOT REQUIRE ANY ACTION PRIOR TO REOPENING */
    RETURN;
END REWIND$SOURCE$FILE;


CLOSE$INT$FILE: PROCEDURE PUBLIC;
    IF MON2(CFILE,.WFCB) = FILEERR THEN
         CALL DISKERR;
END CLOSE$INT$FILE;

SETUP$INT$FILE: PROCEDURE PUBLIC;
     /*  MAKES A NEW FILE */
    IF NOINTFILE THEN  /* ONLY MAKE FILE IF THIS TOGGLE IS OFF */
         RETURN;
    CALL MOVE(.RFCB,.WFCB,9);
    CALL MON1(DFILE,.WFCB);
    IF MON2(MFILE,.WFCB) = FILEERR THEN
         CALL DISKERR;
    WFCB(32) = 0; /* ZERO NEXT RECORD */
 END SETUP$INT$FILE;

READ$SOURCE$FILE: PROCEDURE BYTE;
    DECLARE DCNT BYTE;
    IF(DCNT := MON2(RFILE,RFCBADDR)) > FILEEOF THEN
         CALL DISKERR;
    RETURN DCNT; /* ZERO IF READ ELSE 1 IF EOF - ERRORS > 1 */
END READ$SOURCE$FILE;


WRITE$INT$FILE: PROCEDURE PUBLIC;
    IF NOINTFILE THEN
         RETURN;
    CALL MON1(SDMA,.DISKOUTBUFF);
    IF MON2(WFILE,.WFCB) <> 0 THEN
         CALL DISKERR;
    CALL MON1(SDMA,80H); /* RESET DMA ADDRESS */
END WRITE$INT$FILE;


CRLF: PROCEDURE PUBLIC;
     CALL PRINTCHAR(EOLCHAR);
     CALL PRINTCHAR(LF);
    RETURN;
END CRLF;


PRINT$DEC: PROCEDURE(VALUE) PUBLIC;
    /*
        CONVERTS VALUE TO A DECIMAL NUMBER WHICH IS PRINTED
        ON THE CONSOLE.  USED FOR LINENUMBERING STATEMENTS
        AND TO PRINT PRODUCTIONS.
    */
    DECLARE
            VALUE ADDRESS,
            I     BYTE,
            FLAG  BYTE,
            COUNT BYTE;
    DECLARE DECIMAL(4) ADDRESS DATA(1000,100,10,1);
    FLAG = FALSE;
    DO I = 0 TO 3;
         COUNT = 30H;
         DO WHILE VALUE >= DECIMAL(I);
              VALUE = VALUE - DECIMAL(I);
              FLAG = TRUE;
              COUNT = COUNT + 1;
         END;
         IF FLAG OR (I >= 3) THEN
              CALL PRINTCHAR(COUNT);
         ELSE
              CALL PRINTCHAR(' ');
    END;
    RETURN;
END PRINTDEC;


SETFLAGS: PROCEDURE PUBLIC;
    /*
       RESET COMPILER FLAGS USED DURING PARSING
    */
      RANDOMFILE,FILEIO,
      INPUTSTMT, FORSTMT, GOSUBSTMT = FALSE;
END SETFLAGS;


        /*
         *********************************************************
         *                                                       *
         *     THE FOLLOWING ROUTINE GENERATES THE INTERMEDIATE  *
         *     LANGUAGE FILE. EMIT IS THE ONLY ROUTINE TO        *
         *     ACTUALLY WRITE TO THE DISK.  GENERATE, EMITDAT,   *
         *     AND EMITCON CALL EMIT.                            *
         *                                                       *
         *********************************************************
        */



EMIT: PROCEDURE(OBJCODE) PUBLIC;
    DECLARE OBJCODE BYTE;
    IF (BUFFPTR:=BUFFPTR + 1) >= INTRECSIZE THEN /* WRITE TO DISK */
         DO;
              CALL WRITE$INT$FILE;
              BUFFPTR = 0;
         END;
    DISKOUTBUFF(BUFFPTR) = OBJCODE;
    RETURN;
END EMIT;


        /*
         *********************************************************
         *                                                       *
         *           ***     SCANNER SECTION     ***             *
         *                                                       *
         *********************************************************
        */

CLEAR$LINE$BUFF: PROCEDURE;
    CALL FILL(.LINEBUFF,' ',CONBUFFSIZE);
END CLEAR$LINE$BUFF;


LIST$LINE: PROCEDURE(LENGTH);
    DECLARE
            LENGTH BYTE,
            I      BYTE;
    CALL PRINT$DEC(LINENO);
    CALL PRINT$CHAR(SEPARATOR);
    CALL PRINT$CHAR(' ');
    DO I = 0 TO LENGTH;
         CALL PRINT$CHAR(LINEBUFF(I));
         END;
    CALL CRLF;
    CALL CLEAR$LINE$BUFF;
    SEPARATOR = COLIN;
END LIST$LINE;

        /*
         **********************************************************
         *                                                        *
         *    GETCHAR SETS THE GLOBAL VARIABLE NEXTCHAR TO THE    *
         *    NEXT SOURCEFILE CHARACTER AND RETURNS NEXTCHAR TO   *
         *    THE CALLING ROUTINE.                                *
         *                                                        *
         *    TABS ARE REPLACED WITH A BLANK AND IF EITHER        *
         *    LISTSOURCE IS TRUE OR AN ERROR HAS OCCURED LINES    *
         *    ARE OUTPUT TO THE CONSOLE.                          *
         *                                                        *
         **********************************************************
        */

GETCHAR: PROCEDURE BYTE PUBLIC;
    DECLARE ADDEND(*) BYTE
         DATA ('END',EOLCHAR,LF); /*TO ADD END IF LEFT OFF */
    NEXT$SOURCE$CHAR: PROCEDURE BYTE;
         RETURN SOURCEBUFF(SOURCEPTR);
    END NEXT$SOURCE$CHAR;

    CHECKFILE: PROCEDURE BYTE;
         /*
              CHECKFILE MAINTAINS THE SOURCE BUFFER FULL AND
              CHECKS FOR END OF FILE ON THE SOURCE FILE.
              IF A LINE FEED IS FOUND IT IS SKIPPED.
              IF END OF FILE IS DETECTED THEN TRUE IS RETURNED
              ELSE FALSE IS RETURNED.
         */
         DO FOREVER;  /* ALLOW US TO SKIP LINE FEEDS */
              IF (SOURCEPTR := SOURCEPTR + 1) >= CURSOURCERECSIZE THEN
                   DO;
                        SOURCEPTR = 0;
                        IF READ$SOURCE$FILE = FILEEOF THEN
                             RETURN TRUE;
                   END;
              IF (NEXTCHAR := NEXT$SOURCE$CHAR) <> LF THEN
                   RETURN FALSE;
         END;  /* OF DO FOREVER */
    END CHECKFILE;

    IF CHECKFILE OR (NEXTCHAR = EOFFILLER)  THEN
                   DO; /* EOF REACHED */
                        CALL MOVE(.ADDEND,SBLOC,5);
                        SOURCEPTR = 0;
                        NEXTCHAR = NEXT$SOURCE$CHAR;
                   END;
       IF LINEPTR < CONBUFFSIZE THEN
              LINEBUFF(LINEPTR := LINEPTR + 1) = NEXTCHAR;  /* OUTPUT LINE */
         IF NEXTCHAR = EOLCHAR THEN
              DO;
                   LINENO = LINENO + 1;
                   IF LISTSOURCE OR ERRSET THEN
                        CALL LISTLINE(LINEPTR - 1);  /* NOT EOLCHAR */
                   LINEPTR = 0;
              END;
    IF NEXTCHAR = TAB THEN
         NEXTCHAR = ' ';  /* ONLY NEED REPLACE WITH 1 BLANK  */
    RETURN NEXTCHAR;
END GETCHAR;


GETNOBLANK: PROCEDURE;
    DO WHILE((GETCHAR = ' ') OR (NEXTCHAR = EOFFILLER));
         END;
    RETURN;
END GETNOBLANK;




CHECK$CONTINUATION: PROCEDURE;
    /*
        CHECK FOR CONTINUATION CHAR. IF FOUND SET NEXTCHAR
        TO FIRST CHARACTER ON NEXT LINE.  IT THEN LOOKS TO
        THE PARSER AS IF IT WAS ALL ONE LINE.
    */
    IF NEXTCHAR = CONTCHAR THEN
         DO;
              DO WHILE GETCHAR <> EOLCHAR;
                   END;
              CALL GETNOBLANK;
         END;
    RETURN;
END CHECK$CONTINUATION;


        /*
         **********************************************************
         *                                                        *
         *    ERROR IS THE COMPILER ERROR HANDLING ROUTINE        *
         *    IF AN ERROR IS DETECTED WHILE PARSING A STATEMENT   *
         *    THE REMAINDER OF THE STATEMENT IS SKIPPED AND THE   *
         *    STATEMENT IS WRITTEN ON THE CONSOLE FOLLOWED BY A   *
         *    TWO LETTER DISCRIPTION OF THE ERROR. AN UP ARROR    *
         *    INDICATES WHERE IN THE LINE THE ERROR WAS DETECTED  *
         *    THE PARSER IS RESET AND COMPILATION CONTINUES WITH  *
         *    THE NEXT STATEMENT.                                 *
         *                                                        *
         **********************************************************
        */

ERROR: PROCEDURE(ERRCODE) PUBLIC;
       DECLARE
               ERRCODE ADDRESS,
               POINTER BYTE;
    POINTER = LINEPTR + 2;
    IF PASS2 THEN
         ERRSET = TRUE;  /* SO SOURCE LINE WILL BE LISTED */
    IF TOKEN <> TCR THEN
         DO;  /* SKIP REMAINDER OF LINE */
              DO WHILE NEXTCHAR <> EOLCHAR;
                   CALL CHECK$CONTINUATION;
                   NEXTCHAR = GETCHAR;
                   END;
              CALL GET$NO$BLANK;
         END;
    IF PASS2 THEN
         DO;       /* PRINT ERROR MESSAGE */
              ERRORCOUNT = ERRORCOUNT + 1;
              CALL PRINTCHAR(HIGH(ERRCODE));
              CALL PRINTCHAR(LOW(ERRCODE));
              CALL PRINTCHAR(QUESTIONMARK);
              DO WHILE(POINTER:=POINTER - 1) >= 1;
                   CALL PRINTCHAR(' ');
                   END;
              CALL PRINTCHAR(UPARROW);
              CALL CRLF;
         END;
    ERRSET, COMPILING = FALSE;
    CALL SETFLAGS;
    RETURN;
  END ERROR;

        /*
         *********************************************************
         *                                                       *
         *    INITIALIZE$SCANNER SETS NEXTCHAR TO THE FIRST      *
         *    NON-BLANK CHARACTER ON THE INPUT FILE AND          *
         *    INITIALIZES THE OUTPUTLINE COUNTER AND POINTER     *
         *                                                       *
         *    INITIALIZE$SCANNER IS CALLED AT THE BEGINNING OF   *
         *    PASS ONE AND PASS TWO.                             *
         *                                                       *
         *********************************************************
        */
IN$SCANNER: PROCEDURE PUBLIC;
    DECLARE COUNT BYTE;
    DECLARE I BYTE;
    IF PASS1 THEN /* GET PARAMETER LIST */
        CALL MOVE(PARMS,.PARMLIST,8); /* LAST BLANK IS LEFT UNFILLED */
    CALL OPEN$SOURCEFILE;
    CONT,COLUMN,LINENO,LINEPTR = 0;
    CALL CLEAR$LINE$BUFF;
    SOURCEPTR = SOURCERECSIZE;
    SEPARATOR = COLIN;
    CALL GETNOBLANK;
    IF PARMLIST(0) = '$' THEN
         DO; I = 0;
              DO WHILE (COUNT := PARMLIST(I:=I+1)) <> ' ';
                   IF(COUNT := COUNT - 'A') <= 5 THEN
                        DO CASE COUNT;
                             LISTPROD = TRUE;
                             LISTSOURCE = FALSE;
                             NOINTFILE = TRUE;
                             LOWERTOUPPER = FALSE;
                             DEBUGLN = TRUE;
                             LSTFLAG = TRUE;
                        END; /* OF CASE */
              END;
         END;
END IN$SCANNER;


        /*
         *********************************************************
         *                                                       *
         *    THE SCANNER ACCEPTS INPUT CHARACTERS FROM THE      *
         *    SOURCE FILE RETURNING TOKENS TO THE PARSER.        *
         *    CONVERSION TO UPPERCASE IS PERFORMED WHEN SCAN-    *
         *    NING IDENTIFIERS UNLESS LOWERTOUPPER IS FALSE.     *
         *    BLANKS ARE IGNORED.  EACH TOKEN IS PLACED IN       *
         *    ACCUM.  ACCLEN   IS THE LENGTH OF THE TOKEN.       *
         *    THE TOKEN IS HASHCODED BY SUMMING EACH ASCII       *
         *    CHARACTER MODULO HASHTBLSIZE AND THE RESULT IS     *
         *    RETURNED IN HASHCODE.  SUBTYPE AND FUNCOP ARE      *
         *    SET IF THE TOKEN IS A PREDEFINED FUNCTION.         *
         *    REM AND DATA STATEMENTS ARE HANDLED COMPLETELY     *
         *    BY THE SCANNER. IF THE RESERVED WORD REM OR        *
         *    REMARK IS DETECTED THE INPUT IS SCANNED UNTIL      *
         *    THE END OF THE CURRENT INPUT LINE IS LOCATED.      *
         *    THE NEXT TOKEN (A CARRIAGE RETURN) IS THEN         *
         *    SCANNED AND RTURNED. DATA STATEMENTS ARE SIMILAR   *
         *    EXCEPT THE DATA IS WRITTEN OUT USEING EMITDAT      *
         *                                                       *
         *********************************************************
        */
SCANNER: PROCEDURE PUBLIC;

        /*
         **********************************************************
         *                                                        *
         *    THE FOLLOWING UTILITY PROCEDURES ARE USED BY THE    *
         *    SCANNER.                                            *
         *                                                        *
         **********************************************************
        */

    PUTINACCUM: PROCEDURE;
         IF NOT CONT THEN
              DO;
                   ACCUM(ACCLEN := ACCLEN + 1) = NEXTCHAR;
                   HASHCODE = (HASHCODE + NEXTCHAR) AND HASHMASK;
                   IF ACCLEN >= (IDENTSIZE - 1) THEN
                        CONT = TRUE;
              END;
         RETURN;
    END PUTINACCUM;


    PUTANDGET: PROCEDURE;
         CALL PUTINACCUM;
         CALL GETNOBLANK;
         RETURN;
    END PUTANDGET;


    PUTANDCHAR: PROCEDURE;
         CALL PUTINACCUM;
         NEXTCHAR = GETCHAR;
         RETURN;
    END PUTANDCHAR;


    NUMERIC: PROCEDURE BYTE;
         RETURN(NEXTCHAR - '0') <= 9;
    END NUMERIC;

    LOWERCASE: PROCEDURE BYTE;
         RETURN (NEXTCHAR >= 61H) AND (NEXTCHAR <= 7AH);
    END LOWER$CASE;


    DECIMALPT: PROCEDURE BYTE;
         RETURN NEXTCHAR = '.';
    END DECIMALPT;


    CONV$TO$UPPER: PROCEDURE;
         IF LOWERCASE AND LOWERTOUPPER THEN
              NEXTCHAR = NEXTCHAR AND 5FH;
         RETURN;
    END CONV$TO$UPPER;


    LETTER: PROCEDURE BYTE;
        CALL CONV$TO$UPPER;
         RETURN ((NEXTCHAR - 'A') <= 25) OR LOWERCASE;
    END LETTER;


    ALPHANUM: PROCEDURE BYTE;
         RETURN NUMERIC OR LETTER OR DECIMALPT;
    END ALPHANUM;


    SPOOLNUMERIC: PROCEDURE;
         DO WHILE NUMERIC;
              CALL PUTANDCHAR;
              END;
         RETURN;
    END SPOOLNUMERIC;


    SETUP$NEXT$CALL: PROCEDURE;
         IF NEXTCHAR = ' ' THEN
              CALL GETNOBLANK;
         CONT = FALSE;
         RETURN;
    END SETUP$NEXT$CALL;

EMITDAT: PROCEDURE(OBJCODE);
     /*
       WRITES DATA STATEMENTS DURING PASS2 AND
       COUNTS SIZE OF DATA AREA.
     */
    DECLARE OBJCODE BYTE;
    DATACT = DATACT + 1;
    IF PASS2 THEN
         CALL EMIT(OBJCODE);
    RETURN;
END EMITDAT;

        /*
         *********************************************************
         *                                                       *
         *      LOOKUP IS CALLED BY THE SCANNER WITH THE         *
         *       PRINTNAME OF THE CURRENT TOKEN IN               *
         *      THE ACCUMULATOR.  LOOKUP DETERMINES IF THIS      *
         *      TOKEN IS A RESERVED WORD AND  SETS THE           *
         *      VALUE OF TOKEN.  IF THE TOKEN IS A PREDEFINED    *
         *      FUNCTION THEN THE SUBTYPE AND FUNCOP ARE ALSO    *
         *      SET.                                             *
         *      THE RESERVED WORD TABLE IS DIVIDED INTO 7        *
         *      TABLES FOR RESERVED WORDS OF LENGTH 1 TO 7.      *
         *      THE FOLLOWING VECTORS ARE ALSO USED:             *
         *          TK - TOKEN ASSOCIATED WITH RESERVED WORD     *
         *          OFFSET - INDEX INTO LNG VECTOR FOR A GIVEN   *
         *                   R/W LENGTH                          *
         *          COUNT - NUMBER OF R/W OF A GIVEN LENGTH      *
         *          TKOS - INDEX INTO TK FOR A GIVEN R/W LENGTH  *
         *          ST - SPECIAL DATA FOR PREDEFINED FUNCTIONS   *
         *                                                       *
         *      PREDEFINED FUNCTIONS HAVE TOKEN VALUES >64.      *
         *      THIS NUMBER BECOMES THE FUNCOP AND THE TOKEN     *
         *      IS FUNCT.  FUNCOP IS THE MACHINE CODE FOR THE    *
         *      PARTICULAR PREDEFINED FUNCTION.                  *
         *                                                       *
         *********************************************************
        */

    LOOKUP: PROCEDURE BYTE;

         DECLARE MAXRWLNG LIT '9';  /* MAX LENGTH OF A RESERVED WORD */

         DECLARE LNG1(*) BYTE
             DATA(EOLCHAR,'<','(','+','*',')','-',',','=','/',
                           ';','>',':',POUNDSIGN,UPARROW),  /*  15  */
                 LNG2(*) BYTE
                      DATA('IF','TO','GO','ON','OR','EQ','LT','GT',
                           'LE','GE','NE'),       /*  11  */
                 LNG3(*) BYTE
                       DATA('FOR','LET','REM','DIM','DEF','NOT','AND',
                           'TAN','SIN','COS','SQR','TAB','LOG','LEN',
                           'FRE','ATN','ABS','EXP','INT','END','POS',
                           'RND','SGN','INP','ASC','VAL','XOR','SUB',
                            'OUT'),
                                      /*  29  */
                 LNG4(*) BYTE DATA('THEN','READ','GOTO','ELSE','NEXT',
                           'STOP','DATA','FILE','CHR$','MID$',
                           'STEP','STR$','COSH','SINH'),  /*  14  */
                 LNG5(*) BYTE DATA('PRINT','INPUT','GOSUB','CLOSE',
                                     'LEFT$'),           /*  5  */
                 LNG6(*) BYTE DATA('RETURN','RIGHT$','REMARK'),  /* 3 */
                 LNG7(*) BYTE DATA('RESTORE'),  /*  1  */
                 LNG9(*) BYTE DATA('RANDOMIZE'),
                 TK(*) BYTE  DATA(0,TCR,LESST,LPARN,TPLUS,ASTRK,RPARN,TMINUS,
                           COMMA,EQUAL,SLASH,SCOLN,GTRT,TCOLIN,POUND,
                           EXPON,        /* LNG 1 */
                           TIF,TTO,TGO,TON,TOR,EQUAL,LESST,GTRT,TLEQ,
                           TGEQ,TNE,   /* LNG2 */
                           TFOR,TLET,TREM,TDIM,TDEF,TNOT,TAND,
                           72,69,70,73,74,78,84,76,71,65,75,
                           66,TEND,79,67,68,80,81,88,TXOR,TSUB,TOUT,
                                       /* LNG 3 */
                           TTHEN,TREAD,TGOTO,TELSE,TNEXT,TSTOP,TDATA,
                           TFILE,82,85,TSTEP,87,89,90,  /* LNG 4 */
                           TPRNT,TINPT,TGOSB,TCLOS,83,       /* LNG 5 */
                           TRETN,86,TREM,  /* LNG 6 */
                           TREST,TIRN),
               OFFSET(*) BYTE DATA(0,0,15,37,124,180,205,223,230,230),
               COUNT(*) BYTE DATA(0,15,11,29,14,5,3,1,0,1),
               TKOS(*) BYTE DATA(0,0,15,26,55,69,74,77,78,78),
               ST(*) BYTE DATA(1,1,0,1,1,1,1,1,1,1,1,0,0,1,0,1,
                           5,65,70,5,71,70,65,5,1,1);

         DECLARE
                 PTR              ADDRESS,
                 FIELD BASED PTR (1) BYTE,
                 I                BYTE;

         COMPARE: PROCEDURE BYTE;
              DECLARE I BYTE;
              I = 0;
              DO WHILE (FIELD(I) = ACCUM(I := I + 1)) AND I <= ACCLEN;
                   END;
              RETURN I > ACCLEN;
         END COMPARE;

         IF ACCLEN > MAXRWLNG THEN
              RETURN FALSE;
         PTR = OFFSET(ACCLEN) + .LNG1;
         DO I = 1 TO COUNT(ACCLEN);
              IF COMPARE THEN
                   DO;

                        IF((TOKEN := TK(TKOS(ACCLEN) + I)) > 64) AND
                           (TOKEN <> TDATA) THEN
                             DO;
                                  SUBTYPE = ST(TOKEN - 65);
                                  FUNCOP = TOKEN;
                                  TOKEN = FUNCT;
                             END;
                        RETURN TRUE;
                   END;
              PTR = PTR + ACCLEN;
              END;
         RETURN FALSE;
    END LOOKUP;


    DO FOREVER;  /* TO HANDLE REM, DAT AND CONTINUATION */
    ACCLEN, HASHCODE, TOKEN, SUBTYPE = 0;
        /* FIRST CASE - IS THIS A STRING OR THE CONTINUATION
           OF A STRING?  (ONLY STRINGS MAY BE CONTINUED)
        */
    IF(NEXTCHAR = STRINGDELIM) OR CONT THEN
         DO; /* FOUND STRING */
              TOKEN = STRING;
              CONT = FALSE;
              DO FOREVER;  /* ALLOWS "" IN STRING TO BE " */
                   DO WHILE GETCHAR <> STRINGDELIM;
                   IF NEXTCHAR = EOLCHAR THEN CALL ERROR('US');
                        CALL PUTINACCUM;
                        IF CONT THEN RETURN;
                        END;
                   CALL GETNOBLANK;
                   IF NEXTCHAR <> STRINGDELIM THEN
                        RETURN;
                   CALL PUT$IN$ACCUM;
              END; /* OF DO FOREVER */
         END; /* OF RECOGNIZING A STRING */
       /*
           NEXT CASE IS A NUMERIC WHICH MUST START WITH A
           NUMBER OR WITH A PERIOD
           ONLY FIRST IDENTSIZE CHARACTERS ARE RETAINED
       */
  ELSE IF NUMERIC OR DECIMALPT THEN
         DO; /* HAVE DIGIT */
              TOKEN = FLOATPT;
               DO WHILE NEXTCHAR = '0'; /* ELIM LEADING ZEROS */
                    NEXTCHAR = GETCHAR;
                    END;
              CALL SPOOLNUMERIC;  /* GET ALL THE NUMBERS */
              IF DECIMALPT THEN
                   DO;
                        CALL PUTANDCHAR;
                        CALL SPOOLNUMERIC;
                   END;
              CALL CONV$TO$UPPER;
              IF NEXTCHAR = 'E' THEN
                   DO;  /* A FLOATING POINT NUMBER */
                        CALL PUTANDGET;
                        IF (NEXTCHAR = '+') OR (NEXTCHAR='-') THEN
                             CALL PUTANDGET;
                        IF NOT NUMERIC THEN
                             CALL ERROR('IF');
                        CALL SPOOL$NUMERIC;
                   END;
               IF ACCLEN = 0 THEN
                    HASHCODE, ACCUM(ACCLEN := 1) = '0';
              CALL SETUP$NEXT$CALL;
              RETURN;
         END; /* OF RECOGNIZING NUMERIC CONSTANT */

       /*
           NEXT CASE IS IDENTIFIER. MAY BE RESERVED WORD
           IN WHICH CASE MAY BE REM, OR DATA. THESE STATEMENTS
           ARE HANDLED BY THE SCANNER VICE THE PARSER AND THEN
           ANOTHER LOOP THROUGH THE SCANNER IS MADE.
           ONLY IDENTSIZE-1 CHARACTERS ARE RETAINED
       */
    ELSE IF LETTER THEN
         DO; /* HAVE A LETTER */
              DO WHILE ALPHANUM;
                   CALL PUTANDCHAR;
                   END;
              IF NEXTCHAR = '$' THEN
                   DO;
                        SUBTYPE = STRING;
                        CALL PUTANDCHAR;
                   END;
              ELSE
                   SUBTYPE = FLOATPT;
              IF NOT LOOKUP THEN
                   DO;
                        IF ACCUM(1) = 'F' AND ACCUM(2) = 'N'
                                AND ACCLEN <> 1 THEN
                             TOKEN = UDFUNCT;
                        ELSE
                             TOKEN = IDENTIFIER;
                        CALL SETUP$NEXT$CALL;
                        RETURN;
                   END;
              ELSE /* IS A RW */
                   IF TOKEN = TREM THEN
                        DO WHILE NEXTCHAR <> EOLCHAR;
                             NEXTCHAR = GETCHAR;
                             CALL CHECK$CONTINUATION;
                             END;
                   ELSE
                        IF TOKEN = TDATA THEN
                             DO;
                                   DECLARE DAT LIT '51';
                                  CALL EMITDAT(DAT);
                                  CALL EMITDAT(NEXTCHAR);
                                  DO WHILE GETCHAR <> EOLCHAR;
                                       CALL CHECK$CONTINUATION;
                                       CALL EMITDAT(NEXTCHAR);
                                       END;
                                  CALL EMITDAT(',');
                                  CALL EMITDAT(0);
                                  DATACT = DATACT - 1;
                             END;
                        ELSE
                             DO;
                                  CALL SETUP$NEXT$CALL;
                                  RETURN;
                             END;
         END; /* OF RECOGNIZING RW OR IDENT */
        /*
            LAST CASE IS A SPECIAL CHARACTER - IT MAY BE
            THE CONTINUATION CHARACTER IN WHICH CASE JUST
            GO TO NEXT LINE AND SCAN SOMEMORE.
        */
    ELSE
         DO; /* SPECIAL CHARACTER */
              IF NEXTCHAR = CONTCHAR THEN
                   CALL CHECK$CONTINUATION;
              ELSE
                   DO;
                        CALL PUTANDGET;
                        IF NOT LOOKUP THEN
                             CALL ERROR('IC');
                        RETURN;
                   END;
         END; /* OF RECOGNIZING SPECIAL CHAR */
    END;  /* OF DO FOREVER */

END SCANNER;
END;
