Subversion Repositories Kolibri OS

Compare Revisions

Regard whitespace Rev 8096 → Rev 8097

/programs/develop/oberon07/Source/PROG.ob07
1,13 → 1,13
(*
BSD 2-Clause License
 
Copyright (c) 2018-2019, Anton Krotov
Copyright (c) 2018-2020, Anton Krotov
All rights reserved.
*)
 
MODULE PROG;
 
IMPORT SCAN, LISTS, ARITH, ERRORS, C := COLLECTIONS, IL, UTILS, TARGETS;
IMPORT SCAN, LISTS, ARITH, ERRORS, C := COLLECTIONS, IL, UTILS, TARGETS, STRINGS;
 
 
CONST
24,7 → 24,7
tINTEGER* = 1; tBYTE* = 2; tCHAR* = 3; tSET* = 4;
tBOOLEAN* = 5; tREAL* = 6; tARRAY* = 7; tRECORD* = 8;
tPOINTER* = 9; tPROCEDURE* = 10; tSTRING* = 11; tNIL* = 12;
tCARD32* = 13; tANYREC* = 14; tWCHAR* = 15;
tCARD32* = 13; tANYREC* = 14; tWCHAR* = 15; tNONE* = 16;
 
BASICTYPES* = {tINTEGER, tBYTE, tCHAR, tSET, tBOOLEAN, tREAL, tCARD32, tWCHAR};
 
40,15 → 40,15
sysSADR* = 31; sysTYPEID* = 32; sysCOPY* = 33; sysINF* = 34;
sysPUT8* = 35; sysPUT16* = 36; stCOPY* = 37; stWCHR* = 38;
sysWSADR* = 39; sysPUT32* = 40; (*sysNOP* = 41; sysEINT* = 42;
sysDINT* = 43;*)
sysDINT* = 43;*)sysGET8* = 44; sysGET16* = 45; sysGET32* = 46;
 
default32* = 2;
default32* = 2; _default32* = default32 + 1;
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;
default64* = 14; _default64* = default64 + 1;
systemv* = 16; _systemv* = systemv + 1;
default16* = 18;
code* = 20; _code* = code + 1;
59,10 → 59,10
 
sf_stdcall* = 0; sf_stdcall64* = 1; sf_ccall* = 2; sf_ccall16* = 3;
sf_win64* = 4; sf_systemv* = 5; sf_windows* = 6; sf_linux* = 7;
sf_code* = 8;
sf_noalign* = 9;
sf_code* = 8; sf_oberon* = 9;
sf_noalign* = 10;
 
proc_flags* = {sf_stdcall, sf_stdcall64, sf_ccall, sf_ccall16, sf_win64, sf_systemv, sf_windows, sf_linux, sf_code};
proc_flags* = {sf_stdcall, sf_stdcall64, sf_ccall, sf_ccall16, sf_win64, sf_systemv, sf_windows, sf_linux, sf_code, sf_oberon};
rec_flags* = {sf_noalign};
 
STACK_FRAME = 2;
73,7 → 73,7
OPTIONS* = RECORD
 
version*, stack*, ram*, rom*: INTEGER;
pic*: BOOLEAN;
pic*, lower*: BOOLEAN;
checking*: SET
 
END;
82,13 → 82,11
 
UNIT* = POINTER TO rUNIT;
 
PROGRAM* = POINTER TO rPROGRAM;
_TYPE* = POINTER TO rTYPE;
 
TYPE_* = POINTER TO rTYPE_;
 
FRWPTR* = POINTER TO RECORD (LISTS.ITEM)
 
type: TYPE_;
_type: _TYPE;
baseIdent: SCAN.IDENT;
linked: BOOLEAN;
 
102,7 → 100,7
label*: INTEGER;
used*: BOOLEAN;
processed*: BOOLEAN;
import*: LISTS.ITEM;
_import*: LISTS.ITEM;
using*: LISTS.LIST;
enter*,
leave*: LISTS.ITEM
117,7 → 115,6
 
rUNIT = RECORD (LISTS.ITEM)
 
program*: PROGRAM;
name*: SCAN.IDENT;
idents*: LISTS.LIST;
frwPointers: LISTS.LIST;
133,7 → 130,7
 
PARAM* = POINTER TO rPARAM;
 
rTYPE_ = RECORD (LISTS.ITEM)
rTYPE = RECORD (LISTS.ITEM)
 
typ*: INTEGER;
size*: INTEGER;
140,7 → 137,7
parSize*: INTEGER;
length*: INTEGER;
align*: INTEGER;
base*: TYPE_;
base*: _TYPE;
fields*: LISTS.LIST;
params*: LISTS.LIST;
unit*: UNIT;
147,7 → 144,7
closed*: BOOLEAN;
num*: INTEGER;
call*: INTEGER;
import*: BOOLEAN;
_import*: BOOLEAN;
noalign*: BOOLEAN
 
END;
154,7 → 151,7
 
rFIELD = RECORD (LISTS.ITEM)
 
type*: TYPE_;
_type*: _TYPE;
name*: SCAN.IDENT;
export*: BOOLEAN;
offset*: INTEGER
164,7 → 161,7
rPARAM = RECORD (LISTS.ITEM)
 
name*: SCAN.IDENT;
type*: TYPE_;
_type*: _TYPE;
vPar*: BOOLEAN;
offset*: INTEGER
 
175,10 → 172,10
name*: SCAN.IDENT;
typ*: INTEGER;
export*: BOOLEAN;
import*: LISTS.ITEM;
_import*: LISTS.ITEM;
unit*: UNIT;
value*: ARITH.VALUE;
type*: TYPE_;
_type*: _TYPE;
stproc*: INTEGER;
global*: BOOLEAN;
scopeLvl*: INTEGER;
188,7 → 185,7
 
END;
 
rPROGRAM = RECORD
PROGRAM = RECORD
 
recCount: INTEGER;
units*: LISTS.LIST;
206,18 → 203,20
stTypes*: RECORD
 
tINTEGER*, tBYTE*, tCHAR*, tWCHAR*, tSET*, tBOOLEAN*, tREAL*,
tSTRING*, tNIL*, tCARD32*, tANYREC*: TYPE_
tSTRING*, tNIL*, tCARD32*, tANYREC*, tNONE*: _TYPE
 
END
 
END;
 
DELIMPORT = PROCEDURE (import: LISTS.ITEM);
DELIMPORT = PROCEDURE (_import: LISTS.ITEM);
 
 
VAR
 
LowerCase: BOOLEAN;
idents: C.COLLECTION;
program*: PROGRAM;
 
 
PROCEDURE NewIdent (): IDENT;
237,15 → 236,15
END NewIdent;
 
 
PROCEDURE getOffset* (program: PROGRAM; varIdent: IDENT): INTEGER;
PROCEDURE getOffset* (varIdent: IDENT): INTEGER;
VAR
size: INTEGER;
 
BEGIN
IF varIdent.offset = -1 THEN
size := varIdent.type.size;
size := varIdent._type.size;
IF varIdent.global THEN
IF UTILS.Align(program.bss, varIdent.type.align) THEN
IF UTILS.Align(program.bss, varIdent._type.align) THEN
IF UTILS.maxint - program.bss >= size THEN
varIdent.offset := program.bss;
INC(program.bss, size)
281,7 → 280,7
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)
offset := getOffset(ident)
END
END;
ident := ident.prev(IDENT)
322,7 → 321,6
item: IDENT;
res: BOOLEAN;
proc: PROC;
procs: LISTS.LIST;
 
BEGIN
ASSERT(unit # NIL);
337,8 → 335,8
item.typ := typ;
item.unit := NIL;
item.export := FALSE;
item.import := NIL;
item.type := NIL;
item._import := NIL;
item._type := NIL;
item.value.typ := 0;
item.stproc := 0;
 
348,13 → 346,12
 
IF item.typ IN {idPROC, idIMP} THEN
NEW(proc);
proc.import := NIL;
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);
LISTS.push(program.procs, proc);
item.proc := proc
END;
 
393,16 → 390,16
END UseProc;
 
 
PROCEDURE setVarsType* (unit: UNIT; type: TYPE_);
PROCEDURE setVarsType* (unit: UNIT; _type: _TYPE);
VAR
item: IDENT;
 
BEGIN
ASSERT(type # NIL);
ASSERT(_type # NIL);
 
item := unit.idents.last(IDENT);
WHILE (item # NIL) & (item.typ = idVAR) & (item.type = NIL) DO
item.type := type;
WHILE (item # NIL) & (item.typ = idVAR) & (item._type = NIL) DO
item._type := _type;
item := item.prev(IDENT)
END
END setVarsType;
481,10 → 478,10
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
IF del._type.typ IN BASICTYPES - {tREAL} + {tPOINTER, tPROCEDURE} THEN
lvar := IL.NewVar();
lvar.offset := del.offset;
lvar.size := del.type.size;
lvar.size := del._type.size;
IF del.typ = idVAR THEN
lvar.offset := -lvar.offset
END;
504,18 → 501,18
END closeScope;
 
 
PROCEDURE frwPtr* (unit: UNIT; type: TYPE_; baseIdent: SCAN.IDENT; pos: SCAN.POSITION);
PROCEDURE frwPtr* (unit: UNIT; _type: _TYPE; baseIdent: SCAN.IDENT; pos: SCAN.POSITION);
VAR
newptr: FRWPTR;
 
BEGIN
ASSERT(unit # NIL);
ASSERT(type # NIL);
ASSERT(_type # NIL);
ASSERT(baseIdent # NIL);
 
NEW(newptr);
 
newptr.type := type;
newptr._type := _type;
newptr.baseIdent := baseIdent;
newptr.pos := pos;
newptr.linked := FALSE;
539,8 → 536,8
ident := getIdent(unit, item.baseIdent, TRUE);
 
IF (ident # NIL) THEN
IF (ident.typ = idTYPE) & (ident.type.typ = tRECORD) THEN
item.type.base := ident.type;
IF (ident.typ = idTYPE) & (ident._type.typ = tRECORD) THEN
item._type.base := ident._type;
item.linked := TRUE
ELSE
item.notRecord := TRUE;
558,7 → 555,7
END linkPtr;
 
 
PROCEDURE isTypeEq* (t1, t2: TYPE_): BOOLEAN;
PROCEDURE isTypeEq* (t1, t2: _TYPE): BOOLEAN;
VAR
res: BOOLEAN;
param1, param2: LISTS.ITEM;
576,7 → 573,7
res := ((t1.call = t2.call) OR (t1.call IN {code, _code}) OR (t2.call IN {code, _code})) & ((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);
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))
594,7 → 591,7
END isTypeEq;
 
 
PROCEDURE isBaseOf* (t0, t1: TYPE_): BOOLEAN;
PROCEDURE isBaseOf* (t0, t1: _TYPE): BOOLEAN;
VAR
res: BOOLEAN;
 
617,12 → 614,12
END isBaseOf;
 
 
PROCEDURE isOpenArray* (t: TYPE_): BOOLEAN;
PROCEDURE isOpenArray* (t: _TYPE): BOOLEAN;
RETURN (t.typ = tARRAY) & (t.length = 0)
END isOpenArray;
 
 
PROCEDURE arrcomp* (src, dst: TYPE_): BOOLEAN;
PROCEDURE arrcomp* (src, dst: _TYPE): BOOLEAN;
RETURN (dst.typ = tARRAY) & isOpenArray(src) &
~isOpenArray(src.base) & ~isOpenArray(dst.base) &
isTypeEq(src.base, dst.base)
629,7 → 626,7
END arrcomp;
 
 
PROCEDURE getUnit* (program: PROGRAM; name: SCAN.IDENT): UNIT;
PROCEDURE getUnit* (name: SCAN.IDENT): UNIT;
VAR
item: UNIT;
 
642,7 → 639,7
item := item.next(UNIT)
END;
 
IF (item = NIL) & (name.s = "SYSTEM") THEN
IF (item = NIL) & ((name.s = "SYSTEM") OR LowerCase & (name.s = "system")) THEN
item := program.sysunit
END
 
650,36 → 647,40
END getUnit;
 
 
PROCEDURE enterStTypes (unit: UNIT; program: PROGRAM);
PROCEDURE enterStTypes (unit: UNIT);
 
 
PROCEDURE enter (unit: UNIT; name: SCAN.LEXSTR; _type: _TYPE);
VAR
ident: IDENT;
upper: SCAN.LEXSTR;
 
BEGIN
ident := addIdent(unit, SCAN.enterid("INTEGER"), idTYPE);
ident.type := program.stTypes.tINTEGER;
IF LowerCase THEN
ident := addIdent(unit, SCAN.enterid(name), idTYPE);
ident._type := _type
END;
upper := name;
STRINGS.UpCase(upper);
ident := addIdent(unit, SCAN.enterid(upper), idTYPE);
ident._type := _type
END enter;
 
ident := addIdent(unit, SCAN.enterid("BYTE"), idTYPE);
ident.type := program.stTypes.tBYTE;
 
ident := addIdent(unit, SCAN.enterid("CHAR"), idTYPE);
ident.type := program.stTypes.tCHAR;
BEGIN
enter(unit, "integer", program.stTypes.tINTEGER);
enter(unit, "byte", program.stTypes.tBYTE);
enter(unit, "char", program.stTypes.tCHAR);
enter(unit, "set", program.stTypes.tSET);
enter(unit, "boolean", program.stTypes.tBOOLEAN);
 
ident := addIdent(unit, SCAN.enterid("SET"), idTYPE);
ident.type := program.stTypes.tSET;
 
ident := addIdent(unit, SCAN.enterid("BOOLEAN"), idTYPE);
ident.type := program.stTypes.tBOOLEAN;
 
IF TARGETS.RealSize # 0 THEN
ident := addIdent(unit, SCAN.enterid("REAL"), idTYPE);
ident.type := program.stTypes.tREAL
enter(unit, "real", program.stTypes.tREAL)
END;
 
IF TARGETS.BitDepth >= 32 THEN
ident := addIdent(unit, SCAN.enterid("WCHAR"), idTYPE);
ident.type := program.stTypes.tWCHAR
enter(unit, "wchar", program.stTypes.tWCHAR)
END
 
END enterStTypes;
 
 
689,9 → 690,19
PROCEDURE EnterProc (unit: UNIT; name: SCAN.LEXSTR; proc: INTEGER);
VAR
ident: IDENT;
upper: SCAN.LEXSTR;
 
BEGIN
IF LowerCase THEN
ident := addIdent(unit, SCAN.enterid(name), idSTPROC);
ident.stproc := proc
ident.stproc := proc;
ident._type := program.stTypes.tNONE
END;
upper := name;
STRINGS.UpCase(upper);
ident := addIdent(unit, SCAN.enterid(upper), idSTPROC);
ident.stproc := proc;
ident._type := program.stTypes.tNONE
END EnterProc;
 
 
698,64 → 709,72
PROCEDURE EnterFunc (unit: UNIT; name: SCAN.LEXSTR; func: INTEGER);
VAR
ident: IDENT;
upper: SCAN.LEXSTR;
 
BEGIN
IF LowerCase THEN
ident := addIdent(unit, SCAN.enterid(name), idSTFUNC);
ident.stproc := func
ident.stproc := func;
ident._type := program.stTypes.tNONE
END;
upper := name;
STRINGS.UpCase(upper);
ident := addIdent(unit, SCAN.enterid(upper), idSTFUNC);
ident.stproc := func;
ident._type := program.stTypes.tNONE
END EnterFunc;
 
 
BEGIN
EnterProc(unit, "ASSERT", stASSERT);
EnterProc(unit, "DEC", stDEC);
EnterProc(unit, "EXCL", stEXCL);
EnterProc(unit, "INC", stINC);
EnterProc(unit, "INCL", stINCL);
EnterProc(unit, "NEW", stNEW);
EnterProc(unit, "COPY", stCOPY);
EnterProc(unit, "assert", stASSERT);
EnterProc(unit, "dec", stDEC);
EnterProc(unit, "excl", stEXCL);
EnterProc(unit, "inc", stINC);
EnterProc(unit, "incl", stINCL);
EnterProc(unit, "new", stNEW);
EnterProc(unit, "copy", stCOPY);
 
EnterFunc(unit, "ABS", stABS);
EnterFunc(unit, "ASR", stASR);
EnterFunc(unit, "CHR", stCHR);
EnterFunc(unit, "LEN", stLEN);
EnterFunc(unit, "LSL", stLSL);
EnterFunc(unit, "ODD", stODD);
EnterFunc(unit, "ORD", stORD);
EnterFunc(unit, "ROR", stROR);
EnterFunc(unit, "BITS", stBITS);
EnterFunc(unit, "LSR", stLSR);
EnterFunc(unit, "LENGTH", stLENGTH);
EnterFunc(unit, "MIN", stMIN);
EnterFunc(unit, "MAX", stMAX);
EnterFunc(unit, "abs", stABS);
EnterFunc(unit, "asr", stASR);
EnterFunc(unit, "chr", stCHR);
EnterFunc(unit, "len", stLEN);
EnterFunc(unit, "lsl", stLSL);
EnterFunc(unit, "odd", stODD);
EnterFunc(unit, "ord", stORD);
EnterFunc(unit, "ror", stROR);
EnterFunc(unit, "bits", stBITS);
EnterFunc(unit, "lsr", stLSR);
EnterFunc(unit, "length", stLENGTH);
EnterFunc(unit, "min", stMIN);
EnterFunc(unit, "max", stMAX);
 
IF TARGETS.RealSize # 0 THEN
EnterProc(unit, "PACK", stPACK);
EnterProc(unit, "UNPK", stUNPK);
EnterFunc(unit, "FLOOR", stFLOOR);
EnterFunc(unit, "FLT", stFLT)
EnterProc(unit, "pack", stPACK);
EnterProc(unit, "unpk", stUNPK);
EnterFunc(unit, "floor", stFLOOR);
EnterFunc(unit, "flt", stFLT)
END;
 
IF TARGETS.BitDepth >= 32 THEN
EnterFunc(unit, "WCHR", stWCHR)
EnterFunc(unit, "wchr", stWCHR)
END;
 
IF TARGETS.Dispose THEN
EnterProc(unit, "DISPOSE", stDISPOSE)
EnterProc(unit, "dispose", stDISPOSE)
END
 
END enterStProcs;
 
 
PROCEDURE newUnit* (program: PROGRAM; name: SCAN.IDENT): UNIT;
PROCEDURE newUnit* (name: SCAN.IDENT): UNIT;
VAR
unit: UNIT;
 
BEGIN
ASSERT(program # NIL);
ASSERT(name # NIL);
 
NEW(unit);
 
unit.program := program;
unit.name := name;
unit.closed := FALSE;
unit.idents := LISTS.create(NIL);
763,7 → 782,7
 
ASSERT(openScope(unit, NIL));
 
enterStTypes(unit, program);
enterStTypes(unit);
enterStProcs(unit);
 
ASSERT(openScope(unit, NIL));
785,7 → 804,7
END newUnit;
 
 
PROCEDURE getField* (self: TYPE_; name: SCAN.IDENT; unit: UNIT): FIELD;
PROCEDURE getField* (self: _TYPE; name: SCAN.IDENT; unit: UNIT): FIELD;
VAR
field: FIELD;
 
817,7 → 836,7
END getField;
 
 
PROCEDURE addField* (self: TYPE_; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN;
PROCEDURE addField* (self: _TYPE; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN;
VAR
field: FIELD;
res: BOOLEAN;
832,7 → 851,7
 
field.name := name;
field.export := export;
field.type := NIL;
field._type := NIL;
field.offset := self.size;
 
LISTS.push(self.fields, field)
842,33 → 861,33
END addField;
 
 
PROCEDURE setFields* (self: TYPE_; type: TYPE_): BOOLEAN;
PROCEDURE setFields* (self: _TYPE; _type: _TYPE): BOOLEAN;
VAR
item: FIELD;
res: BOOLEAN;
 
BEGIN
ASSERT(type # NIL);
ASSERT(_type # NIL);
 
item := self.fields.first(FIELD);
 
WHILE (item # NIL) & (item.type # NIL) DO
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;
WHILE res & (item # NIL) & (item._type = NIL) DO
item._type := _type;
IF ~self.noalign THEN
res := UTILS.Align(self.size, type.align)
res := UTILS.Align(self.size, _type.align)
ELSE
res := TRUE
END;
item.offset := self.size;
res := res & (UTILS.maxint - self.size >= type.size);
res := res & (UTILS.maxint - self.size >= _type.size);
IF res THEN
INC(self.size, type.size)
INC(self.size, _type.size)
END;
item := item.next(FIELD)
END
877,7 → 896,7
END setFields;
 
 
PROCEDURE getParam* (self: TYPE_; name: SCAN.IDENT): PARAM;
PROCEDURE getParam* (self: _TYPE; name: SCAN.IDENT): PARAM;
VAR
item: PARAM;
 
894,7 → 913,7
END getParam;
 
 
PROCEDURE addParam* (self: TYPE_; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN;
PROCEDURE addParam* (self: _TYPE; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN;
VAR
param: PARAM;
res: BOOLEAN;
908,7 → 927,7
NEW(param);
 
param.name := name;
param.type := NIL;
param._type := NIL;
param.vPar := vPar;
 
LISTS.push(self.params, param)
918,7 → 937,7
END addParam;
 
 
PROCEDURE Dim* (t: TYPE_): INTEGER;
PROCEDURE Dim* (t: _TYPE): INTEGER;
VAR
res: INTEGER;
 
932,7 → 951,7
END Dim;
 
 
PROCEDURE OpenBase* (t: TYPE_): TYPE_;
PROCEDURE OpenBase* (t: _TYPE): _TYPE;
BEGIN
WHILE isOpenArray(t) DO t := t.base END
RETURN t
939,7 → 958,7
END OpenBase;
 
 
PROCEDURE getFloatParamsPos* (self: TYPE_; maxoffs: INTEGER; VAR int, flt: INTEGER): SET;
PROCEDURE getFloatParamsPos* (self: _TYPE; maxoffs: INTEGER; VAR int, flt: INTEGER): SET;
VAR
res: SET;
param: PARAM;
950,7 → 969,7
flt := 0;
param := self.params.first(PARAM);
WHILE (param # NIL) & (param.offset <= maxoffs + STACK_FRAME) DO
IF ~param.vPar & (param.type.typ = tREAL) THEN
IF ~param.vPar & (param._type.typ = tREAL) THEN
INCL(res, param.offset - STACK_FRAME);
INC(flt)
END;
963,7 → 982,7
END getFloatParamsPos;
 
 
PROCEDURE setParams* (self: TYPE_; type: TYPE_);
PROCEDURE setParams* (self: _TYPE; _type: _TYPE);
VAR
item: LISTS.ITEM;
param: PARAM;
970,42 → 989,42
word, size: INTEGER;
 
BEGIN
ASSERT(type # NIL);
ASSERT(_type # NIL);
 
word := UTILS.target.bit_depth DIV 8;
 
item := self.params.first;
 
WHILE (item # NIL) & (item(PARAM).type # NIL) DO
WHILE (item # NIL) & (item(PARAM)._type # NIL) DO
item := item.next
END;
 
WHILE (item # NIL) & (item(PARAM).type = NIL) DO
WHILE (item # NIL) & (item(PARAM)._type = NIL) DO
param := item(PARAM);
param.type := type;
param._type := _type;
IF param.vPar THEN
IF type.typ = tRECORD THEN
IF _type.typ = tRECORD THEN
size := 2
ELSIF isOpenArray(type) THEN
size := Dim(type) + 1
ELSIF isOpenArray(_type) THEN
size := Dim(_type) + 1
ELSE
size := 1
END;
param.offset := self.parSize + ORD(type.typ = tRECORD) + Dim(type) + STACK_FRAME;
param.offset := self.parSize + ORD(_type.typ = tRECORD) + Dim(_type) + STACK_FRAME;
INC(self.parSize, size)
ELSE
IF type.typ IN {tRECORD, tARRAY} THEN
IF isOpenArray(type) THEN
size := Dim(type) + 1
IF _type.typ IN {tRECORD, tARRAY} THEN
IF isOpenArray(_type) THEN
size := Dim(_type) + 1
ELSE
size := 1
END
ELSE
size := type.size;
size := _type.size;
ASSERT(UTILS.Align(size, word));
size := size DIV word
END;
param.offset := self.parSize + Dim(type) + STACK_FRAME;
param.offset := self.parSize + Dim(_type) + STACK_FRAME;
INC(self.parSize, size)
END;
 
1015,9 → 1034,9
END setParams;
 
 
PROCEDURE enterType* (program: PROGRAM; typ, size, length: INTEGER; unit: UNIT): TYPE_;
PROCEDURE enterType* (typ, size, length: INTEGER; unit: UNIT): _TYPE;
VAR
t: TYPE_;
t: _TYPE;
 
BEGIN
NEW(t);
1038,7 → 1057,7
|64: t.call := default64
END;
 
t.import := FALSE;
t._import := FALSE;
t.noalign := FALSE;
t.parSize := 0;
 
1058,9 → 1077,9
END enterType;
 
 
PROCEDURE getType* (program: PROGRAM; typ: INTEGER): TYPE_;
PROCEDURE getType* (typ: INTEGER): _TYPE;
VAR
res: TYPE_;
res: _TYPE;
 
BEGIN
 
1078,7 → 1097,7
END getType;
 
 
PROCEDURE createSysUnit (program: PROGRAM);
PROCEDURE createSysUnit;
VAR
ident: IDENT;
unit: UNIT;
1087,50 → 1106,69
PROCEDURE EnterProc (sys: UNIT; name: SCAN.LEXSTR; idtyp, proc: INTEGER);
VAR
ident: IDENT;
upper: SCAN.LEXSTR;
 
BEGIN
IF LowerCase THEN
ident := addIdent(sys, SCAN.enterid(name), idtyp);
ident.stproc := proc;
ident._type := program.stTypes.tNONE;
ident.export := TRUE
END;
upper := name;
STRINGS.UpCase(upper);
ident := addIdent(sys, SCAN.enterid(upper), idtyp);
ident.stproc := proc;
ident._type := program.stTypes.tNONE;
ident.export := TRUE
END EnterProc;
 
 
BEGIN
unit := newUnit(program, SCAN.enterid("$SYSTEM"));
unit := newUnit(SCAN.enterid("$SYSTEM"));
 
EnterProc(unit, "ADR", idSYSFUNC, sysADR);
EnterProc(unit, "SIZE", idSYSFUNC, sysSIZE);
EnterProc(unit, "SADR", idSYSFUNC, sysSADR);
EnterProc(unit, "TYPEID", idSYSFUNC, sysTYPEID);
EnterProc(unit, "adr", idSYSFUNC, sysADR);
EnterProc(unit, "size", idSYSFUNC, sysSIZE);
EnterProc(unit, "sadr", idSYSFUNC, sysSADR);
EnterProc(unit, "typeid", idSYSFUNC, sysTYPEID);
 
EnterProc(unit, "GET", idSYSPROC, sysGET);
EnterProc(unit, "PUT8", idSYSPROC, sysPUT8);
EnterProc(unit, "PUT", idSYSPROC, sysPUT);
EnterProc(unit, "CODE", idSYSPROC, sysCODE);
EnterProc(unit, "MOVE", idSYSPROC, sysMOVE);
EnterProc(unit, "get", idSYSPROC, sysGET);
EnterProc(unit, "get8", idSYSPROC, sysGET8);
EnterProc(unit, "put", idSYSPROC, sysPUT);
EnterProc(unit, "put8", idSYSPROC, sysPUT8);
EnterProc(unit, "code", idSYSPROC, sysCODE);
EnterProc(unit, "move", idSYSPROC, sysMOVE);
(*
IF program.target.sys = mConst.Target_iMSP430 THEN
EnterProc(unit, "NOP", idSYSPROC, sysNOP);
EnterProc(unit, "EINT", idSYSPROC, sysEINT);
EnterProc(unit, "DINT", idSYSPROC, sysDINT)
EnterProc(unit, "nop", idSYSPROC, sysNOP);
EnterProc(unit, "eint", idSYSPROC, sysEINT);
EnterProc(unit, "dint", idSYSPROC, sysDINT)
END;
*)
IF TARGETS.RealSize # 0 THEN
EnterProc(unit, "INF", idSYSFUNC, sysINF);
EnterProc(unit, "inf", idSYSFUNC, sysINF);
END;
 
IF TARGETS.CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
EnterProc(unit, "COPY", idSYSPROC, sysCOPY)
EnterProc(unit, "copy", idSYSPROC, sysCOPY)
END;
 
IF TARGETS.BitDepth >= 32 THEN
EnterProc(unit, "WSADR", idSYSFUNC, sysWSADR);
EnterProc(unit, "PUT32", idSYSPROC, sysPUT32);
EnterProc(unit, "PUT16", idSYSPROC, sysPUT16);
EnterProc(unit, "wsadr", idSYSFUNC, sysWSADR);
EnterProc(unit, "put16", idSYSPROC, sysPUT16);
EnterProc(unit, "put32", idSYSPROC, sysPUT32);
EnterProc(unit, "get16", idSYSPROC, sysGET16);
EnterProc(unit, "get32", idSYSPROC, sysGET32);
 
ident := addIdent(unit, SCAN.enterid("CARD32"), idTYPE);
ident.type := program.stTypes.tCARD32;
IF LowerCase THEN
ident := addIdent(unit, SCAN.enterid("card32"), idTYPE);
ident._type := program.stTypes.tCARD32;
ident.export := TRUE
END;
ident := addIdent(unit, SCAN.enterid("CARD32"), idTYPE);
ident._type := program.stTypes.tCARD32;
ident.export := TRUE;
END;
 
closeUnit(unit);
 
1138,7 → 1176,7
END createSysUnit;
 
 
PROCEDURE DelUnused* (program: PROGRAM; DelImport: DELIMPORT);
PROCEDURE DelUnused* (DelImport: DELIMPORT);
VAR
proc: PROC;
flag: BOOLEAN;
1180,10 → 1218,10
 
WHILE proc # NIL DO
IF ~proc.used THEN
IF proc.import = NIL THEN
IF proc._import = NIL THEN
IL.delete2(proc.enter, proc.leave)
ELSE
DelImport(proc.import)
DelImport(proc._import)
END
END;
proc := proc.next(PROC)
1192,24 → 1230,28
END DelUnused;
 
 
PROCEDURE create* (options: OPTIONS): PROGRAM;
VAR
program: PROGRAM;
PROCEDURE ResetLocSize*;
BEGIN
program.locsize := 0
END ResetLocSize;
 
 
PROCEDURE create* (options: OPTIONS);
BEGIN
LowerCase := options.lower;
SCAN.init(options.lower);
idents := C.create();
 
UTILS.SetBitDepth(TARGETS.BitDepth, TARGETS.RealSize = 8);
NEW(program);
 
program.options := options;
 
CASE TARGETS.OS OF
|TARGETS.osWIN32: program.sysflags := {sf_windows, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|TARGETS.osLINUX32: program.sysflags := {sf_linux, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|TARGETS.osKOS: program.sysflags := {sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|TARGETS.osWIN64: program.sysflags := {sf_windows, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
|TARGETS.osLINUX64: program.sysflags := {sf_linux, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
|TARGETS.osWIN32: program.sysflags := {sf_oberon, sf_windows, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|TARGETS.osLINUX32: program.sysflags := {sf_oberon, sf_linux, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|TARGETS.osKOS: program.sysflags := {sf_oberon, sf_stdcall, sf_ccall, sf_ccall16, sf_noalign}
|TARGETS.osWIN64: program.sysflags := {sf_oberon, sf_windows, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
|TARGETS.osLINUX64: program.sysflags := {sf_oberon, sf_linux, sf_stdcall64, sf_win64, sf_systemv, sf_noalign}
|TARGETS.osNONE: program.sysflags := {sf_code}
END;
 
1220,11 → 1262,11
program.types := LISTS.create(NIL);
program.procs := LISTS.create(NIL);
 
program.stTypes.tINTEGER := enterType(program, tINTEGER, TARGETS.WordSize, 0, NIL);
program.stTypes.tBYTE := enterType(program, tBYTE, 1, 0, NIL);
program.stTypes.tCHAR := enterType(program, tCHAR, 1, 0, NIL);
program.stTypes.tSET := enterType(program, tSET, TARGETS.WordSize, 0, NIL);
program.stTypes.tBOOLEAN := enterType(program, tBOOLEAN, 1, 0, NIL);
program.stTypes.tINTEGER := enterType(tINTEGER, TARGETS.WordSize, 0, NIL);
program.stTypes.tBYTE := enterType(tBYTE, 1, 0, NIL);
program.stTypes.tCHAR := enterType(tCHAR, 1, 0, NIL);
program.stTypes.tSET := enterType(tSET, TARGETS.WordSize, 0, NIL);
program.stTypes.tBOOLEAN := enterType(tBOOLEAN, 1, 0, NIL);
 
program.stTypes.tINTEGER.align := TARGETS.WordSize;
program.stTypes.tBYTE.align := 1;
1233,26 → 1275,24
program.stTypes.tBOOLEAN.align := 1;
 
IF TARGETS.BitDepth >= 32 THEN
program.stTypes.tWCHAR := enterType(program, tWCHAR, 2, 0, NIL);
program.stTypes.tCARD32 := enterType(program, tCARD32, 4, 0, NIL);
program.stTypes.tWCHAR := enterType(tWCHAR, 2, 0, NIL);
program.stTypes.tCARD32 := enterType(tCARD32, 4, 0, NIL);
program.stTypes.tWCHAR.align := 2;
program.stTypes.tCARD32.align := 4
END;
 
IF TARGETS.RealSize # 0 THEN
program.stTypes.tREAL := enterType(program, tREAL, TARGETS.RealSize, 0, NIL);
program.stTypes.tREAL := enterType(tREAL, TARGETS.RealSize, 0, NIL);
program.stTypes.tREAL.align := TARGETS.RealSize
END;
 
program.stTypes.tSTRING := enterType(program, tSTRING, TARGETS.WordSize, 0, NIL);
program.stTypes.tNIL := enterType(program, tNIL, TARGETS.WordSize, 0, NIL);
 
program.stTypes.tANYREC := enterType(program, tRECORD, 0, 0, NIL);
program.stTypes.tSTRING := enterType(tSTRING, TARGETS.WordSize, 0, NIL);
program.stTypes.tNIL := enterType(tNIL, TARGETS.WordSize, 0, NIL);
program.stTypes.tNONE := enterType(tNONE, 0, 0, NIL);
program.stTypes.tANYREC := enterType(tRECORD, 0, 0, NIL);
program.stTypes.tANYREC.closed := TRUE;
 
createSysUnit(program)
 
RETURN program
createSysUnit
END create;