Subversion Repositories Kolibri OS

Rev

Rev 7983 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
7983 leency 1
(*
7597 akron1 2
    BSD 2-Clause License
3
 
8097 maxcodehac 4
    Copyright (c) 2018-2020, Anton Krotov
7597 akron1 5
    All rights reserved.
6
*)
7
 
8
MODULE PROG;
9
 
8097 maxcodehac 10
IMPORT SCAN, LISTS, ARITH, ERRORS, C := COLLECTIONS, IL, UTILS, TARGETS, STRINGS;
7597 akron1 11
 
12
 
13
CONST
14
 
15
    MAXARRDIM*    = 5;
16
    MAXSCOPE      = 16;
17
    MAXSYSVPARAM* = 26;
18
 
19
    idNONE*    =  0;  idGUARD   =  1;  idMODULE* =  2;  idCONST*   =  3;
20
    idTYPE*    =  4;  idSTFUNC* =  5;  idSTPROC* =  6;  idVAR*     =  7;
21
    idPROC*    =  8;  idVPAR*   =  9;  idPARAM*  = 10;  idSYSFUNC* = 11;
22
    idSYSPROC* = 12;  idIMP*    = 13;
23
 
24
    tINTEGER* =  1;  tBYTE*      =  2;  tCHAR*   =  3;  tSET*    =  4;
25
    tBOOLEAN* =  5;  tREAL*      =  6;  tARRAY*  =  7;  tRECORD* =  8;
26
    tPOINTER* =  9;  tPROCEDURE* = 10;  tSTRING* = 11;  tNIL*    = 12;
8097 maxcodehac 27
    tCARD32*  = 13;  tANYREC*    = 14;  tWCHAR*  = 15;  tNONE*   = 16;
7597 akron1 28
 
7696 akron1 29
    BASICTYPES* = {tINTEGER, tBYTE, tCHAR, tSET, tBOOLEAN, tREAL, tCARD32, tWCHAR};
7597 akron1 30
 
31
    stABS*  =  1;  stASR*  =  2;  stCHR*    =  3;  stFLOOR* =  4;
32
    stFLT*  =  5;  stLEN*  =  6;  stLSL*    =  7;  stODD*   =  8;
33
    stORD*  =  9;  stROR*  = 10;  stASSERT* = 11;  stDEC*   = 12;
34
    stEXCL* = 13;  stINC*  = 14;  stINCL*   = 15;  stNEW*   = 16;
35
    stPACK* = 17;  stUNPK* = 18;  sysADR*   = 19;  sysSIZE* = 20;
36
    sysGET* = 21;  sysPUT* = 22;
37
 
8097 maxcodehac 38
    stDISPOSE* = 23;  stLSR*     = 24;  stBITS*   = 25;  sysCODE*  = 26;
39
    sysMOVE*   = 27;  stLENGTH*  = 28;  stMIN*    = 29;  stMAX*    = 30;
40
    sysSADR*   = 31;  sysTYPEID* = 32;  sysCOPY*  = 33;  sysINF*   = 34;
41
    sysPUT8*   = 35;  sysPUT16*  = 36;  stCOPY*   = 37;  stWCHR*   = 38;
42
    sysWSADR*  = 39;  sysPUT32*  = 40;  (*sysNOP*   = 41;  sysEINT*  = 42;
43
    sysDINT*   = 43;*)sysGET8*   = 44;  sysGET16* = 45;  sysGET32* = 46;
7597 akron1 44
 
8097 maxcodehac 45
    default32* =  2;  _default32* = default32 + 1;
7597 akron1 46
    stdcall*   =  4;  _stdcall*   = stdcall + 1;
47
    ccall*     =  6;  _ccall*     = ccall + 1;
48
    ccall16*   =  8;  _ccall16*   = ccall16 + 1;
49
    win64*     = 10;  _win64*     = win64 + 1;
50
    stdcall64* = 12;  _stdcall64* = stdcall64 + 1;
8097 maxcodehac 51
    default64* = 14;  _default64* = default64 + 1;
7597 akron1 52
    systemv*   = 16;  _systemv*   = systemv + 1;
7693 akron1 53
    default16* = 18;
54
    code*      = 20;  _code*      = code + 1;
7597 akron1 55
 
7693 akron1 56
    noalign* = 22;
7597 akron1 57
 
7693 akron1 58
    callee_clean_up* = {default32, stdcall, _stdcall, default64, stdcall64, _stdcall64};
7597 akron1 59
 
8097 maxcodehac 60
    sf_stdcall* =  0; sf_stdcall64* = 1; sf_ccall*   = 2; sf_ccall16* = 3;
61
    sf_win64*   =  4; sf_systemv*   = 5; sf_windows* = 6; sf_linux*   = 7;
62
    sf_code*    =  8; sf_oberon*    = 9;
63
    sf_noalign* = 10;
7693 akron1 64
 
8097 maxcodehac 65
    proc_flags* = {sf_stdcall, sf_stdcall64, sf_ccall, sf_ccall16, sf_win64, sf_systemv, sf_windows, sf_linux, sf_code, sf_oberon};
7693 akron1 66
    rec_flags*  = {sf_noalign};
67
 
7597 akron1 68
    STACK_FRAME = 2;
69
 
70
 
71
TYPE
72
 
7693 akron1 73
    OPTIONS* = RECORD
74
 
7696 akron1 75
        version*, stack*, ram*, rom*: INTEGER;
8097 maxcodehac 76
        pic*, lower*: BOOLEAN;
7693 akron1 77
        checking*: SET
78
 
79
    END;
80
 
7597 akron1 81
    IDENT* = POINTER TO rIDENT;
82
 
83
    UNIT* = POINTER TO rUNIT;
84
 
8097 maxcodehac 85
    _TYPE* = POINTER TO rTYPE;
7597 akron1 86
 
87
    FRWPTR* = POINTER TO RECORD (LISTS.ITEM)
88
 
8097 maxcodehac 89
        _type:       _TYPE;
7597 akron1 90
        baseIdent:   SCAN.IDENT;
91
        linked:      BOOLEAN;
92
 
93
        pos*:        SCAN.POSITION;
94
        notRecord*:  BOOLEAN
95
 
96
    END;
97
 
98
    PROC* = POINTER TO RECORD (LISTS.ITEM)
99
 
100
        label*:      INTEGER;
101
        used*:       BOOLEAN;
102
        processed*:  BOOLEAN;
8097 maxcodehac 103
        _import*:    LISTS.ITEM;
7597 akron1 104
        using*:      LISTS.LIST;
105
        enter*,
106
        leave*:      LISTS.ITEM
107
 
108
    END;
109
 
110
    USED_PROC = POINTER TO RECORD (LISTS.ITEM)
111
 
112
        proc: PROC
113
 
114
    END;
115
 
116
    rUNIT = RECORD (LISTS.ITEM)
117
 
118
        name*:       SCAN.IDENT;
7693 akron1 119
        idents*:     LISTS.LIST;
7597 akron1 120
        frwPointers: LISTS.LIST;
121
        gscope:      IDENT;
122
        closed*:     BOOLEAN;
123
        scopeLvl*:   INTEGER;
124
        sysimport*:  BOOLEAN;
7693 akron1 125
        scopes*:     ARRAY MAXSCOPE OF PROC
7597 akron1 126
 
127
    END;
128
 
129
    FIELD* = POINTER TO rFIELD;
130
 
131
    PARAM* = POINTER TO rPARAM;
132
 
8097 maxcodehac 133
    rTYPE = RECORD (LISTS.ITEM)
7597 akron1 134
 
135
        typ*:        INTEGER;
136
        size*:       INTEGER;
7693 akron1 137
        parSize*:    INTEGER;
7597 akron1 138
        length*:     INTEGER;
139
        align*:      INTEGER;
8097 maxcodehac 140
        base*:       _TYPE;
7693 akron1 141
        fields*:     LISTS.LIST;
142
        params*:     LISTS.LIST;
7597 akron1 143
        unit*:       UNIT;
144
        closed*:     BOOLEAN;
145
        num*:        INTEGER;
146
        call*:       INTEGER;
8097 maxcodehac 147
        _import*:    BOOLEAN;
7597 akron1 148
        noalign*:    BOOLEAN
149
 
150
    END;
151
 
152
    rFIELD = RECORD (LISTS.ITEM)
153
 
8097 maxcodehac 154
        _type*:      _TYPE;
7597 akron1 155
        name*:       SCAN.IDENT;
156
        export*:     BOOLEAN;
157
        offset*:     INTEGER
158
 
159
    END;
160
 
161
    rPARAM = RECORD (LISTS.ITEM)
162
 
163
        name*:       SCAN.IDENT;
8097 maxcodehac 164
        _type*:      _TYPE;
7597 akron1 165
        vPar*:       BOOLEAN;
166
        offset*:     INTEGER
167
 
168
    END;
169
 
170
    rIDENT = RECORD (LISTS.ITEM)
171
 
172
        name*:       SCAN.IDENT;
173
        typ*:        INTEGER;
174
        export*:     BOOLEAN;
8097 maxcodehac 175
        _import*:    LISTS.ITEM;
7597 akron1 176
        unit*:       UNIT;
177
        value*:      ARITH.VALUE;
8097 maxcodehac 178
        _type*:      _TYPE;
7597 akron1 179
        stproc*:     INTEGER;
180
        global*:     BOOLEAN;
181
        scopeLvl*:   INTEGER;
182
        offset*:     INTEGER;
183
        proc*:       PROC;
184
        pos*:        SCAN.POSITION
185
 
186
    END;
187
 
8097 maxcodehac 188
    PROGRAM = RECORD
7597 akron1 189
 
190
        recCount:    INTEGER;
7693 akron1 191
        units*:      LISTS.LIST;
7597 akron1 192
        types*:      LISTS.LIST;
193
        sysunit*:    UNIT;
194
        rtl*:        UNIT;
195
        bss*:        INTEGER;
196
        locsize*:    INTEGER;
197
 
198
        procs*:      LISTS.LIST;
199
 
7983 leency 200
        sysflags*:   SET;
201
        options*:    OPTIONS;
202
 
7693 akron1 203
        stTypes*:    RECORD
7597 akron1 204
 
7693 akron1 205
            tINTEGER*, tBYTE*, tCHAR*, tWCHAR*, tSET*, tBOOLEAN*, tREAL*,
8097 maxcodehac 206
            tSTRING*, tNIL*, tCARD32*, tANYREC*, tNONE*: _TYPE
7597 akron1 207
 
7693 akron1 208
        END
7597 akron1 209
 
210
    END;
211
 
8097 maxcodehac 212
    DELIMPORT = PROCEDURE (_import: LISTS.ITEM);
7597 akron1 213
 
214
 
215
VAR
216
 
8097 maxcodehac 217
    LowerCase: BOOLEAN;
7597 akron1 218
    idents: C.COLLECTION;
8097 maxcodehac 219
    program*: PROGRAM;
7597 akron1 220
 
221
 
222
PROCEDURE NewIdent (): IDENT;
223
VAR
224
    ident: IDENT;
225
    citem: C.ITEM;
226
 
227
BEGIN
228
    citem := C.pop(idents);
229
    IF citem = NIL THEN
230
        NEW(ident)
231
    ELSE
232
        ident := citem(IDENT)
233
    END
234
 
235
    RETURN ident
236
END NewIdent;
237
 
238
 
8097 maxcodehac 239
PROCEDURE getOffset* (varIdent: IDENT): INTEGER;
7597 akron1 240
VAR
241
    size: INTEGER;
242
 
243
BEGIN
244
    IF varIdent.offset = -1 THEN
8097 maxcodehac 245
        size := varIdent._type.size;
7597 akron1 246
        IF varIdent.global THEN
8097 maxcodehac 247
            IF UTILS.Align(program.bss, varIdent._type.align) THEN
7696 akron1 248
                IF UTILS.maxint - program.bss >= size THEN
7597 akron1 249
                    varIdent.offset := program.bss;
7696 akron1 250
                    INC(program.bss, size)
7597 akron1 251
                END
252
            END
253
        ELSE
7983 leency 254
            IF UTILS.Align(size, TARGETS.WordSize) THEN
255
                size := size DIV TARGETS.WordSize;
7597 akron1 256
                IF UTILS.maxint - program.locsize >= size THEN
257
                    INC(program.locsize, size);
7696 akron1 258
                    varIdent.offset := program.locsize
7597 akron1 259
                END
260
            END
7696 akron1 261
        END;
262
 
263
        IF varIdent.offset = -1 THEN
264
            ERRORS.Error(204)
7597 akron1 265
        END
266
    END
267
 
268
    RETURN varIdent.offset
269
END getOffset;
270
 
271
 
7693 akron1 272
PROCEDURE closeUnit* (unit: UNIT);
7597 akron1 273
VAR
274
    ident, prev: IDENT;
275
    offset: INTEGER;
276
 
277
BEGIN
278
    ident := unit.idents.last(IDENT);
279
    WHILE (ident # NIL) & (ident.typ # idGUARD) DO
280
        IF (ident.typ = idVAR) & (ident.offset = -1) THEN
7693 akron1 281
            ERRORS.HintMsg(ident.name.s, ident.pos.line, ident.pos.col, 0);
7597 akron1 282
            IF ident.export THEN
8097 maxcodehac 283
                offset := getOffset(ident)
7597 akron1 284
            END
285
        END;
286
        ident := ident.prev(IDENT)
287
    END;
288
 
289
    ident := unit.idents.last(IDENT);
290
    WHILE ident # NIL DO
291
        prev := ident.prev(IDENT);
292
        IF ~ident.export THEN
293
            LISTS.delete(unit.idents, ident);
294
            C.push(idents, ident)
295
        END;
296
        ident := prev
297
    END;
298
 
299
    unit.closed := TRUE
7693 akron1 300
END closeUnit;
7597 akron1 301
 
302
 
303
PROCEDURE unique (unit: UNIT; ident: SCAN.IDENT): BOOLEAN;
304
VAR
305
    item: IDENT;
306
 
307
BEGIN
308
    ASSERT(ident # NIL);
309
 
310
    item := unit.idents.last(IDENT);
311
    WHILE (item.typ # idGUARD) & (item.name # ident) DO
312
        item := item.prev(IDENT)
313
    END
314
 
315
    RETURN item.typ = idGUARD
316
END unique;
317
 
318
 
7693 akron1 319
PROCEDURE addIdent* (unit: UNIT; ident: SCAN.IDENT; typ: INTEGER): IDENT;
7597 akron1 320
VAR
7693 akron1 321
    item:  IDENT;
322
    res:   BOOLEAN;
323
    proc:  PROC;
7597 akron1 324
 
325
BEGIN
326
    ASSERT(unit # NIL);
327
    ASSERT(ident # NIL);
328
 
329
    res := unique(unit, ident);
330
 
331
    IF res THEN
332
        item := NewIdent();
333
 
8097 maxcodehac 334
        item.name    := ident;
335
        item.typ     := typ;
336
        item.unit    := NIL;
337
        item.export  := FALSE;
338
        item._import := NIL;
339
        item._type   := NIL;
7597 akron1 340
        item.value.typ := 0;
341
        item.stproc := 0;
342
 
343
        item.global := unit.scopeLvl = 0;
344
        item.scopeLvl := unit.scopeLvl;
345
        item.offset := -1;
346
 
347
        IF item.typ IN {idPROC, idIMP} THEN
348
            NEW(proc);
8097 maxcodehac 349
            proc._import := NIL;
7597 akron1 350
            proc.label := 0;
351
            proc.used := FALSE;
352
            proc.processed := FALSE;
353
            proc.using := LISTS.create(NIL);
8097 maxcodehac 354
            LISTS.push(program.procs, proc);
7597 akron1 355
            item.proc := proc
356
        END;
357
 
358
        LISTS.push(unit.idents, item)
359
    ELSE
360
        item := NIL
361
    END
362
 
363
    RETURN item
364
END addIdent;
365
 
366
 
367
PROCEDURE UseProc* (unit: UNIT; call_proc: PROC);
368
VAR
7693 akron1 369
    procs: LISTS.LIST;
370
    cur:   LISTS.ITEM;
371
    proc:  USED_PROC;
7597 akron1 372
 
373
BEGIN
374
    IF unit.scopeLvl = 0 THEN
375
        call_proc.used := TRUE
376
    ELSE
377
        procs := unit.scopes[unit.scopeLvl].using;
378
 
379
        cur := procs.first;
380
        WHILE (cur # NIL) & (cur(USED_PROC).proc # call_proc) DO
381
            cur := cur.next
382
        END;
383
 
384
        IF cur = NIL THEN
385
            NEW(proc);
386
            proc.proc := call_proc;
387
            LISTS.push(procs, proc)
388
        END
389
    END
390
END UseProc;
391
 
392
 
8097 maxcodehac 393
PROCEDURE setVarsType* (unit: UNIT; _type: _TYPE);
7597 akron1 394
VAR
395
    item: IDENT;
396
 
397
BEGIN
8097 maxcodehac 398
    ASSERT(_type # NIL);
7597 akron1 399
 
400
    item := unit.idents.last(IDENT);
8097 maxcodehac 401
    WHILE (item # NIL) & (item.typ = idVAR) & (item._type = NIL) DO
402
        item._type := _type;
7597 akron1 403
        item := item.prev(IDENT)
404
    END
7693 akron1 405
END setVarsType;
7597 akron1 406
 
407
 
7693 akron1 408
PROCEDURE getIdent* (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT;
7597 akron1 409
VAR
410
    item: IDENT;
411
 
412
BEGIN
413
    ASSERT(ident # NIL);
414
 
415
    item := unit.idents.last(IDENT);
416
 
7693 akron1 417
    IF item # NIL THEN
7597 akron1 418
 
7693 akron1 419
        IF currentScope THEN
420
            WHILE (item.name # ident) & (item.typ # idGUARD) DO
421
                item := item.prev(IDENT)
422
            END;
423
            IF item.name # ident THEN
424
                item := NIL
425
            END
426
        ELSE
427
            WHILE (item # NIL) & (item.name # ident) DO
428
                item := item.prev(IDENT)
429
            END
7597 akron1 430
        END
7693 akron1 431
 
7597 akron1 432
    END
433
 
434
    RETURN item
435
END getIdent;
436
 
437
 
7693 akron1 438
PROCEDURE openScope* (unit: UNIT; proc: PROC): BOOLEAN;
7597 akron1 439
VAR
440
    item: IDENT;
441
    res:  BOOLEAN;
442
 
443
BEGIN
444
    INC(unit.scopeLvl);
445
 
446
    res := unit.scopeLvl < MAXSCOPE;
447
 
448
    IF res THEN
449
 
450
        unit.scopes[unit.scopeLvl] := proc;
451
 
452
        NEW(item);
453
        item := NewIdent();
454
 
455
        item.name := NIL;
456
        item.typ  := idGUARD;
457
 
458
        LISTS.push(unit.idents, item)
459
    END
460
 
461
    RETURN res
462
END openScope;
463
 
464
 
7693 akron1 465
PROCEDURE closeScope* (unit: UNIT; variables: LISTS.LIST);
7597 akron1 466
VAR
467
    item: IDENT;
468
    del:  IDENT;
7693 akron1 469
    lvar: IL.LOCALVAR;
7597 akron1 470
 
471
BEGIN
472
    item := unit.idents.last(IDENT);
473
 
474
    WHILE (item # NIL) & (item.typ # idGUARD) DO
475
        del  := item;
476
        item := item.prev(IDENT);
477
        IF (del.typ = idVAR) & (del.offset = -1) THEN
7693 akron1 478
            ERRORS.HintMsg(del.name.s, del.pos.line, del.pos.col, 0)
7597 akron1 479
        END;
480
        IF (variables # NIL) & (del.typ IN {idVAR, idPARAM}) & (del.offset # -1) THEN
8097 maxcodehac 481
            IF del._type.typ IN BASICTYPES - {tREAL} + {tPOINTER, tPROCEDURE} THEN
7693 akron1 482
                lvar := IL.NewVar();
7597 akron1 483
                lvar.offset := del.offset;
8097 maxcodehac 484
                lvar.size   := del._type.size;
7597 akron1 485
                IF del.typ = idVAR THEN
486
                    lvar.offset := -lvar.offset
487
                END;
488
                LISTS.push(variables, lvar)
489
            END
490
        END;
491
        LISTS.delete(unit.idents, del);
492
        C.push(idents, del)
493
    END;
494
 
495
    IF (item # NIL) & (item.typ = idGUARD) THEN
496
        LISTS.delete(unit.idents, item);
497
        C.push(idents, item)
498
    END;
499
 
500
    DEC(unit.scopeLvl)
501
END closeScope;
502
 
503
 
8097 maxcodehac 504
PROCEDURE frwPtr* (unit: UNIT; _type: _TYPE; baseIdent: SCAN.IDENT; pos: SCAN.POSITION);
7597 akron1 505
VAR
506
    newptr: FRWPTR;
507
 
508
BEGIN
509
    ASSERT(unit # NIL);
8097 maxcodehac 510
    ASSERT(_type # NIL);
7597 akron1 511
    ASSERT(baseIdent # NIL);
512
 
513
    NEW(newptr);
514
 
8097 maxcodehac 515
    newptr._type      := _type;
7693 akron1 516
    newptr.baseIdent := baseIdent;
517
    newptr.pos       := pos;
518
    newptr.linked    := FALSE;
519
    newptr.notRecord := FALSE;
7597 akron1 520
 
521
    LISTS.push(unit.frwPointers, newptr)
7693 akron1 522
END frwPtr;
7597 akron1 523
 
524
 
7693 akron1 525
PROCEDURE linkPtr* (unit: UNIT): FRWPTR;
7597 akron1 526
VAR
527
    item:  FRWPTR;
528
    ident: IDENT;
529
    res:   FRWPTR;
530
 
531
BEGIN
532
    res  := NIL;
533
    item := unit.frwPointers.last(FRWPTR);
534
 
535
    WHILE (item # NIL) & ~item.linked & (res = NIL) DO
7693 akron1 536
        ident := getIdent(unit, item.baseIdent, TRUE);
7597 akron1 537
 
538
        IF (ident # NIL) THEN
8097 maxcodehac 539
            IF (ident.typ = idTYPE) & (ident._type.typ = tRECORD) THEN
540
                item._type.base := ident._type;
7597 akron1 541
                item.linked := TRUE
542
            ELSE
543
                item.notRecord := TRUE;
544
                res := item
545
            END
546
        ELSE
547
            item.notRecord := FALSE;
548
            res := item
549
        END;
550
 
551
        item := item.prev(FRWPTR)
552
    END
553
 
554
    RETURN res
7693 akron1 555
END linkPtr;
7597 akron1 556
 
557
 
8097 maxcodehac 558
PROCEDURE isTypeEq* (t1, t2: _TYPE): BOOLEAN;
7597 akron1 559
VAR
560
    res: BOOLEAN;
561
    param1, param2: LISTS.ITEM;
562
 
563
BEGIN
564
    IF t1 = t2 THEN
565
        res := TRUE
566
    ELSIF (t1 = NIL) OR (t2 = NIL) THEN
567
        res := FALSE
568
    ELSIF (t1.typ = tPROCEDURE) & (t2.typ = tPROCEDURE) THEN
569
 
570
        param1 := t1.params.first;
571
        param2 := t2.params.first;
572
 
7693 akron1 573
        res := ((t1.call = t2.call) OR (t1.call IN {code, _code}) OR (t2.call IN {code, _code})) & ((param1 # NIL) = (param2 # NIL));
7597 akron1 574
 
575
        WHILE res & (param1 # NIL) & (param2 # NIL) DO
8097 maxcodehac 576
            res := (param1(PARAM).vPar = param2(PARAM).vPar) & isTypeEq(param1(PARAM)._type, param2(PARAM)._type);
7597 akron1 577
            param1 := param1.next;
578
            param2 := param2.next;
579
            res := res & ((param1 # NIL) = (param2 # NIL))
580
        END;
581
 
582
        res := res & isTypeEq(t1.base, t2.base)
583
 
584
    ELSIF (t1.typ = tARRAY) & (t2.typ = tARRAY) THEN
585
        res := (t1.length = 0) & (t2.length = 0) & isTypeEq(t1.base, t2.base)
586
    ELSE
587
        res := FALSE
588
    END
589
 
590
    RETURN res
591
END isTypeEq;
592
 
593
 
8097 maxcodehac 594
PROCEDURE isBaseOf* (t0, t1: _TYPE): BOOLEAN;
7597 akron1 595
VAR
596
    res: BOOLEAN;
597
 
598
BEGIN
7693 akron1 599
    res := (t0.typ = t1.typ) & (t0.typ IN {tPOINTER, tRECORD});
7597 akron1 600
 
7693 akron1 601
    IF res & (t0.typ = tPOINTER) THEN
7597 akron1 602
        t0 := t0.base;
603
        t1 := t1.base
604
    END;
605
 
7693 akron1 606
    IF res THEN
607
        WHILE (t1 # NIL) & (t1 # t0) DO
608
            t1 := t1.base
609
        END;
610
        res := t1 # NIL
7597 akron1 611
    END
612
 
7693 akron1 613
    RETURN res
7597 akron1 614
END isBaseOf;
615
 
616
 
8097 maxcodehac 617
PROCEDURE isOpenArray* (t: _TYPE): BOOLEAN;
7597 akron1 618
    RETURN (t.typ = tARRAY) & (t.length = 0)
619
END isOpenArray;
620
 
621
 
8097 maxcodehac 622
PROCEDURE arrcomp* (src, dst: _TYPE): BOOLEAN;
7696 akron1 623
    RETURN (dst.typ = tARRAY) & isOpenArray(src) &
624
            ~isOpenArray(src.base) & ~isOpenArray(dst.base) &
625
            isTypeEq(src.base, dst.base)
626
END arrcomp;
627
 
628
 
8097 maxcodehac 629
PROCEDURE getUnit* (name: SCAN.IDENT): UNIT;
7597 akron1 630
VAR
631
    item: UNIT;
632
 
633
BEGIN
634
    ASSERT(name # NIL);
635
 
7693 akron1 636
    item := program.units.first(UNIT);
7597 akron1 637
 
638
    WHILE (item # NIL) & (item.name # name) DO
639
        item := item.next(UNIT)
640
    END;
641
 
8097 maxcodehac 642
    IF (item = NIL) & ((name.s = "SYSTEM") OR LowerCase & (name.s = "system")) THEN
7693 akron1 643
        item := program.sysunit
7597 akron1 644
    END
645
 
646
    RETURN item
7693 akron1 647
END getUnit;
7597 akron1 648
 
649
 
8097 maxcodehac 650
PROCEDURE enterStTypes (unit: UNIT);
7597 akron1 651
 
652
 
8097 maxcodehac 653
    PROCEDURE enter (unit: UNIT; name: SCAN.LEXSTR; _type: _TYPE);
654
    VAR
655
        ident: IDENT;
656
        upper: SCAN.LEXSTR;
7597 akron1 657
 
8097 maxcodehac 658
    BEGIN
659
        IF LowerCase THEN
660
            ident := addIdent(unit, SCAN.enterid(name), idTYPE);
661
            ident._type := _type
662
        END;
663
        upper := name;
664
        STRINGS.UpCase(upper);
665
        ident := addIdent(unit, SCAN.enterid(upper), idTYPE);
666
        ident._type := _type
667
    END enter;
7597 akron1 668
 
669
 
8097 maxcodehac 670
BEGIN
671
    enter(unit, "integer", program.stTypes.tINTEGER);
672
    enter(unit, "byte",    program.stTypes.tBYTE);
673
    enter(unit, "char",    program.stTypes.tCHAR);
674
    enter(unit, "set",     program.stTypes.tSET);
675
    enter(unit, "boolean", program.stTypes.tBOOLEAN);
7597 akron1 676
 
7983 leency 677
    IF TARGETS.RealSize # 0 THEN
8097 maxcodehac 678
        enter(unit, "real", program.stTypes.tREAL)
7983 leency 679
    END;
7597 akron1 680
 
7983 leency 681
    IF TARGETS.BitDepth >= 32 THEN
8097 maxcodehac 682
        enter(unit, "wchar", program.stTypes.tWCHAR)
7693 akron1 683
    END
7597 akron1 684
END enterStTypes;
685
 
686
 
687
PROCEDURE enterStProcs (unit: UNIT);
688
 
689
 
7693 akron1 690
    PROCEDURE EnterProc (unit: UNIT; name: SCAN.LEXSTR; proc: INTEGER);
7597 akron1 691
    VAR
692
        ident: IDENT;
8097 maxcodehac 693
        upper: SCAN.LEXSTR;
694
 
7597 akron1 695
    BEGIN
8097 maxcodehac 696
        IF LowerCase THEN
697
            ident := addIdent(unit, SCAN.enterid(name), idSTPROC);
698
            ident.stproc := proc;
699
            ident._type := program.stTypes.tNONE
700
        END;
701
        upper := name;
702
        STRINGS.UpCase(upper);
703
        ident := addIdent(unit, SCAN.enterid(upper), idSTPROC);
704
        ident.stproc := proc;
705
        ident._type := program.stTypes.tNONE
7597 akron1 706
    END EnterProc;
707
 
708
 
7693 akron1 709
    PROCEDURE EnterFunc (unit: UNIT; name: SCAN.LEXSTR; func: INTEGER);
710
    VAR
711
        ident: IDENT;
8097 maxcodehac 712
        upper: SCAN.LEXSTR;
713
 
7693 akron1 714
    BEGIN
8097 maxcodehac 715
        IF LowerCase THEN
716
            ident := addIdent(unit, SCAN.enterid(name), idSTFUNC);
717
            ident.stproc := func;
718
            ident._type := program.stTypes.tNONE
719
        END;
720
        upper := name;
721
        STRINGS.UpCase(upper);
722
        ident := addIdent(unit, SCAN.enterid(upper), idSTFUNC);
723
        ident.stproc := func;
724
        ident._type := program.stTypes.tNONE
7693 akron1 725
    END EnterFunc;
726
 
727
 
7597 akron1 728
BEGIN
8097 maxcodehac 729
    EnterProc(unit, "assert", stASSERT);
730
    EnterProc(unit, "dec",    stDEC);
731
    EnterProc(unit, "excl",   stEXCL);
732
    EnterProc(unit, "inc",    stINC);
733
    EnterProc(unit, "incl",   stINCL);
734
    EnterProc(unit, "new",    stNEW);
735
    EnterProc(unit, "copy",   stCOPY);
7597 akron1 736
 
8097 maxcodehac 737
    EnterFunc(unit, "abs",    stABS);
738
    EnterFunc(unit, "asr",    stASR);
739
    EnterFunc(unit, "chr",    stCHR);
740
    EnterFunc(unit, "len",    stLEN);
741
    EnterFunc(unit, "lsl",    stLSL);
742
    EnterFunc(unit, "odd",    stODD);
743
    EnterFunc(unit, "ord",    stORD);
744
    EnterFunc(unit, "ror",    stROR);
745
    EnterFunc(unit, "bits",   stBITS);
746
    EnterFunc(unit, "lsr",    stLSR);
747
    EnterFunc(unit, "length", stLENGTH);
748
    EnterFunc(unit, "min",    stMIN);
749
    EnterFunc(unit, "max",    stMAX);
7693 akron1 750
 
7983 leency 751
    IF TARGETS.RealSize # 0 THEN
8097 maxcodehac 752
        EnterProc(unit, "pack",  stPACK);
753
        EnterProc(unit, "unpk",  stUNPK);
754
        EnterFunc(unit, "floor", stFLOOR);
755
        EnterFunc(unit, "flt",   stFLT)
7983 leency 756
    END;
7693 akron1 757
 
7983 leency 758
    IF TARGETS.BitDepth >= 32 THEN
8097 maxcodehac 759
        EnterFunc(unit, "wchr", stWCHR)
7983 leency 760
    END;
761
 
762
    IF TARGETS.Dispose THEN
8097 maxcodehac 763
        EnterProc(unit, "dispose", stDISPOSE)
7693 akron1 764
    END
765
 
7597 akron1 766
END enterStProcs;
767
 
768
 
8097 maxcodehac 769
PROCEDURE newUnit* (name: SCAN.IDENT): UNIT;
7597 akron1 770
VAR
7693 akron1 771
    unit: UNIT;
7597 akron1 772
 
773
BEGIN
774
    ASSERT(name # NIL);
775
 
776
    NEW(unit);
777
 
778
    unit.name        := name;
779
    unit.closed      := FALSE;
7693 akron1 780
    unit.idents      := LISTS.create(NIL);
7597 akron1 781
    unit.frwPointers := LISTS.create(NIL);
782
 
7693 akron1 783
    ASSERT(openScope(unit, NIL));
7597 akron1 784
 
8097 maxcodehac 785
    enterStTypes(unit);
7597 akron1 786
    enterStProcs(unit);
787
 
7693 akron1 788
    ASSERT(openScope(unit, NIL));
7597 akron1 789
 
790
    unit.gscope := unit.idents.last(IDENT);
791
 
7693 akron1 792
    LISTS.push(program.units, unit);
7597 akron1 793
 
794
    unit.scopeLvl := 0;
795
    unit.scopes[0] := NIL;
796
 
797
    unit.sysimport := FALSE;
798
 
7983 leency 799
    IF unit.name.s = UTILS.RTL_NAME THEN
7693 akron1 800
        program.rtl := unit
7597 akron1 801
    END
802
 
803
    RETURN unit
7693 akron1 804
END newUnit;
7597 akron1 805
 
806
 
8097 maxcodehac 807
PROCEDURE getField* (self: _TYPE; name: SCAN.IDENT; unit: UNIT): FIELD;
7597 akron1 808
VAR
7693 akron1 809
    field: FIELD;
7597 akron1 810
 
811
BEGIN
812
    ASSERT(self # NIL);
813
    ASSERT(name # NIL);
814
    ASSERT(unit # NIL);
815
 
816
    field := NIL;
817
    WHILE (self # NIL) & (field = NIL) DO
818
 
819
        field := self.fields.first(FIELD);
820
 
821
        WHILE (field # NIL) & (field.name # name) DO
822
            field := field.next(FIELD)
823
        END;
824
 
825
        IF field = NIL THEN
826
            self := self.base
827
        END
828
 
829
    END;
830
 
831
    IF (field # NIL) & (self.unit # unit) & ~field.export THEN
832
        field := NIL
833
    END
834
 
835
    RETURN field
836
END getField;
837
 
838
 
8097 maxcodehac 839
PROCEDURE addField* (self: _TYPE; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN;
7597 akron1 840
VAR
7693 akron1 841
    field: FIELD;
842
    res:   BOOLEAN;
7597 akron1 843
 
844
BEGIN
845
    ASSERT(name # NIL);
846
 
847
    res := getField(self, name, self.unit) = NIL;
848
 
849
    IF res THEN
850
        NEW(field);
851
 
852
        field.name   := name;
853
        field.export := export;
8097 maxcodehac 854
        field._type  := NIL;
7597 akron1 855
        field.offset := self.size;
856
 
857
        LISTS.push(self.fields, field)
858
    END
859
 
860
    RETURN res
861
END addField;
862
 
863
 
8097 maxcodehac 864
PROCEDURE setFields* (self: _TYPE; _type: _TYPE): BOOLEAN;
7597 akron1 865
VAR
866
    item: FIELD;
867
    res:  BOOLEAN;
868
 
869
BEGIN
8097 maxcodehac 870
    ASSERT(_type # NIL);
7597 akron1 871
 
872
    item := self.fields.first(FIELD);
873
 
8097 maxcodehac 874
    WHILE (item # NIL) & (item._type # NIL) DO
7597 akron1 875
        item := item.next(FIELD)
876
    END;
877
 
878
    res := TRUE;
879
 
8097 maxcodehac 880
    WHILE res & (item # NIL) & (item._type = NIL) DO
881
        item._type := _type;
7597 akron1 882
        IF ~self.noalign THEN
8097 maxcodehac 883
            res := UTILS.Align(self.size, _type.align)
7597 akron1 884
        ELSE
885
            res := TRUE
886
        END;
887
        item.offset := self.size;
8097 maxcodehac 888
        res := res & (UTILS.maxint - self.size >= _type.size);
7597 akron1 889
        IF res THEN
8097 maxcodehac 890
            INC(self.size, _type.size)
7597 akron1 891
        END;
892
        item := item.next(FIELD)
893
    END
894
 
895
    RETURN res
896
END setFields;
897
 
898
 
8097 maxcodehac 899
PROCEDURE getParam* (self: _TYPE; name: SCAN.IDENT): PARAM;
7597 akron1 900
VAR
7693 akron1 901
    item: PARAM;
7597 akron1 902
 
903
BEGIN
904
    ASSERT(name # NIL);
905
 
906
    item := self.params.first(PARAM);
907
 
908
    WHILE (item # NIL) & (item.name # name) DO
909
        item := item.next(PARAM)
910
    END
911
 
912
    RETURN item
913
END getParam;
914
 
915
 
8097 maxcodehac 916
PROCEDURE addParam* (self: _TYPE; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN;
7597 akron1 917
VAR
7693 akron1 918
    param: PARAM;
919
    res:   BOOLEAN;
7597 akron1 920
 
921
BEGIN
922
    ASSERT(name # NIL);
923
 
7693 akron1 924
    res := getParam(self, name) = NIL;
7597 akron1 925
 
926
    IF res THEN
927
        NEW(param);
928
 
8097 maxcodehac 929
        param.name  := name;
930
        param._type := NIL;
931
        param.vPar  := vPar;
7597 akron1 932
 
933
        LISTS.push(self.params, param)
934
    END
935
 
936
    RETURN res
937
END addParam;
938
 
939
 
8097 maxcodehac 940
PROCEDURE Dim* (t: _TYPE): INTEGER;
7597 akron1 941
VAR
942
    res: INTEGER;
943
 
944
BEGIN
945
    res := 0;
946
    WHILE isOpenArray(t) DO
947
        t := t.base;
948
        INC(res)
949
    END
950
    RETURN res
951
END Dim;
952
 
953
 
8097 maxcodehac 954
PROCEDURE OpenBase* (t: _TYPE): _TYPE;
7597 akron1 955
BEGIN
956
    WHILE isOpenArray(t) DO t := t.base END
957
    RETURN t
958
END OpenBase;
959
 
960
 
8097 maxcodehac 961
PROCEDURE getFloatParamsPos* (self: _TYPE; maxoffs: INTEGER; VAR int, flt: INTEGER): SET;
7597 akron1 962
VAR
963
    res: SET;
964
    param: PARAM;
965
 
966
BEGIN
967
    res := {};
968
    int := 0;
969
    flt := 0;
970
    param := self.params.first(PARAM);
971
    WHILE (param # NIL) & (param.offset <= maxoffs + STACK_FRAME) DO
8097 maxcodehac 972
        IF ~param.vPar & (param._type.typ = tREAL) THEN
7597 akron1 973
            INCL(res, param.offset - STACK_FRAME);
974
            INC(flt)
975
        END;
976
        param := param.next(PARAM)
977
    END;
978
 
7693 akron1 979
    int := self.parSize - flt
7597 akron1 980
 
981
    RETURN res
982
END getFloatParamsPos;
983
 
984
 
8097 maxcodehac 985
PROCEDURE setParams* (self: _TYPE; _type: _TYPE);
7597 akron1 986
VAR
987
    item: LISTS.ITEM;
988
    param: PARAM;
989
    word, size: INTEGER;
990
 
991
BEGIN
8097 maxcodehac 992
    ASSERT(_type # NIL);
7597 akron1 993
 
7693 akron1 994
    word := UTILS.target.bit_depth DIV 8;
7597 akron1 995
 
996
    item := self.params.first;
997
 
8097 maxcodehac 998
    WHILE (item # NIL) & (item(PARAM)._type # NIL) DO
7597 akron1 999
        item := item.next
1000
    END;
1001
 
8097 maxcodehac 1002
    WHILE (item # NIL) & (item(PARAM)._type = NIL) DO
7597 akron1 1003
        param := item(PARAM);
8097 maxcodehac 1004
        param._type := _type;
7597 akron1 1005
        IF param.vPar THEN
8097 maxcodehac 1006
            IF _type.typ = tRECORD THEN
7597 akron1 1007
                size := 2
8097 maxcodehac 1008
            ELSIF isOpenArray(_type) THEN
1009
                size := Dim(_type) + 1
7597 akron1 1010
            ELSE
1011
                size := 1
1012
            END;
8097 maxcodehac 1013
            param.offset := self.parSize + ORD(_type.typ = tRECORD) + Dim(_type) + STACK_FRAME;
7693 akron1 1014
            INC(self.parSize, size)
7597 akron1 1015
        ELSE
8097 maxcodehac 1016
            IF _type.typ IN {tRECORD, tARRAY} THEN
1017
                IF isOpenArray(_type) THEN
1018
                    size := Dim(_type) + 1
7597 akron1 1019
                ELSE
1020
                    size := 1
1021
                END
1022
            ELSE
8097 maxcodehac 1023
                size := _type.size;
7693 akron1 1024
                ASSERT(UTILS.Align(size, word));
7597 akron1 1025
                size := size DIV word
1026
            END;
8097 maxcodehac 1027
            param.offset := self.parSize + Dim(_type) + STACK_FRAME;
7693 akron1 1028
            INC(self.parSize, size)
7597 akron1 1029
        END;
1030
 
1031
        item := item.next
1032
    END
1033
 
1034
END setParams;
1035
 
1036
 
8097 maxcodehac 1037
PROCEDURE enterType* (typ, size, length: INTEGER; unit: UNIT): _TYPE;
7597 akron1 1038
VAR
8097 maxcodehac 1039
    t: _TYPE;
7597 akron1 1040
 
1041
BEGIN
1042
    NEW(t);
1043
 
1044
    t.typ     := typ;
1045
    t.size    := size;
1046
    t.length  := length;
1047
    t.align   := 0;
1048
    t.base    := NIL;
7693 akron1 1049
    t.fields  := LISTS.create(NIL);
1050
    t.params  := LISTS.create(NIL);
7597 akron1 1051
    t.unit    := unit;
1052
    t.num     := 0;
7693 akron1 1053
 
7983 leency 1054
    CASE TARGETS.BitDepth OF
7693 akron1 1055
    |16: t.call := default16
1056
    |32: t.call := default32
1057
    |64: t.call := default64
7597 akron1 1058
    END;
7693 akron1 1059
 
8097 maxcodehac 1060
    t._import := FALSE;
7597 akron1 1061
    t.noalign := FALSE;
7693 akron1 1062
    t.parSize := 0;
7597 akron1 1063
 
1064
    IF typ IN {tARRAY, tRECORD} THEN
1065
        t.closed := FALSE;
1066
        IF typ = tRECORD THEN
1067
            INC(program.recCount);
1068
            t.num := program.recCount
1069
        END
1070
    ELSE
1071
        t.closed := TRUE
1072
    END;
1073
 
1074
    LISTS.push(program.types, t)
1075
 
1076
    RETURN t
1077
END enterType;
1078
 
1079
 
8097 maxcodehac 1080
PROCEDURE getType* (typ: INTEGER): _TYPE;
7597 akron1 1081
VAR
8097 maxcodehac 1082
    res: _TYPE;
7597 akron1 1083
 
1084
BEGIN
1085
 
7696 akron1 1086
    CASE typ OF
1087
    |ARITH.tINTEGER: res := program.stTypes.tINTEGER
1088
    |ARITH.tREAL:    res := program.stTypes.tREAL
1089
    |ARITH.tSET:     res := program.stTypes.tSET
1090
    |ARITH.tBOOLEAN: res := program.stTypes.tBOOLEAN
1091
    |ARITH.tCHAR:    res := program.stTypes.tCHAR
1092
    |ARITH.tWCHAR:   res := program.stTypes.tWCHAR
1093
    |ARITH.tSTRING:  res := program.stTypes.tSTRING
1094
    END
7597 akron1 1095
 
1096
    RETURN res
1097
END getType;
1098
 
1099
 
8097 maxcodehac 1100
PROCEDURE createSysUnit;
7597 akron1 1101
VAR
1102
    ident: IDENT;
1103
    unit:  UNIT;
1104
 
1105
 
1106
    PROCEDURE EnterProc (sys: UNIT; name: SCAN.LEXSTR; idtyp, proc: INTEGER);
1107
    VAR
1108
        ident: IDENT;
8097 maxcodehac 1109
        upper: SCAN.LEXSTR;
1110
 
7597 akron1 1111
    BEGIN
8097 maxcodehac 1112
        IF LowerCase THEN
1113
            ident := addIdent(sys, SCAN.enterid(name), idtyp);
1114
            ident.stproc := proc;
1115
            ident._type := program.stTypes.tNONE;
1116
            ident.export := TRUE
1117
        END;
1118
        upper := name;
1119
        STRINGS.UpCase(upper);
1120
        ident := addIdent(sys, SCAN.enterid(upper), idtyp);
7597 akron1 1121
        ident.stproc := proc;
8097 maxcodehac 1122
        ident._type := program.stTypes.tNONE;
7597 akron1 1123
        ident.export := TRUE
1124
    END EnterProc;
1125
 
1126
 
1127
BEGIN
8097 maxcodehac 1128
    unit := newUnit(SCAN.enterid("$SYSTEM"));
7597 akron1 1129
 
8097 maxcodehac 1130
    EnterProc(unit, "adr",    idSYSFUNC, sysADR);
1131
    EnterProc(unit, "size",   idSYSFUNC, sysSIZE);
1132
    EnterProc(unit, "sadr",   idSYSFUNC, sysSADR);
1133
    EnterProc(unit, "typeid", idSYSFUNC, sysTYPEID);
7597 akron1 1134
 
8097 maxcodehac 1135
    EnterProc(unit, "get",    idSYSPROC, sysGET);
1136
    EnterProc(unit, "get8",   idSYSPROC, sysGET8);
1137
    EnterProc(unit, "put",    idSYSPROC, sysPUT);
1138
    EnterProc(unit, "put8",   idSYSPROC, sysPUT8);
1139
    EnterProc(unit, "code",   idSYSPROC, sysCODE);
1140
    EnterProc(unit, "move",   idSYSPROC, sysMOVE);
7693 akron1 1141
           (*
1142
    IF program.target.sys = mConst.Target_iMSP430 THEN
8097 maxcodehac 1143
        EnterProc(unit, "nop",  idSYSPROC, sysNOP);
1144
        EnterProc(unit, "eint", idSYSPROC, sysEINT);
1145
        EnterProc(unit, "dint", idSYSPROC, sysDINT)
7693 akron1 1146
    END;
1147
         *)
7983 leency 1148
    IF TARGETS.RealSize # 0 THEN
8097 maxcodehac 1149
        EnterProc(unit, "inf",    idSYSFUNC, sysINF);
7983 leency 1150
    END;
1151
 
1152
    IF TARGETS.CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
8097 maxcodehac 1153
        EnterProc(unit, "copy",   idSYSPROC, sysCOPY)
7983 leency 1154
    END;
1155
 
1156
    IF TARGETS.BitDepth >= 32 THEN
8097 maxcodehac 1157
        EnterProc(unit, "wsadr",  idSYSFUNC, sysWSADR);
1158
        EnterProc(unit, "put16",  idSYSPROC, sysPUT16);
1159
        EnterProc(unit, "put32",  idSYSPROC, sysPUT32);
1160
        EnterProc(unit, "get16",  idSYSPROC, sysGET16);
1161
        EnterProc(unit, "get32",  idSYSPROC, sysGET32);
7597 akron1 1162
 
8097 maxcodehac 1163
        IF LowerCase THEN
1164
            ident := addIdent(unit, SCAN.enterid("card32"), idTYPE);
1165
            ident._type := program.stTypes.tCARD32;
1166
            ident.export := TRUE
1167
        END;
7693 akron1 1168
        ident := addIdent(unit, SCAN.enterid("CARD32"), idTYPE);
8097 maxcodehac 1169
        ident._type := program.stTypes.tCARD32;
1170
        ident.export := TRUE;
7693 akron1 1171
    END;
7597 akron1 1172
 
7693 akron1 1173
    closeUnit(unit);
7597 akron1 1174
 
1175
    program.sysunit := unit
1176
END createSysUnit;
1177
 
1178
 
8097 maxcodehac 1179
PROCEDURE DelUnused* (DelImport: DELIMPORT);
7597 akron1 1180
VAR
7693 akron1 1181
    proc: PROC;
1182
    flag: BOOLEAN;
7597 akron1 1183
 
1184
 
1185
    PROCEDURE process (proc: PROC);
1186
    VAR
1187
        used_proc: LISTS.ITEM;
1188
 
1189
    BEGIN
1190
        proc.processed := TRUE;
1191
 
1192
        used_proc := proc.using.first;
1193
        WHILE used_proc # NIL DO
1194
            used_proc(USED_PROC).proc.used := TRUE;
1195
            used_proc := used_proc.next
1196
        END
1197
 
1198
    END process;
1199
 
1200
 
1201
BEGIN
1202
 
1203
    REPEAT
1204
        flag := FALSE;
1205
        proc := program.procs.first(PROC);
1206
 
1207
        WHILE proc # NIL DO
1208
            IF proc.used & ~proc.processed THEN
1209
                process(proc);
1210
                flag := TRUE
1211
            END;
1212
            proc := proc.next(PROC)
1213
        END
1214
 
1215
    UNTIL ~flag;
1216
 
1217
    proc := program.procs.first(PROC);
1218
 
1219
    WHILE proc # NIL DO
1220
        IF ~proc.used THEN
8097 maxcodehac 1221
            IF proc._import = NIL THEN
7693 akron1 1222
                IL.delete2(proc.enter, proc.leave)
7597 akron1 1223
            ELSE
8097 maxcodehac 1224
                DelImport(proc._import)
7597 akron1 1225
            END
1226
        END;
1227
        proc := proc.next(PROC)
1228
    END
1229
 
1230
END DelUnused;
1231
 
1232
 
8097 maxcodehac 1233
PROCEDURE ResetLocSize*;
1234
BEGIN
1235
    program.locsize := 0
1236
END ResetLocSize;
7597 akron1 1237
 
8097 maxcodehac 1238
 
1239
PROCEDURE create* (options: OPTIONS);
7597 akron1 1240
BEGIN
8097 maxcodehac 1241
    LowerCase := options.lower;
1242
    SCAN.init(options.lower);
7597 akron1 1243
    idents := C.create();
1244
 
7983 leency 1245
    UTILS.SetBitDepth(TARGETS.BitDepth, TARGETS.RealSize = 8);
7597 akron1 1246
 
7983 leency 1247
    program.options := options;
7597 akron1 1248
 
7983 leency 1249
    CASE TARGETS.OS OF
8097 maxcodehac 1250
    |TARGETS.osWIN32:    program.sysflags := {sf_oberon, sf_windows, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
1251
    |TARGETS.osLINUX32:  program.sysflags := {sf_oberon, sf_linux, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
1252
    |TARGETS.osKOS:      program.sysflags := {sf_oberon, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
1253
    |TARGETS.osWIN64:    program.sysflags := {sf_oberon, sf_windows, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
1254
    |TARGETS.osLINUX64:  program.sysflags := {sf_oberon, sf_linux, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
7983 leency 1255
    |TARGETS.osNONE:     program.sysflags := {sf_code}
7693 akron1 1256
    END;
1257
 
7597 akron1 1258
    program.recCount := -1;
1259
    program.bss := 0;
1260
 
7693 akron1 1261
    program.units := LISTS.create(NIL);
7597 akron1 1262
    program.types := LISTS.create(NIL);
1263
    program.procs := LISTS.create(NIL);
1264
 
8097 maxcodehac 1265
    program.stTypes.tINTEGER := enterType(tINTEGER, TARGETS.WordSize, 0, NIL);
1266
    program.stTypes.tBYTE    := enterType(tBYTE,                   1, 0, NIL);
1267
    program.stTypes.tCHAR    := enterType(tCHAR,                   1, 0, NIL);
1268
    program.stTypes.tSET     := enterType(tSET,     TARGETS.WordSize, 0, NIL);
1269
    program.stTypes.tBOOLEAN := enterType(tBOOLEAN,                1, 0, NIL);
7693 akron1 1270
 
7983 leency 1271
    program.stTypes.tINTEGER.align := TARGETS.WordSize;
1272
    program.stTypes.tBYTE.align    := 1;
1273
    program.stTypes.tCHAR.align    := 1;
1274
    program.stTypes.tSET.align     := TARGETS.WordSize;
1275
    program.stTypes.tBOOLEAN.align := 1;
1276
 
1277
    IF TARGETS.BitDepth >= 32 THEN
8097 maxcodehac 1278
        program.stTypes.tWCHAR  := enterType(tWCHAR,  2, 0, NIL);
1279
        program.stTypes.tCARD32 := enterType(tCARD32, 4, 0, NIL);
7983 leency 1280
        program.stTypes.tWCHAR.align  := 2;
1281
        program.stTypes.tCARD32.align := 4
7693 akron1 1282
    END;
1283
 
7983 leency 1284
    IF TARGETS.RealSize # 0 THEN
8097 maxcodehac 1285
        program.stTypes.tREAL := enterType(tREAL, TARGETS.RealSize, 0, NIL);
7983 leency 1286
        program.stTypes.tREAL.align := TARGETS.RealSize
1287
    END;
7693 akron1 1288
 
8097 maxcodehac 1289
    program.stTypes.tSTRING := enterType(tSTRING, TARGETS.WordSize, 0, NIL);
1290
    program.stTypes.tNIL    := enterType(tNIL,    TARGETS.WordSize, 0, NIL);
1291
    program.stTypes.tNONE   := enterType(tNONE,   0, 0, NIL);
1292
    program.stTypes.tANYREC := enterType(tRECORD, 0, 0, NIL);
7597 akron1 1293
    program.stTypes.tANYREC.closed := TRUE;
1294
 
8097 maxcodehac 1295
    createSysUnit
7597 akron1 1296
END create;
1297
 
1298
 
7983 leency 1299
END PROG.