Subversion Repositories Kolibri OS

(*

    BSD 2-Clause License

    Copyright (c) 2018-2021, Anton Krotov

    All rights reserved.

*)

MODULE SCAN;

IMPORT TXT := TEXTDRV, ARITH, S := STRINGS, 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.