forked from KolibriOS/kolibrios
1311 lines
32 KiB
Plaintext
1311 lines
32 KiB
Plaintext
(*
|
|
BSD 2-Clause License
|
|
|
|
Copyright (c) 2018, 2019, Anton Krotov
|
|
All rights reserved.
|
|
*)
|
|
|
|
MODULE PROG;
|
|
|
|
IMPORT SCAN, LISTS, ARITH, ERRORS, MACHINE, C := COLLECTIONS, mConst := CONSTANTS, CODE, UTILS;
|
|
|
|
|
|
CONST
|
|
|
|
MAXARRDIM* = 5;
|
|
MAXSCOPE = 16;
|
|
MAXSYSVPARAM* = 26;
|
|
|
|
idNONE* = 0; idGUARD = 1; idMODULE* = 2; idCONST* = 3;
|
|
idTYPE* = 4; idSTFUNC* = 5; idSTPROC* = 6; idVAR* = 7;
|
|
idPROC* = 8; idVPAR* = 9; idPARAM* = 10; idSYSFUNC* = 11;
|
|
idSYSPROC* = 12; idIMP* = 13;
|
|
|
|
tINTEGER* = 1; tBYTE* = 2; tCHAR* = 3; tSET* = 4;
|
|
tBOOLEAN* = 5; tREAL* = 6; tARRAY* = 7; tRECORD* = 8;
|
|
tPOINTER* = 9; tPROCEDURE* = 10; tSTRING* = 11; tNIL* = 12;
|
|
tCARD16* = 13; tCARD32* = 14; tANYREC* = 15; tWCHAR* = 16;
|
|
|
|
BASICTYPES* = {tINTEGER, tBYTE, tCHAR, tSET, tBOOLEAN, tREAL, tCARD16, tCARD32, tWCHAR};
|
|
|
|
stABS* = 1; stASR* = 2; stCHR* = 3; stFLOOR* = 4;
|
|
stFLT* = 5; stLEN* = 6; stLSL* = 7; stODD* = 8;
|
|
stORD* = 9; stROR* = 10; stASSERT* = 11; stDEC* = 12;
|
|
stEXCL* = 13; stINC* = 14; stINCL* = 15; stNEW* = 16;
|
|
stPACK* = 17; stUNPK* = 18; sysADR* = 19; sysSIZE* = 20;
|
|
sysGET* = 21; sysPUT* = 22;
|
|
|
|
stDISPOSE* = 23; stLSR* = 24; stBITS* = 25; sysCODE* = 26;
|
|
sysMOVE* = 27; stLENGTH* = 28; stMIN* = 29; stMAX* = 30;
|
|
sysSADR* = 31; sysTYPEID* = 32; sysCOPY* = 33; sysINF* = 34;
|
|
sysPUT8* = 35; sysPUT16* = 36; stCOPY* = 37; stWCHR* = 38;
|
|
sysWSADR* = 39; sysPUT32* = 40;
|
|
|
|
default* = 2;
|
|
stdcall* = 4; _stdcall* = stdcall + 1;
|
|
ccall* = 6; _ccall* = ccall + 1;
|
|
ccall16* = 8; _ccall16* = ccall16 + 1;
|
|
win64* = 10; _win64* = win64 + 1;
|
|
stdcall64* = 12; _stdcall64* = stdcall64 + 1;
|
|
default64* = 14;
|
|
systemv* = 16; _systemv* = systemv + 1;
|
|
|
|
noalign* = 20;
|
|
|
|
callee_clean_up* = {default, stdcall, _stdcall, default64, stdcall64, _stdcall64};
|
|
caller_clean_up* = {ccall, ccall16, win64, systemv, _ccall, _ccall16, _win64, _systemv};
|
|
callconv32* = {default, stdcall, ccall, ccall16, _stdcall, _ccall, _ccall16};
|
|
callconv64* = {default64, win64, stdcall64, systemv, _win64, _stdcall64, _systemv};
|
|
|
|
STACK_FRAME = 2;
|
|
|
|
|
|
TYPE
|
|
|
|
IDENT* = POINTER TO rIDENT;
|
|
|
|
UNIT* = POINTER TO rUNIT;
|
|
|
|
PROGRAM* = POINTER TO rPROGRAM;
|
|
|
|
TYPE_* = POINTER TO rTYPE_;
|
|
|
|
FRWPTR* = POINTER TO RECORD (LISTS.ITEM)
|
|
|
|
type: TYPE_;
|
|
baseIdent: SCAN.IDENT;
|
|
linked: BOOLEAN;
|
|
|
|
pos*: SCAN.POSITION;
|
|
notRecord*: BOOLEAN
|
|
|
|
END;
|
|
|
|
IDENTS = POINTER TO RECORD (LISTS.LIST)
|
|
|
|
add*: PROCEDURE (unit: UNIT; ident: SCAN.IDENT; typ: INTEGER): IDENT;
|
|
get*: PROCEDURE (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT
|
|
|
|
END;
|
|
|
|
PROC* = POINTER TO RECORD (LISTS.ITEM)
|
|
|
|
label*: INTEGER;
|
|
used*: BOOLEAN;
|
|
processed*: BOOLEAN;
|
|
import*: LISTS.ITEM;
|
|
using*: LISTS.LIST;
|
|
enter*,
|
|
leave*: LISTS.ITEM
|
|
|
|
END;
|
|
|
|
USED_PROC = POINTER TO RECORD (LISTS.ITEM)
|
|
|
|
proc: PROC
|
|
|
|
END;
|
|
|
|
rUNIT = RECORD (LISTS.ITEM)
|
|
|
|
program*: PROGRAM;
|
|
name*: SCAN.IDENT;
|
|
idents*: IDENTS;
|
|
frwPointers: LISTS.LIST;
|
|
gscope: IDENT;
|
|
closed*: BOOLEAN;
|
|
scopeLvl*: INTEGER;
|
|
sysimport*: BOOLEAN;
|
|
|
|
scopes*: ARRAY MAXSCOPE OF PROC;
|
|
|
|
scope*: RECORD
|
|
|
|
open*: PROCEDURE (unit: UNIT; proc: PROC): BOOLEAN;
|
|
close*: PROCEDURE (unit: UNIT; variables: LISTS.LIST)
|
|
|
|
END;
|
|
|
|
close*: PROCEDURE (unit: UNIT);
|
|
setvars*: PROCEDURE (unit: UNIT; type: TYPE_);
|
|
|
|
pointers*: RECORD
|
|
|
|
add*: PROCEDURE (unit: UNIT; type: TYPE_; baseIdent: SCAN.IDENT; pos: SCAN.POSITION);
|
|
link*: PROCEDURE (unit: UNIT): FRWPTR
|
|
|
|
END
|
|
|
|
END;
|
|
|
|
FIELD* = POINTER TO rFIELD;
|
|
|
|
PARAM* = POINTER TO rPARAM;
|
|
|
|
FIELDS = POINTER TO RECORD (LISTS.LIST)
|
|
|
|
add*: PROCEDURE (rec: TYPE_; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN;
|
|
get*: PROCEDURE (rec: TYPE_; name: SCAN.IDENT; unit: UNIT): FIELD;
|
|
set*: PROCEDURE (rec: TYPE_; type: TYPE_): BOOLEAN
|
|
|
|
END;
|
|
|
|
PARAMS = POINTER TO RECORD (LISTS.LIST)
|
|
|
|
size*: INTEGER;
|
|
|
|
add*: PROCEDURE (proc: TYPE_; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN;
|
|
get*: PROCEDURE (proc: TYPE_; name: SCAN.IDENT): PARAM;
|
|
set*: PROCEDURE (proc: TYPE_; type: TYPE_);
|
|
getfparams*: PROCEDURE (proc: TYPE_; maxparam: INTEGER; VAR int, flt: INTEGER): SET
|
|
|
|
END;
|
|
|
|
rTYPE_ = RECORD (LISTS.ITEM)
|
|
|
|
typ*: INTEGER;
|
|
size*: INTEGER;
|
|
length*: INTEGER;
|
|
align*: INTEGER;
|
|
base*: TYPE_;
|
|
fields*: FIELDS;
|
|
params*: PARAMS;
|
|
unit*: UNIT;
|
|
closed*: BOOLEAN;
|
|
num*: INTEGER;
|
|
call*: INTEGER;
|
|
import*: BOOLEAN;
|
|
noalign*: BOOLEAN
|
|
|
|
END;
|
|
|
|
rFIELD = RECORD (LISTS.ITEM)
|
|
|
|
type*: TYPE_;
|
|
name*: SCAN.IDENT;
|
|
export*: BOOLEAN;
|
|
offset*: INTEGER
|
|
|
|
END;
|
|
|
|
rPARAM = RECORD (LISTS.ITEM)
|
|
|
|
name*: SCAN.IDENT;
|
|
type*: TYPE_;
|
|
vPar*: BOOLEAN;
|
|
offset*: INTEGER
|
|
|
|
END;
|
|
|
|
rIDENT = RECORD (LISTS.ITEM)
|
|
|
|
name*: SCAN.IDENT;
|
|
typ*: INTEGER;
|
|
export*: BOOLEAN;
|
|
import*: LISTS.ITEM;
|
|
unit*: UNIT;
|
|
value*: ARITH.VALUE;
|
|
type*: TYPE_;
|
|
stproc*: INTEGER;
|
|
global*: BOOLEAN;
|
|
scopeLvl*: INTEGER;
|
|
offset*: INTEGER;
|
|
proc*: PROC;
|
|
pos*: SCAN.POSITION
|
|
|
|
END;
|
|
|
|
UNITS* = POINTER TO RECORD (LISTS.LIST)
|
|
|
|
program: PROGRAM;
|
|
|
|
create*: PROCEDURE (units: UNITS; name: SCAN.IDENT): UNIT;
|
|
get*: PROCEDURE (units: UNITS; name: SCAN.IDENT): UNIT
|
|
|
|
END;
|
|
|
|
rPROGRAM = RECORD
|
|
|
|
recCount: INTEGER;
|
|
units*: UNITS;
|
|
types*: LISTS.LIST;
|
|
sysunit*: UNIT;
|
|
rtl*: UNIT;
|
|
bss*: INTEGER;
|
|
locsize*: INTEGER;
|
|
|
|
procs*: LISTS.LIST;
|
|
dll*: BOOLEAN;
|
|
obj*: BOOLEAN;
|
|
|
|
stTypes*: RECORD
|
|
|
|
tINTEGER*, tBYTE*, tCHAR*, tWCHAR*, tSET*, tBOOLEAN*, tREAL*, tSTRING*, tNIL*,
|
|
tCARD16*, tCARD32*, tANYREC*: TYPE_
|
|
|
|
END;
|
|
|
|
target*: RECORD
|
|
|
|
bit_depth*: INTEGER;
|
|
word*: INTEGER;
|
|
adr*: INTEGER;
|
|
sys*: INTEGER
|
|
|
|
END;
|
|
|
|
enterType*: PROCEDURE (program: PROGRAM; typ, size, length: INTEGER; unit: UNIT): TYPE_;
|
|
getType*: PROCEDURE (program: PROGRAM; typ: INTEGER): TYPE_
|
|
|
|
END;
|
|
|
|
DELIMPORT = PROCEDURE (import: LISTS.ITEM);
|
|
|
|
|
|
VAR
|
|
|
|
idents: C.COLLECTION;
|
|
|
|
|
|
PROCEDURE NewIdent (): IDENT;
|
|
VAR
|
|
ident: IDENT;
|
|
citem: C.ITEM;
|
|
|
|
BEGIN
|
|
citem := C.pop(idents);
|
|
IF citem = NIL THEN
|
|
NEW(ident)
|
|
ELSE
|
|
ident := citem(IDENT)
|
|
END
|
|
|
|
RETURN ident
|
|
END NewIdent;
|
|
|
|
|
|
PROCEDURE getOffset* (program: PROGRAM; varIdent: IDENT): INTEGER;
|
|
VAR
|
|
word: INTEGER;
|
|
size: INTEGER;
|
|
|
|
BEGIN
|
|
IF varIdent.offset = -1 THEN
|
|
IF varIdent.global THEN
|
|
IF MACHINE.Align(program.bss, varIdent.type.align) THEN
|
|
IF UTILS.maxint - program.bss >= varIdent.type.size THEN
|
|
varIdent.offset := program.bss;
|
|
INC(program.bss, varIdent.type.size)
|
|
END
|
|
END
|
|
ELSE
|
|
word := program.target.word;
|
|
size := varIdent.type.size;
|
|
IF MACHINE.Align(size, word) THEN
|
|
size := size DIV word;
|
|
IF UTILS.maxint - program.locsize >= size THEN
|
|
INC(program.locsize, size);
|
|
varIdent.offset := program.locsize;
|
|
END
|
|
END
|
|
END
|
|
END
|
|
|
|
RETURN varIdent.offset
|
|
END getOffset;
|
|
|
|
|
|
PROCEDURE close (unit: UNIT);
|
|
VAR
|
|
ident, prev: IDENT;
|
|
offset: INTEGER;
|
|
|
|
BEGIN
|
|
ident := unit.idents.last(IDENT);
|
|
WHILE (ident # NIL) & (ident.typ # idGUARD) DO
|
|
IF (ident.typ = idVAR) & (ident.offset = -1) THEN
|
|
ERRORS.hintmsg(ident.name.s, ident.pos.line, ident.pos.col, 0);
|
|
IF ident.export THEN
|
|
offset := getOffset(unit.program, ident)
|
|
END
|
|
END;
|
|
ident := ident.prev(IDENT)
|
|
END;
|
|
|
|
ident := unit.idents.last(IDENT);
|
|
WHILE ident # NIL DO
|
|
prev := ident.prev(IDENT);
|
|
IF ~ident.export THEN
|
|
LISTS.delete(unit.idents, ident);
|
|
C.push(idents, ident)
|
|
END;
|
|
ident := prev
|
|
END;
|
|
|
|
unit.closed := TRUE
|
|
END close;
|
|
|
|
|
|
PROCEDURE unique (unit: UNIT; ident: SCAN.IDENT): BOOLEAN;
|
|
VAR
|
|
item: IDENT;
|
|
|
|
BEGIN
|
|
ASSERT(ident # NIL);
|
|
|
|
item := unit.idents.last(IDENT);
|
|
WHILE (item.typ # idGUARD) & (item.name # ident) DO
|
|
item := item.prev(IDENT)
|
|
END
|
|
|
|
RETURN item.typ = idGUARD
|
|
END unique;
|
|
|
|
|
|
PROCEDURE addIdent (unit: UNIT; ident: SCAN.IDENT; typ: INTEGER): IDENT;
|
|
VAR
|
|
item: IDENT;
|
|
res: BOOLEAN;
|
|
proc: PROC;
|
|
procs: LISTS.LIST;
|
|
|
|
BEGIN
|
|
ASSERT(unit # NIL);
|
|
ASSERT(ident # NIL);
|
|
|
|
res := unique(unit, ident);
|
|
|
|
IF res THEN
|
|
item := NewIdent();
|
|
|
|
item.name := ident;
|
|
item.typ := typ;
|
|
item.unit := NIL;
|
|
item.export := FALSE;
|
|
item.import := NIL;
|
|
item.type := NIL;
|
|
item.value.typ := 0;
|
|
item.stproc := 0;
|
|
|
|
item.global := unit.scopeLvl = 0;
|
|
item.scopeLvl := unit.scopeLvl;
|
|
item.offset := -1;
|
|
|
|
IF item.typ IN {idPROC, idIMP} THEN
|
|
NEW(proc);
|
|
proc.import := NIL;
|
|
proc.label := 0;
|
|
proc.used := FALSE;
|
|
proc.processed := FALSE;
|
|
proc.using := LISTS.create(NIL);
|
|
procs := unit.program.procs;
|
|
LISTS.push(procs, proc);
|
|
item.proc := proc
|
|
END;
|
|
|
|
LISTS.push(unit.idents, item)
|
|
ELSE
|
|
item := NIL
|
|
END
|
|
|
|
RETURN item
|
|
END addIdent;
|
|
|
|
|
|
PROCEDURE UseProc* (unit: UNIT; call_proc: PROC);
|
|
VAR
|
|
procs: LISTS.LIST;
|
|
cur: LISTS.ITEM;
|
|
proc: USED_PROC;
|
|
|
|
BEGIN
|
|
IF unit.scopeLvl = 0 THEN
|
|
call_proc.used := TRUE
|
|
ELSE
|
|
procs := unit.scopes[unit.scopeLvl].using;
|
|
|
|
cur := procs.first;
|
|
WHILE (cur # NIL) & (cur(USED_PROC).proc # call_proc) DO
|
|
cur := cur.next
|
|
END;
|
|
|
|
IF cur = NIL THEN
|
|
NEW(proc);
|
|
proc.proc := call_proc;
|
|
LISTS.push(procs, proc)
|
|
END
|
|
END
|
|
END UseProc;
|
|
|
|
|
|
PROCEDURE setvars (unit: UNIT; type: TYPE_);
|
|
VAR
|
|
item: IDENT;
|
|
|
|
BEGIN
|
|
ASSERT(type # NIL);
|
|
|
|
item := unit.idents.last(IDENT);
|
|
WHILE (item # NIL) & (item.typ = idVAR) & (item.type = NIL) DO
|
|
item.type := type;
|
|
item := item.prev(IDENT)
|
|
END
|
|
END setvars;
|
|
|
|
|
|
PROCEDURE getIdent (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT;
|
|
VAR
|
|
item: IDENT;
|
|
|
|
BEGIN
|
|
ASSERT(ident # NIL);
|
|
|
|
item := unit.idents.last(IDENT);
|
|
|
|
ASSERT(item # NIL);
|
|
|
|
IF currentScope THEN
|
|
WHILE (item.name # ident) & (item.typ # idGUARD) DO
|
|
item := item.prev(IDENT)
|
|
END;
|
|
IF item.name # ident THEN
|
|
item := NIL
|
|
END
|
|
ELSE
|
|
WHILE (item # NIL) & (item.name # ident) DO
|
|
item := item.prev(IDENT)
|
|
END
|
|
END
|
|
|
|
RETURN item
|
|
END getIdent;
|
|
|
|
|
|
PROCEDURE openScope (unit: UNIT; proc: PROC): BOOLEAN;
|
|
VAR
|
|
item: IDENT;
|
|
res: BOOLEAN;
|
|
|
|
BEGIN
|
|
INC(unit.scopeLvl);
|
|
|
|
res := unit.scopeLvl < MAXSCOPE;
|
|
|
|
IF res THEN
|
|
|
|
unit.scopes[unit.scopeLvl] := proc;
|
|
|
|
NEW(item);
|
|
item := NewIdent();
|
|
|
|
item.name := NIL;
|
|
item.typ := idGUARD;
|
|
|
|
LISTS.push(unit.idents, item)
|
|
END
|
|
|
|
RETURN res
|
|
END openScope;
|
|
|
|
|
|
PROCEDURE closeScope (unit: UNIT; variables: LISTS.LIST);
|
|
VAR
|
|
item: IDENT;
|
|
del: IDENT;
|
|
lvar: CODE.LOCALVAR;
|
|
|
|
BEGIN
|
|
item := unit.idents.last(IDENT);
|
|
|
|
WHILE (item # NIL) & (item.typ # idGUARD) DO
|
|
del := item;
|
|
item := item.prev(IDENT);
|
|
IF (del.typ = idVAR) & (del.offset = -1) THEN
|
|
ERRORS.hintmsg(del.name.s, del.pos.line, del.pos.col, 0)
|
|
END;
|
|
IF (variables # NIL) & (del.typ IN {idVAR, idPARAM}) & (del.offset # -1) THEN
|
|
IF del.type.typ IN BASICTYPES - {tREAL} + {tPOINTER, tPROCEDURE} THEN
|
|
lvar := CODE.NewVar();
|
|
lvar.offset := del.offset;
|
|
lvar.size := del.type.size;
|
|
IF del.typ = idVAR THEN
|
|
lvar.offset := -lvar.offset
|
|
END;
|
|
LISTS.push(variables, lvar)
|
|
END
|
|
END;
|
|
LISTS.delete(unit.idents, del);
|
|
C.push(idents, del)
|
|
END;
|
|
|
|
IF (item # NIL) & (item.typ = idGUARD) THEN
|
|
LISTS.delete(unit.idents, item);
|
|
C.push(idents, item)
|
|
END;
|
|
|
|
DEC(unit.scopeLvl)
|
|
|
|
END closeScope;
|
|
|
|
|
|
PROCEDURE frwptr (unit: UNIT; type: TYPE_; baseIdent: SCAN.IDENT; pos: SCAN.POSITION);
|
|
VAR
|
|
newptr: FRWPTR;
|
|
|
|
BEGIN
|
|
ASSERT(unit # NIL);
|
|
ASSERT(type # NIL);
|
|
ASSERT(baseIdent # NIL);
|
|
|
|
NEW(newptr);
|
|
|
|
newptr.type := type;
|
|
newptr.baseIdent := baseIdent;
|
|
newptr.pos := pos;
|
|
newptr.linked := FALSE;
|
|
newptr.notRecord := FALSE;
|
|
|
|
LISTS.push(unit.frwPointers, newptr)
|
|
END frwptr;
|
|
|
|
|
|
PROCEDURE linkptr (unit: UNIT): FRWPTR;
|
|
VAR
|
|
item: FRWPTR;
|
|
ident: IDENT;
|
|
res: FRWPTR;
|
|
|
|
BEGIN
|
|
res := NIL;
|
|
item := unit.frwPointers.last(FRWPTR);
|
|
|
|
WHILE (item # NIL) & ~item.linked & (res = NIL) DO
|
|
ident := unit.idents.get(unit, item.baseIdent, TRUE);
|
|
|
|
IF (ident # NIL) THEN
|
|
IF (ident.typ = idTYPE) & (ident.type.typ = tRECORD) THEN
|
|
item.type.base := ident.type;
|
|
item.linked := TRUE
|
|
ELSE
|
|
item.notRecord := TRUE;
|
|
res := item
|
|
END
|
|
ELSE
|
|
item.notRecord := FALSE;
|
|
res := item
|
|
END;
|
|
|
|
item := item.prev(FRWPTR)
|
|
END
|
|
|
|
RETURN res
|
|
END linkptr;
|
|
|
|
|
|
PROCEDURE isTypeEq* (t1, t2: TYPE_): BOOLEAN;
|
|
VAR
|
|
res: BOOLEAN;
|
|
param1, param2: LISTS.ITEM;
|
|
|
|
BEGIN
|
|
IF t1 = t2 THEN
|
|
res := TRUE
|
|
ELSIF (t1 = NIL) OR (t2 = NIL) THEN
|
|
res := FALSE
|
|
ELSIF (t1.typ = tPROCEDURE) & (t2.typ = tPROCEDURE) THEN
|
|
|
|
param1 := t1.params.first;
|
|
param2 := t2.params.first;
|
|
|
|
res := (t1.call = t2.call) & ((param1 # NIL) = (param2 # NIL));
|
|
|
|
WHILE res & (param1 # NIL) & (param2 # NIL) DO
|
|
res := (param1(PARAM).vPar = param2(PARAM).vPar) & isTypeEq(param1(PARAM).type, param2(PARAM).type);
|
|
param1 := param1.next;
|
|
param2 := param2.next;
|
|
res := res & ((param1 # NIL) = (param2 # NIL))
|
|
END;
|
|
|
|
res := res & isTypeEq(t1.base, t2.base)
|
|
|
|
ELSIF (t1.typ = tARRAY) & (t2.typ = tARRAY) THEN
|
|
res := (t1.length = 0) & (t2.length = 0) & isTypeEq(t1.base, t2.base)
|
|
ELSE
|
|
res := FALSE
|
|
END
|
|
|
|
RETURN res
|
|
END isTypeEq;
|
|
|
|
|
|
PROCEDURE isBaseOf* (t0, t1: TYPE_): BOOLEAN;
|
|
VAR
|
|
res: BOOLEAN;
|
|
|
|
BEGIN
|
|
res := ((t0.typ = tPOINTER) & (t1.typ = tPOINTER)) OR ((t0.typ = tRECORD) & (t1.typ = tRECORD));
|
|
|
|
IF (t0.typ = tPOINTER) & (t1.typ = tPOINTER) THEN
|
|
t0 := t0.base;
|
|
t1 := t1.base
|
|
END;
|
|
|
|
WHILE res & (t1 # NIL) & (t1 # t0) DO
|
|
t1 := t1.base
|
|
END
|
|
|
|
RETURN res & (t1 = t0)
|
|
END isBaseOf;
|
|
|
|
|
|
PROCEDURE isOpenArray* (t: TYPE_): BOOLEAN;
|
|
RETURN (t.typ = tARRAY) & (t.length = 0)
|
|
END isOpenArray;
|
|
|
|
|
|
PROCEDURE getunit (units: UNITS; name: SCAN.IDENT): UNIT;
|
|
VAR
|
|
item: UNIT;
|
|
|
|
BEGIN
|
|
ASSERT(name # NIL);
|
|
|
|
item := units.first(UNIT);
|
|
|
|
WHILE (item # NIL) & (item.name # name) DO
|
|
item := item.next(UNIT)
|
|
END;
|
|
|
|
IF (item = NIL) & (name.s = "SYSTEM") THEN
|
|
item := units.program.sysunit
|
|
END
|
|
|
|
RETURN item
|
|
END getunit;
|
|
|
|
|
|
PROCEDURE enterStTypes (unit: UNIT; program: PROGRAM);
|
|
VAR
|
|
ident: IDENT;
|
|
stName: SCAN.IDENT;
|
|
|
|
BEGIN
|
|
|
|
stName := SCAN.enterid("INTEGER");
|
|
ident := addIdent(unit, stName, idTYPE);
|
|
ident.type := program.stTypes.tINTEGER;
|
|
|
|
stName := SCAN.enterid("BYTE");
|
|
ident := addIdent(unit, stName, idTYPE);
|
|
ident.type := program.stTypes.tBYTE;
|
|
|
|
stName := SCAN.enterid("CHAR");
|
|
ident := addIdent(unit, stName, idTYPE);
|
|
ident.type := program.stTypes.tCHAR;
|
|
|
|
stName := SCAN.enterid("WCHAR");
|
|
ident := addIdent(unit, stName, idTYPE);
|
|
ident.type := program.stTypes.tWCHAR;
|
|
|
|
stName := SCAN.enterid("SET");
|
|
ident := addIdent(unit, stName, idTYPE);
|
|
ident.type := program.stTypes.tSET;
|
|
|
|
stName := SCAN.enterid("BOOLEAN");
|
|
ident := addIdent(unit, stName, idTYPE);
|
|
ident.type := program.stTypes.tBOOLEAN;
|
|
|
|
stName := SCAN.enterid("REAL");
|
|
ident := addIdent(unit, stName, idTYPE);
|
|
ident.type := program.stTypes.tREAL;
|
|
|
|
END enterStTypes;
|
|
|
|
|
|
PROCEDURE enterStProcs (unit: UNIT);
|
|
|
|
|
|
PROCEDURE EnterProc (unit: UNIT; name: SCAN.LEXSTR; idtyp, proc: INTEGER);
|
|
VAR
|
|
ident: IDENT;
|
|
BEGIN
|
|
ident := addIdent(unit, SCAN.enterid(name), idtyp);
|
|
ident.stproc := proc
|
|
END EnterProc;
|
|
|
|
|
|
BEGIN
|
|
EnterProc(unit, "ASSERT", idSTPROC, stASSERT);
|
|
EnterProc(unit, "DEC", idSTPROC, stDEC);
|
|
EnterProc(unit, "EXCL", idSTPROC, stEXCL);
|
|
EnterProc(unit, "INC", idSTPROC, stINC);
|
|
EnterProc(unit, "INCL", idSTPROC, stINCL);
|
|
EnterProc(unit, "NEW", idSTPROC, stNEW);
|
|
EnterProc(unit, "PACK", idSTPROC, stPACK);
|
|
EnterProc(unit, "UNPK", idSTPROC, stUNPK);
|
|
EnterProc(unit, "DISPOSE", idSTPROC, stDISPOSE);
|
|
EnterProc(unit, "COPY", idSTPROC, stCOPY);
|
|
|
|
EnterProc(unit, "ABS", idSTFUNC, stABS);
|
|
EnterProc(unit, "ASR", idSTFUNC, stASR);
|
|
EnterProc(unit, "CHR", idSTFUNC, stCHR);
|
|
EnterProc(unit, "WCHR", idSTFUNC, stWCHR);
|
|
EnterProc(unit, "FLOOR", idSTFUNC, stFLOOR);
|
|
EnterProc(unit, "FLT", idSTFUNC, stFLT);
|
|
EnterProc(unit, "LEN", idSTFUNC, stLEN);
|
|
EnterProc(unit, "LSL", idSTFUNC, stLSL);
|
|
EnterProc(unit, "ODD", idSTFUNC, stODD);
|
|
EnterProc(unit, "ORD", idSTFUNC, stORD);
|
|
EnterProc(unit, "ROR", idSTFUNC, stROR);
|
|
EnterProc(unit, "BITS", idSTFUNC, stBITS);
|
|
EnterProc(unit, "LSR", idSTFUNC, stLSR);
|
|
EnterProc(unit, "LENGTH", idSTFUNC, stLENGTH);
|
|
EnterProc(unit, "MIN", idSTFUNC, stMIN);
|
|
EnterProc(unit, "MAX", idSTFUNC, stMAX);
|
|
END enterStProcs;
|
|
|
|
|
|
PROCEDURE newunit (units: UNITS; name: SCAN.IDENT): UNIT;
|
|
VAR
|
|
unit: UNIT;
|
|
idents: IDENTS;
|
|
|
|
BEGIN
|
|
ASSERT(units # NIL);
|
|
ASSERT(name # NIL);
|
|
|
|
NEW(unit);
|
|
|
|
NEW(idents);
|
|
ASSERT(LISTS.create(idents) = idents);
|
|
|
|
idents.add := addIdent;
|
|
idents.get := getIdent;
|
|
|
|
unit.program := units.program;
|
|
unit.name := name;
|
|
unit.closed := FALSE;
|
|
unit.idents := idents;
|
|
unit.frwPointers := LISTS.create(NIL);
|
|
|
|
unit.scope.open := openScope;
|
|
unit.scope.close := closeScope;
|
|
unit.close := close;
|
|
unit.setvars := setvars;
|
|
unit.pointers.add := frwptr;
|
|
unit.pointers.link := linkptr;
|
|
|
|
ASSERT(unit.scope.open(unit, NIL));
|
|
|
|
enterStTypes(unit, units.program);
|
|
enterStProcs(unit);
|
|
|
|
ASSERT(unit.scope.open(unit, NIL));
|
|
|
|
unit.gscope := unit.idents.last(IDENT);
|
|
|
|
LISTS.push(units, unit);
|
|
|
|
unit.scopeLvl := 0;
|
|
unit.scopes[0] := NIL;
|
|
|
|
unit.sysimport := FALSE;
|
|
|
|
IF unit.name.s = mConst.RTL_NAME THEN
|
|
unit.program.rtl := unit
|
|
END
|
|
|
|
RETURN unit
|
|
END newunit;
|
|
|
|
|
|
PROCEDURE getField (self: TYPE_; name: SCAN.IDENT; unit: UNIT): FIELD;
|
|
VAR
|
|
field: FIELD;
|
|
|
|
BEGIN
|
|
ASSERT(self # NIL);
|
|
ASSERT(name # NIL);
|
|
ASSERT(unit # NIL);
|
|
|
|
field := NIL;
|
|
WHILE (self # NIL) & (field = NIL) DO
|
|
|
|
field := self.fields.first(FIELD);
|
|
|
|
WHILE (field # NIL) & (field.name # name) DO
|
|
field := field.next(FIELD)
|
|
END;
|
|
|
|
IF field = NIL THEN
|
|
self := self.base
|
|
END
|
|
|
|
END;
|
|
|
|
IF (field # NIL) & (self.unit # unit) & ~field.export THEN
|
|
field := NIL
|
|
END
|
|
|
|
RETURN field
|
|
END getField;
|
|
|
|
|
|
PROCEDURE addField (self: TYPE_; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN;
|
|
VAR
|
|
field: FIELD;
|
|
res: BOOLEAN;
|
|
|
|
BEGIN
|
|
ASSERT(name # NIL);
|
|
|
|
res := getField(self, name, self.unit) = NIL;
|
|
|
|
IF res THEN
|
|
NEW(field);
|
|
|
|
field.name := name;
|
|
field.export := export;
|
|
field.type := NIL;
|
|
field.offset := self.size;
|
|
|
|
LISTS.push(self.fields, field)
|
|
END
|
|
|
|
RETURN res
|
|
END addField;
|
|
|
|
|
|
PROCEDURE setFields (self: TYPE_; type: TYPE_): BOOLEAN;
|
|
VAR
|
|
item: FIELD;
|
|
res: BOOLEAN;
|
|
|
|
BEGIN
|
|
ASSERT(type # NIL);
|
|
|
|
item := self.fields.first(FIELD);
|
|
|
|
WHILE (item # NIL) & (item.type # NIL) DO
|
|
item := item.next(FIELD)
|
|
END;
|
|
|
|
res := TRUE;
|
|
|
|
WHILE res & (item # NIL) & (item.type = NIL) DO
|
|
item.type := type;
|
|
IF ~self.noalign THEN
|
|
res := MACHINE.Align(self.size, type.align)
|
|
ELSE
|
|
res := TRUE
|
|
END;
|
|
item.offset := self.size;
|
|
res := res & (UTILS.maxint - self.size >= type.size);
|
|
IF res THEN
|
|
INC(self.size, type.size)
|
|
END;
|
|
item := item.next(FIELD)
|
|
END
|
|
|
|
RETURN res
|
|
END setFields;
|
|
|
|
|
|
PROCEDURE getParam (self: TYPE_; name: SCAN.IDENT): PARAM;
|
|
VAR
|
|
item: PARAM;
|
|
|
|
BEGIN
|
|
ASSERT(name # NIL);
|
|
|
|
item := self.params.first(PARAM);
|
|
|
|
WHILE (item # NIL) & (item.name # name) DO
|
|
item := item.next(PARAM)
|
|
END
|
|
|
|
RETURN item
|
|
END getParam;
|
|
|
|
|
|
PROCEDURE addParam (self: TYPE_; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN;
|
|
VAR
|
|
param: PARAM;
|
|
res: BOOLEAN;
|
|
|
|
BEGIN
|
|
ASSERT(name # NIL);
|
|
|
|
res := self.params.get(self, name) = NIL;
|
|
|
|
IF res THEN
|
|
NEW(param);
|
|
|
|
param.name := name;
|
|
param.type := NIL;
|
|
param.vPar := vPar;
|
|
|
|
LISTS.push(self.params, param)
|
|
END
|
|
|
|
RETURN res
|
|
END addParam;
|
|
|
|
|
|
PROCEDURE Dim* (t: TYPE_): INTEGER;
|
|
VAR
|
|
res: INTEGER;
|
|
|
|
BEGIN
|
|
res := 0;
|
|
WHILE isOpenArray(t) DO
|
|
t := t.base;
|
|
INC(res)
|
|
END
|
|
RETURN res
|
|
END Dim;
|
|
|
|
|
|
PROCEDURE OpenBase* (t: TYPE_): TYPE_;
|
|
BEGIN
|
|
WHILE isOpenArray(t) DO t := t.base END
|
|
RETURN t
|
|
END OpenBase;
|
|
|
|
|
|
PROCEDURE getFloatParamsPos (self: TYPE_; maxoffs: INTEGER; VAR int, flt: INTEGER): SET;
|
|
VAR
|
|
res: SET;
|
|
param: PARAM;
|
|
|
|
BEGIN
|
|
res := {};
|
|
int := 0;
|
|
flt := 0;
|
|
param := self.params.first(PARAM);
|
|
WHILE (param # NIL) & (param.offset <= maxoffs + STACK_FRAME) DO
|
|
IF ~param.vPar & (param.type.typ = tREAL) THEN
|
|
INCL(res, param.offset - STACK_FRAME);
|
|
INC(flt)
|
|
END;
|
|
param := param.next(PARAM)
|
|
END;
|
|
|
|
int := self.params.size - flt
|
|
|
|
RETURN res
|
|
END getFloatParamsPos;
|
|
|
|
|
|
PROCEDURE setParams (self: TYPE_; type: TYPE_);
|
|
VAR
|
|
item: LISTS.ITEM;
|
|
param: PARAM;
|
|
word, size: INTEGER;
|
|
|
|
BEGIN
|
|
ASSERT(type # NIL);
|
|
|
|
word := MACHINE.target.bit_depth DIV 8;
|
|
|
|
item := self.params.first;
|
|
|
|
WHILE (item # NIL) & (item(PARAM).type # NIL) DO
|
|
item := item.next
|
|
END;
|
|
|
|
WHILE (item # NIL) & (item(PARAM).type = NIL) DO
|
|
param := item(PARAM);
|
|
param.type := type;
|
|
IF param.vPar THEN
|
|
IF type.typ = tRECORD THEN
|
|
size := 2
|
|
ELSIF isOpenArray(type) THEN
|
|
size := Dim(type) + 1
|
|
ELSE
|
|
size := 1
|
|
END;
|
|
param.offset := self.params.size + ORD(type.typ = tRECORD) + Dim(type) + STACK_FRAME;
|
|
INC(self.params.size, size)
|
|
ELSE
|
|
IF type.typ IN {tRECORD, tARRAY} THEN
|
|
IF isOpenArray(type) THEN
|
|
size := Dim(type) + 1
|
|
ELSE
|
|
size := 1
|
|
END
|
|
ELSE
|
|
size := type.size;
|
|
ASSERT(MACHINE.Align(size, word));
|
|
size := size DIV word
|
|
END;
|
|
param.offset := self.params.size + Dim(type) + STACK_FRAME;
|
|
INC(self.params.size, size)
|
|
END;
|
|
|
|
item := item.next
|
|
END
|
|
|
|
END setParams;
|
|
|
|
|
|
PROCEDURE enterType (program: PROGRAM; typ, size, length: INTEGER; unit: UNIT): TYPE_;
|
|
VAR
|
|
t: TYPE_;
|
|
fields: FIELDS;
|
|
params: PARAMS;
|
|
|
|
BEGIN
|
|
NEW(t);
|
|
|
|
NEW(fields);
|
|
ASSERT(LISTS.create(fields) = fields);
|
|
|
|
NEW(params);
|
|
ASSERT(LISTS.create(params) = params);
|
|
|
|
t.typ := typ;
|
|
t.size := size;
|
|
t.length := length;
|
|
t.align := 0;
|
|
t.base := NIL;
|
|
t.fields := fields;
|
|
t.params := params;
|
|
t.unit := unit;
|
|
t.num := 0;
|
|
IF program.target.bit_depth = 32 THEN
|
|
t.call := default
|
|
ELSIF program.target.bit_depth = 64 THEN
|
|
t.call := default64
|
|
END;
|
|
t.import := FALSE;
|
|
t.noalign := FALSE;
|
|
|
|
t.fields.add := addField;
|
|
t.fields.get := getField;
|
|
t.fields.set := setFields;
|
|
|
|
t.params.add := addParam;
|
|
t.params.get := getParam;
|
|
t.params.getfparams := getFloatParamsPos;
|
|
t.params.set := setParams;
|
|
t.params.size := 0;
|
|
|
|
IF typ IN {tARRAY, tRECORD} THEN
|
|
t.closed := FALSE;
|
|
IF typ = tRECORD THEN
|
|
INC(program.recCount);
|
|
t.num := program.recCount
|
|
END
|
|
ELSE
|
|
t.closed := TRUE
|
|
END;
|
|
|
|
LISTS.push(program.types, t)
|
|
|
|
RETURN t
|
|
END enterType;
|
|
|
|
|
|
PROCEDURE getType (program: PROGRAM; typ: INTEGER): TYPE_;
|
|
VAR
|
|
res: TYPE_;
|
|
|
|
BEGIN
|
|
|
|
IF typ = ARITH.tINTEGER THEN
|
|
res := program.stTypes.tINTEGER
|
|
ELSIF typ = ARITH.tREAL THEN
|
|
res := program.stTypes.tREAL
|
|
ELSIF typ = ARITH.tSET THEN
|
|
res := program.stTypes.tSET
|
|
ELSIF typ = ARITH.tBOOLEAN THEN
|
|
res := program.stTypes.tBOOLEAN
|
|
ELSIF typ = ARITH.tCHAR THEN
|
|
res := program.stTypes.tCHAR
|
|
ELSIF typ = ARITH.tWCHAR THEN
|
|
res := program.stTypes.tWCHAR
|
|
ELSIF typ = ARITH.tSTRING THEN
|
|
res := program.stTypes.tSTRING
|
|
ELSE
|
|
res := NIL
|
|
END;
|
|
|
|
ASSERT(res # NIL)
|
|
|
|
RETURN res
|
|
END getType;
|
|
|
|
|
|
PROCEDURE createSysUnit (program: PROGRAM);
|
|
VAR
|
|
ident: IDENT;
|
|
unit: UNIT;
|
|
|
|
|
|
PROCEDURE EnterProc (sys: UNIT; name: SCAN.LEXSTR; idtyp, proc: INTEGER);
|
|
VAR
|
|
ident: IDENT;
|
|
BEGIN
|
|
ident := addIdent(sys, SCAN.enterid(name), idtyp);
|
|
ident.stproc := proc;
|
|
ident.export := TRUE
|
|
END EnterProc;
|
|
|
|
|
|
BEGIN
|
|
unit := program.units.create(program.units, SCAN.enterid("$SYSTEM"));
|
|
|
|
EnterProc(unit, "ADR", idSYSFUNC, sysADR);
|
|
EnterProc(unit, "SIZE", idSYSFUNC, sysSIZE);
|
|
EnterProc(unit, "SADR", idSYSFUNC, sysSADR);
|
|
EnterProc(unit, "WSADR", idSYSFUNC, sysWSADR);
|
|
EnterProc(unit, "TYPEID", idSYSFUNC, sysTYPEID);
|
|
EnterProc(unit, "INF", idSYSFUNC, sysINF);
|
|
|
|
EnterProc(unit, "GET", idSYSPROC, sysGET);
|
|
EnterProc(unit, "PUT", idSYSPROC, sysPUT);
|
|
EnterProc(unit, "PUT8", idSYSPROC, sysPUT8);
|
|
EnterProc(unit, "PUT16", idSYSPROC, sysPUT16);
|
|
EnterProc(unit, "PUT32", idSYSPROC, sysPUT32);
|
|
EnterProc(unit, "CODE", idSYSPROC, sysCODE);
|
|
EnterProc(unit, "MOVE", idSYSPROC, sysMOVE);
|
|
EnterProc(unit, "COPY", idSYSPROC, sysCOPY);
|
|
|
|
ident := addIdent(unit, SCAN.enterid("CARD16"), idTYPE);
|
|
ident.type := program.stTypes.tCARD16;
|
|
ident.export := TRUE;
|
|
|
|
ident := addIdent(unit, SCAN.enterid("CARD32"), idTYPE);
|
|
ident.type := program.stTypes.tCARD32;
|
|
ident.export := TRUE;
|
|
|
|
unit.close(unit);
|
|
|
|
program.sysunit := unit
|
|
END createSysUnit;
|
|
|
|
|
|
PROCEDURE DelUnused* (program: PROGRAM; DelImport: DELIMPORT);
|
|
VAR
|
|
proc: PROC;
|
|
flag: BOOLEAN;
|
|
|
|
|
|
PROCEDURE process (proc: PROC);
|
|
VAR
|
|
used_proc: LISTS.ITEM;
|
|
|
|
BEGIN
|
|
proc.processed := TRUE;
|
|
|
|
used_proc := proc.using.first;
|
|
WHILE used_proc # NIL DO
|
|
used_proc(USED_PROC).proc.used := TRUE;
|
|
used_proc := used_proc.next
|
|
END
|
|
|
|
END process;
|
|
|
|
|
|
BEGIN
|
|
|
|
REPEAT
|
|
|
|
flag := FALSE;
|
|
proc := program.procs.first(PROC);
|
|
|
|
WHILE proc # NIL DO
|
|
IF proc.used & ~proc.processed THEN
|
|
process(proc);
|
|
flag := TRUE
|
|
END;
|
|
proc := proc.next(PROC)
|
|
END
|
|
|
|
UNTIL ~flag;
|
|
|
|
proc := program.procs.first(PROC);
|
|
|
|
WHILE proc # NIL DO
|
|
IF ~proc.used THEN
|
|
IF proc.import = NIL THEN
|
|
CODE.delete2(proc.enter, proc.leave)
|
|
ELSE
|
|
DelImport(proc.import)
|
|
END
|
|
END;
|
|
proc := proc.next(PROC)
|
|
END
|
|
|
|
END DelUnused;
|
|
|
|
|
|
PROCEDURE create* (bit_depth, sys: INTEGER): PROGRAM;
|
|
VAR
|
|
program: PROGRAM;
|
|
units: UNITS;
|
|
|
|
BEGIN
|
|
idents := C.create();
|
|
|
|
MACHINE.SetBitDepth(bit_depth);
|
|
NEW(program);
|
|
NEW(units);
|
|
ASSERT(LISTS.create(units) = units);
|
|
|
|
program.target.bit_depth := bit_depth;
|
|
program.target.word := bit_depth DIV 8;
|
|
program.target.adr := bit_depth DIV 8;
|
|
program.target.sys := sys;
|
|
|
|
program.recCount := -1;
|
|
program.bss := 0;
|
|
|
|
program.units := units;
|
|
program.types := LISTS.create(NIL);
|
|
|
|
program.procs := LISTS.create(NIL);
|
|
|
|
program.enterType := enterType;
|
|
program.getType := getType;
|
|
|
|
program.stTypes.tINTEGER := enterType(program, tINTEGER, program.target.word, 0, NIL);
|
|
program.stTypes.tBYTE := enterType(program, tBYTE, 1, 0, NIL);
|
|
program.stTypes.tCHAR := enterType(program, tCHAR, 1, 0, NIL);
|
|
program.stTypes.tWCHAR := enterType(program, tWCHAR, 2, 0, NIL);
|
|
program.stTypes.tSET := enterType(program, tSET, program.target.word, 0, NIL);
|
|
program.stTypes.tBOOLEAN := enterType(program, tBOOLEAN, 1, 0, NIL);
|
|
program.stTypes.tREAL := enterType(program, tREAL, 8, 0, NIL);
|
|
program.stTypes.tSTRING := enterType(program, tSTRING, program.target.word, 0, NIL);
|
|
program.stTypes.tNIL := enterType(program, tNIL, program.target.word, 0, NIL);
|
|
program.stTypes.tCARD16 := enterType(program, tCARD16, 2, 0, NIL);
|
|
program.stTypes.tCARD32 := enterType(program, tCARD32, 4, 0, NIL);
|
|
program.stTypes.tANYREC := enterType(program, tRECORD, 0, 0, NIL);
|
|
program.stTypes.tANYREC.closed := TRUE;
|
|
|
|
program.stTypes.tINTEGER.align := program.stTypes.tINTEGER.size;
|
|
program.stTypes.tBYTE.align := 1;
|
|
program.stTypes.tCHAR.align := program.stTypes.tCHAR.size;
|
|
program.stTypes.tWCHAR.align := program.stTypes.tWCHAR.size;
|
|
program.stTypes.tSET.align := program.stTypes.tSET.size;
|
|
program.stTypes.tBOOLEAN.align := program.stTypes.tBOOLEAN.size;
|
|
program.stTypes.tREAL.align := program.stTypes.tREAL.size;
|
|
program.stTypes.tCARD16.align := program.stTypes.tCARD16.size;
|
|
program.stTypes.tCARD32.align := program.stTypes.tCARD32.size;
|
|
|
|
units.program := program;
|
|
|
|
units.create := newunit;
|
|
units.get := getunit;
|
|
|
|
program.dll := FALSE;
|
|
program.obj := FALSE;
|
|
|
|
createSysUnit(program)
|
|
|
|
RETURN program
|
|
END create;
|
|
|
|
|
|
END PROG. |