ruberon/source/SCAN.ob07

MODULE SCAN;

IMPORT TXT := TEXTDRV,
    ARITH,
    S := STRINGS IN "./strings/STRINGS.ob07",
    ERRORS, LISTS;


CONST

    NUMLEN  = 256;
    IDLEN   = 256;
    TEXTLEN = 512;

    lxUNDEF*   =  0;  lxIDENT*   =  1;  lxINTEGER*   =  2;  lxHEX*     =  3;
    lxCHAR*    =  4;  lxFLOAT*   =  5;  lxSTRING*    =  6;  lxCOMMENT* =  7;
    lxEOF*     =  8;

    lxPLUS*    = 21;  lxMINUS*   = 22;  lxMUL*       = 23;  lxSLASH*   = 24;
    lxNOT*     = 25;  lxAND*     = 26;  lxPOINT*     = 27;  lxCOMMA*   = 28;
    lxSEMI*    = 29;  lxBAR*     = 30;  lxLROUND*    = 31;  lxLSQUARE* = 32;
    lxLCURLY*  = 33;  lxCARET*   = 34;  lxEQ*        = 35;  lxNE*      = 36;
    lxLT*      = 37;  lxGT*      = 38;  lxCOLON*     = 39;  lxRROUND*  = 40;
    lxRSQUARE* = 41;  lxRCURLY*  = 42;  lxLE*        = 43;  lxGE*      = 44;
    lxASSIGN*  = 45;  lxRANGE*   = 46;

    lxKW       = 51;

    lxARRAY*   = 51;  lxBEGIN*   = 52;  lxBY*        = 53;  lxCASE*    = 54;
    lxCONST*   = 55;  lxDIV*     = 56;  lxDO*        = 57;  lxELSE*    = 58;
    lxELSIF*   = 59;  lxEND*     = 60;  lxFALSE*     = 61;  lxFOR*     = 62;
    lxIF*      = 63;  lxIMPORT*  = 64;  lxIN*        = 65;  lxIS*      = 66;
    lxMOD*     = 67;  lxMODULE*  = 68;  lxNIL*       = 69;  lxOF*      = 70;
    lxOR*      = 71;  lxPOINTER* = 72;  lxPROCEDURE* = 73;  lxRECORD*  = 74;
    lxREPEAT*  = 75;  lxRETURN*  = 76;  lxTHEN*      = 77;  lxTO*      = 78;
    lxTRUE*    = 79;  lxTYPE*    = 80;  lxUNTIL*     = 81;  lxVAR*     = 82;
    lxWHILE*   = 83;

    lxERROR01* =  -1;  lxERROR02* =  -2;  lxERROR03* =  -3;  lxERROR04* =  -4;
    lxERROR05* =  -5;  (*lxERROR06* =  -6;*)  lxERROR07* =  -7;  lxERROR08* =  -8;
    lxERROR09* =  -9;  lxERROR10* = -10;  lxERROR11* = -11;  lxERROR12* = -12;
    lxERROR13* = -13;


TYPE

    TEXTSTR* = ARRAY TEXTLEN OF CHAR;
    IDSTR* = ARRAY IDLEN OF CHAR;

    DEF = POINTER TO RECORD (LISTS.ITEM)

        ident: IDSTR

    END;

    STRING* = POINTER TO RECORD (LISTS.ITEM)

        s*: TEXTSTR;
        offset*, offsetW*, hash: INTEGER

    END;

    IDENT* = RECORD

        s*:    IDSTR;
        hash*: INTEGER

    END;

    POSITION* = RECORD

        line*, col*: INTEGER

    END;

    LEX* = RECORD

        sym*:       INTEGER;
        pos*:       POSITION;
        ident*:     IDENT;
        string*:    STRING;
        value*:     ARITH.VALUE;
        error*:     INTEGER

    END;

    SCANNER* = TXT.TEXT;

    KEYWORD = ARRAY 10 OF CHAR;


VAR

    delimiters: ARRAY 256 OF BOOLEAN;

    upto, LowerCase, _if: BOOLEAN;

    strings, def: LISTS.LIST;

    KW: ARRAY 33 OF RECORD upper, lower: KEYWORD; uhash, lhash: INTEGER END;


PROCEDURE enterKW (s: KEYWORD; idx: INTEGER);
    BEGIN
        KW[idx].lower := s;
        KW[idx].upper := s;
        S.UpCase(KW[idx].upper);
        KW[idx].uhash := S.HashStr(KW[idx].upper);
        KW[idx].lhash := S.HashStr(KW[idx].lower);
    END enterKW;


PROCEDURE checkKW (ident: IDENT): INTEGER;
    VAR
        i, res: INTEGER;

    BEGIN
        res := lxIDENT;
        i := 0;
        WHILE i < LEN(KW) DO
            IF (KW[i].uhash = ident.hash) & (KW[i].upper = ident.s)
            OR LowerCase & (KW[i].lhash = ident.hash) & (KW[i].lower = ident.s) THEN
                res := i + lxKW;
                i := LEN(KW)
            END;
            INC(i)
        END

        RETURN res
    END checkKW;


PROCEDURE enterStr* (s: TEXTSTR): STRING;
    VAR
        str, res: STRING;
        hash: INTEGER;

    BEGIN
        hash := S.HashStr(s);
        str := strings.first(STRING);
        res := NIL;
        WHILE str # NIL DO
            IF (str.hash = hash) & (str.s = s) THEN
                res := str;
                str := NIL
            ELSE
                str := str.next(STRING)
            END
        END;
        IF res = NIL THEN
            NEW(res);
            res.s := s;
            res.offset  := -1;
            res.offsetW := -1;
            res.hash := hash;
            LISTS.push(strings, res)
        END

        RETURN res
    END enterStr;


PROCEDURE nextc (text: TXT.TEXT): CHAR;
    BEGIN
        TXT.next(text)
        RETURN text.peak
    END nextc;


PROCEDURE setIdent* (VAR ident: IDENT; s: IDSTR);
    BEGIN
        ident.s := s;
        ident.hash := S.HashStr(s)
    END setIdent;


PROCEDURE ident (text: TXT.TEXT; VAR lex: LEX);
    VAR
        c: CHAR;
        i: INTEGER;

    BEGIN
        c := text.peak;
        ASSERT(S.letter(c));

        i := 0;
        WHILE (i < IDLEN - 1) & (S.letter(c) OR S.digit(c)) DO
            lex.ident.s[i] := c;
            INC(i);
            c := nextc(text)
        END;

        lex.ident.s[i] := 0X;
        lex.ident.hash := S.HashStr(lex.ident.s);
        lex.sym := checkKW(lex.ident);

        IF S.letter(c) OR S.digit(c) THEN
            ERRORS.WarningMsg(lex.pos.line, lex.pos.col, 2);
            WHILE S.letter(c) OR S.digit(c) DO
                c := nextc(text)
            END
        END
    END ident;


PROCEDURE number (text: TXT.TEXT; VAR lex: LEX);
    TYPE
        NUMSTR = ARRAY NUMLEN OF CHAR;

    VAR
        c: CHAR;
        hex: BOOLEAN;
        error, sym, i: INTEGER;
        num: NUMSTR;


        PROCEDURE push (VAR num: NUMSTR; VAR i: INTEGER; c: CHAR);
        BEGIN
            IF i < NUMLEN - 1 THEN
                num[i] := c;
                INC(i)
            END
        END push;


    BEGIN
        c := text.peak;
        ASSERT(S.digit(c));

        i := 0;

        error := 0;

        sym := lxINTEGER;
        hex := FALSE;

        WHILE S.digit(c) DO
            push(num, i, c);
            c := nextc(text)
        END;

        WHILE S.hexdigit(c) OR LowerCase & ("a" <= c) & (c <= "f") DO
            S.cap(c);
            push(num, i, c);
            c := nextc(text);
            hex := TRUE
        END;

        IF (c = "H") OR LowerCase & (c = "h") THEN
            push(num, i, c);
            TXT.next(text);
            sym := lxHEX

        ELSIF (c = "X") OR LowerCase & (c = "x") THEN
            push(num, i, c);
            TXT.next(text);
            sym := lxCHAR

        ELSIF c = "." THEN

            IF hex THEN
                sym := lxERROR01
            ELSE

                c := nextc(text);

                IF c # "." THEN
                    push(num, i, ".");
                    sym := lxFLOAT
                ELSE
                    sym := lxINTEGER;
                    text.peak := 7FX;
                    upto := TRUE
                END;

                WHILE S.digit(c) DO
                    push(num, i, c);
                    c := nextc(text)
                END;

                IF (c = "E") OR LowerCase & (c = "e") THEN

                    push(num, i, c);
                    c := nextc(text);
                    IF (c = "+") OR (c = "-") THEN
                        push(num, i, c);
                        c := nextc(text)
                    END;

                    IF S.digit(c) THEN
                        WHILE S.digit(c) DO
                            push(num, i, c);
                            c := nextc(text)
                        END
                    ELSE
                        sym := lxERROR02
                    END

                END

            END

        ELSIF hex THEN
            sym := lxERROR01

        END;

        IF (i = NUMLEN - 1) & (sym >= 0) THEN
            sym := lxERROR07
        END;

        num[i] := 0X;

        IF sym = lxINTEGER THEN
            ARITH.iconv(num, lex.value, error)
        ELSIF (sym = lxHEX) OR (sym = lxCHAR) THEN
            ARITH.hconv(num, lex.value, error)
        ELSIF sym = lxFLOAT THEN
            ARITH.fconv(num, lex.value, error)
        END;

        CASE error OF
        |0:
        |1: sym := lxERROR08
        |2: sym := lxERROR09
        |3: sym := lxERROR10
        |4: sym := lxERROR11
        |5: sym := lxERROR12
        END;

        lex.sym := sym
    END number;


PROCEDURE string (text: TXT.TEXT; VAR lex: LEX; quot: CHAR);
    VAR
        c: CHAR;
        i: INTEGER;
        str: TEXTSTR;

    BEGIN
        c  := nextc(text);

        i := 0;
        WHILE (i < LEN(str) - 1) & (c # quot) & (c # 0X) & ~text.eol & ~text.eof DO
            str[i] := c;
            c := nextc(text);
            INC(i)
        END;

        str[i] := 0X;

        IF (i = LEN(str) - 1) & (c # quot) & (c # 0X) & ~text.eol & ~text.eof THEN
            lex.sym := lxERROR05
        END;

        IF c = quot THEN
            TXT.next(text);
            IF i # 1 THEN
                lex.sym := lxSTRING
            ELSE
                lex.sym := lxCHAR;
                ARITH.setChar(lex.value, ORD(str[0]))
            END
        ELSIF lex.sym # lxERROR05 THEN
            lex.sym := lxERROR03
        END;

        IF lex.sym = lxSTRING THEN
            lex.string := enterStr(str);
            lex.value.typ := ARITH.tSTRING;
            lex.value.string := lex.string
        END

    END string;


PROCEDURE comment (text: TXT.TEXT);
    VAR
        c: CHAR;
        cond, depth: INTEGER;

    BEGIN
        cond  := 0;
        depth := 1;

        REPEAT

            c := text.peak;
            TXT.next(text);

            IF c = "*" THEN
                IF cond = 1 THEN
                    cond := 0;
                    INC(depth)
                ELSE
                cond := 2
                END
            ELSIF c = ")" THEN
                IF cond = 2 THEN
                    DEC(depth)
                END;
                cond := 0
            ELSIF c = "(" THEN
                cond := 1
            ELSE
                cond := 0
            END

        UNTIL (depth = 0) OR text.eof

    END comment;


PROCEDURE delimiter (text: TXT.TEXT; c: CHAR): INTEGER;
    VAR
        sym: INTEGER;
        c0:  CHAR;

    BEGIN
        c0 := c;
        c := nextc(text);

        CASE c0 OF
        |"+":
            sym := lxPLUS

        |"-":
            sym := lxMINUS

        |"*":
            sym := lxMUL

        |"/":
            sym := lxSLASH;

            IF c = "/" THEN
                sym := lxCOMMENT;
                REPEAT
                    TXT.next(text)
                UNTIL text.eol OR text.eof
            END

        |"~":
            sym := lxNOT

        |"&":
            sym := lxAND

        |".":
            sym := lxPOINT;

            IF c = "." THEN
                sym := lxRANGE;
                TXT.next(text)
            END

        |",":
            sym := lxCOMMA

        |";":
            sym := lxSEMI

        |"|":
            sym := lxBAR

        |"(":
            sym := lxLROUND;

            IF c = "*" THEN
                sym := lxCOMMENT;
                TXT.next(text);
                comment(text)
            END

        |"[":
            sym := lxLSQUARE

        |"{":
            sym := lxLCURLY

        |"^":
            sym := lxCARET

        |"=":
            sym := lxEQ

        |"#":
            sym := lxNE

        |"<":
            sym := lxLT;

            IF c = "=" THEN
                sym := lxLE;
                TXT.next(text)
            END

        |">":
            sym := lxGT;

            IF c = "=" THEN
                sym := lxGE;
                TXT.next(text)
            END

        |":":
            sym := lxCOLON;

            IF c = "=" THEN
                sym := lxASSIGN;
                TXT.next(text)
            END

        |")":
            sym := lxRROUND

        |"]":
            sym := lxRSQUARE

        |"}":
            sym := lxRCURLY

        END

        RETURN sym
    END delimiter;


PROCEDURE Next* (text: SCANNER; VAR lex: LEX);
    VAR
        c: CHAR;


        PROCEDURE check (cond: BOOLEAN; text: SCANNER; lex: LEX; errno: INTEGER);
            BEGIN
                IF ~cond THEN
                    ERRORS.ErrorMsg(text.fname, lex.pos.line, lex.pos.col, errno)
                END
        END check;


        PROCEDURE IsDef (str: ARRAY OF CHAR): BOOLEAN;
            VAR
                cur: DEF;

            BEGIN
                cur := def.first(DEF);
                WHILE (cur # NIL) & (cur.ident # str) DO
                    cur := cur.next(DEF)
                END

                RETURN cur # NIL
        END IsDef;


        PROCEDURE Skip (text: SCANNER);
        VAR
            i: INTEGER;

        BEGIN
            i := 0;
            WHILE (i <= text.ifc) & ~text._skip[i] DO
                INC(i)
            END;
            text.skip := i <= text.ifc
        END Skip;


        PROCEDURE prep_if (text: SCANNER; VAR lex: LEX);
        VAR
            skip: BOOLEAN;

        BEGIN
            INC(text.ifc);
            text._elsif[text.ifc] := lex.sym = lxELSIF;
            IF lex.sym = lxIF THEN
                INC(text.elsec);
                text._else[text.elsec] := FALSE
            END;
            _if := TRUE;
            skip := TRUE;
            text.skip := FALSE;

            Next(text, lex);
            check(lex.sym = lxLROUND, text, lex, 64);

            Next(text, lex);
            check(lex.sym = lxIDENT, text, lex, 22);

            REPEAT
                IF IsDef(lex.ident.s) THEN
                    skip := FALSE
                END;

                Next(text, lex);
                IF lex.sym = lxBAR THEN
                    Next(text, lex);
                    check(lex.sym = lxIDENT, text, lex, 22)
                ELSE
                    check(lex.sym = lxRROUND, text, lex, 33)
                END
            UNTIL lex.sym = lxRROUND;

            _if := FALSE;
            text._skip[text.ifc] := skip;
            Skip(text);
            Next(text, lex)
        END prep_if;


        PROCEDURE prep_end (text: SCANNER; VAR lex: LEX);
        BEGIN
            check(text.ifc > 0, text, lex, 118);
            IF lex.sym = lxEND THEN
                WHILE text._elsif[text.ifc] DO
                    DEC(text.ifc)
                END;
                DEC(text.ifc);
                DEC(text.elsec)
            ELSIF (lex.sym = lxELSE) OR (lex.sym = lxELSIF) THEN
                check(~text._else[text.elsec], text, lex, 118);
                text._skip[text.ifc] := ~text._skip[text.ifc];
                text._else[text.elsec] := lex.sym = lxELSE
            END;
            Skip(text);
            IF lex.sym = lxELSIF THEN
                prep_if(text, lex)
            ELSE
                Next(text, lex)
            END
        END prep_end;


    BEGIN

        REPEAT
            c := text.peak;

            WHILE S.space(c) DO
                c := nextc(text)
            END;

            lex.pos.line := text.line;
            lex.pos.col  := text.col;

            IF S.letter(c) THEN
                ident(text, lex)
            ELSIF S.digit(c) THEN
                number(text, lex)
            ELSIF (c = '"') OR (c = "'") THEN
                string(text, lex, c)
            ELSIF delimiters[ORD(c)] THEN
                lex.sym := delimiter(text, c)
            ELSIF c = "$" THEN
                IF S.letter(nextc(text)) THEN
                    ident(text, lex);
                    IF lex.sym = lxIF THEN
                        IF ~_if THEN
                            prep_if(text, lex)
                        END
                    ELSIF (lex.sym = lxEND) OR (lex.sym = lxELSE) OR (lex.sym = lxELSIF) THEN
                        IF ~_if THEN
                            prep_end(text, lex)
                        END
                    ELSE
                        check(FALSE, text, lex, 119)
                    END
                ELSE
                    check(FALSE, text, lex, 119)
                END
            ELSIF c = 0X THEN
                lex.sym := lxEOF;
                text.skip := FALSE;
                IF text.eof THEN
                    INC(lex.pos.col)
                END
            ELSIF (c = 7FX) & upto THEN
                upto := FALSE;
                lex.sym := lxRANGE;
                DEC(lex.pos.col);
                TXT.next(text)
            ELSE
                TXT.next(text);
                lex.sym := lxERROR04
            END;

            IF lex.sym < 0 THEN
                lex.error := -lex.sym
            ELSE
                lex.error := 0
            END

        UNTIL (lex.sym # lxCOMMENT) & ~text.skip

    END Next;


PROCEDURE open* (name: ARRAY OF CHAR): SCANNER;
        RETURN TXT.open(name)
    END open;


PROCEDURE close* (VAR scanner: SCANNER);
    BEGIN
        TXT.close(scanner)
    END close;


PROCEDURE init* (lower: BOOLEAN);
    VAR
        i: INTEGER;
        delim: ARRAY 23 OF CHAR;

    BEGIN
        upto := FALSE;
        LowerCase := lower;

        FOR i := 0 TO 255 DO
            delimiters[i] := FALSE
        END;

        delim := "+-*/~&.,;|([{^=#<>:)]}";

        FOR i := 0 TO LEN(delim) - 2 DO
            delimiters[ORD(delim[i])] := TRUE
        END;

        enterKW("array",      0);
        enterKW("begin",      1);
        enterKW("by",         2);
        enterKW("case",       3);
        enterKW("const",      4);
        enterKW("div",        5);
        enterKW("do",         6);
        enterKW("else",       7);
        enterKW("elsif",      8);
        enterKW("end",        9);
        enterKW("false",     10);
        enterKW("for",       11);
        enterKW("if",        12);
        enterKW("import",    13);
        enterKW("in",        14);
        enterKW("is",        15);
        enterKW("mod",       16);
        enterKW("module",    17);
        enterKW("nil",       18);
        enterKW("of",        19);
        enterKW("or",        20);
        enterKW("pointer",   21);
        enterKW("procedure", 22);
        enterKW("record",    23);
        enterKW("repeat",    24);
        enterKW("return",    25);
        enterKW("then",      26);
        enterKW("to",        27);
        enterKW("true",      28);
        enterKW("type",      29);
        enterKW("until",     30);
        enterKW("var",       31);
        enterKW("while",     32)
    END init;


PROCEDURE NewDef* (str: ARRAY OF CHAR);
    VAR
        item: DEF;

    BEGIN
        NEW(item);
        COPY(str, item.ident);
        LISTS.push(def, item)
    END NewDef;


BEGIN
    def := LISTS.create(NIL);
    strings := LISTS.create(NIL)
END SCAN.