| 0,0 → 1,1271 |
|---|
| (* |
| BSD 2-Clause License |
| |
| Copyright (c) 2018-2021, Anton Krotov |
| All rights reserved. |
| *) |
| |
| MODULE PROG; |
| |
| IMPORT SCAN, LISTS, ARITH, ERRORS, C := COLLECTIONS, IL, UTILS, TARGETS, STRINGS, PATHS; |
| |
| |
| 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; |
| tCARD32* = 13; tANYREC* = 14; tWCHAR* = 15; tNONE* = 16; |
| |
| BASICTYPES* = {tINTEGER, tBYTE, tCHAR, tSET, tBOOLEAN, tREAL, 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; (*sysNOP* = 41; sysEINT* = 42; |
| sysDINT* = 43;*)sysGET8* = 44; sysGET16* = 45; sysGET32* = 46; |
| |
| default32* = 2; _default32* = default32 + 1; |
| stdcall* = 4; _stdcall* = stdcall + 1; |
| cdecl* = 6; _cdecl* = cdecl + 1; |
| ccall* = 8; _ccall* = ccall + 1; |
| win64* = 10; _win64* = win64 + 1; |
| default64* = 12; _default64* = default64 + 1; |
| systemv* = 14; _systemv* = systemv + 1; |
| default16* = 16; _default16* = default16 + 1; |
| code* = 18; _code* = code + 1; |
| |
| noalign* = 22; |
| |
| callee_clean_up* = {default32, _default32, stdcall, _stdcall, default64, _default64}; |
| |
| sf_stdcall* = 0; sf_oberon* = 1; sf_cdecl* = 2; sf_ccall* = 3; |
| sf_win64* = 4; sf_systemv* = 5; sf_windows* = 6; sf_linux* = 7; |
| sf_code* = 8; |
| sf_noalign* = 9; |
| |
| proc_flags* = {sf_stdcall, sf_cdecl, sf_ccall, sf_win64, sf_systemv, sf_windows, sf_linux, sf_code, sf_oberon}; |
| rec_flags* = {sf_noalign}; |
| |
| STACK_FRAME = 2; |
| |
| |
| TYPE |
| |
| OPTIONS* = RECORD |
| |
| version*, stack*, ram*, rom*: INTEGER; |
| pic*, lower*: BOOLEAN; |
| checking*: SET |
| |
| END; |
| |
| IDENT* = POINTER TO rIDENT; |
| |
| UNIT* = POINTER TO rUNIT; |
| |
| _TYPE* = POINTER TO rTYPE; |
| |
| FRWPTR* = POINTER TO RECORD (LISTS.ITEM) |
| |
| _type: _TYPE; |
| baseIdent: SCAN.IDENT; |
| linked: BOOLEAN; |
| |
| pos*: SCAN.POSITION; |
| notRecord*: BOOLEAN |
| |
| 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) |
| |
| fname*: PATHS.PATH; |
| name*: SCAN.IDENT; |
| idents*: LISTS.LIST; |
| frwPointers: LISTS.LIST; |
| gscope: IDENT; |
| closed*: BOOLEAN; |
| scopeLvl*: INTEGER; |
| sysimport*: BOOLEAN; |
| scopes*: ARRAY MAXSCOPE OF PROC |
| |
| END; |
| |
| FIELD* = POINTER TO rFIELD; |
| |
| PARAM* = POINTER TO rPARAM; |
| |
| rTYPE = RECORD (LISTS.ITEM) |
| |
| typ*: INTEGER; |
| size*: INTEGER; |
| parSize*: INTEGER; |
| length*: INTEGER; |
| align*: INTEGER; |
| base*: _TYPE; |
| fields*: LISTS.LIST; |
| params*: LISTS.LIST; |
| 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; |
| |
| PROGRAM = RECORD |
| |
| recCount: INTEGER; |
| units*: LISTS.LIST; |
| types*: LISTS.LIST; |
| sysunit*: UNIT; |
| rtl*: UNIT; |
| bss*: INTEGER; |
| locsize*: INTEGER; |
| |
| procs*: LISTS.LIST; |
| |
| sysflags*: SET; |
| options*: OPTIONS; |
| |
| stTypes*: RECORD |
| |
| tINTEGER*, tBYTE*, tCHAR*, tWCHAR*, tSET*, tBOOLEAN*, tREAL*, |
| tSTRING*, tNIL*, tCARD32*, tANYREC*, tNONE*: _TYPE |
| |
| END |
| |
| END; |
| |
| DELIMPORT = PROCEDURE (_import: LISTS.ITEM); |
| |
| |
| VAR |
| |
| LowerCase*: BOOLEAN; |
| idents: C.COLLECTION; |
| program*: PROGRAM; |
| |
| |
| 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* (varIdent: IDENT): INTEGER; |
| VAR |
| size: INTEGER; |
| |
| BEGIN |
| IF varIdent.offset = -1 THEN |
| size := varIdent._type.size; |
| IF varIdent.global 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) |
| END |
| END |
| ELSE |
| IF UTILS.Align(size, TARGETS.WordSize) THEN |
| size := size DIV TARGETS.WordSize; |
| IF UTILS.maxint - program.locsize >= size THEN |
| INC(program.locsize, size); |
| varIdent.offset := program.locsize |
| END |
| END |
| END; |
| |
| IF varIdent.offset = -1 THEN |
| ERRORS.Error(204) |
| END |
| END |
| |
| RETURN varIdent.offset |
| END getOffset; |
| |
| |
| PROCEDURE closeUnit* (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(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 closeUnit; |
| |
| |
| PROCEDURE IdEq* (a, b: SCAN.IDENT): BOOLEAN; |
| RETURN (a.hash = b.hash) & (a.s = b.s) |
| END IdEq; |
| |
| |
| PROCEDURE unique (unit: UNIT; ident: SCAN.IDENT): BOOLEAN; |
| VAR |
| item: IDENT; |
| |
| BEGIN |
| item := unit.idents.last(IDENT); |
| WHILE (item.typ # idGUARD) & ~IdEq(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; |
| |
| BEGIN |
| ASSERT(unit # 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); |
| LISTS.push(program.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 setVarsType* (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 setVarsType; |
| |
| |
| PROCEDURE getIdent* (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT; |
| VAR |
| item: IDENT; |
| |
| BEGIN |
| item := unit.idents.last(IDENT); |
| |
| IF item # NIL THEN |
| |
| IF currentScope THEN |
| WHILE (item.typ # idGUARD) & ~IdEq(item.name, ident) DO |
| item := item.prev(IDENT) |
| END; |
| IF item.typ = idGUARD THEN |
| item := NIL |
| END |
| ELSE |
| WHILE (item # NIL) & ~IdEq(item.name, ident) DO |
| item := item.prev(IDENT) |
| END |
| 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.s := ""; |
| item.name.hash := 0; |
| item.typ := idGUARD; |
| |
| LISTS.push(unit.idents, item) |
| END |
| |
| RETURN res |
| END openScope; |
| |
| |
| PROCEDURE closeScope* (unit: UNIT); |
| VAR |
| item: IDENT; |
| del: IDENT; |
| |
| 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; |
| 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); |
| |
| 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 := getIdent(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) 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); |
| 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 = t1.typ) & (t0.typ IN {tPOINTER, tRECORD}); |
| |
| IF res & (t0.typ = tPOINTER) THEN |
| t0 := t0.base; |
| t1 := t1.base |
| END; |
| |
| IF res THEN |
| WHILE (t1 # NIL) & (t1 # t0) DO |
| t1 := t1.base |
| END; |
| res := t1 # NIL |
| END |
| |
| RETURN res |
| END isBaseOf; |
| |
| |
| PROCEDURE isOpenArray* (t: _TYPE): BOOLEAN; |
| RETURN (t.typ = tARRAY) & (t.length = 0) |
| END isOpenArray; |
| |
| |
| PROCEDURE arrcomp* (src, dst: _TYPE): BOOLEAN; |
| RETURN (dst.typ = tARRAY) & isOpenArray(src) & |
| ~isOpenArray(src.base) & ~isOpenArray(dst.base) & |
| isTypeEq(src.base, dst.base) |
| END arrcomp; |
| |
| |
| PROCEDURE getUnit* (name: PATHS.PATH): UNIT; |
| VAR |
| item: UNIT; |
| |
| BEGIN |
| item := program.units.first(UNIT); |
| |
| WHILE (item # NIL) & (item.fname # name) DO |
| item := item.next(UNIT) |
| END; |
| |
| IF (item = NIL) & ((name = "SYSTEM") OR LowerCase & (name = "system")) THEN |
| item := program.sysunit |
| END |
| |
| RETURN item |
| END getUnit; |
| |
| |
| PROCEDURE enterStTypes (unit: UNIT); |
| |
| |
| PROCEDURE enter (unit: UNIT; nameStr: SCAN.IDSTR; _type: _TYPE); |
| VAR |
| ident: IDENT; |
| upper: SCAN.IDSTR; |
| name: SCAN.IDENT; |
| |
| BEGIN |
| IF LowerCase THEN |
| SCAN.setIdent(name, nameStr); |
| ident := addIdent(unit, name, idTYPE); |
| ident._type := _type |
| END; |
| upper := nameStr; |
| STRINGS.UpCase(upper); |
| SCAN.setIdent(name, upper); |
| ident := addIdent(unit, name, idTYPE); |
| ident._type := _type |
| END enter; |
| |
| |
| 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); |
| |
| IF TARGETS.RealSize # 0 THEN |
| enter(unit, "real", program.stTypes.tREAL) |
| END; |
| |
| IF TARGETS.BitDepth >= 32 THEN |
| enter(unit, "wchar", program.stTypes.tWCHAR) |
| END |
| END enterStTypes; |
| |
| |
| PROCEDURE enterStProcs (unit: UNIT); |
| |
| |
| PROCEDURE Enter (unit: UNIT; nameStr: SCAN.IDSTR; nfunc, tfunc: INTEGER); |
| VAR |
| ident: IDENT; |
| upper: SCAN.IDSTR; |
| name: SCAN.IDENT; |
| |
| BEGIN |
| IF LowerCase THEN |
| SCAN.setIdent(name, nameStr); |
| ident := addIdent(unit, name, tfunc); |
| ident.stproc := nfunc; |
| ident._type := program.stTypes.tNONE |
| END; |
| upper := nameStr; |
| STRINGS.UpCase(upper); |
| SCAN.setIdent(name, upper); |
| ident := addIdent(unit, name, tfunc); |
| ident.stproc := nfunc; |
| ident._type := program.stTypes.tNONE |
| END Enter; |
| |
| |
| BEGIN |
| Enter(unit, "assert", stASSERT, idSTPROC); |
| Enter(unit, "dec", stDEC, idSTPROC); |
| Enter(unit, "excl", stEXCL, idSTPROC); |
| Enter(unit, "inc", stINC, idSTPROC); |
| Enter(unit, "incl", stINCL, idSTPROC); |
| Enter(unit, "new", stNEW, idSTPROC); |
| Enter(unit, "copy", stCOPY, idSTPROC); |
| |
| Enter(unit, "abs", stABS, idSTFUNC); |
| Enter(unit, "asr", stASR, idSTFUNC); |
| Enter(unit, "chr", stCHR, idSTFUNC); |
| Enter(unit, "len", stLEN, idSTFUNC); |
| Enter(unit, "lsl", stLSL, idSTFUNC); |
| Enter(unit, "odd", stODD, idSTFUNC); |
| Enter(unit, "ord", stORD, idSTFUNC); |
| Enter(unit, "ror", stROR, idSTFUNC); |
| Enter(unit, "bits", stBITS, idSTFUNC); |
| Enter(unit, "lsr", stLSR, idSTFUNC); |
| Enter(unit, "length", stLENGTH, idSTFUNC); |
| Enter(unit, "min", stMIN, idSTFUNC); |
| Enter(unit, "max", stMAX, idSTFUNC); |
| |
| IF TARGETS.RealSize # 0 THEN |
| Enter(unit, "pack", stPACK, idSTPROC); |
| Enter(unit, "unpk", stUNPK, idSTPROC); |
| Enter(unit, "floor", stFLOOR, idSTFUNC); |
| Enter(unit, "flt", stFLT, idSTFUNC) |
| END; |
| |
| IF TARGETS.BitDepth >= 32 THEN |
| Enter(unit, "wchr", stWCHR, idSTFUNC) |
| END; |
| |
| IF TARGETS.Dispose THEN |
| Enter(unit, "dispose", stDISPOSE, idSTPROC) |
| END |
| |
| END enterStProcs; |
| |
| |
| PROCEDURE newUnit* (name: SCAN.IDENT): UNIT; |
| VAR |
| unit: UNIT; |
| |
| BEGIN |
| NEW(unit); |
| |
| unit.name := name; |
| unit.closed := FALSE; |
| unit.idents := LISTS.create(NIL); |
| unit.frwPointers := LISTS.create(NIL); |
| |
| ASSERT(openScope(unit, NIL)); |
| |
| enterStTypes(unit); |
| enterStProcs(unit); |
| |
| ASSERT(openScope(unit, NIL)); |
| |
| unit.gscope := unit.idents.last(IDENT); |
| |
| LISTS.push(program.units, unit); |
| |
| unit.scopeLvl := 0; |
| unit.scopes[0] := NIL; |
| |
| unit.sysimport := FALSE; |
| |
| IF unit.name.s = UTILS.RTL_NAME THEN |
| 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(unit # NIL); |
| |
| field := NIL; |
| WHILE (self # NIL) & (field = NIL) DO |
| |
| field := self.fields.first(FIELD); |
| |
| WHILE (field # NIL) & ~IdEq(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 |
| 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 := UTILS.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 |
| item := self.params.first(PARAM); |
| |
| WHILE (item # NIL) & ~IdEq(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 |
| res := getParam(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.parSize - 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 := UTILS.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.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 |
| ELSE |
| size := 1 |
| END |
| ELSE |
| size := _type.size; |
| ASSERT(UTILS.Align(size, word)); |
| size := size DIV word |
| END; |
| param.offset := self.parSize + Dim(_type) + STACK_FRAME; |
| INC(self.parSize, size) |
| END; |
| |
| item := item.next |
| END |
| |
| END setParams; |
| |
| |
| PROCEDURE enterType* (typ, size, length: INTEGER; unit: UNIT): _TYPE; |
| VAR |
| t: _TYPE; |
| |
| BEGIN |
| NEW(t); |
| |
| t.typ := typ; |
| t.size := size; |
| t.length := length; |
| t.align := 0; |
| t.base := NIL; |
| t.fields := LISTS.create(NIL); |
| t.params := LISTS.create(NIL); |
| t.unit := unit; |
| t.num := 0; |
| |
| CASE TARGETS.BitDepth OF |
| |16: t.call := default16 |
| |32: t.call := default32 |
| |64: t.call := default64 |
| END; |
| |
| t._import := FALSE; |
| t.noalign := FALSE; |
| t.parSize := 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* (typ: INTEGER): _TYPE; |
| VAR |
| res: _TYPE; |
| |
| BEGIN |
| |
| CASE typ OF |
| |ARITH.tINTEGER: res := program.stTypes.tINTEGER |
| |ARITH.tREAL: res := program.stTypes.tREAL |
| |ARITH.tSET: res := program.stTypes.tSET |
| |ARITH.tBOOLEAN: res := program.stTypes.tBOOLEAN |
| |ARITH.tCHAR: res := program.stTypes.tCHAR |
| |ARITH.tWCHAR: res := program.stTypes.tWCHAR |
| |ARITH.tSTRING: res := program.stTypes.tSTRING |
| END |
| |
| RETURN res |
| END getType; |
| |
| |
| PROCEDURE createSysUnit; |
| VAR |
| ident: IDENT; |
| unit: UNIT; |
| name: SCAN.IDENT; |
| |
| |
| PROCEDURE EnterProc (sys: UNIT; nameStr: SCAN.IDSTR; idtyp, proc: INTEGER); |
| VAR |
| ident: IDENT; |
| upper: SCAN.IDSTR; |
| name: SCAN.IDENT; |
| |
| BEGIN |
| IF LowerCase THEN |
| SCAN.setIdent(name, nameStr); |
| ident := addIdent(sys, name, idtyp); |
| ident.stproc := proc; |
| ident._type := program.stTypes.tNONE; |
| ident.export := TRUE |
| END; |
| upper := nameStr; |
| STRINGS.UpCase(upper); |
| SCAN.setIdent(name, upper); |
| ident := addIdent(sys, name, idtyp); |
| ident.stproc := proc; |
| ident._type := program.stTypes.tNONE; |
| ident.export := TRUE |
| END EnterProc; |
| |
| |
| BEGIN |
| SCAN.setIdent(name, "$SYSTEM"); |
| unit := newUnit(name); |
| unit.fname := "SYSTEM"; |
| |
| 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, "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) |
| END; |
| *) |
| IF TARGETS.RealSize # 0 THEN |
| EnterProc(unit, "inf", idSYSFUNC, sysINF); |
| END; |
| |
| IF TARGETS.CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN |
| EnterProc(unit, "copy", idSYSPROC, sysCOPY) |
| END; |
| |
| IF TARGETS.BitDepth >= 32 THEN |
| 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); |
| |
| IF LowerCase THEN |
| SCAN.setIdent(name, "card32"); |
| ident := addIdent(unit, name, idTYPE); |
| ident._type := program.stTypes.tCARD32; |
| ident.export := TRUE |
| END; |
| SCAN.setIdent(name, "CARD32"); |
| ident := addIdent(unit, name, idTYPE); |
| ident._type := program.stTypes.tCARD32; |
| ident.export := TRUE; |
| END; |
| |
| closeUnit(unit); |
| |
| program.sysunit := unit |
| END createSysUnit; |
| |
| |
| PROCEDURE DelUnused* (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 |
| IL.delete2(proc.enter, proc.leave) |
| ELSE |
| DelImport(proc._import) |
| END |
| END; |
| proc := proc.next(PROC) |
| END |
| |
| END DelUnused; |
| |
| |
| 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); |
| |
| program.options := options; |
| |
| CASE TARGETS.OS OF |
| |TARGETS.osWIN32: program.sysflags := {sf_oberon, sf_windows, sf_stdcall, sf_cdecl, sf_ccall, sf_noalign} |
| |TARGETS.osLINUX32: program.sysflags := {sf_oberon, sf_linux, sf_stdcall, sf_cdecl, sf_ccall, sf_noalign} |
| |TARGETS.osKOS: program.sysflags := {sf_oberon, sf_stdcall, sf_cdecl, sf_ccall, sf_noalign} |
| |TARGETS.osWIN64: program.sysflags := {sf_oberon, sf_windows, sf_win64, sf_systemv, sf_ccall, sf_noalign} |
| |TARGETS.osLINUX64: program.sysflags := {sf_oberon, sf_linux, sf_win64, sf_systemv, sf_ccall, sf_noalign} |
| |TARGETS.osNONE: program.sysflags := {sf_code} |
| END; |
| |
| program.recCount := -1; |
| program.bss := 0; |
| |
| program.units := LISTS.create(NIL); |
| program.types := LISTS.create(NIL); |
| program.procs := LISTS.create(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; |
| program.stTypes.tCHAR.align := 1; |
| program.stTypes.tSET.align := TARGETS.WordSize; |
| program.stTypes.tBOOLEAN.align := 1; |
| |
| IF TARGETS.BitDepth >= 32 THEN |
| 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(tREAL, TARGETS.RealSize, 0, NIL); |
| program.stTypes.tREAL.align := TARGETS.RealSize |
| END; |
| |
| 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 |
| END create; |
| |
| |
| END PROG. |