WebSVN – Kolibri OS – Diff – /programs/develop/oberon07/source/PROG.ob07

 (*
     BSD 2-Clause License
-    Copyright (c) 2018-2020, Anton Krotov
+    Copyright (c) 2018-2021, Anton Krotov
     All rights reserved.
 *)
 MODULE PROG;
     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;
-    ccall*     =  6;  _ccall*     = ccall + 1;
+    cdecl*     =  6;  _cdecl*     = cdecl + 1;
-    ccall16*   =  8;  _ccall16*   = ccall16 + 1;
+    ccall*     =  8;  _ccall*     = ccall + 1;
-    win64*     = 10;  _win64*     = win64 + 1;
-    stdcall64* = 12;  _stdcall64* = stdcall64 + 1;
+    win64*     = 10;  _win64*     = win64 + 1;
-    default64* = 14;  _default64* = default64 + 1;
+    default64* = 12;  _default64* = default64 + 1;
-    systemv*   = 16;  _systemv*   = systemv + 1;
+    systemv*   = 14;  _systemv*   = systemv + 1;
-    default16* = 18;
+    default16* = 16;  _default16* = default16 + 1;
-    code*      = 20;  _code*      = code + 1;
+    code*      = 18;  _code*      = code + 1;
     noalign* = 22;
-    callee_clean_up* = {default32, stdcall, _stdcall, default64, stdcall64, _stdcall64};
+    callee_clean_up* = {default32, _default32, stdcall, _stdcall, default64, _default64};
-    sf_stdcall* =  0; sf_stdcall64* = 1; sf_ccall*   = 2; sf_ccall16* = 3;
+    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_win64*   =  4; sf_systemv*   = 5; sf_windows* = 6; sf_linux*  = 7;
-    sf_code*    =  8; sf_oberon*    = 9;
+    sf_code*    =  8;
     END;
     rUNIT = RECORD (LISTS.ITEM)
     rUNIT = RECORD (LISTS.ITEM)
         fname*:      PATHS.PATH;
         name*:       SCAN.IDENT;
         idents*:     LISTS.LIST;
     DELIMPORT = PROCEDURE (_import: LISTS.ITEM);
 VAR
-    LowerCase: BOOLEAN;
+    LowerCase*: BOOLEAN;
     unit.closed := TRUE
+END closeUnit;
+PROCEDURE IdEq* (a, b: SCAN.IDENT): BOOLEAN;
+    RETURN (a.hash = b.hash) & (a.s = b.s)
-END closeUnit;
+END IdEq;
 PROCEDURE unique (unit: UNIT; ident: SCAN.IDENT): BOOLEAN;
-VAR
-    item: IDENT;
 VAR
-BEGIN
+    item: IDENT;
     ASSERT(ident # NIL);
 BEGIN
     item := unit.idents.last(IDENT);
-    WHILE (item.typ # idGUARD) & (item.name # ident) DO
+    WHILE (item.typ # idGUARD) & ~IdEq(item.name, ident) DO
     res:   BOOLEAN;
     proc:  PROC;
 BEGIN
-    ASSERT(unit # NIL);
-    ASSERT(ident # NIL);
+    ASSERT(unit # NIL);
     res := unique(unit, ident);
 PROCEDURE getIdent* (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT;
 VAR
     item: IDENT;
-BEGIN
-    ASSERT(ident # NIL);
 BEGIN
     item := unit.idents.last(IDENT);
     IF item # NIL THEN
         IF currentScope THEN
-            WHILE (item.name # ident) & (item.typ # idGUARD) DO
+            WHILE (item.typ # idGUARD) & ~IdEq(item.name, ident) DO
                 item := item.prev(IDENT)
             END;
-            IF item.name # ident THEN
+            IF item.typ = idGUARD THEN
                 item := NIL
             END
         ELSE
-            WHILE (item # NIL) & (item.name # ident) DO
+            WHILE (item # NIL) & ~IdEq(item.name, ident) DO
                 item := item.prev(IDENT)
         unit.scopes[unit.scopeLvl] := proc;
         NEW(item);
         item := NewIdent();
         item.name.s := "";
-        item.name := NIL;
+        item.name.hash := 0;
         item.typ  := idGUARD;
         LISTS.push(unit.idents, item)
     END
     RETURN res
 END openScope;
 PROCEDURE closeScope* (unit: UNIT; variables: LISTS.LIST);
-VAR
+PROCEDURE closeScope* (unit: UNIT);
-    item: IDENT;
+VAR
-    del:  IDENT;
+    item: IDENT;
-    lvar: IL.LOCALVAR;
+    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;
-        IF (variables # NIL) & (del.typ IN {idVAR, idPARAM}) & (del.offset # -1) THEN
-            IF del._type.typ IN BASICTYPES - {tREAL} + {tPOINTER, tPROCEDURE} THEN
-                lvar := IL.NewVar();
-                lvar.offset := del.offset;
+    item := unit.idents.last(IDENT);
                 lvar.size   := del._type.size;
-                IF del.typ = idVAR THEN
+    WHILE (item # NIL) & (item.typ # idGUARD) DO
-                    lvar.offset := -lvar.offset
+        del  := item;
     newptr: FRWPTR;
 BEGIN
     ASSERT(unit # NIL);
-    ASSERT(_type # NIL);
-    ASSERT(baseIdent # NIL);
+    ASSERT(_type # NIL);
     NEW(newptr);
             ~isOpenArray(src.base) & ~isOpenArray(dst.base) &
             isTypeEq(src.base, dst.base)
 END arrcomp;
-PROCEDURE getUnit* (name: SCAN.IDENT): UNIT;
+PROCEDURE getUnit* (name: PATHS.PATH): UNIT;
 VAR
-    item: UNIT;
-BEGIN
+    item: UNIT;
-    ASSERT(name # NIL);
 BEGIN
     item := program.units.first(UNIT);
-    WHILE (item # NIL) & (item.name # name) DO
+    WHILE (item # NIL) & (item.fname # name) DO
         item := item.next(UNIT)
     END;
-    IF (item = NIL) & ((name.s = "SYSTEM") OR LowerCase & (name.s = "system")) THEN
+    IF (item = NIL) & ((name = "SYSTEM") OR LowerCase & (name = "system")) THEN
         item := program.sysunit
     END
     RETURN item
+END getUnit;
 END getUnit;
+PROCEDURE enterStTypes (unit: UNIT);
 PROCEDURE enterStTypes (unit: UNIT);
     PROCEDURE enter (unit: UNIT; nameStr: SCAN.IDSTR; _type: _TYPE);
+    VAR
-    PROCEDURE enter (unit: UNIT; name: SCAN.LEXSTR; _type: _TYPE);
+        ident: IDENT;
+        upper: SCAN.IDSTR;
-    VAR
+        name:  SCAN.IDENT;
         ident: IDENT;
-        upper: SCAN.LEXSTR;
+    BEGIN
         IF LowerCase THEN
-PROCEDURE enterStProcs (unit: UNIT);
-    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._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;
+PROCEDURE enterStProcs (unit: UNIT);
+    PROCEDURE Enter (unit: UNIT; nameStr: SCAN.IDSTR; nfunc, tfunc: INTEGER);
-    PROCEDURE EnterFunc (unit: UNIT; name: SCAN.LEXSTR; func: INTEGER);
+    VAR
-    VAR
+        ident: IDENT;
+        upper: SCAN.IDSTR;
-        ident: IDENT;
+        name:  SCAN.IDENT;
-        upper: SCAN.LEXSTR;
     BEGIN
-    BEGIN
+        IF LowerCase THEN
-        IF LowerCase THEN
+            SCAN.setIdent(name, nameStr);
-            ident := addIdent(unit, SCAN.enterid(name), idSTFUNC);
+            ident := addIdent(unit, name, tfunc);
+            ident.stproc := nfunc;
-            ident.stproc := func;
+            ident._type := program.stTypes.tNONE
-            ident._type := program.stTypes.tNONE
+        END;
-        END;
+        upper := nameStr;
-        upper := name;
+        STRINGS.UpCase(upper);
-        STRINGS.UpCase(upper);
+        SCAN.setIdent(name, upper);
-        ident := addIdent(unit, SCAN.enterid(upper), idSTFUNC);
+        ident := addIdent(unit, name, tfunc);
-        ident.stproc := func;
+        ident.stproc := nfunc;
         ident._type := program.stTypes.tNONE
-    END EnterFunc;
+    END Enter;
 BEGIN
-    EnterProc(unit, "assert", stASSERT);
+    Enter(unit, "assert", stASSERT, idSTPROC);
-    EnterProc(unit, "dec",    stDEC);
+    Enter(unit, "dec",    stDEC,    idSTPROC);
-    EnterProc(unit, "excl",   stEXCL);
+    Enter(unit, "excl",   stEXCL,   idSTPROC);
-    EnterProc(unit, "inc",    stINC);
+    Enter(unit, "inc",    stINC,    idSTPROC);
-    EnterProc(unit, "incl",   stINCL);
+    Enter(unit, "incl",   stINCL,   idSTPROC);
-    EnterProc(unit, "new",    stNEW);
+    Enter(unit, "new",    stNEW,    idSTPROC);
-    EnterProc(unit, "copy",   stCOPY);
+    Enter(unit, "copy",   stCOPY,   idSTPROC);
-    EnterFunc(unit, "abs",    stABS);
+    Enter(unit, "abs",    stABS,    idSTFUNC);
-    EnterFunc(unit, "asr",    stASR);
+    Enter(unit, "asr",    stASR,    idSTFUNC);
-    EnterFunc(unit, "chr",    stCHR);
+    Enter(unit, "chr",    stCHR,    idSTFUNC);
-    EnterFunc(unit, "len",    stLEN);
+    Enter(unit, "len",    stLEN,    idSTFUNC);
-    EnterFunc(unit, "lsl",    stLSL);
+    Enter(unit, "lsl",    stLSL,    idSTFUNC);
-    EnterFunc(unit, "odd",    stODD);
+    Enter(unit, "odd",    stODD,    idSTFUNC);
-    EnterFunc(unit, "ord",    stORD);
+    Enter(unit, "ord",    stORD,    idSTFUNC);
-    EnterFunc(unit, "ror",    stROR);
+    Enter(unit, "ror",    stROR,    idSTFUNC);
-    EnterFunc(unit, "bits",   stBITS);
+    Enter(unit, "bits",   stBITS,   idSTFUNC);
-    EnterFunc(unit, "lsr",    stLSR);
+    Enter(unit, "lsr",    stLSR,    idSTFUNC);
-    EnterFunc(unit, "length", stLENGTH);
+    Enter(unit, "length", stLENGTH, idSTFUNC);
-    EnterFunc(unit, "min",    stMIN);
+    Enter(unit, "min",    stMIN,    idSTFUNC);
-    EnterFunc(unit, "max",    stMAX);
+    Enter(unit, "max",    stMAX,    idSTFUNC);
     IF TARGETS.RealSize # 0 THEN
-        EnterProc(unit, "pack",  stPACK);
+        Enter(unit, "pack",  stPACK,  idSTPROC);
-        EnterProc(unit, "unpk",  stUNPK);
+        Enter(unit, "unpk",  stUNPK,  idSTPROC);
-        EnterFunc(unit, "floor", stFLOOR);
+        Enter(unit, "floor", stFLOOR, idSTFUNC);
-        EnterFunc(unit, "flt",   stFLT)
+        Enter(unit, "flt",   stFLT,   idSTFUNC)
     END;
     IF TARGETS.BitDepth >= 32 THEN
-        EnterFunc(unit, "wchr", stWCHR)
+        Enter(unit, "wchr", stWCHR, idSTFUNC)
-    END;
-    IF TARGETS.Dispose THEN
+    END;
         EnterProc(unit, "dispose", stDISPOSE)
-    END
+    IF TARGETS.Dispose THEN
         Enter(unit, "dispose", stDISPOSE, idSTPROC)
 VAR
     field: FIELD;
 BEGIN
-    ASSERT(self # NIL);
-    ASSERT(name # NIL);
+    ASSERT(self # NIL);
     ASSERT(unit # NIL);
     field := NIL;
     WHILE (self # NIL) & (field = NIL) DO
         field := self.fields.first(FIELD);
-        WHILE (field # NIL) & (field.name # name) DO
+        WHILE (field # NIL) & ~IdEq(field.name, name) DO
 VAR
     field: FIELD;
     res:   BOOLEAN;
-BEGIN
-    ASSERT(name # NIL);
 BEGIN
     res := getField(self, name, self.unit) = NIL;
 PROCEDURE getParam* (self: _TYPE; name: SCAN.IDENT): PARAM;
 VAR
     item: PARAM;
-BEGIN
-    ASSERT(name # NIL);
 BEGIN
     item := self.params.first(PARAM);
-    WHILE (item # NIL) & (item.name # name) DO
+    WHILE (item # NIL) & ~IdEq(item.name, name) DO
         item := item.next(PARAM)
     END
 VAR
     param: PARAM;
     res:   BOOLEAN;
-BEGIN
-    ASSERT(name # NIL);
 BEGIN
     res := getParam(self, name) = NIL;
 PROCEDURE createSysUnit;
 VAR
     ident: IDENT;
+    unit:  UNIT;
-    unit:  UNIT;
+    name:  SCAN.IDENT;
-    PROCEDURE EnterProc (sys: UNIT; name: SCAN.LEXSTR; idtyp, proc: INTEGER);
+    PROCEDURE EnterProc (sys: UNIT; nameStr: SCAN.IDSTR; idtyp, proc: INTEGER);
+    VAR
-    VAR
+        ident: IDENT;
-        ident: IDENT;
+        upper: SCAN.IDSTR;
+        name:  SCAN.IDENT;
-        upper: SCAN.LEXSTR;
     BEGIN
-    BEGIN
+        IF LowerCase THEN
-        IF LowerCase THEN
+            SCAN.setIdent(name, nameStr);
-            ident := addIdent(sys, SCAN.enterid(name), idtyp);
+            ident := addIdent(sys, name, idtyp);
             ident.stproc := proc;
             ident._type := program.stTypes.tNONE;
+            ident.export := TRUE
-            ident.export := TRUE
+        END;
-        END;
+        upper := nameStr;
-        upper := name;
+        STRINGS.UpCase(upper);
-        STRINGS.UpCase(upper);
+        SCAN.setIdent(name, upper);
-        ident := addIdent(sys, SCAN.enterid(upper), idtyp);
+        ident := addIdent(sys, name, idtyp);
         ident.stproc := proc;
+        ident._type := program.stTypes.tNONE;
-        ident._type := program.stTypes.tNONE;
+        ident.export := TRUE
+    END EnterProc;
         ident.export := TRUE
     END EnterProc;
 BEGIN
     SCAN.setIdent(name, "$SYSTEM");
         EnterProc(unit, "put32",  idSYSPROC, sysPUT32);
         EnterProc(unit, "get16",  idSYSPROC, sysGET16);
         EnterProc(unit, "get32",  idSYSPROC, sysGET32);
+        IF LowerCase THEN
-        IF LowerCase THEN
+            SCAN.setIdent(name, "card32");
-            ident := addIdent(unit, SCAN.enterid("card32"), idTYPE);
+            ident := addIdent(unit, name, idTYPE);
             ident._type := program.stTypes.tCARD32;
             ident.export := TRUE
+        END;
-        END;
+        SCAN.setIdent(name, "CARD32");
-        ident := addIdent(unit, SCAN.enterid("CARD32"), idTYPE);
+        ident := addIdent(unit, name, idTYPE);
         ident._type := program.stTypes.tCARD32;
         ident.export := TRUE;
     END;
     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_ccall, sf_ccall16, sf_noalign}
+    |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_ccall, sf_ccall16, 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_ccall, sf_ccall16, 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_stdcall64, sf_win64, sf_systemv, 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_stdcall64, sf_win64, sf_systemv, 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;

Subversion Repositories Kolibri OS

(root)/programs/develop/oberon07/source/PROG.ob07 – Rev 8097 → 8859