kolibrios/programs/develop/oberon07/Source/CODE.ob07

(*
    BSD 2-Clause License

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

MODULE CODE;

IMPORT LISTS, SCAN, STRINGS, CHL := CHUNKLISTS, C := COLLECTIONS;


CONST

    little_endian* = 0;
    big_endian* = 1;

    call_stack* = 0;
    call_win64* = 1;
    call_sysv*  = 2;

    opJMP* = 0; opLABEL* = 1; opCOPYS* = 2; opGADR* = 3; opCONST* = 4; opLLOAD32* = 5;
    opCOPYA* = 6; opCASET* = 7; opMULC* = 8; opMUL* = 9;
    opDIV* = 10; opMOD* = 11; opDIVL* = 12; opMODL* = 13; opDIVR* = 14; opMODR* = 15;
    opUMINUS* = 16;
    opADD* = 17; opSUB* = 18; opADDL* = 19; opSUBL* = 20; opADDR* = 21; opSUBR* = 22;
    opSAVE* = 23; opSAVEC* = 24; opSAVE8* = 25; opSAVE8C* = 26; opCHKBYTE* = 27; opDROP* = 28;
    opNOT* = 29;

    opEQ*  = 30; opNE*  = 31; opLT*  = 32; opLE*  = 33; opGT*  = 34; opGE*  = 35;
    opEQL* = 36; opNEL* = 37; opLTL* = 38; opLEL* = 39; opGTL* = 40; opGEL* = 41;
    opEQR* = 42; opNER* = 43; opLTR* = 44; opLER* = 45; opGTR* = 46; opGER* = 47;

    opVLOAD32* = 48; opGLOAD32* = 49;

    opJNE* = 50; opJE* = 51;

    opEQS* = 52; opNES* = opEQS + 1; opLTS* = opEQS + 2; opLES* = opEQS + 3; opGTS* = opEQS + 4; opGES* = opEQS + 5 (* 58 *);

    opSAVE32* = 58; opLLOAD8* = 59;

    opCONSTF* = 60; opLOADF* = 61; opSAVEF* = 62; opMULF* = 63; opDIVF* = 64; opDIVFI* = 65;
    opUMINF* = 66; opADDFI* = 67; opSUBFI* = 68; opADDF* = 69; opSUBF* = 70;

    opINC1B* = 71; opDEC1B* = 72; opINCCB* = 73; opDECCB* = 74; opINCB* = 75; opDECB* = 76;

    opCASEL* = 77; opCASER* = 78; opCASELR* = 79;

    opEQF*  = 80; opNEF*  = opEQF + 1; opLTF*  = opEQF + 2; opLEF*  = opEQF + 3; opGTF*  = opEQF + 4; opGEF*  = opEQF + 5;
    opEQFI* = opEQF + 6; opNEFI* = opEQF + 7; opLTFI* = opEQF + 8; opLEFI* = opEQF + 9; opGTFI* = opEQF + 10; opGEFI* = opEQF + 11; (* 91 *)

    opLOAD8* = 92; opLOAD16* = 93; opLOAD32* = 94; opPRECALL* = 95; opRES* = 96; opRESF* = 97;
    opERRC* = 98; opSWITCH* = 99;

    opSBOOL* = 100; opSBOOLC* = 101; opNOP* = 102;

    opMULS* = 103; opMULSC* = 104; opDIVS* = 105; opDIVSC* = 106;
    opADDS* = 107; opSUBS* = 108; opADDSL* = 109; opSUBSL* = 110; opADDSR* = 111; opSUBSR* = 112;
    opUMINS* = 113; opIN* = 114; opINL* = 115; opINR* = 116;
    opRSET* = 117; opRSETL* = 118; opRSETR* = 119; opRSET1* = 120; opLENGTH* = 121;

    opINC1* = 122; opDEC1* = 123; opINCC* = 124; opDECC* = 125; opINC* = 126; opDEC* = 127;
    opINCL* = 128; opEXCL* = 129; opINCLC* = 130; opEXCLC* = 131; opNEW* = 132; opDISP* = 133;
    opPACK* = 134; opPACKC* = 135; opUNPK* = 136; opCOPY* = 137; opENTER* = 138; opLEAVE* = 139;
    opCALL* = 140; opSAVEP* = 141; opCALLP* = 142; opEQP* = 143; opNEP* = 144; opLEAVER* = 145;
    opGET* = 146; opSAVE16* = 147; opABS* = 148; opFABS* = 149; opFLOOR* = 150; opFLT* = 151;
    opODD* = 152; opORD* = 153; opASR* = 154; opLSL* = 155; opROR* = 156;
    opASR1* = 157; opLSL1* = 158; opROR1* = 159; opASR2* = 160; opLSL2* = 161; opROR2* = 162;
    opPUSHP* = 163; opLADR* = 164; opTYPEGP* = 165; opIS* = 166; opPUSHF* = 167; opVADR* = 168;
    opPUSHT* = 169; opTYPEGR* = 170; opISREC* = 171; opCHKIDX* = 172; opPARAM* = 173;
    opCHKIDX2* = 174; opLEN* = 175; opROT* = 176; opSAVES* = 177; opSADR* = 178; opERR* = 179;

    opCHR* = 180; opENDSW* = 181; opLEAVEF* = 182; opCLEANUP* = 183; opMOVE* = 184;
    opLSR* = 185; opLSR1* = 186; opLSR2* = 187;
    opMIN* = 188; opMINC* = 189; opMAX* = 190; opMAXC* = 191; opJNZ* = 192;
    opEQB* = 193; opNEB* = 194; opINF* = 195; opJZ* = 196; opVLOAD8* = 197; opGLOAD8* = 198;
    opLLOAD16* = 199; opVLOAD16* = 200; opGLOAD16* = 201;
    opLOAD64* = 202; opLLOAD64* = 203; opVLOAD64* = 204; opGLOAD64* = 205; opSAVE64* = 206;

    opTYPEGD* = 207; opCALLI* = 208; opPUSHIP* = 209; opSAVEIP* = 210; opEQIP* = 211; opNEIP* = 212;
    opSAVE16C* = 213; opWCHR* = 214; opCOPYS2* = 215; opLENGTHW* = 216;

    opEQS2*  = 217; opNES2* = opEQS2 + 1; opLTS2* = opEQS2 + 2; opLES2* = opEQS2 + 3; opGTS2* = opEQS2 + 4; opGES2* = opEQS2 + 5 (* 222 *);
    opEQSW*  = 223; opNESW* = opEQSW + 1; opLTSW* = opEQSW + 2; opLESW* = opEQSW + 3; opGTSW* = opEQSW + 4; opGESW* = opEQSW + 5 (* 228 *);
    opEQSW2*  = 229; opNESW2* = opEQSW2 + 1; opLTSW2* = opEQSW2 + 2; opLESW2* = opEQSW2 + 3; opGTSW2* = opEQSW2 + 4; opGESW2* = opEQSW2 + 5 (* 234 *);

    opCODE* = 235;

    opALIGN16* = 236; opPOPSP* = 237;
    opWIN64CALL* = 238; opWIN64CALLI* = 239; opWIN64CALLP* = 240; opLOOP* = 241; opENDLOOP* = 242;
    opSYSVCALL* = 243; opSYSVCALLI* = 244; opSYSVCALLP* = 245; opSYSVALIGN16* = 246; opWIN64ALIGN16* = 247;


    opSADR_PARAM* = 1000; opLOAD64_PARAM* = 1001; opLLOAD64_PARAM* = 1002; opGLOAD64_PARAM* = 1003;
    opVADR_PARAM* = 1004; opCONST_PARAM* = 1005; opGLOAD32_PARAM* = 1006; opLLOAD32_PARAM* = 1007;
    opLOAD32_PARAM* = 1008;

    opLADR_SAVEC* = 1009; opGADR_SAVEC* = 1010; opLADR_SAVE* = 1011;

    opLADR_INC1* = 1012; opLADR_DEC1* = 1013; opLADR_INCC* = 1014; opLADR_DECC* = 1015;
    opLADR_INC1B* = 1016; opLADR_DEC1B* = 1017; opLADR_INCCB* = 1018; opLADR_DECCB* = 1019;
    opLADR_INC* = 1020; opLADR_DEC* = 1021; opLADR_INCB* = 1022; opLADR_DECB* = 1023;
    opLADR_INCL* = 1024; opLADR_EXCL* = 1025; opLADR_INCLC* = 1026; opLADR_EXCLC* = 1027;
    opLADR_UNPK* = 1028;


    _move      *=   0;
    _move2     *=   1;
    _strcmpw   *=   2;
    _strcmpw2  *=   3;
    _set       *=   4;
    _set2      *=   5;
    _lengthw   *=   6;
    _strcmp2   *=   7;
    _div       *=   8;
    _mod       *=   9;
    _div2      *=  10;
    _mod2      *=  11;
    _arrcpy    *=  12;
    _rot       *=  13;
    _new       *=  14;
    _dispose   *=  15;
    _strcmp    *=  16;
    _error     *=  17;
    _is        *=  18;
    _isrec     *=  19;
    _guard     *=  20;
    _guardrec  *=  21;
    _length    *=  22;
    _init      *=  23;
    _dllentry  *=  24;
    _strcpy    *=  25;
    _exit      *=  26;
    _strcpy2   *=  27;


TYPE

    LOCALVAR* = POINTER TO RECORD (LISTS.ITEM)

        offset*, size*, count*: INTEGER

    END;

    COMMAND* = POINTER TO RECORD (LISTS.ITEM)

        opcode*:    INTEGER;
        param1*:    INTEGER;
        param2*:    INTEGER;
        param3*:    INTEGER;
        float*:     REAL;
        variables*: LISTS.LIST;
        allocReg*:  BOOLEAN

    END;

    CMDSTACK = POINTER TO RECORD

        data: ARRAY 1000 OF COMMAND;
        top:  INTEGER

    END;

    EXPORT_PROC* = POINTER TO RECORD (LISTS.ITEM)

        label*: INTEGER;
        name*:  SCAN.LEXSTR

    END;

    IMPORT_LIB* = POINTER TO RECORD (LISTS.ITEM)

        name*:   SCAN.LEXSTR;
        procs*:  LISTS.LIST

    END;

    IMPORT_PROC* = POINTER TO RECORD (LISTS.ITEM)

        label*: INTEGER;
        lib*:   IMPORT_LIB;
        name*:  SCAN.LEXSTR;
        count:  INTEGER

    END;


    CODES* = POINTER TO RECORD

        last:       COMMAND;
        begcall:    CMDSTACK;
        endcall:    CMDSTACK;
        commands*:  LISTS.LIST;
        export*:    LISTS.LIST;
        import*:    LISTS.LIST;
        types*:     CHL.INTLIST;
        data*:      CHL.BYTELIST;
        dmin*:      INTEGER;
        lcount*:    INTEGER;
        bss*:       INTEGER;
        rtl*:       ARRAY 28 OF INTEGER;

        charoffs:   ARRAY 256 OF INTEGER;
        wcharoffs:  ARRAY 65536 OF INTEGER;

        fregs:      INTEGER;
        wstr:       ARRAY 4*1024 OF WCHAR;

        errlabel*:  INTEGER

    END;


VAR

    codes*: CODES;
    endianness: INTEGER;
    numRegsFloat: INTEGER;

    commands, variables: C.COLLECTION;


PROCEDURE NewCmd (): COMMAND;
VAR
    cmd:   COMMAND;
    citem: C.ITEM;

BEGIN
    citem := C.pop(commands);
    IF citem = NIL THEN
        NEW(cmd)
    ELSE
        cmd := citem(COMMAND)
    END;

    cmd.allocReg := FALSE

    RETURN cmd
END NewCmd;


PROCEDURE NewVar* (): LOCALVAR;
VAR
    lvar:  LOCALVAR;
    citem: C.ITEM;

BEGIN
    citem := C.pop(variables);
    IF citem = NIL THEN
        NEW(lvar)
    ELSE
        lvar := citem(LOCALVAR)
    END;

    lvar.count := 0

    RETURN lvar
END NewVar;


PROCEDURE setlast* (cmd: COMMAND);
BEGIN
    codes.last := cmd
END setlast;


PROCEDURE getlast* (): COMMAND;
    RETURN codes.last
END getlast;


PROCEDURE PutByte (codes: CODES; b: BYTE);
BEGIN
    CHL.PushByte(codes.data, b)
END PutByte;


PROCEDURE putstr* (s: ARRAY OF CHAR): INTEGER;
VAR
    i, n, res: INTEGER;
BEGIN
    res := CHL.Length(codes.data);

    i := 0;
    n := LENGTH(s);
    WHILE i < n DO
        PutByte(codes, ORD(s[i]));
        INC(i)
    END;

    PutByte(codes, 0)

    RETURN res
END putstr;


PROCEDURE putstr1* (c: INTEGER): INTEGER;
VAR
    res: INTEGER;

BEGIN
    IF codes.charoffs[c] = -1 THEN
        res := CHL.Length(codes.data);
        PutByte(codes, c);
        PutByte(codes, 0);
        codes.charoffs[c] := res
    ELSE
        res := codes.charoffs[c]
    END

    RETURN res
END putstr1;


PROCEDURE putstrW* (s: ARRAY OF CHAR): INTEGER;
VAR
    i, n, res: INTEGER;

BEGIN
    res := CHL.Length(codes.data);

    IF ODD(res) THEN
        PutByte(codes, 0);
        INC(res)
    END;

    n := STRINGS.Utf8To16(s, codes.wstr);

    i := 0;
    WHILE i < n DO
        IF endianness = little_endian THEN
            PutByte(codes, ORD(codes.wstr[i]) MOD 256);
            PutByte(codes, ORD(codes.wstr[i]) DIV 256)
        ELSIF endianness = big_endian THEN
            PutByte(codes, ORD(codes.wstr[i]) DIV 256);
            PutByte(codes, ORD(codes.wstr[i]) MOD 256)
        END;
        INC(i)
    END;

    PutByte(codes, 0);
    PutByte(codes, 0)

    RETURN res
END putstrW;


PROCEDURE putstrW1* (c: INTEGER): INTEGER;
VAR
    res: INTEGER;

BEGIN
    IF codes.wcharoffs[c] = -1 THEN
        res := CHL.Length(codes.data);

        IF ODD(res) THEN
            PutByte(codes, 0);
            INC(res)
        END;

        IF endianness = little_endian THEN
            PutByte(codes, c MOD 256);
            PutByte(codes, c DIV 256)
        ELSIF endianness = big_endian THEN
            PutByte(codes, c DIV 256);
            PutByte(codes, c MOD 256)
        END;

        PutByte(codes, 0);
        PutByte(codes, 0);

        codes.wcharoffs[c] := res
    ELSE
        res := codes.wcharoffs[c]
    END

    RETURN res
END putstrW1;


PROCEDURE SetMinDataSize* (size: INTEGER);
BEGIN
    codes.dmin := CHL.Length(codes.data) + size
END SetMinDataSize;


PROCEDURE push (stk: CMDSTACK; cmd: COMMAND);
BEGIN
    INC(stk.top);
    stk.data[stk.top] := cmd
END push;


PROCEDURE pop (stk: CMDSTACK): COMMAND;
VAR
    res: COMMAND;
BEGIN
    res := stk.data[stk.top];
    DEC(stk.top)
    RETURN res
END pop;


PROCEDURE pushBegEnd* (VAR beg, end: COMMAND);
BEGIN
    push(codes.begcall, beg);
    push(codes.endcall, end);
    beg := codes.last;
    end := beg.next(COMMAND)
END pushBegEnd;


PROCEDURE popBegEnd* (VAR beg, end: COMMAND);
BEGIN
    beg := pop(codes.begcall);
    end := pop(codes.endcall)
END popBegEnd;


PROCEDURE AddRec* (base: INTEGER);
BEGIN
    CHL.PushInt(codes.types, base)
END AddRec;


PROCEDURE insert (cur, nov: COMMAND);
VAR
    old_opcode, param2: INTEGER;


    PROCEDURE set (cur: COMMAND; opcode, param2: INTEGER);
    BEGIN
        cur.opcode := opcode;
        cur.param1 := cur.param2;
        cur.param2 := param2
    END set;


BEGIN
    old_opcode := cur.opcode;
    param2 := nov.param2;

    IF (nov.opcode = opPARAM) & (param2 = 1) THEN

        CASE old_opcode OF
        |opGLOAD64: cur.opcode := opGLOAD64_PARAM
        |opLLOAD64: cur.opcode := opLLOAD64_PARAM
        |opLOAD64:  cur.opcode := opLOAD64_PARAM
        |opGLOAD32: cur.opcode := opGLOAD32_PARAM
        |opLLOAD32: cur.opcode := opLLOAD32_PARAM
        |opLOAD32:  cur.opcode := opLOAD32_PARAM
        |opSADR:    cur.opcode := opSADR_PARAM
        |opVADR:    cur.opcode := opVADR_PARAM
        |opCONST:   cur.opcode := opCONST_PARAM
        ELSE
            old_opcode := -1
        END

    ELSIF old_opcode = opLADR THEN

        CASE nov.opcode OF
        |opSAVEC: set(cur, opLADR_SAVEC, param2)
        |opSAVE:  cur.opcode := opLADR_SAVE
        |opINC1:  cur.opcode := opLADR_INC1
        |opDEC1:  cur.opcode := opLADR_DEC1
        |opINC:   cur.opcode := opLADR_INC
        |opDEC:   cur.opcode := opLADR_DEC
        |opINC1B: cur.opcode := opLADR_INC1B
        |opDEC1B: cur.opcode := opLADR_DEC1B
        |opINCB:  cur.opcode := opLADR_INCB
        |opDECB:  cur.opcode := opLADR_DECB
        |opINCL:  cur.opcode := opLADR_INCL
        |opEXCL:  cur.opcode := opLADR_EXCL
        |opUNPK:  cur.opcode := opLADR_UNPK
        |opINCC:  set(cur, opLADR_INCC, param2)
        |opDECC:  set(cur, opLADR_DECC, param2)
        |opINCCB: set(cur, opLADR_INCCB, param2)
        |opDECCB: set(cur, opLADR_DECCB, param2)
        |opINCLC: set(cur, opLADR_INCLC, param2)
        |opEXCLC: set(cur, opLADR_EXCLC, param2)
        ELSE
            old_opcode := -1
        END

    ELSIF (nov.opcode = opSAVEC) & (old_opcode = opGADR) THEN
        set(cur, opGADR_SAVEC, param2)

    ELSIF (nov.opcode = opMULC) & (old_opcode = opMULC) THEN
        cur.param2 := param2 * cur.param2

    ELSE
        old_opcode := -1
    END;

    IF old_opcode = -1 THEN
        LISTS.insert(codes.commands, cur, nov);
        codes.last := nov
    ELSE
        C.push(commands, nov);
        codes.last := cur
    END
END insert;


PROCEDURE AddCmd* (opcode: INTEGER; param: INTEGER);
VAR
    cmd: COMMAND;
BEGIN
    cmd := NewCmd();
    cmd.opcode := opcode;
    cmd.param1 := 0;
    cmd.param2 := param;
    insert(codes.last, cmd)
END AddCmd;


PROCEDURE AddCmd2* (opcode: INTEGER; param1, param2: INTEGER);
VAR
    cmd: COMMAND;
BEGIN
    cmd := NewCmd();
    cmd.opcode := opcode;
    cmd.param1 := param1;
    cmd.param2 := param2;
    insert(codes.last, cmd)
END AddCmd2;


PROCEDURE NewLabel* (): INTEGER;
BEGIN
    INC(codes.lcount)
    RETURN codes.lcount - 1
END NewLabel;


PROCEDURE SetLabel* (label: INTEGER);
BEGIN
    AddCmd(opLABEL, label)
END SetLabel;


PROCEDURE SetErrLabel*;
BEGIN
    codes.errlabel := NewLabel();
    SetLabel(codes.errlabel)
END SetErrLabel;


PROCEDURE AddCmd0* (opcode: INTEGER);
BEGIN
    AddCmd(opcode, 0)
END AddCmd0;


PROCEDURE deleteVarList (list: LISTS.LIST);
VAR
    last: LISTS.ITEM;

BEGIN
    WHILE list.last # NIL DO
        last := LISTS.pop(list);
        C.push(variables, last)
    END
END deleteVarList;


PROCEDURE delete (cmd: COMMAND);
BEGIN
    IF cmd.variables # NIL THEN
        deleteVarList(cmd.variables)
    END;
    LISTS.delete(codes.commands, cmd);
    C.push(commands, cmd)
END delete;


PROCEDURE delete2* (first, last: LISTS.ITEM);
VAR
    cur, next: LISTS.ITEM;

BEGIN
    cur := first;

    IF first # last THEN
        REPEAT
            next := cur.next;
            LISTS.delete(codes.commands, cur);
            C.push(commands, cur);
            cur := next
        UNTIL cur = last
    END;

    LISTS.delete(codes.commands, cur);
    C.push(commands, cur)
END delete2;


PROCEDURE AddJmpCmd* (opcode: INTEGER; label: INTEGER);
VAR
    prev: COMMAND;
    not:  BOOLEAN;

BEGIN
    prev := codes.last;
    not := prev.opcode = opNOT;
    IF not THEN
        IF opcode = opJE THEN
            opcode := opJNE
        ELSIF opcode = opJNE THEN
            opcode := opJE
        ELSE
            not := FALSE
        END
    END;

    AddCmd2(opcode, label, label);

    IF not THEN
        delete(prev)
    END

END AddJmpCmd;


PROCEDURE OnError* (line, error: INTEGER);
BEGIN
    AddCmd(opERRC, LSL(line, 4) + error);
    AddJmpCmd(opJMP, codes.errlabel)
END OnError;


PROCEDURE TypeGuard* (op, t: INTEGER; line, error: INTEGER);
VAR
    label: INTEGER;
BEGIN
    AddCmd(op, t);
    label := NewLabel();
    AddJmpCmd(opJE, label);
    OnError(line, error);
    SetLabel(label)
END TypeGuard;


PROCEDURE TypeCheck* (t: INTEGER);
BEGIN
    AddCmd(opIS, t)
END TypeCheck;


PROCEDURE TypeCheckRec* (t: INTEGER);
BEGIN
    AddCmd(opISREC, t)
END TypeCheckRec;


PROCEDURE New* (size, typenum: INTEGER);
BEGIN
    AddCmd2(opNEW, typenum, size)
END New;


PROCEDURE fcmp* (opcode: INTEGER);
BEGIN
    AddCmd(opcode, 0);
    DEC(codes.fregs, 2);
    ASSERT(codes.fregs >= 0)
END fcmp;


PROCEDURE not*;
VAR
    prev: COMMAND;
BEGIN
    prev := codes.last;
    IF prev.opcode = opNOT THEN
        codes.last := prev.prev(COMMAND);
        delete(prev)
    ELSE
        AddCmd0(opNOT)
    END
END not;


PROCEDURE Enter* (label, params: INTEGER): COMMAND;
VAR
    cmd: COMMAND;

BEGIN
    cmd := NewCmd();
    cmd.opcode := opENTER;
    cmd.param1 := label;
    cmd.param3 := params;
    cmd.allocReg := TRUE;
    insert(codes.last, cmd)

    RETURN codes.last
END Enter;


PROCEDURE Leave* (result, float: BOOLEAN; paramsize: INTEGER): COMMAND;
BEGIN
    IF result THEN
        IF float THEN
            AddCmd(opLEAVEF, paramsize)
        ELSE
            AddCmd(opLEAVER, paramsize)
        END
    ELSE
        AddCmd(opLEAVE, paramsize)
    END

    RETURN codes.last
END Leave;


PROCEDURE Call* (proc, callconv, fparams: INTEGER);
BEGIN
    CASE callconv OF
    |call_stack: AddJmpCmd(opCALL, proc)
    |call_win64: AddJmpCmd(opWIN64CALL, proc)
    |call_sysv:  AddJmpCmd(opSYSVCALL, proc)
    END;
    codes.last(COMMAND).param2 := fparams
END Call;


PROCEDURE CallImp* (proc: LISTS.ITEM; callconv, fparams: INTEGER);
BEGIN
    CASE callconv OF
    |call_stack: AddJmpCmd(opCALLI, proc(IMPORT_PROC).label)
    |call_win64: AddJmpCmd(opWIN64CALLI, proc(IMPORT_PROC).label)
    |call_sysv:  AddJmpCmd(opSYSVCALLI, proc(IMPORT_PROC).label)
    END;
    codes.last(COMMAND).param2 := fparams
END CallImp;


PROCEDURE CallP* (callconv, fparams: INTEGER);
BEGIN
    CASE callconv OF
    |call_stack: AddCmd0(opCALLP)
    |call_win64: AddCmd(opWIN64CALLP, fparams)
    |call_sysv:  AddCmd(opSYSVCALLP, fparams)
    END
END CallP;


PROCEDURE AssignProc* (proc: INTEGER);
BEGIN
    AddJmpCmd(opSAVEP, proc)
END AssignProc;


PROCEDURE AssignImpProc* (proc: LISTS.ITEM);
BEGIN
    AddJmpCmd(opSAVEIP, proc(IMPORT_PROC).label)
END AssignImpProc;


PROCEDURE PushProc* (proc: INTEGER);
BEGIN
    AddJmpCmd(opPUSHP, proc)
END PushProc;


PROCEDURE PushImpProc* (proc: LISTS.ITEM);
BEGIN
    AddJmpCmd(opPUSHIP, proc(IMPORT_PROC).label)
END PushImpProc;


PROCEDURE ProcCmp* (proc: INTEGER; eq: BOOLEAN);
BEGIN
    IF eq THEN
        AddJmpCmd(opEQP, proc)
    ELSE
        AddJmpCmd(opNEP, proc)
    END
END ProcCmp;


PROCEDURE ProcImpCmp* (proc: LISTS.ITEM; eq: BOOLEAN);
BEGIN
    IF eq THEN
        AddJmpCmd(opEQIP, proc(IMPORT_PROC).label)
    ELSE
        AddJmpCmd(opNEIP, proc(IMPORT_PROC).label)
    END
END ProcImpCmp;


PROCEDURE SysGet* (size: INTEGER);
BEGIN
    AddCmd(opGET, size)
END SysGet;


PROCEDURE load* (size: INTEGER);
VAR
    last: COMMAND;

BEGIN
    last := codes.last;
    CASE size OF
    |1:
        IF last.opcode = opLADR THEN
            last.opcode := opLLOAD8
        ELSIF last.opcode = opVADR THEN
            last.opcode := opVLOAD8
        ELSIF last.opcode = opGADR THEN
            last.opcode := opGLOAD8
        ELSE
            AddCmd0(opLOAD8)
        END

    |2:
        IF last.opcode = opLADR THEN
            last.opcode := opLLOAD16
        ELSIF last.opcode = opVADR THEN
            last.opcode := opVLOAD16
        ELSIF last.opcode = opGADR THEN
            last.opcode := opGLOAD16
        ELSE
            AddCmd0(opLOAD16)
        END

    |4:
        IF last.opcode = opLADR THEN
            last.opcode := opLLOAD32
        ELSIF last.opcode = opVADR THEN
            last.opcode := opVLOAD32
        ELSIF last.opcode = opGADR THEN
            last.opcode := opGLOAD32
        ELSE
            AddCmd0(opLOAD32)
        END

    |8:
        IF last.opcode = opLADR THEN
            last.opcode := opLLOAD64
        ELSIF last.opcode = opVADR THEN
            last.opcode := opVLOAD64
        ELSIF last.opcode = opGADR THEN
            last.opcode := opGLOAD64
        ELSE
            AddCmd0(opLOAD64)
        END
    END
END load;


PROCEDURE SysPut* (size: INTEGER);
BEGIN
    CASE size OF
    |1: AddCmd0(opSAVE8)
    |2: AddCmd0(opSAVE16)
    |4: AddCmd0(opSAVE32)
    |8: AddCmd0(opSAVE64)
    END
END SysPut;


PROCEDURE savef*;
BEGIN
    AddCmd0(opSAVEF);
    DEC(codes.fregs);
    ASSERT(codes.fregs >= 0)
END savef;


PROCEDURE pushf*;
BEGIN
    AddCmd0(opPUSHF);
    DEC(codes.fregs);
    ASSERT(codes.fregs >= 0)
END pushf;


PROCEDURE loadf* (): BOOLEAN;
BEGIN
    AddCmd0(opLOADF);
    INC(codes.fregs)
    RETURN codes.fregs < numRegsFloat
END loadf;


PROCEDURE inf* (): BOOLEAN;
BEGIN
    AddCmd0(opINF);
    INC(codes.fregs)
    RETURN codes.fregs < numRegsFloat
END inf;


PROCEDURE fbinop* (opcode: INTEGER);
BEGIN
    AddCmd0(opcode);
    DEC(codes.fregs);
    ASSERT(codes.fregs > 0)
END fbinop;


PROCEDURE saves* (offset, length: INTEGER);
BEGIN
    AddCmd2(opSAVES, length, offset)
END saves;


PROCEDURE abs* (real: BOOLEAN);
BEGIN
    IF real THEN
        AddCmd0(opFABS)
    ELSE
        AddCmd0(opABS)
    END
END abs;


PROCEDURE floor*;
BEGIN
    AddCmd0(opFLOOR);
    DEC(codes.fregs);
    ASSERT(codes.fregs >= 0)
END floor;


PROCEDURE flt* (): BOOLEAN;
BEGIN
    AddCmd0(opFLT);
    INC(codes.fregs)
    RETURN codes.fregs < numRegsFloat
END flt;


PROCEDURE odd*;
BEGIN
    AddCmd0(opODD)
END odd;


PROCEDURE ord*;
BEGIN
    AddCmd0(opORD)
END ord;


PROCEDURE shift_minmax* (op: CHAR);
BEGIN
    CASE op OF
    |"A": AddCmd0(opASR)
    |"L": AddCmd0(opLSL)
    |"O": AddCmd0(opROR)
    |"R": AddCmd0(opLSR)
    |"m": AddCmd0(opMIN)
    |"x": AddCmd0(opMAX)
    END
END shift_minmax;


PROCEDURE shift_minmax1* (op: CHAR; x: INTEGER);
BEGIN
    CASE op OF
    |"A": AddCmd(opASR1, x)
    |"L": AddCmd(opLSL1, x)
    |"O": AddCmd(opROR1, x)
    |"R": AddCmd(opLSR1, x)
    |"m": AddCmd(opMINC, x)
    |"x": AddCmd(opMAXC, x)
    END
END shift_minmax1;


PROCEDURE shift_minmax2* (op: CHAR; x: INTEGER);
BEGIN
    CASE op OF
    |"A": AddCmd(opASR2, x)
    |"L": AddCmd(opLSL2, x)
    |"O": AddCmd(opROR2, x)
    |"R": AddCmd(opLSR2, x)
    |"m": AddCmd(opMINC, x)
    |"x": AddCmd(opMAXC, x)
    END
END shift_minmax2;


PROCEDURE len* (dim: INTEGER);
BEGIN
    AddCmd(opLEN, dim)
END len;


PROCEDURE Float* (r: REAL);
VAR
    cmd: COMMAND;

BEGIN
    cmd := NewCmd();
    cmd.opcode := opCONSTF;
    cmd.float := r;
    insert(codes.last, cmd);
    INC(codes.fregs);
    ASSERT(codes.fregs <= numRegsFloat)
END Float;


PROCEDURE precall* (flt: BOOLEAN): INTEGER;
VAR
    res: INTEGER;
BEGIN
    res := codes.fregs;
    AddCmd2(opPRECALL, ORD(flt), res);
    codes.fregs := 0
    RETURN res
END precall;


PROCEDURE resf* (fregs: INTEGER): BOOLEAN;
BEGIN
    AddCmd(opRESF, fregs);
    codes.fregs := fregs + 1
    RETURN codes.fregs < numRegsFloat
END resf;


PROCEDURE res* (fregs: INTEGER);
BEGIN
    AddCmd(opRES, fregs);
    codes.fregs := fregs
END res;


PROCEDURE retf*;
BEGIN
    DEC(codes.fregs);
    ASSERT(codes.fregs = 0)
END retf;


PROCEDURE drop*;
BEGIN
    AddCmd0(opDROP)
END drop;


PROCEDURE case* (a, b, L, R: INTEGER);
VAR
    cmd: COMMAND;

BEGIN
    IF a = b THEN
        cmd := NewCmd();
        cmd.opcode := opCASELR;
        cmd.param1 := a;
        cmd.param2 := L;
        cmd.param3 := R;
        insert(codes.last, cmd)
    ELSE
        AddCmd2(opCASEL, a, L);
        AddCmd2(opCASER, b, R)
    END
END case;


PROCEDURE caset* (a, label: INTEGER);
BEGIN
    AddCmd2(opCASET, label, a)
END caset;


PROCEDURE AddExp* (label: INTEGER; name: SCAN.LEXSTR);
VAR
    exp: EXPORT_PROC;

BEGIN
    NEW(exp);
    exp.label := label;
    exp.name  := name;
    LISTS.push(codes.export, exp)
END AddExp;


PROCEDURE AddImp* (dll, proc: SCAN.LEXSTR): IMPORT_PROC;
VAR
    lib: IMPORT_LIB;
    p:   IMPORT_PROC;

BEGIN
    lib := codes.import.first(IMPORT_LIB);
    WHILE (lib # NIL) & (lib.name # dll) DO
        lib := lib.next(IMPORT_LIB)
    END;

    IF lib = NIL THEN
        NEW(lib);
        lib.name := dll;
        lib.procs := LISTS.create(NIL);
        LISTS.push(codes.import, lib)
    END;

    p := lib.procs.first(IMPORT_PROC);
    WHILE (p # NIL) & (p.name # proc) DO
        p := p.next(IMPORT_PROC)
    END;

    IF p = NIL THEN
        NEW(p);
        p.name  := proc;
        p.label := NewLabel();
        p.lib   := lib;
        p.count := 1;
        LISTS.push(lib.procs, p)
    ELSE
        INC(p.count)
    END

    RETURN p
END AddImp;


PROCEDURE DelImport* (imp: LISTS.ITEM);
VAR
    lib: IMPORT_LIB;

BEGIN
    DEC(imp(IMPORT_PROC).count);
    IF imp(IMPORT_PROC).count = 0 THEN
        lib := imp(IMPORT_PROC).lib;
        LISTS.delete(lib.procs, imp);
        IF lib.procs.first = NIL THEN
            LISTS.delete(codes.import, lib)
        END
    END
END DelImport;


PROCEDURE init* (pNumRegsFloat, pEndianness: INTEGER);
VAR
    cmd:    COMMAND;
    i:      INTEGER;

BEGIN
    commands := C.create();
    variables := C.create();
    numRegsFloat := pNumRegsFloat;
    endianness := pEndianness;

    NEW(codes);
    NEW(codes.begcall);
    codes.begcall.top := -1;
    NEW(codes.endcall);
    codes.endcall.top := -1;
    codes.commands := LISTS.create(NIL);
    codes.export   := LISTS.create(NIL);
    codes.import   := LISTS.create(NIL);
    codes.types    := CHL.CreateIntList();
    codes.data     := CHL.CreateByteList();

    NEW(cmd); cmd.opcode := opNOP; LISTS.push(codes.commands, cmd);
    codes.last := cmd;
    NEW(cmd); cmd.opcode := opNOP; LISTS.push(codes.commands, cmd);

    AddRec(0);

    codes.lcount := 0;

    codes.fregs := 0;

    FOR i := 0 TO LEN(codes.charoffs) - 1 DO
        codes.charoffs[i] := -1
    END;

    FOR i := 0 TO LEN(codes.wcharoffs) - 1 DO
        codes.wcharoffs[i] := -1
    END

END init;


END CODE.