kolibrios-gitea/programs/develop/oberon07/Source/PARS.ob07

(*
    BSD 2-Clause License

    Copyright (c) 2018-2020, Anton Krotov
    All rights reserved.
*)

MODULE PARS;

IMPORT PROG, SCAN, ARITH, STRINGS, ERRORS, LISTS, IL, CONSOLE, PATHS, UTILS,
       C := COLLECTIONS, TARGETS, THUMB;


CONST

    eCONST*   =  1;  eTYPE*   =  2;  eVAR*     =  3;  eEXPR*    =  4;
    eVREC*    =  5;  ePROC*   =  6;  eVPAR*    =  7;  ePARAM*   =  8;
    eSTPROC*  =  9;  eSTFUNC* = 10;  eSYSFUNC* = 11;  eSYSPROC* = 12;
    eIMP*     = 13;


TYPE

    PATH* = PATHS.PATH;

    PARSER* = POINTER TO rPARSER;

    POSITION* = RECORD (SCAN.POSITION)

        parser*: PARSER

    END;

    EXPR* = RECORD

        obj*:         INTEGER;
        _type*:       PROG._TYPE;
        value*:       ARITH.VALUE;
        stproc*:      INTEGER;
        readOnly*:    BOOLEAN;
        ident*:       PROG.IDENT

    END;

    STATPROC  = PROCEDURE (parser: PARSER);
    EXPRPROC  = PROCEDURE (parser: PARSER; VAR e: EXPR);
    RETPROC   = PROCEDURE (parser: PARSER; e: EXPR; t: PROG._TYPE; pos: POSITION): BOOLEAN;

    rPARSER = RECORD (C.ITEM)

        fname*:      PATH;
        path:        PATH;
        lib_path:    PATH;
        ext:         PATH;
        modname:     PATH;
        scanner:     SCAN.SCANNER;
        lex*:        SCAN.LEX;
        sym*:        INTEGER;
        unit*:       PROG.UNIT;
        constexp*:   BOOLEAN;
        main*:       BOOLEAN;

        open*:       PROCEDURE (parser: PARSER; modname: ARRAY OF CHAR): BOOLEAN;
        parse*:      PROCEDURE (parser: PARSER);
        StatSeq*:    STATPROC;
        expression*: EXPRPROC;
        designator*: EXPRPROC;
        chkreturn:   RETPROC;

        create*:     PROCEDURE (path, lib_path: PATH; StatSeq: STATPROC; expression, designator: EXPRPROC; chkreturn: RETPROC): PARSER

    END;


VAR

    parsers: C.COLLECTION;

    lines*, modules: INTEGER;


PROCEDURE destroy* (VAR parser: PARSER);
BEGIN
    IF parser.scanner # NIL THEN
        SCAN.close(parser.scanner)
    END;

    C.push(parsers, parser);
    parser := NIL
END destroy;


PROCEDURE getpos (parser: PARSER; VAR pos: POSITION);
BEGIN
    pos.line   := parser.lex.pos.line;
    pos.col    := parser.lex.pos.col;
    pos.parser := parser
END getpos;


PROCEDURE error* (pos: POSITION; errno: INTEGER);
BEGIN
    ERRORS.ErrorMsg(pos.parser.fname, pos.line, pos.col, errno)
END error;


PROCEDURE check* (condition: BOOLEAN; pos: POSITION; errno: INTEGER);
BEGIN
    IF ~condition THEN
        error(pos, errno)
    END
END check;


PROCEDURE check1* (condition: BOOLEAN; parser: PARSER; errno: INTEGER);
VAR
    pos: POSITION;

BEGIN
    IF ~condition THEN
        getpos(parser, pos);
        error(pos, errno)
    END
END check1;


PROCEDURE Next* (parser: PARSER);
VAR
    errno: INTEGER;

BEGIN
    SCAN.Next(parser.scanner, parser.lex);
    errno := parser.lex.error;
    IF errno = 0 THEN
        IF (TARGETS.RealSize = 0) & (parser.lex.sym = SCAN.lxFLOAT) THEN
            errno := -SCAN.lxERROR13
        ELSIF (TARGETS.BitDepth = 16) & (parser.lex.sym = SCAN.lxCHAR) & (parser.lex.value.typ = ARITH.tWCHAR) THEN
            errno := -SCAN.lxERROR10
        END
    END;

    IF errno # 0 THEN
        check1(FALSE, parser, errno)
    END;
    parser.sym := parser.lex.sym
END Next;


PROCEDURE NextPos (parser: PARSER; VAR pos: POSITION);
BEGIN
    Next(parser);
    getpos(parser, pos)
END NextPos;


PROCEDURE checklex* (parser: PARSER; sym: INTEGER);
VAR
    err: INTEGER;

BEGIN

    IF parser.sym # sym THEN

        CASE sym OF
        |SCAN.lxCOMMA:   err := 65
        |SCAN.lxRROUND:  err := 33
        |SCAN.lxPOINT:   err := 26
        |SCAN.lxIDENT:   err := 22
        |SCAN.lxRSQUARE: err := 71
        |SCAN.lxRCURLY:  err := 35
        |SCAN.lxUNDEF:   err := 34
        |SCAN.lxTHEN:    err := 88
        |SCAN.lxEND:     err := 27
        |SCAN.lxDO:      err := 89
        |SCAN.lxUNTIL:   err := 90
        |SCAN.lxCOLON:   err := 53
        |SCAN.lxOF:      err := 67
        |SCAN.lxASSIGN:  err := 96
        |SCAN.lxTO:      err := 57
        |SCAN.lxLROUND:  err := 64
        |SCAN.lxEQ:      err := 32
        |SCAN.lxSEMI:    err := 24
        |SCAN.lxRETURN:  err := 38
        |SCAN.lxMODULE:  err := 21
        END;

        check1(FALSE, parser, err)
    END
END checklex;


PROCEDURE ExpectSym* (parser: PARSER; sym: INTEGER);
BEGIN
    Next(parser);
    checklex(parser, sym)
END ExpectSym;


PROCEDURE ImportList (parser: PARSER);
VAR
    name:    SCAN.IDENT;
    parser2: PARSER;
    pos:     POSITION;
    alias:   BOOLEAN;
    unit:    PROG.UNIT;
    ident:   PROG.IDENT;

BEGIN
    alias := FALSE;

    REPEAT

        ExpectSym(parser, SCAN.lxIDENT);
        name := parser.lex.ident;

        getpos(parser, pos);

        IF ~alias THEN
            ident := PROG.addIdent(parser.unit, name, PROG.idMODULE);
            check(ident # NIL, pos, 30)
        END;

        Next(parser);

        IF (parser.sym = SCAN.lxCOMMA) OR (parser.sym = SCAN.lxSEMI) THEN
            alias := FALSE;
            unit := PROG.getUnit(name);

            IF unit # NIL THEN
                check(unit.closed, pos, 31)
            ELSE
                parser2 := parser.create(parser.path, parser.lib_path,
                    parser.StatSeq, parser.expression, parser.designator, parser.chkreturn);

                IF ~parser2.open(parser2, name.s) THEN
                    IF parser.path # parser.lib_path THEN
                        destroy(parser2);
                        parser2 := parser.create(parser.lib_path, parser.lib_path,
                            parser.StatSeq, parser.expression, parser.designator, parser.chkreturn);
                        check(parser2.open(parser2, name.s), pos, 29)
                    ELSE
                        error(pos, 29)
                    END
                END;

                parser2.parse(parser2);
                unit := parser2.unit;
                destroy(parser2)
            END;
            IF unit = PROG.program.sysunit THEN
                parser.unit.sysimport := TRUE
            END;
            ident.unit := unit

        ELSIF parser.sym = SCAN.lxASSIGN THEN
            alias := TRUE

        ELSE
            check1(FALSE, parser, 28)
        END

    UNTIL parser.sym = SCAN.lxSEMI;

    Next(parser)

END ImportList;


PROCEDURE QIdent (parser: PARSER; forward: BOOLEAN): PROG.IDENT;
VAR
    ident: PROG.IDENT;
    unit:  PROG.UNIT;

BEGIN
    ASSERT(parser.sym = SCAN.lxIDENT);

    ident := PROG.getIdent(parser.unit, parser.lex.ident, FALSE);

    IF ~forward THEN
        check1(ident # NIL, parser, 48)
    END;

    IF (ident # NIL) & (ident.typ = PROG.idMODULE) THEN
        unit := ident.unit;
        ExpectSym(parser, SCAN.lxPOINT);
        ExpectSym(parser, SCAN.lxIDENT);
        ident := PROG.getIdent(unit, parser.lex.ident, FALSE);
        check1((ident # NIL) & ident.export, parser, 48)
    END

    RETURN ident
END QIdent;


PROCEDURE strcmp* (VAR v: ARITH.VALUE; v2: ARITH.VALUE; operator: INTEGER);
VAR
    str: SCAN.LEXSTR;
    string1, string2: SCAN.IDENT;
    bool: BOOLEAN;

BEGIN

    IF v.typ = ARITH.tCHAR THEN
        ASSERT(v2.typ = ARITH.tSTRING);
        ARITH.charToStr(v, str);
        string1 := SCAN.enterid(str);
        string2 := v2.string(SCAN.IDENT)
    END;

    IF v2.typ = ARITH.tCHAR THEN
        ASSERT(v.typ = ARITH.tSTRING);
        ARITH.charToStr(v2, str);
        string2 := SCAN.enterid(str);
        string1 := v.string(SCAN.IDENT)
    END;

    IF v.typ = v2.typ THEN
        string1 := v.string(SCAN.IDENT);
        string2 := v2.string(SCAN.IDENT)
    END;

    CASE operator OF
    |SCAN.lxEQ: bool := string1.s =  string2.s
    |SCAN.lxNE: bool := string1.s #  string2.s
    |SCAN.lxLT: bool := string1.s <  string2.s
    |SCAN.lxGT: bool := string1.s >  string2.s
    |SCAN.lxLE: bool := string1.s <= string2.s
    |SCAN.lxGE: bool := string1.s >= string2.s
    END;

    ARITH.setbool(v, bool)
END strcmp;


PROCEDURE ConstExpression* (parser: PARSER; VAR v: ARITH.VALUE);
VAR
    e: EXPR;
    pos: POSITION;

BEGIN
    getpos(parser, pos);
    parser.constexp := TRUE;
    parser.expression(parser, e);
    parser.constexp := FALSE;
    check(e.obj = eCONST, pos, 62);
    v := e.value
END ConstExpression;


PROCEDURE FieldList (parser: PARSER; rec: PROG._TYPE);
VAR
    name:   SCAN.IDENT;
    export: BOOLEAN;
    pos:    POSITION;

BEGIN
    ASSERT(parser.sym = SCAN.lxIDENT);

    WHILE parser.sym = SCAN.lxIDENT DO

        getpos(parser, pos);

        name := parser.lex.ident;

        Next(parser);

        export := parser.sym = SCAN.lxMUL;

        IF export THEN
            check1(parser.unit.scopeLvl = 0, parser, 61);
            Next(parser)
        END;

        check(PROG.addField(rec, name, export), pos, 30);

        IF parser.sym = SCAN.lxCOMMA THEN
            ExpectSym(parser, SCAN.lxIDENT)
        ELSE
            checklex(parser, SCAN.lxCOLON)
        END

    END

END FieldList;


PROCEDURE FormalParameters (parser: PARSER; _type: PROG._TYPE);
VAR
    ident: PROG.IDENT;


    PROCEDURE FPSection (parser: PARSER; _type: PROG._TYPE);
    VAR
        ident:   PROG.IDENT;
        exit:    BOOLEAN;
        vPar:    BOOLEAN;
        dim:     INTEGER;
        t0, t1:  PROG._TYPE;

    BEGIN
        vPar := parser.sym = SCAN.lxVAR;
        IF vPar THEN
            Next(parser)
        END;

        checklex(parser, SCAN.lxIDENT);
        exit := FALSE;

        WHILE (parser.sym = SCAN.lxIDENT) & ~exit DO
            check1(PROG.addParam(_type, parser.lex.ident, vPar), parser, 30);
            Next(parser);
            IF parser.sym = SCAN.lxCOMMA THEN
                ExpectSym(parser, SCAN.lxIDENT)
            ELSIF parser.sym = SCAN.lxCOLON THEN
                Next(parser);
                dim := 0;
                WHILE parser.sym = SCAN.lxARRAY DO
                    INC(dim);
                    check1(dim <= PROG.MAXARRDIM, parser, 84);
                    ExpectSym(parser, SCAN.lxOF);
                    Next(parser)
                END;
                checklex(parser, SCAN.lxIDENT);
                ident := QIdent(parser, FALSE);
                check1(ident.typ = PROG.idTYPE, parser, 68);

                t0 := ident._type;
                t1 := t0;

                WHILE dim > 0 DO
                    t1 := PROG.enterType(PROG.tARRAY, -1, 0, parser.unit);
                    t1.base := t0;
                    t0 := t1;
                    DEC(dim)
                END;

                PROG.setParams(_type, t1);
                Next(parser);
                exit := TRUE
            ELSE
                checklex(parser, SCAN.lxCOLON)
            END
        END

    END FPSection;


BEGIN
    IF parser.sym = SCAN.lxLROUND THEN

        Next(parser);

        IF (parser.sym = SCAN.lxVAR) OR (parser.sym = SCAN.lxIDENT) THEN
            FPSection(parser, _type);
            WHILE parser.sym = SCAN.lxSEMI DO
                Next(parser);
                FPSection(parser, _type)
            END
        END;

        checklex(parser, SCAN.lxRROUND);
        Next(parser);

        IF parser.sym = SCAN.lxCOLON THEN
            ExpectSym(parser, SCAN.lxIDENT);
            ident := QIdent(parser, FALSE);
            check1(ident.typ = PROG.idTYPE, parser, 68);
            check1(~(ident._type.typ IN {PROG.tRECORD, PROG.tARRAY}), parser, 69);
            check1( ~(ODD(_type.call) & (ident._type.typ = PROG.tREAL)), parser, 113);
            _type.base := ident._type;
            Next(parser)
        ELSE
            _type.base := NIL
        END

    END
END FormalParameters;


PROCEDURE sysflag (parser: PARSER; proc: BOOLEAN): INTEGER;
VAR
    res, sf: INTEGER;

BEGIN
    IF parser.lex.s = "stdcall" THEN
        sf := PROG.sf_stdcall
    ELSIF parser.lex.s = "stdcall64" THEN
        sf := PROG.sf_stdcall64
    ELSIF parser.lex.s = "ccall" THEN
        sf := PROG.sf_ccall
    ELSIF parser.lex.s = "ccall16" THEN
        sf := PROG.sf_ccall16
    ELSIF parser.lex.s = "win64" THEN
        sf := PROG.sf_win64
    ELSIF parser.lex.s = "systemv" THEN
        sf := PROG.sf_systemv
    ELSIF parser.lex.s = "windows" THEN
        sf := PROG.sf_windows
    ELSIF parser.lex.s = "linux" THEN
        sf := PROG.sf_linux
    ELSIF parser.lex.s = "code" THEN
        sf := PROG.sf_code
    ELSIF parser.lex.s = "oberon" THEN
        sf := PROG.sf_oberon
    ELSIF parser.lex.s = "noalign" THEN
        sf := PROG.sf_noalign
    ELSE
        check1(FALSE, parser, 124)
    END;

    check1(sf IN PROG.program.sysflags, parser, 125);

    IF proc THEN
        check1(sf IN PROG.proc_flags, parser, 123)
    ELSE
        check1(sf IN PROG.rec_flags, parser, 123)
    END;

    CASE sf OF
    |PROG.sf_stdcall:
        res := PROG.stdcall
    |PROG.sf_stdcall64:
        res := PROG.stdcall64
    |PROG.sf_ccall:
        res := PROG.ccall
    |PROG.sf_ccall16:
        res := PROG.ccall16
    |PROG.sf_win64:
        res := PROG.win64
    |PROG.sf_systemv:
        res := PROG.systemv
    |PROG.sf_code:
        res := PROG.code
    |PROG.sf_oberon:
        IF TARGETS.OS IN {TARGETS.osWIN32, TARGETS.osLINUX32, TARGETS.osKOS} THEN
            res := PROG.default32
        ELSIF TARGETS.OS IN {TARGETS.osWIN64, TARGETS.osLINUX64} THEN
            res := PROG.default64
        END
    |PROG.sf_windows:
        IF TARGETS.OS = TARGETS.osWIN32 THEN
            res := PROG.stdcall
        ELSIF TARGETS.OS = TARGETS.osWIN64 THEN
            res := PROG.win64
        END
    |PROG.sf_linux:
        IF TARGETS.OS = TARGETS.osLINUX32 THEN
            res := PROG.ccall16
        ELSIF TARGETS.OS = TARGETS.osLINUX64 THEN
            res := PROG.systemv
        END
    |PROG.sf_noalign:
        res := PROG.noalign
    END

    RETURN res
END sysflag;


PROCEDURE procflag (parser: PARSER; VAR _import: IL.IMPORT_PROC; isProc: BOOLEAN): INTEGER;
VAR
    call: INTEGER;
    dll, proc: SCAN.LEXSTR;
    pos: POSITION;


    PROCEDURE getStr (parser: PARSER; VAR name: SCAN.LEXSTR);
    VAR
        pos: POSITION;
        str: ARITH.VALUE;

    BEGIN
        getpos(parser, pos);
        ConstExpression(parser, str);
        IF str.typ = ARITH.tSTRING THEN
            name := str.string(SCAN.IDENT).s
        ELSIF str.typ = ARITH.tCHAR THEN
            ARITH.charToStr(str, name)
        ELSE
            check(FALSE, pos, 117)
        END
    END getStr;


BEGIN
    _import := NIL;

    IF parser.sym = SCAN.lxLSQUARE THEN
        getpos(parser, pos);
        check1(parser.unit.sysimport, parser, 54);
        Next(parser);
        call := sysflag(parser, TRUE);
        Next(parser);
        IF parser.sym = SCAN.lxMINUS THEN
            Next(parser);
            INC(call)
        END;

        IF isProc & (parser.sym = SCAN.lxCOMMA) THEN
            Next(parser);
            getStr(parser, dll);
            STRINGS.UpCase(dll);
            checklex(parser, SCAN.lxCOMMA);
            Next(parser);
            getStr(parser, proc);
            _import := IL.AddImp(dll, proc)
        END;

        checklex(parser, SCAN.lxRSQUARE);
        Next(parser)
    ELSE
        CASE TARGETS.BitDepth OF
        |16: call := PROG.default16
        |32: IF TARGETS.CPU = TARGETS.cpuX86 THEN
                 call := PROG.default32
             ELSE
                 call := PROG.ccall
             END
        |64: call := PROG.default64
        END
    END;

    IF _import # NIL THEN
        check(TARGETS.Import, pos, 70)
    END

    RETURN call
END procflag;


PROCEDURE _type (parser: PARSER; VAR t: PROG._TYPE; flags: SET);
CONST
    comma   = 0;
    closed  = 1;
    forward = 2;

VAR
    arrLen:     ARITH.VALUE;
    typeSize:   ARITH.VALUE;
    ident:      PROG.IDENT;
    unit:       PROG.UNIT;
    pos, pos2:  POSITION;
    fieldType:  PROG._TYPE;
    baseIdent:  SCAN.IDENT;
    a, b:       INTEGER;
    RecFlag:    INTEGER;
    _import:     IL.IMPORT_PROC;

BEGIN
    unit := parser.unit;
    t := NIL;

    IF parser.sym = SCAN.lxIDENT THEN
        ident := QIdent(parser, forward IN flags);

        IF ident # NIL THEN
            check1(ident.typ = PROG.idTYPE, parser, 49);
            t := ident._type;
            check1(t # NIL, parser, 50);
            IF closed IN flags THEN
                check1(t.closed, parser, 50)
            END
        END;

        Next(parser)

    ELSIF (parser.sym = SCAN.lxARRAY) OR ((parser.sym = SCAN.lxCOMMA) & (comma IN flags)) THEN

        IF parser.sym = SCAN.lxARRAY THEN
            getpos(parser, pos2)
        END;
        NextPos(parser, pos);

        ConstExpression(parser, arrLen);

        check(arrLen.typ = ARITH.tINTEGER, pos, 43);
        check(ARITH.check(arrLen),         pos, 39);
        check(ARITH.getInt(arrLen) > 0,    pos, 51);

        t := PROG.enterType(PROG.tARRAY, -1, ARITH.getInt(arrLen), unit);

        IF parser.sym = SCAN.lxCOMMA THEN
            _type(parser, t.base, {comma, closed})
        ELSIF parser.sym = SCAN.lxOF THEN
            Next(parser);
            _type(parser, t.base, {closed})
        ELSE
            check1(FALSE, parser, 47)
        END;

        t.align := t.base.align;

        a := t.length;
        b := t.base.size;
        check(ARITH.mulInt(a, b), pos2, 104);
        check(ARITH.setInt(typeSize, a), pos2, 104);
        t.size := a;

        t.closed := TRUE

    ELSIF parser.sym = SCAN.lxRECORD THEN
        getpos(parser, pos2);
        Next(parser);

        t := PROG.enterType(PROG.tRECORD, 0, 0, unit);
        t.align := 1;

        IF parser.sym = SCAN.lxLSQUARE THEN
            check1(parser.unit.sysimport, parser, 54);
            Next(parser);
            RecFlag := sysflag(parser, FALSE);
            t.noalign := RecFlag = PROG.noalign;
            ExpectSym(parser, SCAN.lxRSQUARE);
            Next(parser)
        END;

        IF parser.sym = SCAN.lxLROUND THEN
            check1(~t.noalign, parser, 111);
            ExpectSym(parser, SCAN.lxIDENT);
            getpos(parser, pos);

            _type(parser, t.base, {closed});

            check(t.base.typ IN {PROG.tRECORD, PROG.tPOINTER}, pos, 52);

            IF t.base.typ = PROG.tPOINTER THEN
                t.base := t.base.base;
                check(t.base # NIL, pos, 55)
            END;

            check(~t.base.noalign, pos, 112);

            checklex(parser, SCAN.lxRROUND);
            Next(parser);

            t.size := t.base.size;
            IF t.base.align > t.align THEN
                t.align := t.base.align
            END
        ELSE
            t.base := PROG.program.stTypes.tANYREC
        END;

        WHILE parser.sym = SCAN.lxIDENT DO
            FieldList(parser, t);

            ASSERT(parser.sym = SCAN.lxCOLON);
            Next(parser);

            _type(parser, fieldType, {closed});
            check(PROG.setFields(t, fieldType), pos2, 104);

            IF (fieldType.align > t.align) & ~t.noalign THEN
                t.align := fieldType.align
            END;

            IF parser.sym = SCAN.lxSEMI THEN
                ExpectSym(parser, SCAN.lxIDENT)
            ELSE
                checklex(parser, SCAN.lxEND)
            END
        END;

        t.closed := TRUE;

        IL.AddRec(t.base.num);

        IF ~t.noalign THEN
            check(UTILS.Align(t.size, t.align), pos2, 104);
            check(ARITH.setInt(typeSize, t.size), pos2, 104)
        END;

        checklex(parser, SCAN.lxEND);
        Next(parser)

    ELSIF parser.sym = SCAN.lxPOINTER THEN
        ExpectSym(parser, SCAN.lxTO);
        Next(parser);

        t := PROG.enterType(PROG.tPOINTER, TARGETS.AdrSize, 0, unit);
        t.align := TARGETS.AdrSize;

        getpos(parser, pos);

        IF parser.sym = SCAN.lxIDENT THEN
            baseIdent := parser.lex.ident
        END;

        _type(parser, t.base, {forward});

        IF t.base # NIL THEN
            check(t.base.typ = PROG.tRECORD, pos, 58)
        ELSE
            PROG.frwPtr(unit, t, baseIdent, pos)
        END

    ELSIF parser.sym = SCAN.lxPROCEDURE THEN
        NextPos(parser, pos);
        t := PROG.enterType(PROG.tPROCEDURE, TARGETS.AdrSize, 0, unit);
        t.align := TARGETS.AdrSize;
        t.call := procflag(parser, _import, FALSE);
        FormalParameters(parser, t)
    ELSE
        check1(FALSE, parser, 49)
    END

END _type;


PROCEDURE IdentDef (parser: PARSER; typ: INTEGER; VAR name: SCAN.IDENT): PROG.IDENT;
VAR
    ident:  PROG.IDENT;
    pos:    POSITION;

BEGIN
    ASSERT(parser.sym = SCAN.lxIDENT);

    name := parser.lex.ident;
    getpos(parser, pos);
    ident := PROG.addIdent(parser.unit, name, typ);
    check(ident # NIL, pos, 30);
    ident.pos := pos;
    Next(parser);

    IF parser.sym = SCAN.lxMUL THEN
        check1(ident.global, parser, 61);
        ident.export := TRUE;
        Next(parser)
    END

    RETURN ident
END IdentDef;


PROCEDURE ConstTypeDeclaration (parser: PARSER; _const: BOOLEAN);
VAR
    ident: PROG.IDENT;
    name:  SCAN.IDENT;
    pos:   POSITION;

BEGIN
    IF _const THEN
        ident := IdentDef(parser, PROG.idNONE, name)
    ELSE
        ident := IdentDef(parser, PROG.idTYPE, name)
    END;

    checklex(parser, SCAN.lxEQ);
    NextPos(parser, pos);

    IF _const THEN
        ConstExpression(parser, ident.value);
        IF ident.value.typ = ARITH.tINTEGER THEN
            check(ARITH.check(ident.value), pos, 39)
        ELSIF ident.value.typ = ARITH.tREAL THEN
            check(ARITH.check(ident.value), pos, 40)
        END;
        ident.typ  := PROG.idCONST;
        ident._type := PROG.getType(ident.value.typ)
    ELSE
        _type(parser, ident._type, {})
    END;

    checklex(parser, SCAN.lxSEMI);
    Next(parser)

END ConstTypeDeclaration;


PROCEDURE VarDeclaration (parser: PARSER);
VAR
    ident: PROG.IDENT;
    name:  SCAN.IDENT;
    t:     PROG._TYPE;

BEGIN

    REPEAT
        ident := IdentDef(parser, PROG.idVAR, name);

        IF parser.sym = SCAN.lxCOMMA THEN
            ExpectSym(parser, SCAN.lxIDENT)
        ELSIF parser.sym = SCAN.lxCOLON THEN
            Next(parser);
            _type(parser, t, {});
            PROG.setVarsType(parser.unit, t);
            checklex(parser, SCAN.lxSEMI);
            Next(parser)
        ELSE
            checklex(parser, SCAN.lxCOLON)
        END

    UNTIL parser.sym # SCAN.lxIDENT

END VarDeclaration;


PROCEDURE DeclarationSequence (parser: PARSER): BOOLEAN;
VAR
    ptr: PROG.FRWPTR;
    endmod: BOOLEAN;
    pos: POSITION;


    PROCEDURE ProcDeclaration (parser: PARSER): BOOLEAN;
    VAR
        proc:       PROG.IDENT;
        endname,
        name:       SCAN.IDENT;
        param:      PROG.PARAM;
        unit:       PROG.UNIT;
        ident:      PROG.IDENT;
        e:          EXPR;
        pos, pos1,
        pos2:       POSITION;
        label:      INTEGER;
        enter:      IL.COMMAND;
        call:       INTEGER;
        t:          PROG._TYPE;
        _import:    IL.IMPORT_PROC;
        endmod, b:  BOOLEAN;
        fparams:    SET;
        variables:  LISTS.LIST;
        int, flt:   INTEGER;
        comma:      BOOLEAN;
        code, iv:   ARITH.VALUE;
        codeProc,
        handler:    BOOLEAN;

    BEGIN
        endmod := FALSE;
        handler := FALSE;

        unit := parser.unit;

        call := procflag(parser, _import, TRUE);

        getpos(parser, pos);
        pos1 := pos;
        checklex(parser, SCAN.lxIDENT);

        IF _import # NIL THEN
            proc := IdentDef(parser, PROG.idIMP, name);
            proc._import := _import;
            IF _import.name = "" THEN
                _import.name := name.s
            END;
            PROG.program.procs.last(PROG.PROC)._import := _import
        ELSE
            proc := IdentDef(parser, PROG.idPROC, name)
        END;

        check(PROG.openScope(unit, proc.proc), pos, 116);

        proc._type := PROG.enterType(PROG.tPROCEDURE, TARGETS.AdrSize, 0, unit);
        t := proc._type;
        t.align := TARGETS.AdrSize;
        t.call  := call;

        FormalParameters(parser, t);

        IF parser.sym = SCAN.lxLSQUARE THEN
            getpos(parser, pos2);
            check(TARGETS.target = TARGETS.STM32CM3, pos2, 24);
            Next(parser);
            getpos(parser, pos2);
            ConstExpression(parser, iv);
            check(iv.typ = ARITH.tINTEGER, pos2, 43);
            check((0 <= ARITH.Int(iv)) & (ARITH.Int(iv) <= THUMB.maxIVT), pos2, 46);
            check(THUMB.SetIV(ARITH.Int(iv)), pos2, 121);
            checklex(parser, SCAN.lxRSQUARE);
            Next(parser);
            handler := TRUE
        END;

        codeProc := call IN {PROG.code, PROG._code};

        IF call IN {PROG.systemv, PROG._systemv} THEN
            check(t.parSize <= PROG.MAXSYSVPARAM, pos, 120)
        END;

        param := t.params.first(PROG.PARAM);
        WHILE param # NIL DO
            ident := PROG.addIdent(unit, param.name, PROG.idPARAM);
            ASSERT(ident # NIL);
            ident._type := param._type;
            ident.offset := param.offset;
            IF param.vPar THEN
                ident.typ := PROG.idVPAR
            END;
            param := param.next(PROG.PARAM)
        END;

        IF _import = NIL THEN
            label := IL.NewLabel();
            proc.proc.label := label;
            proc.proc.used  := handler;
            IF handler THEN
                IL.AddCmd2(IL.opHANDLER, label, ARITH.Int(iv))
            END
        END;

        IF codeProc THEN
            enter := IL.EnterC(label);
            comma := FALSE;
            WHILE (parser.sym # SCAN.lxSEMI) OR comma DO
                getpos(parser, pos2);
                ConstExpression(parser, code);
                check(code.typ = ARITH.tINTEGER, pos2, 43);
                IF TARGETS.WordSize > TARGETS.InstrSize THEN
                    CASE TARGETS.InstrSize OF
                    |1: check(ARITH.range(code, 0, 255), pos, 42)
                    |2: check(ARITH.range(code, 0, 65535), pos, 110)
                    END
                END;
                IL.AddCmd(IL.opCODE, ARITH.getInt(code));
                comma := parser.sym = SCAN.lxCOMMA;
                IF comma THEN
                    Next(parser)
                ELSE
                    checklex(parser, SCAN.lxSEMI)
                END
            END
        END;

        checklex(parser, SCAN.lxSEMI);
        Next(parser);

        IF _import = NIL THEN

            IF parser.main & proc.export & TARGETS.Dll THEN
                IF TARGETS.target = TARGETS.KolibriOSDLL THEN
                    check((proc.name.s # "lib_init") & (proc.name.s # "version"), pos, 114)
                END;
                IL.AddExp(label, proc.name.s);
                proc.proc.used := TRUE
            END;

            IF ~codeProc THEN
                b := DeclarationSequence(parser)
            END;

            PROG.ResetLocSize;
            IF call IN {PROG._win64, PROG.win64} THEN
                fparams := PROG.getFloatParamsPos(proc._type, 3, int, flt);
                enter := IL.Enter(label, LSL(ORD(fparams), 5) + MIN(proc._type.parSize, 4))
            ELSIF call IN {PROG._systemv, PROG.systemv} THEN
                fparams := PROG.getFloatParamsPos(proc._type, PROG.MAXSYSVPARAM - 1, int, flt);
                enter := IL.Enter(label, -(LSL(ORD(fparams), 5) + proc._type.parSize))
            ELSIF codeProc THEN

            ELSE
                enter := IL.Enter(label, 0)
            END;
            proc.proc.enter := enter;

            IF ~codeProc & (parser.sym = SCAN.lxBEGIN) THEN
                Next(parser);
                parser.StatSeq(parser)
            END;

            IF ~codeProc & (t.base # NIL) THEN
                checklex(parser, SCAN.lxRETURN);
                NextPos(parser, pos);
                parser.expression(parser, e);
                check(parser.chkreturn(parser, e, t.base, pos), pos, 87)
            END;

            IF ~codeProc THEN
                proc.proc.leave := IL.Leave(t.base # NIL, (t.base # NIL) & (t.base.typ = PROG.tREAL), PROG.program.locsize,
                    t.parSize * ORD((t.call IN PROG.callee_clean_up) OR (t.call IN {PROG.systemv, PROG._systemv})));
                enter.param2 := PROG.program.locsize;
                checklex(parser, SCAN.lxEND)
            ELSE
                proc.proc.leave := IL.LeaveC()
            END;

            IF TARGETS.CPU = TARGETS.cpuMSP430 THEN
                check((enter.param2 * ORD(~codeProc) + proc._type.parSize) * 2 + 16 < PROG.program.options.ram, pos1, 63)
            END
        END;

        IF parser.sym = SCAN.lxEND THEN
            Next(parser);
            IF parser.sym = SCAN.lxIDENT THEN
                getpos(parser, pos);
                endname := parser.lex.ident;
                IF ~codeProc & (_import = NIL) THEN
                    check(endname = name, pos, 60);
                    ExpectSym(parser, SCAN.lxSEMI);
                    Next(parser)
                ELSE
                    IF endname = parser.unit.name THEN
                        ExpectSym(parser, SCAN.lxPOINT);
                        Next(parser);
                        endmod := TRUE
                    ELSIF endname = name THEN
                        ExpectSym(parser, SCAN.lxSEMI);
                        Next(parser)
                    ELSE
                        error(pos, 60)
                    END
                END
            ELSIF parser.sym = SCAN.lxSEMI THEN
                Next(parser)
            ELSE
                checklex(parser, SCAN.lxIDENT)
            END
        END;

        IF ~codeProc & (_import = NIL) THEN
            variables := LISTS.create(NIL);
        ELSE
            variables := NIL
        END;

        PROG.closeScope(unit, variables);

        IF ~codeProc & (_import = NIL) THEN
            enter.variables := variables
        END

        RETURN endmod
    END ProcDeclaration;


BEGIN
    IF parser.sym = SCAN.lxCONST THEN
        Next(parser);
        WHILE parser.sym = SCAN.lxIDENT DO
            ConstTypeDeclaration(parser, TRUE)
        END
    END;

    IF parser.sym = SCAN.lxTYPE THEN
        Next(parser);
        WHILE parser.sym = SCAN.lxIDENT DO
            ConstTypeDeclaration(parser, FALSE)
        END
    END;

    ptr := PROG.linkPtr(parser.unit);
    IF ptr # NIL THEN
        pos.line := ptr.pos.line;
        pos.col  := ptr.pos.col;
        pos.parser := parser;
        IF ptr.notRecord THEN
            error(pos, 58)
        ELSE
            error(pos, 48)
        END
    END;

    IF parser.sym = SCAN.lxVAR THEN
        Next(parser);
        IF parser.sym = SCAN.lxIDENT THEN
            VarDeclaration(parser)
        END
    END;

    endmod := FALSE;
    WHILE ~endmod & (parser.sym = SCAN.lxPROCEDURE) DO
        Next(parser);
        endmod := ProcDeclaration(parser)
    END

    RETURN endmod
END DeclarationSequence;


PROCEDURE parse (parser: PARSER);
VAR
    unit:     PROG.UNIT;
    label:    INTEGER;
    name:     INTEGER;
    endmod:   BOOLEAN;
    errlabel: INTEGER;
    errno:    INTEGER;

BEGIN
    ASSERT(parser # NIL);
    ASSERT(parser.scanner # NIL);

    ExpectSym(parser, SCAN.lxMODULE);
    ExpectSym(parser, SCAN.lxIDENT);

    IF ~parser.main THEN
        check1(parser.lex.s = parser.modname, parser, 23)
    END;

    unit := PROG.newUnit(parser.lex.ident);

    parser.unit := unit;

    ExpectSym(parser, SCAN.lxSEMI);

    Next(parser);
    IF parser.sym = SCAN.lxIMPORT THEN
        ImportList(parser)
    END;

    INC(modules);

    CONSOLE.String("compiling ");
    CONSOLE.String("("); CONSOLE.Int(modules); CONSOLE.String(") ");
    CONSOLE.String(unit.name.s);
    IF parser.unit.sysimport THEN
        CONSOLE.String(" (SYSTEM)")
    END;
    CONSOLE.Ln;

    IF TARGETS.CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
        IL.fname(parser.fname)
    END;

    label := IL.NewLabel();
    IL.AddJmpCmd(IL.opJMP, label);

    name := IL.putstr(unit.name.s);

    errlabel := IL.NewLabel();
    IL.SetLabel(errlabel);
    IL.StrAdr(name);
    IL.Param1;
    IL.AddCmd(IL.opPUSHC, modules);
    IL.AddCmd0(IL.opERR);

    FOR errno := 1 TO LEN(IL.codes.errlabels) - 1 DO
        IL.SetErrLabel(errno);
        IL.AddCmd(IL.opPUSHC, errno);
        IL.AddJmpCmd(IL.opJMP, errlabel)
    END;

    endmod := DeclarationSequence(parser);

    IL.SetLabel(label);

    IF ~endmod THEN

        IF parser.sym = SCAN.lxBEGIN THEN
            Next(parser);
            parser.StatSeq(parser)
        END;

        checklex(parser, SCAN.lxEND);

        ExpectSym(parser, SCAN.lxIDENT);
        check1(parser.lex.s = unit.name.s, parser, 25);
        ExpectSym(parser, SCAN.lxPOINT)
    END;

    INC(lines, parser.lex.pos.line);
    PROG.closeUnit(unit)
END parse;


PROCEDURE open (parser: PARSER; modname: ARRAY OF CHAR): BOOLEAN;
BEGIN
    ASSERT(parser # NIL);

    STRINGS.append(parser.fname, modname);
    STRINGS.append(parser.fname, parser.ext);
    STRINGS.append(parser.modname, modname);

    parser.scanner := SCAN.open(parser.fname)

    RETURN parser.scanner # NIL
END open;


PROCEDURE NewParser (): PARSER;
VAR
    pars:  PARSER;
    citem: C.ITEM;

BEGIN
    citem := C.pop(parsers);
    IF citem = NIL THEN
        NEW(pars)
    ELSE
        pars := citem(PARSER)
    END

    RETURN pars
END NewParser;


PROCEDURE create* (path, lib_path: PATH; StatSeq: STATPROC; expression, designator: EXPRPROC; chkreturn: RETPROC): PARSER;
VAR
    parser: PARSER;

BEGIN
    parser := NewParser();

    parser.path     := path;
    parser.lib_path := lib_path;
    parser.ext      := UTILS.FILE_EXT;
    parser.fname    := path;
    parser.modname  := "";
    parser.scanner  := NIL;
    parser.unit     := NIL;
    parser.constexp := FALSE;
    parser.main     := FALSE;

    parser.open       := open;
    parser.parse      := parse;
    parser.StatSeq    := StatSeq;
    parser.expression := expression;
    parser.designator := designator;
    parser.chkreturn  := chkreturn;
    parser.create     := create

    RETURN parser
END create;


PROCEDURE init* (options: PROG.OPTIONS);
BEGIN
    PROG.create(options);
    parsers := C.create();
    lines   := 0;
    modules := 0
END init;


END PARS.