diff --git a/bootstrap/unix-44/Configuration.c b/bootstrap/unix-44/Configuration.c index 1f5afbb7..821dff97 100644 --- a/bootstrap/unix-44/Configuration.c +++ b/bootstrap/unix-44/Configuration.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" @@ -13,6 +13,6 @@ export void *Configuration__init(void) __DEFMOD; __REGMOD("Configuration", 0); /* BEGIN */ - __MOVE("1.95 [2016/08/24] for gcc LP64 on cygwin", Configuration_versionLong, 41); + __MOVE("1.95 [2016/08/23] for gcc LP64 on cygwin", Configuration_versionLong, 41); __ENDMOD; } diff --git a/bootstrap/unix-44/Configuration.h b/bootstrap/unix-44/Configuration.h index eef3a15d..ec5e865a 100644 --- a/bootstrap/unix-44/Configuration.h +++ b/bootstrap/unix-44/Configuration.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Configuration__h #define Configuration__h diff --git a/bootstrap/unix-44/Console.c b/bootstrap/unix-44/Console.c index 5fa65e00..f9161937 100644 --- a/bootstrap/unix-44/Console.c +++ b/bootstrap/unix-44/Console.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Platform.h" @@ -21,7 +21,7 @@ export void Console_String (CHAR *s, LONGINT s__len); void Console_Flush (void) { INTEGER error; - error = Platform_Write(((LONGINT)(1)), (LONGINT)(uintptr_t)Console_line, Console_pos); + error = Platform_Write(((LONGINT)(1)), (LONGINT)(SYSTEM_ADDRESS)Console_line, Console_pos); Console_pos = 0; } diff --git a/bootstrap/unix-44/Console.h b/bootstrap/unix-44/Console.h index 53dbdfa8..5fdd4e4d 100644 --- a/bootstrap/unix-44/Console.h +++ b/bootstrap/unix-44/Console.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Console__h #define Console__h diff --git a/bootstrap/unix-44/Files.c b/bootstrap/unix-44/Files.c index 5d92e963..5a1dd875 100644 --- a/bootstrap/unix-44/Files.c +++ b/bootstrap/unix-44/Files.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #include "SYSTEM.h" #include "Configuration.h" #include "Console.h" @@ -257,7 +257,7 @@ static void Files_Flush (Files_Buffer buf) if (buf->org != f->pos) { error = Platform_Seek(f->fd, buf->org, Platform_SeekSet); } - error = Platform_Write(f->fd, (LONGINT)(uintptr_t)buf->data, buf->size); + error = Platform_Write(f->fd, (LONGINT)(SYSTEM_ADDRESS)buf->data, buf->size); if (error != 0) { Files_Err((CHAR*)"error writing file", (LONGINT)19, f, error); } @@ -656,7 +656,7 @@ void Files_ReadBytes (Files_Rider *r, LONGINT *r__typ, SYSTEM_BYTE *x, LONGINT x } else { min = n; } - __MOVE((LONGINT)(uintptr_t)buf->data + offset, (LONGINT)(uintptr_t)x + xpos, min); + __MOVE((LONGINT)(SYSTEM_ADDRESS)buf->data + offset, (LONGINT)(SYSTEM_ADDRESS)x + xpos, min); offset += min; (*r).offset = offset; xpos += min; @@ -721,7 +721,7 @@ void Files_WriteBytes (Files_Rider *r, LONGINT *r__typ, SYSTEM_BYTE *x, LONGINT } else { min = n; } - __MOVE((LONGINT)(uintptr_t)x + xpos, (LONGINT)(uintptr_t)buf->data + offset, min); + __MOVE((LONGINT)(SYSTEM_ADDRESS)x + xpos, (LONGINT)(SYSTEM_ADDRESS)buf->data + offset, min); offset += min; (*r).offset = offset; if (offset > buf->size) { @@ -772,15 +772,15 @@ void Files_Rename (CHAR *old, LONGINT old__len, CHAR *new, LONGINT new__len, INT *res = 3; return; } - error = Platform_Read(fdold, (LONGINT)(uintptr_t)buf, ((LONGINT)(4096)), &n); + error = Platform_Read(fdold, (LONGINT)(SYSTEM_ADDRESS)buf, ((LONGINT)(4096)), &n); while (n > 0) { - error = Platform_Write(fdnew, (LONGINT)(uintptr_t)buf, n); + error = Platform_Write(fdnew, (LONGINT)(SYSTEM_ADDRESS)buf, n); if (error != 0) { ignore = Platform_Close(fdold); ignore = Platform_Close(fdnew); Files_Err((CHAR*)"cannot move file", (LONGINT)17, NIL, error); } - error = Platform_Read(fdold, (LONGINT)(uintptr_t)buf, ((LONGINT)(4096)), &n); + error = Platform_Read(fdold, (LONGINT)(SYSTEM_ADDRESS)buf, ((LONGINT)(4096)), &n); } ignore = Platform_Close(fdold); ignore = Platform_Close(fdnew); @@ -838,7 +838,7 @@ static void Files_FlipBytes (SYSTEM_BYTE *src, LONGINT src__len, SYSTEM_BYTE *de j += 1; } } else { - __MOVE((LONGINT)(uintptr_t)src, (LONGINT)(uintptr_t)dest, src__len); + __MOVE((LONGINT)(SYSTEM_ADDRESS)src, (LONGINT)(SYSTEM_ADDRESS)dest, src__len); } } @@ -858,14 +858,16 @@ void Files_ReadLInt (Files_Rider *R, LONGINT *R__typ, LONGINT *x) { CHAR b[4]; Files_ReadBytes(&*R, R__typ, (void*)b, ((LONGINT)(4)), ((LONGINT)(4))); - *x = ((LONGINT)((int)b[0] + __ASHL((int)b[1], 8)) + __ASHL((LONGINT)b[2], 16)) + __ASHL((LONGINT)b[3], 24); + *x = ((int)((int)b[0] + __ASHL((int)b[1], 8)) + __ASHL((int)b[2], 16)) + __ASHL((int)b[3], 24); } void Files_ReadSet (Files_Rider *R, LONGINT *R__typ, SET *x) { CHAR b[4]; + LONGINT l; Files_ReadBytes(&*R, R__typ, (void*)b, ((LONGINT)(4)), ((LONGINT)(4))); - *x = (SET)(((LONGINT)((int)b[0] + __ASHL((int)b[1], 8)) + __ASHL((LONGINT)b[2], 16)) + __ASHL((LONGINT)b[3], 24)); + l = ((int)((int)b[0] + __ASHL((int)b[1], 8)) + __ASHL((int)b[2], 16)) + __ASHL((int)b[3], 24); + *x = (SET)l; } void Files_ReadReal (Files_Rider *R, LONGINT *R__typ, REAL *x) @@ -921,11 +923,11 @@ void Files_ReadNum (Files_Rider *R, LONGINT *R__typ, LONGINT *x) n = 0; Files_Read(&*R, R__typ, (void*)&ch); while ((int)ch >= 128) { - n += __ASH((LONGINT)((int)ch - 128), s); + n += __ASH((int)((int)ch - 128), s); s += 7; Files_Read(&*R, R__typ, (void*)&ch); } - n += __ASH((LONGINT)(__MASK((int)ch, -64) - __ASHL(__ASHR((int)ch, 6), 6)), s); + n += __ASH((int)(__MASK((int)ch, -64) - __ASHL(__ASHR((int)ch, 6), 6)), s); *x = n; } @@ -1006,7 +1008,7 @@ static void Files_Finalize (SYSTEM_PTR o) { Files_File f = NIL; LONGINT res; - f = (Files_File)(uintptr_t)o; + f = (Files_File)(SYSTEM_ADDRESS)o; if (f->fd >= 0) { Files_CloseOSFile(f); if (f->tempFile) { diff --git a/bootstrap/unix-44/Files.h b/bootstrap/unix-44/Files.h index b60e6242..a4a4ea8c 100644 --- a/bootstrap/unix-44/Files.h +++ b/bootstrap/unix-44/Files.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #ifndef Files__h #define Files__h diff --git a/bootstrap/unix-44/Heap.c b/bootstrap/unix-44/Heap.c index 4cabf8c6..30ec687a 100644 --- a/bootstrap/unix-44/Heap.c +++ b/bootstrap/unix-44/Heap.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tskSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tskSfF */ #include "SYSTEM.h" struct Heap__1 { @@ -101,7 +101,7 @@ export void Heap_Unlock (void); extern void *Heap__init(); extern LONGINT Platform_MainStackFrame; extern LONGINT Platform_OSAllocate(LONGINT size); -#define Heap_FetchAddress(pointer) (LONGINT)(uintptr_t)(*((void**)((uintptr_t)pointer))) +#define Heap_FetchAddress(pointer) (LONGINT)(SYSTEM_ADDRESS)(*((void**)((SYSTEM_ADDRESS)pointer))) #define Heap_HeapModuleInit() Heap__init() #define Heap_OSAllocate(size) Platform_OSAllocate(size) #define Heap_PlatformHalt(code) Platform_Halt(code) @@ -134,7 +134,7 @@ SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs) __COPY(name, m->name, ((LONGINT)(20))); m->refcnt = 0; m->enumPtrs = enumPtrs; - m->next = (Heap_Module)(uintptr_t)Heap_modules; + m->next = (Heap_Module)(SYSTEM_ADDRESS)Heap_modules; Heap_modules = (SYSTEM_PTR)m; _o_result = (void*)m; return _o_result; @@ -315,7 +315,7 @@ SYSTEM_PTR Heap_NEWREC (LONGINT tag) __PUT(adr + 8, 0, LONGINT); Heap_allocated += blksz; Heap_Unlock(); - _o_result = (SYSTEM_PTR)(uintptr_t)(adr + 4); + _o_result = (SYSTEM_PTR)(SYSTEM_ADDRESS)(adr + 4); return _o_result; } @@ -326,12 +326,12 @@ SYSTEM_PTR Heap_NEWBLK (LONGINT size) SYSTEM_PTR new; Heap_Lock(); blksz = __ASHL(__ASHR(size + 31, 4), 4); - new = Heap_NEWREC((LONGINT)(uintptr_t)&blksz); - tag = ((LONGINT)(uintptr_t)new + blksz) - 12; + new = Heap_NEWREC((LONGINT)(SYSTEM_ADDRESS)&blksz); + tag = ((LONGINT)(SYSTEM_ADDRESS)new + blksz) - 12; __PUT(tag - 4, 0, LONGINT); __PUT(tag, blksz, LONGINT); __PUT(tag + 4, -4, LONGINT); - __PUT((LONGINT)(uintptr_t)new - 4, tag, LONGINT); + __PUT((LONGINT)(SYSTEM_ADDRESS)new - 4, tag, LONGINT); Heap_Unlock(); _o_result = new; return _o_result; @@ -360,7 +360,7 @@ static void Heap_Mark (LONGINT q) __GET(tag, offset, LONGINT); fld = q + offset; p = Heap_FetchAddress(fld); - __PUT(fld, (SYSTEM_PTR)(uintptr_t)n, SYSTEM_PTR); + __PUT(fld, (SYSTEM_PTR)(SYSTEM_ADDRESS)n, SYSTEM_PTR); } else { fld = q + offset; n = Heap_FetchAddress(fld); @@ -369,7 +369,7 @@ static void Heap_Mark (LONGINT q) if (!__ODD(tagbits)) { __PUT(n - 4, tagbits + 1, LONGINT); __PUT(q - 4, tag + 1, LONGINT); - __PUT(fld, (SYSTEM_PTR)(uintptr_t)p, SYSTEM_PTR); + __PUT(fld, (SYSTEM_PTR)(SYSTEM_ADDRESS)p, SYSTEM_PTR); p = q; q = n; tag = tagbits; @@ -384,7 +384,7 @@ static void Heap_Mark (LONGINT q) static void Heap_MarkP (SYSTEM_PTR p) { - Heap_Mark((LONGINT)(uintptr_t)p); + Heap_Mark((LONGINT)(SYSTEM_ADDRESS)p); } static void Heap_Scan (void) @@ -553,7 +553,7 @@ static void Heap_Finalize (void) } else { prev->next = n->next; } - (*n->finalize)((SYSTEM_PTR)(uintptr_t)n->obj); + (*n->finalize)((SYSTEM_PTR)(SYSTEM_ADDRESS)n->obj); if (prev == NIL) { n = Heap_fin; } else { @@ -572,7 +572,7 @@ void Heap_FINALL (void) while (Heap_fin != NIL) { n = Heap_fin; Heap_fin = Heap_fin->next; - (*n->finalize)((SYSTEM_PTR)(uintptr_t)n->obj); + (*n->finalize)((SYSTEM_PTR)(SYSTEM_ADDRESS)n->obj); } } @@ -589,9 +589,9 @@ static void Heap_MarkStack (LONGINT n, LONGINT *cand, LONGINT cand__len) } if (n == 0) { nofcand = 0; - sp = (LONGINT)(uintptr_t)&frame; + sp = (LONGINT)(SYSTEM_ADDRESS)&frame; stack0 = Heap_PlatformMainStackFrame(); - inc = (LONGINT)(uintptr_t)&align.p - (LONGINT)(uintptr_t)&align; + inc = (LONGINT)(SYSTEM_ADDRESS)&align.p - (LONGINT)(SYSTEM_ADDRESS)&align; if (sp > stack0) { inc = -inc; } @@ -622,7 +622,7 @@ void Heap_GC (BOOLEAN markStack) LONGINT cand[10000]; if (Heap_lockdepth == 0 || (Heap_lockdepth == 1 && !markStack)) { Heap_Lock(); - m = (Heap_Module)(uintptr_t)Heap_modules; + m = (Heap_Module)(SYSTEM_ADDRESS)Heap_modules; while (m != NIL) { if (m->enumPtrs != NIL) { (*m->enumPtrs)(Heap_MarkP); @@ -699,7 +699,7 @@ void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize) { Heap_FinNode f; __NEW(f, Heap_FinDesc); - f->obj = (LONGINT)(uintptr_t)obj; + f->obj = (LONGINT)(SYSTEM_ADDRESS)obj; f->finalize = finalize; f->marked = 1; f->next = Heap_fin; diff --git a/bootstrap/unix-44/Heap.h b/bootstrap/unix-44/Heap.h index 38e549be..a2cab30c 100644 --- a/bootstrap/unix-44/Heap.h +++ b/bootstrap/unix-44/Heap.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tskSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tskSfF */ #ifndef Heap__h #define Heap__h diff --git a/bootstrap/unix-44/Modules.c b/bootstrap/unix-44/Modules.c index d5164a2a..330b7506 100644 --- a/bootstrap/unix-44/Modules.c +++ b/bootstrap/unix-44/Modules.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Console.h" #include "Heap.h" diff --git a/bootstrap/unix-44/Modules.h b/bootstrap/unix-44/Modules.h index 5e27b653..ac8ac89e 100644 --- a/bootstrap/unix-44/Modules.h +++ b/bootstrap/unix-44/Modules.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Modules__h #define Modules__h diff --git a/bootstrap/unix-44/OPB.c b/bootstrap/unix-44/OPB.c index d834a9e8..0f614e6a 100644 --- a/bootstrap/unix-44/OPB.c +++ b/bootstrap/unix-44/OPB.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "OPM.h" #include "OPS.h" @@ -34,7 +34,9 @@ export void OPB_In (OPT_Node *x, OPT_Node y); export void OPB_Index (OPT_Node *x, OPT_Node y); export void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ); static BOOLEAN OPB_IntToBool (LONGINT i); +static OPT_Struct OPB_IntType (LONGINT size); export void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y); +static LONGINT OPB_LongerSize (LONGINT i); export void OPB_MOp (SHORTINT op, OPT_Node *x); export OPT_Node OPB_NewBoolConst (BOOLEAN boolval); export OPT_Node OPB_NewIntConst (LONGINT intval); @@ -51,6 +53,8 @@ export void OPB_Return (OPT_Node *x, OPT_Object proc); export void OPB_SetElem (OPT_Node *x); static void OPB_SetIntType (OPT_Node node); export void OPB_SetRange (OPT_Node *x, OPT_Node y); +static LONGINT OPB_ShorterSize (LONGINT i); +static INTEGER OPB_SignedByteSize (LONGINT n); export void OPB_StFct (OPT_Node *par0, SHORTINT fctno, INTEGER parno); export void OPB_StPar0 (OPT_Node *par0, INTEGER fctno); export void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno); @@ -90,8 +94,8 @@ OPT_Node OPB_NewLeaf (OPT_Object obj) node = OPT_NewNode(9); break; default: - OPB_err(127); node = OPT_NewNode(0); + OPB_err(127); break; } node->obj = obj; @@ -220,21 +224,68 @@ OPT_Node OPB_EmptySet (void) return _o_result; } +static INTEGER OPB_SignedByteSize (LONGINT n) +{ + INTEGER _o_result; + INTEGER b; + if (n < 0) { + n = -(n + 1); + } + b = 1; + while ((b < 8 && __ASH(n, -(__ASHL(b, 3) - 1)) != 0)) { + b += 1; + } + _o_result = b; + return _o_result; +} + +static LONGINT OPB_ShorterSize (LONGINT i) +{ + LONGINT _o_result; + if (i >= (int)OPM_LIntSize) { + _o_result = OPM_IntSize; + return _o_result; + } else { + _o_result = OPM_SIntSize; + return _o_result; + } + __RETCHK; +} + +static LONGINT OPB_LongerSize (LONGINT i) +{ + LONGINT _o_result; + if (i <= (int)OPM_SIntSize) { + _o_result = OPM_IntSize; + return _o_result; + } else { + _o_result = OPM_LIntSize; + return _o_result; + } + __RETCHK; +} + +static OPT_Struct OPB_IntType (LONGINT size) +{ + OPT_Struct _o_result; + OPT_Struct result = NIL; + if (size <= OPT_sinttyp->size) { + result = OPT_sinttyp; + } else if (size <= OPT_inttyp->size) { + result = OPT_inttyp; + } else { + result = OPT_linttyp; + } + if (size > OPT_linttyp->size) { + OPB_err(203); + } + _o_result = result; + return _o_result; +} + static void OPB_SetIntType (OPT_Node node) { - LONGINT v; - v = node->conval->intval; - if ((OPM_MinSInt <= (LONGINT)v && (LONGINT)v <= OPM_MaxSInt)) { - node->typ = OPT_sinttyp; - } else if ((OPM_MinInt <= (LONGINT)v && (LONGINT)v <= OPM_MaxInt)) { - node->typ = OPT_inttyp; - } else if ((OPM_MinLInt <= v && v <= OPM_MaxLInt)) { - node->typ = OPT_linttyp; - } else { - OPB_err(203); - node->typ = OPT_sinttyp; - node->conval->intval = 1; - } + node->typ = OPB_IntType(OPB_SignedByteSize(node->conval->intval)); } OPT_Node OPB_NewIntConst (LONGINT intval) @@ -378,16 +429,16 @@ void OPB_Field (OPT_Node *x, OPT_Object y) } } -static struct TypTest__57 { +static struct TypTest__61 { OPT_Node *x; OPT_Object *obj; BOOLEAN *guard; - struct TypTest__57 *lnk; -} *TypTest__57_s; + struct TypTest__61 *lnk; +} *TypTest__61_s; -static void GTT__58 (OPT_Struct t0, OPT_Struct t1); +static void GTT__62 (OPT_Struct t0, OPT_Struct t1); -static void GTT__58 (OPT_Struct t0, OPT_Struct t1) +static void GTT__62 (OPT_Struct t0, OPT_Struct t1) { OPT_Node node = NIL; OPT_Struct t = NIL; @@ -400,54 +451,54 @@ static void GTT__58 (OPT_Struct t0, OPT_Struct t1) t1 = t1->BaseTyp; } if (t1 == t0 || t0->form == 0) { - if (*TypTest__57_s->guard) { - OPB_BindNodes(5, NIL, &*TypTest__57_s->x, NIL); - (*TypTest__57_s->x)->readonly = (*TypTest__57_s->x)->left->readonly; + if (*TypTest__61_s->guard) { + OPB_BindNodes(5, NIL, &*TypTest__61_s->x, NIL); + (*TypTest__61_s->x)->readonly = (*TypTest__61_s->x)->left->readonly; } else { node = OPT_NewNode(11); node->subcl = 16; - node->left = *TypTest__57_s->x; - node->obj = *TypTest__57_s->obj; - *TypTest__57_s->x = node; + node->left = *TypTest__61_s->x; + node->obj = *TypTest__61_s->obj; + *TypTest__61_s->x = node; } } else { OPB_err(85); } } else if (t0 != t1) { OPB_err(85); - } else if (!*TypTest__57_s->guard) { - if ((*TypTest__57_s->x)->class == 5) { + } else if (!*TypTest__61_s->guard) { + if ((*TypTest__61_s->x)->class == 5) { node = OPT_NewNode(11); node->subcl = 16; - node->left = *TypTest__57_s->x; - node->obj = *TypTest__57_s->obj; - *TypTest__57_s->x = node; + node->left = *TypTest__61_s->x; + node->obj = *TypTest__61_s->obj; + *TypTest__61_s->x = node; } else { - *TypTest__57_s->x = OPB_NewBoolConst(1); + *TypTest__61_s->x = OPB_NewBoolConst(1); } } } void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard) { - struct TypTest__57 _s; + struct TypTest__61 _s; _s.x = x; _s.obj = &obj; _s.guard = &guard; - _s.lnk = TypTest__57_s; - TypTest__57_s = &_s; + _s.lnk = TypTest__61_s; + TypTest__61_s = &_s; if (OPB_NotVar(*x)) { OPB_err(112); } else if ((*x)->typ->form == 13) { if (((*x)->typ->BaseTyp->comp != 4 && (*x)->typ != OPT_sysptrtyp)) { OPB_err(85); } else if (obj->typ->form == 13) { - GTT__58((*x)->typ->BaseTyp, obj->typ->BaseTyp); + GTT__62((*x)->typ->BaseTyp, obj->typ->BaseTyp); } else { OPB_err(86); } } else if (((((*x)->typ->comp == 4 && (*x)->class == 1)) && obj->typ->comp == 4)) { - GTT__58((*x)->typ, obj->typ); + GTT__62((*x)->typ, obj->typ); } else { OPB_err(87); } @@ -456,7 +507,7 @@ void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard) } else { (*x)->typ = OPT_booltyp; } - TypTest__57_s = _s.lnk; + TypTest__61_s = _s.lnk; } void OPB_In (OPT_Node *x, OPT_Node y) @@ -469,7 +520,7 @@ void OPB_In (OPT_Node *x, OPT_Node y) } else if ((__IN(f, 0x70) && y->typ->form == 9)) { if ((*x)->class == 7) { k = (*x)->conval->intval; - if (k < 0 || k > (LONGINT)OPM_MaxSet) { + if (k < 0 || k > (int)OPM_MaxSet) { OPB_err(202); } else if (y->class == 7) { (*x)->conval->intval = OPB_BoolToInt(__IN(k, y->conval->setval)); @@ -522,13 +573,13 @@ static void OPB_CheckRealType (INTEGER f, INTEGER nr, OPT_Const x) x->intval = -1; } -static struct MOp__28 { - struct MOp__28 *lnk; -} *MOp__28_s; +static struct MOp__30 { + struct MOp__30 *lnk; +} *MOp__30_s; -static OPT_Node NewOp__29 (SHORTINT op, OPT_Struct typ, OPT_Node z); +static OPT_Node NewOp__31 (SHORTINT op, OPT_Struct typ, OPT_Node z); -static OPT_Node NewOp__29 (SHORTINT op, OPT_Struct typ, OPT_Node z) +static OPT_Node NewOp__31 (SHORTINT op, OPT_Struct typ, OPT_Node z) { OPT_Node _o_result; OPT_Node node = NIL; @@ -545,9 +596,9 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) INTEGER f; OPT_Struct typ = NIL; OPT_Node z = NIL; - struct MOp__28 _s; - _s.lnk = MOp__28_s; - MOp__28_s = &_s; + struct MOp__30 _s; + _s.lnk = MOp__30_s; + MOp__30_s = &_s; z = *x; if (z->class == 8 || z->class == 9) { OPB_err(126); @@ -561,7 +612,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) z->conval->intval = OPB_BoolToInt(!OPB_IntToBool(z->conval->intval)); z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(98); @@ -589,7 +640,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) } z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(97); @@ -610,7 +661,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) } z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(111); @@ -622,7 +673,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) z->conval->intval = (int)__CAP((CHAR)z->conval->intval); z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(111); @@ -635,7 +686,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) z->conval->intval = OPB_BoolToInt(__ODD(z->conval->intval)); z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(111); @@ -648,7 +699,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) f = 10; } if (z->class < 7 || f == 10) { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } else { OPB_err(127); } @@ -657,7 +708,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) case 25: if ((__IN(f, 0x70) && z->class == 7)) { if ((0 <= z->conval->intval && z->conval->intval <= -1)) { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } else { OPB_err(219); } @@ -674,7 +725,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) } } *x = z; - MOp__28_s = _s.lnk; + MOp__30_s = _s.lnk; } static void OPB_CheckPtr (OPT_Node x, OPT_Node y) @@ -865,41 +916,13 @@ static void OPB_ConstOp (INTEGER op, OPT_Node x, OPT_Node y) __GUARDEQP(yval, OPT_ConstDesc) = *xval; } break; - case 4: + case 4: case 5: case 6: if (__IN(g, 0x70)) { - x->typ = y->typ; - } else if (g == 7) { - x->typ = OPT_realtyp; - xval->realval = xval->intval; - } else if (g == 8) { - x->typ = OPT_lrltyp; - xval->realval = xval->intval; - } else { - OPB_err(100); - y->typ = x->typ; - __GUARDEQP(yval, OPT_ConstDesc) = *xval; - } - break; - case 5: - if (g == 4) { - y->typ = OPT_inttyp; - } else if (__IN(g, 0x70)) { - x->typ = y->typ; - } else if (g == 7) { - x->typ = OPT_realtyp; - xval->realval = xval->intval; - } else if (g == 8) { - x->typ = OPT_lrltyp; - xval->realval = xval->intval; - } else { - OPB_err(100); - y->typ = x->typ; - __GUARDEQP(yval, OPT_ConstDesc) = *xval; - } - break; - case 6: - if (__IN(g, 0x70)) { - y->typ = OPT_linttyp; + if (x->typ->size <= y->typ->size) { + x->typ = y->typ; + } else { + x->typ = OPB_IntType(x->typ->size); + } } else if (g == 7) { x->typ = OPT_realtyp; xval->realval = xval->intval; @@ -1178,7 +1201,7 @@ static void OPB_Convert (OPT_Node *x, OPT_Struct typ) OPB_err(203); r = (LONGREAL)1; } - (*x)->conval->intval = __ENTIER(r); + (*x)->conval->intval = (int)__ENTIER(r); OPB_SetIntType(*x); } } @@ -1196,15 +1219,15 @@ static void OPB_Convert (OPT_Node *x, OPT_Struct typ) (*x)->typ = typ; } -static struct Op__38 { +static struct Op__40 { INTEGER *f, *g; - struct Op__38 *lnk; -} *Op__38_s; + struct Op__40 *lnk; +} *Op__40_s; -static void NewOp__39 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y); -static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y); +static void NewOp__41 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y); +static BOOLEAN strings__43 (OPT_Node *x, OPT_Node *y); -static void NewOp__39 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y) +static void NewOp__41 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y) { OPT_Node node = NIL; node = OPT_NewNode(12); @@ -1215,29 +1238,29 @@ static void NewOp__39 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y) *x = node; } -static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y) +static BOOLEAN strings__43 (OPT_Node *x, OPT_Node *y) { BOOLEAN _o_result; BOOLEAN ok, xCharArr, yCharArr; - xCharArr = (__IN((*x)->typ->comp, 0x0c) && (*x)->typ->BaseTyp->form == 3) || *Op__38_s->f == 10; - yCharArr = (__IN((*y)->typ->comp, 0x0c) && (*y)->typ->BaseTyp->form == 3) || *Op__38_s->g == 10; - if ((((xCharArr && *Op__38_s->g == 3)) && (*y)->class == 7)) { + xCharArr = (__IN((*x)->typ->comp, 0x0c) && (*x)->typ->BaseTyp->form == 3) || *Op__40_s->f == 10; + yCharArr = (__IN((*y)->typ->comp, 0x0c) && (*y)->typ->BaseTyp->form == 3) || *Op__40_s->g == 10; + if ((((xCharArr && *Op__40_s->g == 3)) && (*y)->class == 7)) { OPB_CharToString(*y); - *Op__38_s->g = 10; + *Op__40_s->g = 10; yCharArr = 1; } - if ((((yCharArr && *Op__38_s->f == 3)) && (*x)->class == 7)) { + if ((((yCharArr && *Op__40_s->f == 3)) && (*x)->class == 7)) { OPB_CharToString(*x); - *Op__38_s->f = 10; + *Op__40_s->f = 10; xCharArr = 1; } ok = (xCharArr && yCharArr); if (ok) { - if ((*Op__38_s->f == 10 && (*x)->conval->intval2 == 1)) { + if ((*Op__40_s->f == 10 && (*x)->conval->intval2 == 1)) { (*x)->typ = OPT_chartyp; (*x)->conval->intval = 0; OPB_Index(&*y, OPB_NewIntConst(((LONGINT)(0)))); - } else if ((*Op__38_s->g == 10 && (*y)->conval->intval2 == 1)) { + } else if ((*Op__40_s->g == 10 && (*y)->conval->intval2 == 1)) { (*y)->typ = OPT_chartyp; (*y)->conval->intval = 0; OPB_Index(&*x, OPB_NewIntConst(((LONGINT)(0)))); @@ -1254,11 +1277,11 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPT_Struct typ = NIL; BOOLEAN do_; LONGINT val; - struct Op__38 _s; + struct Op__40 _s; _s.f = &f; _s.g = &g; - _s.lnk = Op__38_s; - Op__38_s = &_s; + _s.lnk = Op__40_s; + Op__40_s = &_s; z = *x; if (((z->class == 8 || z->class == 9) || y->class == 8) || y->class == 9) { OPB_err(126); @@ -1276,15 +1299,8 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(100); } break; - case 4: - if (__IN(g, 0x01f0)) { - OPB_Convert(&z, y->typ); - } else { - OPB_err(100); - } - break; - case 5: - if (g == 4) { + case 4: case 5: case 6: + if ((__IN(g, 0x70) && y->typ->size < z->typ->size)) { OPB_Convert(&y, z->typ); } else if (__IN(g, 0x01f0)) { OPB_Convert(&z, y->typ); @@ -1292,15 +1308,6 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(100); } break; - case 6: - if (__IN(g, 0x70)) { - OPB_Convert(&y, z->typ); - } else if (__IN(g, 0x0180)) { - OPB_Convert(&z, y->typ); - } else { - OPB_err(100); - } - break; case 7: if (__IN(g, 0x70)) { OPB_Convert(&y, z->typ); @@ -1386,7 +1393,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) typ = OPT_undftyp; } if (do_) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 2: @@ -1405,7 +1412,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(102); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; case 3: do_ = 1; @@ -1428,7 +1435,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) typ = OPT_undftyp; } if (do_) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 4: @@ -1446,7 +1453,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(104); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; case 5: if (f == 2) { @@ -1456,7 +1463,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } else if ((y->class == 7 && OPB_IntToBool(y->conval->intval))) { } else { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } } else if (f != 0) { OPB_err(94); @@ -1479,7 +1486,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } if (do_) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 7: @@ -1488,7 +1495,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) typ = OPT_undftyp; } if ((!__IN(f, 0x70) || y->class != 7) || y->conval->intval != 0) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 8: @@ -1499,7 +1506,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } else if ((y->class == 7 && !OPB_IntToBool(y->conval->intval))) { } else { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } } else if (f != 0) { OPB_err(95); @@ -1507,16 +1514,16 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } break; case 9: case 10: - if (__IN(f, 0x6bff) || strings__41(&z, &y)) { + if (__IN(f, 0x6bff) || strings__43(&z, &y)) { typ = OPT_booltyp; } else { OPB_err(107); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; case 11: case 12: case 13: case 14: - if (__IN(f, 0x01f9) || strings__41(&z, &y)) { + if (__IN(f, 0x01f9) || strings__43(&z, &y)) { typ = OPT_booltyp; } else { OPM_LogWLn(); @@ -1525,7 +1532,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(108); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; default: OPM_LogWStr((CHAR*)"unhandled case in OPB.Op, op = ", (LONGINT)32); @@ -1535,7 +1542,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } *x = z; - Op__38_s = _s.lnk; + Op__40_s = _s.lnk; } void OPB_SetRange (OPT_Node *x, OPT_Node y) @@ -1546,13 +1553,13 @@ void OPB_SetRange (OPT_Node *x, OPT_Node y) } else if ((__IN((*x)->typ->form, 0x70) && __IN(y->typ->form, 0x70))) { if ((*x)->class == 7) { k = (*x)->conval->intval; - if (0 > k || k > (LONGINT)OPM_MaxSet) { + if (0 > k || k > (int)OPM_MaxSet) { OPB_err(202); } } if (y->class == 7) { l = y->conval->intval; - if (0 > l || l > (LONGINT)OPM_MaxSet) { + if (0 > l || l > (int)OPM_MaxSet) { OPB_err(202); } } @@ -1582,7 +1589,7 @@ void OPB_SetElem (OPT_Node *x) OPB_err(93); } else if ((*x)->class == 7) { k = (*x)->conval->intval; - if ((0 <= k && k <= (LONGINT)OPM_MaxSet)) { + if ((0 <= k && k <= (int)OPM_MaxSet)) { (*x)->conval->setval = __SETOF(k); } else { OPB_err(202); @@ -1596,8 +1603,9 @@ void OPB_SetElem (OPT_Node *x) static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) { + OPT_Struct y = NIL; INTEGER f, g; - OPT_Struct y = NIL, p = NIL, q = NIL; + OPT_Struct p = NIL, q = NIL; if (OPM_Verbose) { OPM_LogWLn(); OPM_LogWStr((CHAR*)"PROCEDURE CheckAssign", (LONGINT)22); @@ -1627,31 +1635,20 @@ static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) case 0: case 10: break; case 1: - if (!__IN(g, 0x1a)) { + if (!((__IN(g, 0x7a) && y->size == 1))) { OPB_err(113); } break; - case 2: case 3: case 4: case 9: + case 2: case 3: case 9: if (g != f) { OPB_err(113); } break; - case 5: - if (!__IN(g, 0x30)) { + case 4: case 5: case 6: + if (!__IN(g, 0x70) || x->size < y->size) { OPB_err(113); } break; - case 6: - if (OPM_LIntSize == 4) { - if (!__IN(g, 0x70)) { - OPB_err(113); - } - } else { - if (!__IN(g, 0x70)) { - OPB_err(113); - } - } - break; case 7: if (!__IN(g, 0xf0)) { OPB_err(113); @@ -1832,14 +1829,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) x = OPB_NewIntConst(((LONGINT)(0))); x->typ = OPT_chartyp; break; - case 4: - x = OPB_NewIntConst(OPM_MinSInt); - break; - case 5: - x = OPB_NewIntConst(OPM_MinInt); - break; - case 6: - x = OPB_NewIntConst(OPM_MinLInt); + case 4: case 5: case 6: + x = OPB_NewIntConst(OPM_SignedMinimum(x->typ->size)); break; case 9: x = OPB_NewIntConst(((LONGINT)(0))); @@ -1869,14 +1860,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) x = OPB_NewIntConst(((LONGINT)(255))); x->typ = OPT_chartyp; break; - case 4: - x = OPB_NewIntConst(OPM_MaxSInt); - break; - case 5: - x = OPB_NewIntConst(OPM_MaxInt); - break; - case 6: - x = OPB_NewIntConst(OPM_MaxLInt); + case 4: case 5: case 6: + x = OPB_NewIntConst(OPM_SignedMaximum(x->typ->size)); break; case 9: x = OPB_NewIntConst(OPM_MaxSet); @@ -1909,10 +1894,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) case 10: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if (f == 5) { - OPB_Convert(&x, OPT_sinttyp); - } else if (f == 6) { - OPB_Convert(&x, OPT_inttyp); + } else if ((__IN(f, 0x70) && x->typ->size > (int)OPM_SIntSize)) { + OPB_Convert(&x, OPB_IntType(OPB_ShorterSize(x->typ->size))); } else if (f == 8) { OPB_Convert(&x, OPT_realtyp); } else { @@ -1922,10 +1905,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) case 11: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if (f == 4) { - OPB_Convert(&x, OPT_inttyp); - } else if (f == 5) { - OPB_Convert(&x, OPT_linttyp); + } else if ((__IN(f, 0x70) && x->typ->size < (int)OPM_LIntSize)) { + OPB_Convert(&x, OPB_IntType(OPB_LongerSize(x->typ->size))); } else if (f == 7) { OPB_Convert(&x, OPT_lrltyp); } else if (f == 3) { @@ -1973,7 +1954,7 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - if (f != 6) { + if (x->typ->size != (int)OPM_LIntSize) { OPB_Convert(&x, OPT_linttyp); } } else { @@ -2011,9 +1992,9 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) case 24: case 25: case 28: case 31: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if ((x->class == 7 && __IN(f, 0x30))) { + } else if ((((x->class == 7 && __IN(f, 0x70))) && x->typ->size < OPT_linttyp->size)) { OPB_Convert(&x, OPT_linttyp); - } else if (!__IN(f, 0x2040)) { + } else if (!((__IN(x->typ->form, 0x2070) && x->typ->size == (int)OPM_PointerSize))) { OPB_err(111); x->typ = OPT_linttyp; } @@ -2062,13 +2043,13 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) *par0 = x; } -static struct StPar1__52 { - struct StPar1__52 *lnk; -} *StPar1__52_s; +static struct StPar1__56 { + struct StPar1__56 *lnk; +} *StPar1__56_s; -static OPT_Node NewOp__53 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right); +static OPT_Node NewOp__57 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right); -static OPT_Node NewOp__53 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right) +static OPT_Node NewOp__57 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right) { OPT_Node _o_result; OPT_Node node = NIL; @@ -2085,9 +2066,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) INTEGER f, L; OPT_Struct typ = NIL; OPT_Node p = NIL, t = NIL; - struct StPar1__52 _s; - _s.lnk = StPar1__52_s; - StPar1__52_s = &_s; + struct StPar1__56 _s; + _s.lnk = StPar1__56_s; + StPar1__56_s = &_s; p = *par0; f = x->typ->form; switch (fctno) { @@ -2103,7 +2084,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) OPB_err(111); } } - p = NewOp__53(19, fctno, p, x); + p = NewOp__57(19, fctno, p, x); p->typ = OPT_notyp; } break; @@ -2111,10 +2092,10 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - if ((x->class == 7 && (0 > x->conval->intval || x->conval->intval > (LONGINT)OPM_MaxSet))) { + if ((x->class == 7 && (0 > x->conval->intval || x->conval->intval > (int)OPM_MaxSet))) { OPB_err(202); } - p = NewOp__53(19, fctno, p, x); + p = NewOp__57(19, fctno, p, x); } else { OPB_err(111); } @@ -2123,7 +2104,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) case 17: if (!__IN(f, 0x70) || x->class != 7) { OPB_err(69); - } else if (f == 4) { + } else if (x->typ->size == 1) { L = (int)x->conval->intval; typ = p->typ; while ((L > 0 && __IN(typ->comp, 0x0c))) { @@ -2139,7 +2120,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) p = p->left; x->conval->intval += 1; } - p = NewOp__53(12, 19, p, x); + p = NewOp__57(12, 19, p, x); p->typ = OPT_linttyp; } else { p = x; @@ -2161,7 +2142,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) t = x; x = p; p = t; - p = NewOp__53(19, 18, p, x); + p = NewOp__57(19, 18, p, x); } else { OPB_err(111); } @@ -2187,7 +2168,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) } p->obj = NIL; } else { - p = NewOp__53(12, 17, p, x); + p = NewOp__57(12, 17, p, x); p->typ = OPT_linttyp; } } else { @@ -2218,9 +2199,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) OPB_err(111); } else { if (fctno == 22) { - p = NewOp__53(12, 27, p, x); + p = NewOp__57(12, 27, p, x); } else { - p = NewOp__53(12, 28, p, x); + p = NewOp__57(12, 28, p, x); } p->typ = p->left->typ; } @@ -2237,7 +2218,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) x = p; p = t; } - p = NewOp__53(19, fctno, p, x); + p = NewOp__57(19, fctno, p, x); } else { OPB_err(111); } @@ -2247,7 +2228,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - p = NewOp__53(12, 26, p, x); + p = NewOp__57(12, 26, p, x); } else { OPB_err(111); } @@ -2257,6 +2238,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (((x->class == 8 || x->class == 9) || __IN(f, 0x1401)) || x->typ->comp == 3) { OPB_err(126); } + if (x->typ->size < p->typ->size) { + OPB_err(-308); + } t = OPT_NewNode(11); t->subcl = 29; t->left = x; @@ -2268,7 +2252,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - p = NewOp__53(19, 30, p, x); + p = NewOp__57(19, 30, p, x); } else { OPB_err(111); } @@ -2277,9 +2261,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) case 31: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if ((x->class == 7 && __IN(f, 0x30))) { + } else if ((((x->class == 7 && __IN(f, 0x70))) && x->typ->size < OPT_linttyp->size)) { OPB_Convert(&x, OPT_linttyp); - } else if (!__IN(f, 0x2040)) { + } else if (!((__IN(x->typ->form, 0x2070) && x->typ->size == (int)OPM_PointerSize))) { OPB_err(111); x->typ = OPT_linttyp; } @@ -2314,7 +2298,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) break; } *par0 = p; - StPar1__52_s = _s.lnk; + StPar1__56_s = _s.lnk; } void OPB_StParN (OPT_Node *par0, OPT_Node x, INTEGER fctno, INTEGER n) @@ -2433,7 +2417,7 @@ static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpa ftyp = ftyp->BaseTyp; atyp = atyp->BaseTyp; if ((fvarpar && ftyp == OPT_bytetyp)) { - if (!__IN(f, 0x0c) || !__IN(atyp->form, 0x1e)) { + if (!__IN(f, 0x0c) || !((__IN(atyp->form, 0x7e) && atyp->size == 1))) { if (__IN(18, OPM_opt)) { OPB_err(-301); } @@ -2516,7 +2500,7 @@ void OPB_Param (OPT_Node ap, OPT_Object fp) OPB_err(111); } } else if ((fp->typ == OPT_sysptrtyp && ap->typ->form == 13)) { - } else if ((ap->typ != fp->typ && !((fp->typ->form == 1 && __IN(ap->typ->form, 0x18))))) { + } else if ((ap->typ != fp->typ && !((fp->typ->form == 1 && ((__IN(ap->typ->form, 0x7e) && ap->typ->size == 1)))))) { OPB_err(123); } else if ((fp->typ->form == 13 && ap->class == 5)) { OPB_err(123); diff --git a/bootstrap/unix-44/OPB.h b/bootstrap/unix-44/OPB.h index 4c37f01f..d1c88266 100644 --- a/bootstrap/unix-44/OPB.h +++ b/bootstrap/unix-44/OPB.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPB__h #define OPB__h diff --git a/bootstrap/unix-44/OPC.c b/bootstrap/unix-44/OPC.c index 417337c0..3abccc9a 100644 --- a/bootstrap/unix-44/OPC.c +++ b/bootstrap/unix-44/OPC.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Configuration.h" #include "OPM.h" @@ -16,12 +16,13 @@ static CHAR OPC_BodyNameExt[13]; export void OPC_Align (LONGINT *adr, LONGINT base); export void OPC_Andent (OPT_Struct typ); static void OPC_AnsiParamList (OPT_Object obj, BOOLEAN showParamNames); -export LONGINT OPC_Base (OPT_Struct typ); +export LONGINT OPC_BaseAlignment (OPT_Struct typ); export OPT_Object OPC_BaseTProc (OPT_Object obj); export void OPC_BegBlk (void); export void OPC_BegStat (void); static void OPC_CProcDefs (OPT_Object obj, INTEGER vis); export void OPC_Case (LONGINT caseVal, INTEGER form); +static void OPC_CharacterLiteral (LONGINT c); export void OPC_Cmp (INTEGER rel); export void OPC_CompleteIdent (OPT_Object obj); export void OPC_Constant (OPT_Const con, INTEGER form); @@ -73,8 +74,10 @@ static void OPC_PutBase (OPT_Struct typ); static void OPC_PutPtrOffsets (OPT_Struct typ, LONGINT adr, LONGINT *cnt); static void OPC_RegCmds (OPT_Object obj); export void OPC_SetInclude (BOOLEAN exclude); +export LONGINT OPC_SizeAlignment (LONGINT size); static void OPC_Stars (OPT_Struct typ, BOOLEAN *openClause); static void OPC_Str1 (CHAR *s, LONGINT s__len, LONGINT x); +static void OPC_StringLiteral (CHAR *s, LONGINT s__len, LONGINT l); export void OPC_TDescDecl (OPT_Struct typ); export void OPC_TypeDefs (OPT_Object obj, INTEGER vis); export void OPC_TypeOf (OPT_Object ap); @@ -315,7 +318,7 @@ void OPC_Andent (OPT_Struct typ) static BOOLEAN OPC_Undefined (OPT_Object obj) { BOOLEAN _o_result; - _o_result = (((obj->mnolev >= 0 && obj->linkadr != (LONGINT)(3 + OPM_currFile))) && obj->linkadr != 2) || obj->name[0] == 0x00; + _o_result = obj->name[0] == 0x00 || (((obj->mnolev >= 0 && obj->linkadr != (int)(3 + OPM_currFile))) && obj->linkadr != 2); return _o_result; } @@ -815,14 +818,15 @@ void OPC_TDescDecl (OPT_Struct typ) OPC_Andent(typ); OPC_Str1((CHAR*)", #", (LONGINT)4, typ->n + 1); OPC_Str1((CHAR*)", #) = {__TDFLDS(", (LONGINT)18, OPC_NofPtrs(typ)); - OPM_Write('\"'); + OPM_Write('"'); if (typ->strobj != NIL) { OPM_WriteStringVar((void*)typ->strobj->name, ((LONGINT)(256))); } - OPC_Str1((CHAR*)"\", #), {", (LONGINT)9, typ->size); + OPM_Write('"'); + OPC_Str1((CHAR*)", #), {", (LONGINT)8, typ->size); nofptrs = 0; OPC_PutPtrOffsets(typ, ((LONGINT)(0)), &nofptrs); - OPC_Str1((CHAR*)"#}}", (LONGINT)4, -((nofptrs + 1) * (LONGINT)OPM_LIntSize)); + OPC_Str1((CHAR*)"#}}", (LONGINT)4, -((nofptrs + 1) * (int)OPM_LIntSize)); OPC_EndStat(); } @@ -864,70 +868,37 @@ void OPC_Align (LONGINT *adr, LONGINT base) } } -LONGINT OPC_Base (OPT_Struct typ) +LONGINT OPC_SizeAlignment (LONGINT size) { LONGINT _o_result; - switch (typ->form) { - case 1: - _o_result = 1; - return _o_result; - break; - case 3: - _o_result = OPM_CharAlign; - return _o_result; - break; - case 2: - _o_result = OPM_BoolAlign; - return _o_result; - break; - case 4: - _o_result = OPM_SIntAlign; - return _o_result; - break; - case 5: - _o_result = OPM_IntAlign; - return _o_result; - break; - case 6: - _o_result = OPM_LIntAlign; - return _o_result; - break; - case 7: - _o_result = OPM_RealAlign; - return _o_result; - break; - case 8: - _o_result = OPM_LRealAlign; - return _o_result; - break; - case 9: - _o_result = OPM_SetAlign; - return _o_result; - break; - case 13: - _o_result = OPM_PointerAlign; - return _o_result; - break; - case 14: - _o_result = OPM_ProcAlign; - return _o_result; - break; - case 15: - if (typ->comp == 4) { - _o_result = __MASK(typ->align, -65536); - return _o_result; - } else { - _o_result = OPC_Base(typ->BaseTyp); - return _o_result; - } - break; - default: - OPM_LogWStr((CHAR*)"unhandled case in OPC.Base, typ^form = ", (LONGINT)40); - OPM_LogWNum(typ->form, ((LONGINT)(0))); - OPM_LogWLn(); - break; + LONGINT alignment; + if (size < (int)OPM_Alignment) { + alignment = 1; + while (alignment < size) { + alignment = __ASHL(alignment, 1); + } + } else { + alignment = OPM_Alignment; } - __RETCHK; + _o_result = alignment; + return _o_result; +} + +LONGINT OPC_BaseAlignment (OPT_Struct typ) +{ + LONGINT _o_result; + LONGINT alignment; + if (typ->form == 15) { + if (typ->comp == 4) { + alignment = __MASK(typ->align, -65536); + } else { + alignment = OPC_BaseAlignment(typ->BaseTyp); + } + } else { + alignment = OPC_SizeAlignment(typ->size); + } + _o_result = alignment; + return _o_result; } static void OPC_FillGap (LONGINT gap, LONGINT off, LONGINT align, LONGINT *n, LONGINT *curAlign) @@ -938,11 +909,11 @@ static void OPC_FillGap (LONGINT gap, LONGINT off, LONGINT align, LONGINT *n, LO if ((*curAlign < align && gap - (adr - off) >= align)) { gap -= (adr - off) + align; OPC_BegStat(); - if (align == (LONGINT)OPM_IntSize) { + if (align == (int)OPM_IntSize) { OPM_WriteString((CHAR*)"INTEGER", (LONGINT)8); - } else if (align == (LONGINT)OPM_LIntSize) { + } else if (align == (int)OPM_LIntSize) { OPM_WriteString((CHAR*)"LONGINT", (LONGINT)8); - } else if (align == (LONGINT)OPM_LRealSize) { + } else if (align == (int)OPM_LRealSize) { OPM_WriteString((CHAR*)"LONGREAL", (LONGINT)9); } OPC_Str1((CHAR*)" _prvt#", (LONGINT)8, *n); @@ -981,7 +952,7 @@ static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, LONGINT *off, LONGINT * } } else { adr = *off; - fldAlign = OPC_Base(fld->typ); + fldAlign = OPC_BaseAlignment(fld->typ); OPC_Align(&adr, fldAlign); gap = fld->adr - adr; if (fldAlign > *curAlign) { @@ -1007,7 +978,7 @@ static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, LONGINT *off, LONGINT * } } if (last) { - adr = typ->size - (LONGINT)__ASHR(typ->sysflag, 8); + adr = typ->size - (int)__ASHR(typ->sysflag, 8); if (adr == 0) { gap = 1; } else { @@ -1170,10 +1141,10 @@ static void OPC_Include (CHAR *name, LONGINT name__len) { __DUP(name, name__len, CHAR); OPM_WriteString((CHAR*)"#include ", (LONGINT)10); - OPM_Write('\"'); + OPM_Write('"'); OPM_WriteStringVar((void*)name, name__len); OPM_WriteString((CHAR*)".h", (LONGINT)3); - OPM_Write('\"'); + OPM_Write('"'); OPM_WriteLn(); __DEL(name); } @@ -1238,8 +1209,8 @@ void OPC_GenHdr (OPT_Node n) static void OPC_GenHeaderMsg (void) { INTEGER i; - OPM_WriteString((CHAR*)"/*", (LONGINT)3); - OPM_WriteString((CHAR*)" voc ", (LONGINT)6); + OPM_WriteString((CHAR*)"/* ", (LONGINT)4); + OPM_WriteString((CHAR*)"voc", (LONGINT)4); OPM_Write(' '); OPM_WriteString(Configuration_versionLong, ((LONGINT)(41))); OPM_Write(' '); @@ -1855,26 +1826,56 @@ void OPC_Cmp (INTEGER rel) } } +static void OPC_CharacterLiteral (LONGINT c) +{ + if (c < 32 || c > 126) { + OPM_WriteString((CHAR*)"0x", (LONGINT)3); + OPM_WriteHex(c); + } else { + OPM_Write('\''); + if ((c == 92 || c == 39) || c == 63) { + OPM_Write('\\'); + } + OPM_Write((CHAR)c); + OPM_Write('\''); + } +} + +static void OPC_StringLiteral (CHAR *s, LONGINT s__len, LONGINT l) +{ + LONGINT i; + INTEGER c; + __DUP(s, s__len, CHAR); + OPM_Write('"'); + i = 0; + while (i < l) { + c = (int)s[__X(i, s__len)]; + if (c < 32 || c > 126) { + OPM_Write('\\'); + OPM_Write((CHAR)(48 + __ASHR(c, 6))); + c = __MASK(c, -64); + OPM_Write((CHAR)(48 + __ASHR(c, 3))); + c = __MASK(c, -8); + OPM_Write((CHAR)(48 + c)); + } else { + if ((c == 92 || c == 34) || c == 63) { + OPM_Write('\\'); + } + OPM_Write((CHAR)c); + } + i += 1; + } + OPM_Write('"'); + __DEL(s); +} + void OPC_Case (LONGINT caseVal, INTEGER form) { CHAR ch; OPM_WriteString((CHAR*)"case ", (LONGINT)6); switch (form) { case 3: - ch = (CHAR)caseVal; - if ((ch >= ' ' && ch <= '~')) { - OPM_Write('\''); - if (((ch == '\\' || ch == '\?') || ch == '\'') || ch == '\"') { - OPM_Write('\\'); - OPM_Write(ch); - } else { - OPM_Write(ch); - } - OPM_Write('\''); - } else { - OPM_WriteString((CHAR*)"0x", (LONGINT)3); - OPM_WriteHex(caseVal); - } + OPC_CharacterLiteral(caseVal); break; case 4: case 5: case 6: OPM_WriteInt(caseVal); @@ -1932,8 +1933,7 @@ void OPC_Len (OPT_Object obj, OPT_Struct array, LONGINT dim) void OPC_Constant (OPT_Const con, INTEGER form) { - INTEGER i, len; - CHAR ch; + INTEGER i; SET s; LONGINT hex; BOOLEAN skipLeading; @@ -1945,18 +1945,7 @@ void OPC_Constant (OPT_Const con, INTEGER form) OPM_WriteInt(con->intval); break; case 3: - ch = (CHAR)con->intval; - if ((ch >= ' ' && ch <= '~')) { - OPM_Write('\''); - if (((ch == '\\' || ch == '\?') || ch == '\'') || ch == '\"') { - OPM_Write('\\'); - } - OPM_Write(ch); - OPM_Write('\''); - } else { - OPM_WriteString((CHAR*)"0x", (LONGINT)3); - OPM_WriteHex(con->intval); - } + OPC_CharacterLiteral(con->intval); break; case 4: case 5: case 6: OPM_WriteInt(con->intval); @@ -1991,18 +1980,7 @@ void OPC_Constant (OPT_Const con, INTEGER form) } break; case 10: - OPM_Write('\"'); - len = (int)con->intval2 - 1; - i = 0; - while (i < len) { - ch = (*con->ext)[__X(i, ((LONGINT)(256)))]; - if (((ch == '\\' || ch == '\?') || ch == '\'') || ch == '\"') { - OPM_Write('\\'); - } - OPM_Write(ch); - i += 1; - } - OPM_Write('\"'); + OPC_StringLiteral(*con->ext, ((LONGINT)(256)), con->intval2 - 1); break; case 11: OPM_WriteString((CHAR*)"NIL", (LONGINT)4); @@ -2015,74 +1993,74 @@ void OPC_Constant (OPT_Const con, INTEGER form) } } -static struct InitKeywords__47 { +static struct InitKeywords__48 { SHORTINT *n; - struct InitKeywords__47 *lnk; -} *InitKeywords__47_s; + struct InitKeywords__48 *lnk; +} *InitKeywords__48_s; -static void Enter__48 (CHAR *s, LONGINT s__len); +static void Enter__49 (CHAR *s, LONGINT s__len); -static void Enter__48 (CHAR *s, LONGINT s__len) +static void Enter__49 (CHAR *s, LONGINT s__len) { INTEGER h; __DUP(s, s__len, CHAR); h = OPC_PerfectHash((void*)s, s__len); - OPC_hashtab[__X(h, ((LONGINT)(105)))] = *InitKeywords__47_s->n; - __COPY(s, OPC_keytab[__X(*InitKeywords__47_s->n, ((LONGINT)(36)))], ((LONGINT)(9))); - *InitKeywords__47_s->n += 1; + OPC_hashtab[__X(h, ((LONGINT)(105)))] = *InitKeywords__48_s->n; + __COPY(s, OPC_keytab[__X(*InitKeywords__48_s->n, ((LONGINT)(36)))], ((LONGINT)(9))); + *InitKeywords__48_s->n += 1; __DEL(s); } static void OPC_InitKeywords (void) { SHORTINT n, i; - struct InitKeywords__47 _s; + struct InitKeywords__48 _s; _s.n = &n; - _s.lnk = InitKeywords__47_s; - InitKeywords__47_s = &_s; + _s.lnk = InitKeywords__48_s; + InitKeywords__48_s = &_s; n = 0; i = 0; while (i <= 104) { OPC_hashtab[__X(i, ((LONGINT)(105)))] = -1; i += 1; } - Enter__48((CHAR*)"asm", (LONGINT)4); - Enter__48((CHAR*)"auto", (LONGINT)5); - Enter__48((CHAR*)"break", (LONGINT)6); - Enter__48((CHAR*)"case", (LONGINT)5); - Enter__48((CHAR*)"char", (LONGINT)5); - Enter__48((CHAR*)"const", (LONGINT)6); - Enter__48((CHAR*)"continue", (LONGINT)9); - Enter__48((CHAR*)"default", (LONGINT)8); - Enter__48((CHAR*)"do", (LONGINT)3); - Enter__48((CHAR*)"double", (LONGINT)7); - Enter__48((CHAR*)"else", (LONGINT)5); - Enter__48((CHAR*)"enum", (LONGINT)5); - Enter__48((CHAR*)"extern", (LONGINT)7); - Enter__48((CHAR*)"export", (LONGINT)7); - Enter__48((CHAR*)"float", (LONGINT)6); - Enter__48((CHAR*)"for", (LONGINT)4); - Enter__48((CHAR*)"fortran", (LONGINT)8); - Enter__48((CHAR*)"goto", (LONGINT)5); - Enter__48((CHAR*)"if", (LONGINT)3); - Enter__48((CHAR*)"import", (LONGINT)7); - Enter__48((CHAR*)"int", (LONGINT)4); - Enter__48((CHAR*)"long", (LONGINT)5); - Enter__48((CHAR*)"register", (LONGINT)9); - Enter__48((CHAR*)"return", (LONGINT)7); - Enter__48((CHAR*)"short", (LONGINT)6); - Enter__48((CHAR*)"signed", (LONGINT)7); - Enter__48((CHAR*)"sizeof", (LONGINT)7); - Enter__48((CHAR*)"static", (LONGINT)7); - Enter__48((CHAR*)"struct", (LONGINT)7); - Enter__48((CHAR*)"switch", (LONGINT)7); - Enter__48((CHAR*)"typedef", (LONGINT)8); - Enter__48((CHAR*)"union", (LONGINT)6); - Enter__48((CHAR*)"unsigned", (LONGINT)9); - Enter__48((CHAR*)"void", (LONGINT)5); - Enter__48((CHAR*)"volatile", (LONGINT)9); - Enter__48((CHAR*)"while", (LONGINT)6); - InitKeywords__47_s = _s.lnk; + Enter__49((CHAR*)"asm", (LONGINT)4); + Enter__49((CHAR*)"auto", (LONGINT)5); + Enter__49((CHAR*)"break", (LONGINT)6); + Enter__49((CHAR*)"case", (LONGINT)5); + Enter__49((CHAR*)"char", (LONGINT)5); + Enter__49((CHAR*)"const", (LONGINT)6); + Enter__49((CHAR*)"continue", (LONGINT)9); + Enter__49((CHAR*)"default", (LONGINT)8); + Enter__49((CHAR*)"do", (LONGINT)3); + Enter__49((CHAR*)"double", (LONGINT)7); + Enter__49((CHAR*)"else", (LONGINT)5); + Enter__49((CHAR*)"enum", (LONGINT)5); + Enter__49((CHAR*)"extern", (LONGINT)7); + Enter__49((CHAR*)"export", (LONGINT)7); + Enter__49((CHAR*)"float", (LONGINT)6); + Enter__49((CHAR*)"for", (LONGINT)4); + Enter__49((CHAR*)"fortran", (LONGINT)8); + Enter__49((CHAR*)"goto", (LONGINT)5); + Enter__49((CHAR*)"if", (LONGINT)3); + Enter__49((CHAR*)"import", (LONGINT)7); + Enter__49((CHAR*)"int", (LONGINT)4); + Enter__49((CHAR*)"long", (LONGINT)5); + Enter__49((CHAR*)"register", (LONGINT)9); + Enter__49((CHAR*)"return", (LONGINT)7); + Enter__49((CHAR*)"short", (LONGINT)6); + Enter__49((CHAR*)"signed", (LONGINT)7); + Enter__49((CHAR*)"sizeof", (LONGINT)7); + Enter__49((CHAR*)"static", (LONGINT)7); + Enter__49((CHAR*)"struct", (LONGINT)7); + Enter__49((CHAR*)"switch", (LONGINT)7); + Enter__49((CHAR*)"typedef", (LONGINT)8); + Enter__49((CHAR*)"union", (LONGINT)6); + Enter__49((CHAR*)"unsigned", (LONGINT)9); + Enter__49((CHAR*)"void", (LONGINT)5); + Enter__49((CHAR*)"volatile", (LONGINT)9); + Enter__49((CHAR*)"while", (LONGINT)6); + InitKeywords__48_s = _s.lnk; } diff --git a/bootstrap/unix-44/OPC.h b/bootstrap/unix-44/OPC.h index 52ed8dab..b7d34a07 100644 --- a/bootstrap/unix-44/OPC.h +++ b/bootstrap/unix-44/OPC.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPC__h #define OPC__h @@ -11,7 +11,7 @@ import void OPC_Align (LONGINT *adr, LONGINT base); import void OPC_Andent (OPT_Struct typ); -import LONGINT OPC_Base (OPT_Struct typ); +import LONGINT OPC_BaseAlignment (OPT_Struct typ); import OPT_Object OPC_BaseTProc (OPT_Object obj); import void OPC_BegBlk (void); import void OPC_BegStat (void); @@ -40,6 +40,7 @@ import void OPC_InitTDesc (OPT_Struct typ); import void OPC_Len (OPT_Object obj, OPT_Struct array, LONGINT dim); import LONGINT OPC_NofPtrs (OPT_Struct typ); import void OPC_SetInclude (BOOLEAN exclude); +import LONGINT OPC_SizeAlignment (LONGINT size); import void OPC_TDescDecl (OPT_Struct typ); import void OPC_TypeDefs (OPT_Object obj, INTEGER vis); import void OPC_TypeOf (OPT_Object ap); diff --git a/bootstrap/unix-44/OPM.c b/bootstrap/unix-44/OPM.c index 8e5add20..bf683e41 100644 --- a/bootstrap/unix-44/OPM.c +++ b/bootstrap/unix-44/OPM.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Configuration.h" #include "Console.h" @@ -14,8 +14,8 @@ typedef static CHAR OPM_SourceFileName[256]; -export INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_CharAlign, OPM_BoolAlign, OPM_SIntAlign, OPM_IntAlign, OPM_LIntAlign, OPM_SetAlign, OPM_RealAlign, OPM_LRealAlign, OPM_PointerAlign, OPM_ProcAlign, OPM_RecAlign, OPM_MaxSet; -export LONGINT OPM_MinSInt, OPM_MinInt, OPM_MinLInt, OPM_MaxSInt, OPM_MaxInt, OPM_MaxLInt, OPM_MaxIndex; +export INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_MaxSet; +export LONGINT OPM_MaxIndex; export LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; export BOOLEAN OPM_noerr; export LONGINT OPM_curpos, OPM_errpos, OPM_breakpc; @@ -57,7 +57,6 @@ export void OPM_LogWNum (LONGINT i, LONGINT len); export void OPM_LogWStr (CHAR *s, LONGINT s__len); static void OPM_MakeFileName (CHAR *name, LONGINT name__len, CHAR *FName, LONGINT FName__len, CHAR *ext, LONGINT ext__len); export void OPM_Mark (INTEGER n, LONGINT pos); -static INTEGER OPM_Min (INTEGER a, INTEGER b); export void OPM_NewSym (CHAR *modName, LONGINT modName__len); export void OPM_OldSym (CHAR *modName, LONGINT modName__len, BOOLEAN *done); export void OPM_OpenFiles (CHAR *moduleName, LONGINT moduleName__len); @@ -65,6 +64,8 @@ export BOOLEAN OPM_OpenPar (void); export void OPM_RegisterNewSym (void); static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt); static void OPM_ShowLine (LONGINT pos); +export LONGINT OPM_SignedMaximum (LONGINT bytecount); +export LONGINT OPM_SignedMinimum (LONGINT bytecount); export void OPM_SymRCh (CHAR *ch); export LONGINT OPM_SymRInt (void); export void OPM_SymRLReal (LONGREAL *lr); @@ -85,7 +86,7 @@ export void OPM_WriteString (CHAR *s, LONGINT s__len); export void OPM_WriteStringVar (CHAR *s, LONGINT s__len); export BOOLEAN OPM_eofSF (void); export void OPM_err (INTEGER n); -static LONGINT OPM_minus (LONGINT i); +static LONGINT OPM_minusop (LONGINT i); static LONGINT OPM_power0 (LONGINT i, LONGINT j); @@ -117,50 +118,38 @@ static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) i = 1; while (s[__X(i, s__len)] != 0x00) { switch (s[__X(i, s__len)]) { - case 'e': - *opt = *opt ^ 0x0200; - break; - case 's': - *opt = *opt ^ 0x10; - break; - case 'm': - *opt = *opt ^ 0x0400; - break; - case 'x': - *opt = *opt ^ 0x01; - break; - case 'r': - *opt = *opt ^ 0x04; - break; - case 't': - *opt = *opt ^ 0x08; - break; case 'a': *opt = *opt ^ 0x80; break; - case 'k': - *opt = *opt ^ 0x40; - break; - case 'p': - *opt = *opt ^ 0x20; - break; - case 'S': - *opt = *opt ^ 0x2000; - break; case 'c': *opt = *opt ^ 0x4000; break; - case 'M': - *opt = *opt ^ 0x8000; + case 'e': + *opt = *opt ^ 0x0200; break; case 'f': *opt = *opt ^ 0x010000; break; - case 'F': - *opt = *opt ^ 0x020000; + case 'k': + *opt = *opt ^ 0x40; break; - case 'V': - *opt = *opt ^ 0x040000; + case 'm': + *opt = *opt ^ 0x0400; + break; + case 'p': + *opt = *opt ^ 0x20; + break; + case 'r': + *opt = *opt ^ 0x04; + break; + case 's': + *opt = *opt ^ 0x10; + break; + case 't': + *opt = *opt ^ 0x08; + break; + case 'x': + *opt = *opt ^ 0x01; break; case 'B': if (s[__X(i + 1, s__len)] != 0x00) { @@ -178,6 +167,19 @@ static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) __ASSERT(OPM_IntSize == 2 || OPM_IntSize == 4, 0); __ASSERT(OPM_PointerSize == 4 || OPM_PointerSize == 8, 0); __ASSERT(OPM_Alignment == 4 || OPM_Alignment == 8, 0); + Files_SetSearchPath((CHAR*)"", (LONGINT)1); + break; + case 'F': + *opt = *opt ^ 0x020000; + break; + case 'M': + *opt = *opt ^ 0x8000; + break; + case 'S': + *opt = *opt ^ 0x2000; + break; + case 'V': + *opt = *opt ^ 0x040000; break; default: OPM_LogWStr((CHAR*)" warning: option ", (LONGINT)19); @@ -227,17 +229,17 @@ BOOLEAN OPM_OpenPar (void) OPM_LogWLn(); OPM_LogWStr((CHAR*)" x - turn off array indices check", (LONGINT)35); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" a - don\'t check ASSERTs at runtime, use this option in tested production code", (LONGINT)80); + OPM_LogWStr((CHAR*)" a - don't check ASSERTs at runtime, use this option in tested production code", (LONGINT)80); OPM_LogWLn(); OPM_LogWStr((CHAR*)" p - turn off automatic pointer initialization", (LONGINT)48); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" t - don\'t check type guards (use in rare cases such as low-level modules where every cycle counts)", (LONGINT)101); + OPM_LogWStr((CHAR*)" t - don't check type guards (use in rare cases such as low-level modules where every cycle counts)", (LONGINT)101); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" S - don\'t call external assembler/compiler, only generate C code", (LONGINT)67); + OPM_LogWStr((CHAR*)" S - don't call external assembler/compiler, only generate C code", (LONGINT)67); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" c - don\'t call linker", (LONGINT)24); + OPM_LogWStr((CHAR*)" c - don't call linker", (LONGINT)24); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" f - don\'t use color output", (LONGINT)29); + OPM_LogWStr((CHAR*)" f - don't use color output", (LONGINT)29); OPM_LogWLn(); OPM_LogWStr((CHAR*)" F - force writing new symbol file in current directory", (LONGINT)57); OPM_LogWLn(); @@ -540,14 +542,17 @@ void OPM_FPrintSet (LONGINT *fp, SET set) void OPM_FPrintReal (LONGINT *fp, REAL real) { - OPM_FPrint(&*fp, __VAL(LONGINT, real)); + INTEGER i; + LONGINT l; + __GET((LONGINT)(SYSTEM_ADDRESS)&real, l, LONGINT); + OPM_FPrint(&*fp, l); } void OPM_FPrintLReal (LONGINT *fp, LONGREAL lr) { LONGINT l, h; - __GET((LONGINT)(uintptr_t)&lr, l, LONGINT); - __GET((LONGINT)(uintptr_t)&lr + 4, h, LONGINT); + __GET((LONGINT)(SYSTEM_ADDRESS)&lr, l, LONGINT); + __GET((LONGINT)(SYSTEM_ADDRESS)&lr + 4, h, LONGINT); OPM_FPrint(&*fp, l); OPM_FPrint(&*fp, h); } @@ -575,7 +580,7 @@ static void OPM_GetProperty (Texts_Scanner *S, LONGINT *S__typ, CHAR *name, LONG __DEL(name); } -static LONGINT OPM_minus (LONGINT i) +static LONGINT OPM_minusop (LONGINT i) { LONGINT _o_result; _o_result = -i; @@ -603,103 +608,62 @@ static void OPM_VerboseListSizes (void) OPM_LogWLn(); OPM_LogWStr((CHAR*)"CHAR ", (LONGINT)14); OPM_LogWNum(OPM_CharSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_CharAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"BOOLEAN ", (LONGINT)14); OPM_LogWNum(OPM_BoolSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_BoolAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"SHORTINT ", (LONGINT)14); OPM_LogWNum(OPM_SIntSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_SIntAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"INTEGER ", (LONGINT)14); OPM_LogWNum(OPM_IntSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_IntAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"LONGINT ", (LONGINT)14); OPM_LogWNum(OPM_LIntSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_LIntAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"SET ", (LONGINT)14); OPM_LogWNum(OPM_SetSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_SetAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"REAL ", (LONGINT)14); OPM_LogWNum(OPM_RealSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_RealAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"LONGREAL ", (LONGINT)14); OPM_LogWNum(OPM_LRealSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_LRealAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"PTR ", (LONGINT)14); OPM_LogWNum(OPM_PointerSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_PointerAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"PROC ", (LONGINT)14); OPM_LogWNum(OPM_ProcSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_ProcAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"RECORD ", (LONGINT)14); OPM_LogWNum(OPM_RecSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_RecAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Min shortint ", (LONGINT)14); - OPM_LogWNum(OPM_MinSInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Max shortint ", (LONGINT)14); - OPM_LogWNum(OPM_MaxSInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Min integer ", (LONGINT)14); - OPM_LogWNum(OPM_MinInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Max integer ", (LONGINT)14); - OPM_LogWNum(OPM_MaxInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Min longint ", (LONGINT)14); - OPM_LogWNum(OPM_MinLInt, ((LONGINT)(4))); - OPM_LogWLn(); } -static INTEGER OPM_Min (INTEGER a, INTEGER b) +LONGINT OPM_SignedMaximum (LONGINT bytecount) { - INTEGER _o_result; - if (a < b) { - _o_result = a; - return _o_result; - } else { - _o_result = b; - return _o_result; - } - __RETCHK; + LONGINT _o_result; + LONGINT result; + result = 1; + result = __LSH(result, __ASHL(bytecount, 3) - 1, LONGINT); + _o_result = result - 1; + return _o_result; +} + +LONGINT OPM_SignedMinimum (LONGINT bytecount) +{ + LONGINT _o_result; + _o_result = -OPM_SignedMaximum(bytecount) - 1; + return _o_result; } static void OPM_GetProperties (void) { - LONGINT base; OPM_ProcSize = OPM_PointerSize; OPM_LIntSize = __ASHL(OPM_IntSize, 1); OPM_SetSize = OPM_LIntSize; - OPM_CharAlign = OPM_Min(OPM_Alignment, OPM_CharSize); - OPM_BoolAlign = OPM_Min(OPM_Alignment, OPM_BoolSize); - OPM_SIntAlign = OPM_Min(OPM_Alignment, OPM_SIntSize); - OPM_RecAlign = OPM_Min(OPM_Alignment, OPM_RecSize); - OPM_RealAlign = OPM_Min(OPM_Alignment, OPM_RealSize); - OPM_LRealAlign = OPM_Min(OPM_Alignment, OPM_LRealSize); - OPM_PointerAlign = OPM_Min(OPM_Alignment, OPM_PointerSize); - OPM_ProcAlign = OPM_Min(OPM_Alignment, OPM_ProcSize); - OPM_IntAlign = OPM_Min(OPM_Alignment, OPM_IntSize); - OPM_LIntAlign = OPM_Min(OPM_Alignment, OPM_LIntSize); - OPM_SetAlign = OPM_Min(OPM_Alignment, OPM_SetSize); - base = -2; - OPM_MinSInt = __ASH(base, __ASHL(OPM_SIntSize, 3) - 2); - OPM_MaxSInt = OPM_minus(OPM_MinSInt + 1); - OPM_MinInt = __ASH(base, __ASHL(OPM_IntSize, 3) - 2); - OPM_MaxInt = OPM_minus(OPM_MinInt + 1); - OPM_MinLInt = __ASH(base, __ASHL(OPM_LIntSize, 3) - 2); - OPM_MaxLInt = OPM_minus(OPM_MinLInt + 1); if (OPM_RealSize == 4) { OPM_MaxReal = 3.40282346000000e+038; } else if (OPM_RealSize == 8) { @@ -713,7 +677,7 @@ static void OPM_GetProperties (void) OPM_MinReal = -OPM_MaxReal; OPM_MinLReal = -OPM_MaxLReal; OPM_MaxSet = __ASHL(OPM_SetSize, 3) - 1; - OPM_MaxIndex = OPM_MaxLInt; + OPM_MaxIndex = OPM_SignedMaximum(OPM_PointerSize); if (OPM_Verbose) { OPM_VerboseListSizes(); } @@ -875,7 +839,7 @@ void OPM_WriteInt (LONGINT i) { CHAR s[20]; LONGINT i1, k; - if (i == OPM_MinInt || i == OPM_MinLInt) { + if (i == OPM_SignedMinimum(OPM_IntSize) || i == OPM_SignedMinimum(OPM_LIntSize)) { OPM_Write('('); OPM_WriteInt(i + 1); OPM_WriteString((CHAR*)"-1)", (LONGINT)4); @@ -908,13 +872,13 @@ void OPM_WriteReal (LONGREAL r, CHAR suffx) CHAR s[32]; CHAR ch; INTEGER i; - if ((((r < OPM_MaxLInt && r > OPM_MinLInt)) && r == (__ENTIER(r)))) { + if ((((r < OPM_SignedMaximum(OPM_LIntSize) && r > OPM_SignedMinimum(OPM_LIntSize))) && r == ((int)__ENTIER(r)))) { if (suffx == 'f') { OPM_WriteString((CHAR*)"(REAL)", (LONGINT)7); } else { OPM_WriteString((CHAR*)"(LONGREAL)", (LONGINT)11); } - OPM_WriteInt(__ENTIER(r)); + OPM_WriteInt((int)__ENTIER(r)); } else { Texts_OpenWriter(&W, Texts_Writer__typ); if (suffx == 'f') { diff --git a/bootstrap/unix-44/OPM.h b/bootstrap/unix-44/OPM.h index db46c598..ed914bff 100644 --- a/bootstrap/unix-44/OPM.h +++ b/bootstrap/unix-44/OPM.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPM__h #define OPM__h @@ -6,8 +6,8 @@ #include "SYSTEM.h" -import INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_CharAlign, OPM_BoolAlign, OPM_SIntAlign, OPM_IntAlign, OPM_LIntAlign, OPM_SetAlign, OPM_RealAlign, OPM_LRealAlign, OPM_PointerAlign, OPM_ProcAlign, OPM_RecAlign, OPM_MaxSet; -import LONGINT OPM_MinSInt, OPM_MinInt, OPM_MinLInt, OPM_MaxSInt, OPM_MaxInt, OPM_MaxLInt, OPM_MaxIndex; +import INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_MaxSet; +import LONGINT OPM_MaxIndex; import LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; import BOOLEAN OPM_noerr; import LONGINT OPM_curpos, OPM_errpos, OPM_breakpc; @@ -38,6 +38,8 @@ import void OPM_OldSym (CHAR *modName, LONGINT modName__len, BOOLEAN *done); import void OPM_OpenFiles (CHAR *moduleName, LONGINT moduleName__len); import BOOLEAN OPM_OpenPar (void); import void OPM_RegisterNewSym (void); +import LONGINT OPM_SignedMaximum (LONGINT bytecount); +import LONGINT OPM_SignedMinimum (LONGINT bytecount); import void OPM_SymRCh (CHAR *ch); import LONGINT OPM_SymRInt (void); import void OPM_SymRLReal (LONGREAL *lr); diff --git a/bootstrap/unix-44/OPP.c b/bootstrap/unix-44/OPP.c index ffe3dff2..01d2144d 100644 --- a/bootstrap/unix-44/OPP.c +++ b/bootstrap/unix-44/OPP.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "OPB.h" #include "OPM.h" @@ -438,10 +438,10 @@ static void OPP_TypeDecl (OPT_Struct *typ, OPT_Struct *banned) if (OPP_sym == 38) { OPP_qualident(&id); if (id->mode == 5) { - if (id->typ != *banned) { - *typ = id->typ; - } else { + if (id->typ == *banned) { OPP_err(58); + } else { + *typ = id->typ; } } else { OPP_err(52); @@ -1783,6 +1783,24 @@ void OPP_Module (OPT_Node *prog, SET opt) if (OPP_sym == 63) { OPS_Get(&OPP_sym); } else { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Unexpected symbol found when MODULE expected:", (LONGINT)46); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" sym: ", (LONGINT)15); + OPM_LogWNum(OPP_sym, ((LONGINT)(1))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.name: ", (LONGINT)15); + OPM_LogWStr(OPS_name, ((LONGINT)(256))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.str: ", (LONGINT)15); + OPM_LogWStr(OPS_str, ((LONGINT)(256))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.numtyp: ", (LONGINT)15); + OPM_LogWNum(OPS_numtyp, ((LONGINT)(1))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.intval: ", (LONGINT)15); + OPM_LogWNum(OPS_intval, ((LONGINT)(1))); + OPM_LogWLn(); OPP_err(16); } if (OPP_sym == 38) { diff --git a/bootstrap/unix-44/OPP.h b/bootstrap/unix-44/OPP.h index 40e2def4..bf56b7d7 100644 --- a/bootstrap/unix-44/OPP.h +++ b/bootstrap/unix-44/OPP.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPP__h #define OPP__h diff --git a/bootstrap/unix-44/OPS.c b/bootstrap/unix-44/OPS.c index efed04c6..cacf9256 100644 --- a/bootstrap/unix-44/OPS.c +++ b/bootstrap/unix-44/OPS.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #include "SYSTEM.h" #include "OPM.h" @@ -173,7 +173,7 @@ static void OPS_Number (void) OPS_numtyp = 1; if (n <= 2) { while (i < n) { - OPS_intval = __ASHL(OPS_intval, 4) + (LONGINT)Ord__7(dig[i], 1); + OPS_intval = __ASHL(OPS_intval, 4) + (int)Ord__7(dig[i], 1); i += 1; } } else { @@ -188,7 +188,7 @@ static void OPS_Number (void) OPS_intval = -1; } while (i < n) { - OPS_intval = __ASHL(OPS_intval, 4) + (LONGINT)Ord__7(dig[i], 1); + OPS_intval = __ASHL(OPS_intval, 4) + (int)Ord__7(dig[i], 1); i += 1; } } else { @@ -199,8 +199,8 @@ static void OPS_Number (void) while (i < n) { d = Ord__7(dig[i], 0); i += 1; - if (OPS_intval <= __DIV(2147483647 - (LONGINT)d, 10)) { - OPS_intval = OPS_intval * 10 + (LONGINT)d; + if (OPS_intval <= __DIV(2147483647 - (int)d, 10)) { + OPS_intval = OPS_intval * 10 + (int)d; } else { OPS_err(203); } @@ -325,7 +325,7 @@ void OPS_Get (SHORTINT *sym) } } switch (OPS_ch) { - case '\"': case '\'': + case '"': case '\'': OPS_Str(&s); break; case '#': diff --git a/bootstrap/unix-44/OPS.h b/bootstrap/unix-44/OPS.h index dae6e457..e901bcfc 100644 --- a/bootstrap/unix-44/OPS.h +++ b/bootstrap/unix-44/OPS.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #ifndef OPS__h #define OPS__h diff --git a/bootstrap/unix-44/OPT.c b/bootstrap/unix-44/OPT.c index 8c943c20..b32d0ebd 100644 --- a/bootstrap/unix-44/OPT.c +++ b/bootstrap/unix-44/OPT.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "OPM.h" #include "OPS.h" @@ -849,7 +849,7 @@ static void OPT_InConstant (LONGINT f, OPT_Const conval) conval->intval = 0; break; default: - OPM_LogWStr((CHAR*)"unhandled case in OPT.InConstant(), f = ", (LONGINT)41); + OPM_LogWStr((CHAR*)"unhandled case in InConstant(), f = ", (LONGINT)37); OPM_LogWNum(f, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1072,7 +1072,7 @@ static void OPT_InStruct (OPT_Struct *typ) OPT_InSign(mno, &(*typ)->BaseTyp, &(*typ)->link); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.InStruct, tag = ", (LONGINT)39); + OPM_LogWStr((CHAR*)"unhandled case at InStruct, tag = ", (LONGINT)35); OPM_LogWNum(tag, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1175,7 +1175,7 @@ static OPT_Object OPT_InObj (SHORTINT mno) } break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.InObj, tag = ", (LONGINT)36); + OPM_LogWStr((CHAR*)"unhandled case at InObj, tag = ", (LONGINT)32); OPM_LogWNum(tag, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1464,14 +1464,14 @@ static void OPT_OutStr (OPT_Struct typ) OPM_SymWInt(((LONGINT)(18))); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutStr, typ^.comp = ", (LONGINT)43); + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.comp = ", (LONGINT)39); OPM_LogWNum(typ->comp, ((LONGINT)(0))); OPM_LogWLn(); break; } break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutStr, typ^.form = ", (LONGINT)43); + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.form = ", (LONGINT)39); OPM_LogWNum(typ->form, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1536,7 +1536,7 @@ static void OPT_OutObj (OPT_Object obj) OPT_FPrintErr(obj, 251); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutObj, obj^.history = ", (LONGINT)46); + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj^.history = ", (LONGINT)42); OPM_LogWNum(obj->history, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1592,7 +1592,7 @@ static void OPT_OutObj (OPT_Object obj) OPT_OutName((void*)obj->name, ((LONGINT)(256))); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutObj, obj.mode = ", (LONGINT)42); + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj.mode = ", (LONGINT)38); OPM_LogWNum(obj->mode, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1809,6 +1809,7 @@ export void *OPT__init(void) OPT_syslink = OPT_topScope->right; OPT_universe = OPT_topScope; OPT_topScope->right = NIL; + OPT_EnterTyp((CHAR*)"BOOLEAN", 2, OPM_BoolSize, &OPT_booltyp); OPT_EnterTyp((CHAR*)"CHAR", 3, OPM_CharSize, &OPT_chartyp); OPT_EnterTyp((CHAR*)"SET", 9, OPM_SetSize, &OPT_settyp); OPT_EnterTyp((CHAR*)"REAL", 7, OPM_RealSize, &OPT_realtyp); @@ -1816,7 +1817,6 @@ export void *OPT__init(void) OPT_EnterTyp((CHAR*)"LONGINT", 6, OPM_LIntSize, &OPT_linttyp); OPT_EnterTyp((CHAR*)"LONGREAL", 8, OPM_LRealSize, &OPT_lrltyp); OPT_EnterTyp((CHAR*)"SHORTINT", 4, OPM_SIntSize, &OPT_sinttyp); - OPT_EnterTyp((CHAR*)"BOOLEAN", 2, OPM_BoolSize, &OPT_booltyp); OPT_EnterBoolConst((CHAR*)"FALSE", ((LONGINT)(0))); OPT_EnterBoolConst((CHAR*)"TRUE", ((LONGINT)(1))); OPT_EnterProc((CHAR*)"HALT", 0); diff --git a/bootstrap/unix-44/OPT.h b/bootstrap/unix-44/OPT.h index 45816124..41b3e7ec 100644 --- a/bootstrap/unix-44/OPT.h +++ b/bootstrap/unix-44/OPT.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPT__h #define OPT__h @@ -59,8 +59,7 @@ typedef INTEGER ref, sysflag; LONGINT n, size, align, txtpos; BOOLEAN allocated, pbused, pvused; - char _prvt0[8]; - LONGINT pbfp, pvfp; + char _prvt0[16]; OPT_Struct BaseTyp; OPT_Object link, strobj; } OPT_StrDesc; diff --git a/bootstrap/unix-44/OPV.c b/bootstrap/unix-44/OPV.c index 23bff9c0..cf646f5e 100644 --- a/bootstrap/unix-44/OPV.c +++ b/bootstrap/unix-44/OPV.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "OPC.h" #include "OPM.h" @@ -23,7 +23,7 @@ export LONGINT *OPV_ExitInfo__typ; static void OPV_ActualPar (OPT_Node n, OPT_Object fp); export void OPV_AdrAndSize (OPT_Object topScope); static void OPV_CaseStat (OPT_Node n, OPT_Object outerProc); -static void OPV_Convert (OPT_Node n, INTEGER form, INTEGER prec); +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INTEGER prec); static void OPV_DefineTDescs (OPT_Node n); static void OPV_Entier (OPT_Node n, INTEGER prec); static void OPV_GetTProcNum (OPT_Object obj); @@ -38,6 +38,7 @@ static LONGINT OPV_NaturalAlignment (LONGINT size, LONGINT max); static void OPV_NewArr (OPT_Node d, OPT_Node x); static INTEGER OPV_Precedence (INTEGER class, INTEGER subclass, INTEGER form, INTEGER comp); static BOOLEAN OPV_SideEffects (OPT_Node n); +static void OPV_SizeCast (LONGINT size); static void OPV_Stamp (OPS_Name s); static OPT_Object OPV_SuperProc (OPT_Node n); static void OPV_Traverse (OPT_Object obj, OPT_Object outerScope, BOOLEAN exported); @@ -82,10 +83,10 @@ void OPV_TypSize (OPT_Struct typ) btyp = typ->BaseTyp; if (btyp == NIL) { offset = 0; - base = OPM_RecAlign; + base = OPC_SizeAlignment(OPM_RecSize); } else { OPV_TypSize(btyp); - offset = btyp->size - (LONGINT)__ASHR(btyp->sysflag, 8); + offset = btyp->size - (int)__ASHR(btyp->sysflag, 8); base = btyp->align; } fld = typ->link; @@ -93,7 +94,7 @@ void OPV_TypSize (OPT_Struct typ) btyp = fld->typ; OPV_TypSize(btyp); size = btyp->size; - fbase = OPC_Base(btyp); + fbase = OPC_BaseAlignment(btyp); OPC_Align(&offset, fbase); fld->adr = offset; offset += size; @@ -107,7 +108,7 @@ void OPV_TypSize (OPT_Struct typ) offset = 1; } if (OPM_RecSize == 0) { - base = OPV_NaturalAlignment(offset, OPM_RecAlign); + base = OPV_NaturalAlignment(offset, OPC_SizeAlignment(OPM_RecSize)); } OPC_Align(&offset, base); if ((typ->strobj == NIL && __MASK(typ->align, -65536) == 0)) { @@ -332,7 +333,7 @@ static INTEGER OPV_Precedence (INTEGER class, INTEGER subclass, INTEGER form, IN return _o_result; break; default: - OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence Nmop, subclass = ", (LONGINT)51); + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Nmop, subclass = ", (LONGINT)55); OPM_LogWNum(subclass, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -402,7 +403,7 @@ static INTEGER OPV_Precedence (INTEGER class, INTEGER subclass, INTEGER form, IN return _o_result; break; default: - OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence Ndop, subclass = ", (LONGINT)51); + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Ndop, subclass = ", (LONGINT)55); OPM_LogWNum(subclass, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -465,41 +466,26 @@ static void OPV_Entier (OPT_Node n, INTEGER prec) } } -static void OPV_Convert (OPT_Node n, INTEGER form, INTEGER prec) +static void OPV_SizeCast (LONGINT size) { - INTEGER from; + if (size <= 4) { + OPM_WriteString((CHAR*)"(int)", (LONGINT)6); + } else { + OPM_WriteString((CHAR*)"(SYSTEM_INT64)", (LONGINT)15); + } +} + +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INTEGER prec) +{ + INTEGER from, to; from = n->typ->form; - if (form == 9) { + to = newtype->form; + if (to == 9) { OPM_WriteString((CHAR*)"__SETOF(", (LONGINT)9); OPV_Entier(n, -1); OPM_Write(')'); - } else if (form == 6) { - if (from < 6) { - OPM_WriteString((CHAR*)"(LONGINT)", (LONGINT)10); - } - OPV_Entier(n, 9); - } else if (form == 5) { - if (from < 5) { - OPM_WriteString((CHAR*)"(int)", (LONGINT)6); - OPV_expr(n, 9); - } else { - if (__IN(2, OPM_opt)) { - OPM_WriteString((CHAR*)"__SHORT", (LONGINT)8); - if (OPV_SideEffects(n)) { - OPM_Write('F'); - } - OPM_Write('('); - OPV_Entier(n, -1); - OPM_WriteString((CHAR*)", ", (LONGINT)3); - OPM_WriteInt(OPM_MaxInt + 1); - OPM_Write(')'); - } else { - OPM_WriteString((CHAR*)"(int)", (LONGINT)6); - OPV_Entier(n, 9); - } - } - } else if (form == 4) { - if (__IN(2, OPM_opt)) { + } else if (__IN(to, 0x70)) { + if ((newtype->size < n->typ->size && __IN(2, OPM_opt))) { OPM_WriteString((CHAR*)"__SHORT", (LONGINT)8); if (OPV_SideEffects(n)) { OPM_Write('F'); @@ -507,13 +493,15 @@ static void OPV_Convert (OPT_Node n, INTEGER form, INTEGER prec) OPM_Write('('); OPV_Entier(n, -1); OPM_WriteString((CHAR*)", ", (LONGINT)3); - OPM_WriteInt(OPM_MaxSInt + 1); + OPM_WriteInt(OPM_SignedMaximum(newtype->size) + 1); OPM_Write(')'); } else { - OPM_WriteString((CHAR*)"(int)", (LONGINT)6); + if (newtype->size != n->typ->size) { + OPV_SizeCast(newtype->size); + } OPV_Entier(n, 9); } - } else if (form == 3) { + } else if (to == 3) { if (__IN(2, OPM_opt)) { OPM_WriteString((CHAR*)"__CHR", (LONGINT)6); if (OPV_SideEffects(n)) { @@ -576,7 +564,7 @@ static void OPV_design (OPT_Node n, INTEGER prec) OPT_Struct typ = NIL; INTEGER class, designPrec, comp; OPT_Node d = NIL, x = NIL; - INTEGER dims, i, _for__26; + INTEGER dims, i, _for__27; comp = n->typ->comp; obj = n->obj; class = n->class; @@ -652,15 +640,15 @@ static void OPV_design (OPT_Node n, INTEGER prec) } x = x->left; } - _for__26 = dims; + _for__27 = dims; i = 1; - while (i <= _for__26) { + while (i <= _for__27) { OPM_Write(')'); i += 1; } if (n->typ->comp == 3) { OPM_Write(')'); - while ((LONGINT)i < __ASHR(d->typ->size - 4, 2)) { + while ((int)i < __ASHR(d->typ->size - 4, 2)) { OPM_WriteString((CHAR*)" * ", (LONGINT)4); OPV_Len(d, i); i += 1; @@ -795,7 +783,7 @@ static void OPV_ActualPar (OPT_Node n, OPT_Object fp) } if ((((mode == 2 && n->class == 11)) && n->subcl == 29)) { OPV_expr(n->left, prec); - } else if ((((((form == 6 && n->class == 7)) && n->conval->intval <= OPM_MaxInt)) && n->conval->intval >= OPM_MinInt)) { + } else if ((((((form == 6 && n->class == 7)) && n->conval->intval <= OPM_SignedMaximum(OPM_IntSize))) && n->conval->intval >= OPM_SignedMinimum(OPM_IntSize))) { OPM_WriteString((CHAR*)"((LONGINT)(", (LONGINT)12); OPV_expr(n, prec); OPM_WriteString((CHAR*)"))", (LONGINT)3); @@ -914,7 +902,7 @@ static void OPV_expr (OPT_Node n, INTEGER prec) OPM_Write(')'); break; case 20: - OPV_Convert(l, form, exprPrec); + OPV_Convert(l, n->typ, exprPrec); break; case 21: if (OPV_SideEffects(l)) { @@ -943,7 +931,7 @@ static void OPV_expr (OPT_Node n, INTEGER prec) OPM_Write(')'); break; case 24: - OPM_WriteString((CHAR*)"(LONGINT)(uintptr_t)", (LONGINT)21); + OPM_WriteString((CHAR*)"(LONGINT)(SYSTEM_ADDRESS)", (LONGINT)26); if (l->class == 1) { OPC_CompleteIdent(l->obj); } else { @@ -954,20 +942,16 @@ static void OPV_expr (OPT_Node n, INTEGER prec) } break; case 29: - if ((((__IN(n->typ->form, 0x6240) && __IN(l->typ->form, 0x6240))) && n->typ->size == l->typ->size) || !__IN(l->class, 0x17)) { + if (!__IN(l->class, 0x17) || (((__IN(n->typ->form, 0x6240) && __IN(l->typ->form, 0x6240))) && n->typ->size == l->typ->size)) { OPM_Write('('); OPC_Ident(n->typ->strobj); OPM_Write(')'); if (__IN(n->typ->form, 0x6000) || __IN(l->typ->form, 0x6000)) { - OPM_WriteString((CHAR*)"(uintptr_t)", (LONGINT)12); + OPM_WriteString((CHAR*)"(SYSTEM_ADDRESS)", (LONGINT)17); } OPV_expr(l, exprPrec); } else { - if (__IN(n->typ->form, 0x6000) || __IN(l->typ->form, 0x6000)) { - OPM_WriteString((CHAR*)"__VALP(", (LONGINT)8); - } else { - OPM_WriteString((CHAR*)"__VAL(", (LONGINT)7); - } + OPM_WriteString((CHAR*)"__VAL(", (LONGINT)7); OPC_Ident(n->typ->strobj); OPM_WriteString((CHAR*)", ", (LONGINT)3); OPV_expr(l, -1); @@ -1326,7 +1310,7 @@ static void OPV_NewArr (OPT_Node d, OPT_Node x) OPM_WriteInt(base->size); OPM_WriteString((CHAR*)"))", (LONGINT)3); OPM_WriteString((CHAR*)", ", (LONGINT)3); - OPM_WriteInt(OPC_Base(base)); + OPM_WriteInt(OPC_BaseAlignment(base)); OPM_WriteString((CHAR*)", ", (LONGINT)3); OPM_WriteInt(nofdim); OPM_WriteString((CHAR*)", ", (LONGINT)3); diff --git a/bootstrap/unix-44/OPV.h b/bootstrap/unix-44/OPV.h index 0de9e6cc..04828b2f 100644 --- a/bootstrap/unix-44/OPV.h +++ b/bootstrap/unix-44/OPV.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPV__h #define OPV__h diff --git a/bootstrap/unix-44/Platform.c b/bootstrap/unix-44/Platform.c index 3cce2026..74c43788 100644 --- a/bootstrap/unix-44/Platform.c +++ b/bootstrap/unix-44/Platform.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" typedef @@ -118,14 +118,14 @@ export BOOLEAN Platform_getEnv (CHAR *var, LONGINT var__len, CHAR *val, LONGINT #define Platform_EXDEV() EXDEV extern void Heap_InitHeap(); #define Platform_HeapInitHeap() Heap_InitHeap() -#define Platform_allocate(size) (LONGINT)(uintptr_t)((void*)malloc((size_t)size)) +#define Platform_allocate(size) (LONGINT)(SYSTEM_ADDRESS)((void*)malloc((size_t)size)) #define Platform_chdir(n, n__len) chdir((char*)n) #define Platform_closefile(fd) close(fd) #define Platform_err() errno #define Platform_errc(c) write(1, &c, 1) #define Platform_errstring(s, s__len) write(1, s, s__len-1) #define Platform_exit(code) exit(code) -#define Platform_free(address) free((void*)(uintptr_t)address) +#define Platform_free(address) free((void*)(SYSTEM_ADDRESS)address) #define Platform_fstat(fd) fstat(fd, &s) #define Platform_fsync(fd) fsync(fd) #define Platform_ftruncate(fd, l) ftruncate(fd, l) @@ -138,13 +138,13 @@ extern void Heap_InitHeap(); #define Platform_opennew(n, n__len) open((char*)n, O_CREAT | O_TRUNC | O_RDWR, 0664) #define Platform_openro(n, n__len) open((char*)n, O_RDONLY) #define Platform_openrw(n, n__len) open((char*)n, O_RDWR) -#define Platform_readfile(fd, p, l) read(fd, (void*)(uintptr_t)(p), l) +#define Platform_readfile(fd, p, l) read(fd, (void*)(SYSTEM_ADDRESS)(p), l) #define Platform_rename(o, o__len, n, n__len) rename((char*)o, (char*)n) #define Platform_sectotm(s) struct tm *time = localtime((time_t*)&s) #define Platform_seekcur() SEEK_CUR #define Platform_seekend() SEEK_END #define Platform_seekset() SEEK_SET -#define Platform_sethandler(s, h) SystemSetHandler(s, (uintptr_t)h) +#define Platform_sethandler(s, h) SystemSetHandler(s, (SYSTEM_ADDRESS)h) #define Platform_stat(n, n__len) stat((char*)n, &s) #define Platform_statdev() (LONGINT)s.st_dev #define Platform_statino() (LONGINT)s.st_ino @@ -161,7 +161,7 @@ extern void Heap_InitHeap(); #define Platform_tvsec() tv.tv_sec #define Platform_tvusec() tv.tv_usec #define Platform_unlink(n, n__len) unlink((char*)n) -#define Platform_writefile(fd, p, l) write(fd, (void*)(uintptr_t)(p), l) +#define Platform_writefile(fd, p, l) write(fd, (void*)(SYSTEM_ADDRESS)(p), l) BOOLEAN Platform_TooManyFiles (INTEGER e) { @@ -229,7 +229,7 @@ void Platform_Init (INTEGER argc, LONGINT argvadr) Platform_ArgVecPtr av = NIL; Platform_MainStackFrame = argvadr; Platform_ArgCount = argc; - av = (Platform_ArgVecPtr)(uintptr_t)argvadr; + av = (Platform_ArgVecPtr)(SYSTEM_ADDRESS)argvadr; Platform_ArgVector = (*av)[0]; Platform_HaltCode = -128; Platform_HeapInitHeap(); @@ -262,7 +262,7 @@ void Platform_GetArg (INTEGER n, CHAR *val, LONGINT val__len) { Platform_ArgVec av = NIL; if (n < Platform_ArgCount) { - av = (Platform_ArgVec)(uintptr_t)Platform_ArgVector; + av = (Platform_ArgVec)(SYSTEM_ADDRESS)Platform_ArgVector; __COPY(*(*av)[__X(n, ((LONGINT)(1024)))], val, val__len); } } @@ -529,7 +529,7 @@ INTEGER Platform_Read (LONGINT h, LONGINT p, LONGINT l, LONGINT *n) INTEGER Platform_ReadBuf (LONGINT h, SYSTEM_BYTE *b, LONGINT b__len, LONGINT *n) { INTEGER _o_result; - *n = Platform_readfile(h, (LONGINT)(uintptr_t)b, b__len); + *n = Platform_readfile(h, (LONGINT)(SYSTEM_ADDRESS)b, b__len); if (*n < 0) { *n = 0; _o_result = Platform_err(); @@ -765,7 +765,7 @@ static void Platform_TestLittleEndian (void) { INTEGER i; i = 1; - __GET((LONGINT)(uintptr_t)&i, Platform_LittleEndian, BOOLEAN); + __GET((LONGINT)(SYSTEM_ADDRESS)&i, Platform_LittleEndian, BOOLEAN); } __TDESC(Platform_FileIdentity, 1, 0) = {__TDFLDS("FileIdentity", 12), {-4}}; diff --git a/bootstrap/unix-44/Platform.h b/bootstrap/unix-44/Platform.h index 581da770..dd5ce434 100644 --- a/bootstrap/unix-44/Platform.h +++ b/bootstrap/unix-44/Platform.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Platform__h #define Platform__h diff --git a/bootstrap/unix-44/Reals.c b/bootstrap/unix-44/Reals.c index 0f1c3a92..2323e34d 100644 --- a/bootstrap/unix-44/Reals.c +++ b/bootstrap/unix-44/Reals.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" @@ -58,7 +58,7 @@ INTEGER Reals_Expo (REAL x) { INTEGER _o_result; INTEGER i; - __GET((LONGINT)(uintptr_t)&x + 2, i, INTEGER); + __GET((LONGINT)(SYSTEM_ADDRESS)&x + 2, i, INTEGER); _o_result = __MASK(__ASHR(i, 7), -256); return _o_result; } @@ -66,17 +66,17 @@ INTEGER Reals_Expo (REAL x) void Reals_SetExpo (REAL *x, INTEGER ex) { CHAR c; - __GET((LONGINT)(uintptr_t)x + 3, c, CHAR); - __PUT((LONGINT)(uintptr_t)x + 3, (CHAR)(__ASHL(__ASHR((int)c, 7), 7) + __MASK(__ASHR(ex, 1), -128)), CHAR); - __GET((LONGINT)(uintptr_t)x + 2, c, CHAR); - __PUT((LONGINT)(uintptr_t)x + 2, (CHAR)(__MASK((int)c, -128) + __ASHL(__MASK(ex, -2), 7)), CHAR); + __GET((LONGINT)(SYSTEM_ADDRESS)x + 3, c, CHAR); + __PUT((LONGINT)(SYSTEM_ADDRESS)x + 3, (CHAR)(__ASHL(__ASHR((int)c, 7), 7) + __MASK(__ASHR(ex, 1), -128)), CHAR); + __GET((LONGINT)(SYSTEM_ADDRESS)x + 2, c, CHAR); + __PUT((LONGINT)(SYSTEM_ADDRESS)x + 2, (CHAR)(__MASK((int)c, -128) + __ASHL(__MASK(ex, -2), 7)), CHAR); } INTEGER Reals_ExpoL (LONGREAL x) { INTEGER _o_result; INTEGER i; - __GET((LONGINT)(uintptr_t)&x + 6, i, INTEGER); + __GET((LONGINT)(SYSTEM_ADDRESS)&x + 6, i, INTEGER); _o_result = __MASK(__ASHR(i, 4), -2048); return _o_result; } @@ -89,8 +89,8 @@ void Reals_ConvertL (LONGREAL x, INTEGER n, CHAR *d, LONGINT d__len) } k = 0; if (n > 9) { - i = __ENTIER(x / (LONGREAL)(LONGREAL)1000000000); - j = __ENTIER(x - i * (LONGREAL)1000000000); + i = (int)__ENTIER(x / (LONGREAL)(LONGREAL)1000000000); + j = (int)__ENTIER(x - i * (LONGREAL)1000000000); if (j < 0) { j = 0; } @@ -100,9 +100,9 @@ void Reals_ConvertL (LONGREAL x, INTEGER n, CHAR *d, LONGINT d__len) k += 1; } } else { - i = __ENTIER(x); + i = (int)__ENTIER(x); } - while (k < (LONGINT)n) { + while (k < (int)n) { d[__X(k, d__len)] = (CHAR)(__MOD(i, 10) + 48); i = __DIV(i, 10); k += 1; @@ -134,7 +134,7 @@ static void Reals_BytesToHex (SYSTEM_BYTE *b, LONGINT b__len, SYSTEM_BYTE *d, LO CHAR by; i = 0; l = b__len; - while ((LONGINT)i < l) { + while ((int)i < l) { by = __VAL(CHAR, b[__X(i, b__len)]); d[__X(__ASHL(i, 1), d__len)] = Reals_ToHex(__ASHR((int)by, 4)); d[__X(__ASHL(i, 1) + 1, d__len)] = Reals_ToHex(__MASK((int)by, -16)); diff --git a/bootstrap/unix-44/Reals.h b/bootstrap/unix-44/Reals.h index 4a783296..7e6b534c 100644 --- a/bootstrap/unix-44/Reals.h +++ b/bootstrap/unix-44/Reals.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Reals__h #define Reals__h diff --git a/bootstrap/unix-44/SYSTEM.c b/bootstrap/unix-44/SYSTEM.c index 50e91c6d..33511a70 100644 --- a/bootstrap/unix-44/SYSTEM.c +++ b/bootstrap/unix-44/SYSTEM.c @@ -35,7 +35,7 @@ void SYSTEM_INHERIT(LONGINT *t, LONGINT *t0) void SYSTEM_ENUMP(void *adr, LONGINT n, void (*P)()) { while (n > 0) { - P((LONGINT)(uintptr_t)(*((void**)(adr)))); + P((LONGINT)(SYSTEM_ADDRESS)(*((void**)(adr)))); adr = ((void**)adr) + 1; n--; } @@ -106,7 +106,7 @@ SYSTEM_PTR SYSTEM_NEWARR(LONGINT *typ, LONGINT elemsz, int elemalgn, int nofdim, else if (typ == (LONGINT*)POINTER__typ) { /* element type is a pointer */ x = Heap_NEWBLK(size + nofelems * sizeof(LONGINT)); - p = (LONGINT*)(uintptr_t)x[-1]; + p = (LONGINT*)(SYSTEM_ADDRESS)x[-1]; p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */ while (n <= nofelems) {*p = n*sizeof(LONGINT); p++; n++;} @@ -119,7 +119,7 @@ SYSTEM_PTR SYSTEM_NEWARR(LONGINT *typ, LONGINT elemsz, int elemalgn, int nofdim, while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */ nptr = nofelems * nofptrs; /* total number of pointers */ x = Heap_NEWBLK(size + nptr * sizeof(LONGINT)); - p = (LONGINT*)(uintptr_t)x[- 1]; + p = (LONGINT*)(SYSTEM_ADDRESS)x[- 1]; p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ p -= nptr - 1; n = 0; off = dataoff; while (n < nofelems) {i = 0; @@ -155,7 +155,7 @@ typedef void (*SystemSignalHandler)(INTEGER); // = Platform_SignalHandler // (Ignore other signals) } - void SystemSetHandler(int s, uintptr_t h) { + void SystemSetHandler(int s, SYSTEM_ADDRESS h) { if (s >= 2 && s <= 4) { int needtosetsystemhandler = handler[s-2] == 0; handler[s-2] = (SystemSignalHandler)h; @@ -194,12 +194,12 @@ typedef void (*SystemSignalHandler)(INTEGER); // = Platform_SignalHandler } } - void SystemSetInterruptHandler(uintptr_t h) { + void SystemSetInterruptHandler(SYSTEM_ADDRESS h) { EnsureConsoleCtrlHandler(); SystemInterruptHandler = (SystemSignalHandler)h; } - void SystemSetQuitHandler(uintptr_t h) { + void SystemSetQuitHandler(SYSTEM_ADDRESS h) { EnsureConsoleCtrlHandler(); SystemQuitHandler = (SystemSignalHandler)h; } diff --git a/bootstrap/unix-44/SYSTEM.h b/bootstrap/unix-44/SYSTEM.h index 949951ac..6377745e 100644 --- a/bootstrap/unix-44/SYSTEM.h +++ b/bootstrap/unix-44/SYSTEM.h @@ -1,28 +1,38 @@ #ifndef SYSTEM__h #define SYSTEM__h -#ifndef _WIN32 - - // Building for a Unix/Linux based system - #include // For memcpy ... - #include // For uintptr_t ... - +#if defined(_WIN64) + typedef long long SYSTEM_INT64; + typedef unsigned long long SYSTEM_CARD64; #else - - // Building for Windows platform with either mingw under cygwin, or the MS C compiler - #ifdef _WIN64 - typedef unsigned long long size_t; - typedef unsigned long long uintptr_t; - #else - typedef unsigned int size_t; - typedef unsigned int uintptr_t; - #endif /* _WIN64 */ - - typedef unsigned int uint32_t; - void * __cdecl memcpy(void * dest, const void * source, size_t size); - + typedef long SYSTEM_INT64; + typedef unsigned long SYSTEM_CARD64; #endif +typedef int SYSTEM_INT32; +typedef unsigned int SYSTEM_CARD32; +typedef short int SYSTEM_INT16; +typedef unsigned short int SYSTEM_CARD16; +typedef signed char SYSTEM_INT8; +typedef unsigned char SYSTEM_CARD8; + +#if (__SIZEOF_POINTER__ == 8) || defined(_WIN64) || defined(__LP64__) + #if defined(_WIN64) + typedef unsigned long long size_t; + #else + typedef unsigned long size_t; + #endif +#else + typedef unsigned int size_t; +#endif + +#define SYSTEM_ADDRESS size_t +#define _SIZE_T_DECLARED // For FreeBSD +#define _SIZE_T_DEFINED_ // For OpenBSD + +void *memcpy(void *dest, const void *source, SYSTEM_ADDRESS size); + + // The compiler uses 'import' and 'export' which translate to 'extern' and // nothing respectively. @@ -70,6 +80,7 @@ typedef unsigned char U_SHORTINT; #endif typedef U_LONGINT SET; +typedef U_LONGINT U_SET; // OS Memory allocation interfaces are in PlatformXXX.Mod @@ -96,10 +107,10 @@ extern LONGINT SYSTEM_ENTIER (double x); // Signal handling in SYSTEM.c #ifndef _WIN32 - extern void SystemSetHandler(int s, uintptr_t h); + extern void SystemSetHandler(int s, SYSTEM_ADDRESS h); #else - extern void SystemSetInterruptHandler(uintptr_t h); - extern void SystemSetQuitHandler (uintptr_t h); + extern void SystemSetInterruptHandler(SYSTEM_ADDRESS h); + extern void SystemSetQuitHandler (SYSTEM_ADDRESS h); #endif @@ -122,20 +133,20 @@ static int __str_cmp(CHAR *x, CHAR *y){ #define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d; LONGINT _i=0,_t=n-1; \ while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;} -#define __DUP(x, l, t) x=(void*)memcpy((void*)(uintptr_t)Platform_OSAllocate(l*sizeof(t)),x,l*sizeof(t)) +#define __DUP(x, l, t) x=(void*)memcpy((void*)(SYSTEM_ADDRESS)Platform_OSAllocate(l*sizeof(t)),x,l*sizeof(t)) #define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) -#define __DEL(x) Platform_OSFree((LONGINT)(uintptr_t)x) +#define __DEL(x) Platform_OSFree((LONGINT)(SYSTEM_ADDRESS)x) /* SYSTEM ops */ -#define __VAL(t, x) ((t)(x)) -#define __VALP(t, x) ((t)(uintptr_t)(x)) +#define __VAL(t, x) (*(t*)&(x)) -#define __GET(a, x, t) x= *(t*)(uintptr_t)(a) -#define __PUT(a, x, t) *(t*)(uintptr_t)(a)=x + +#define __GET(a, x, t) x= *(t*)(SYSTEM_ADDRESS)(a) +#define __PUT(a, x, t) *(t*)(SYSTEM_ADDRESS)(a)=x #define __LSHL(x, n, t) ((t)((U_##t)(x)<<(n))) #define __LSHR(x, n, t) ((t)((U_##t)(x)>>(n))) @@ -150,7 +161,7 @@ static int __str_cmp(CHAR *x, CHAR *y){ #define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t)) #define __BIT(x, n) (*(U_LONGINT*)(x)>>(n)&1) -#define __MOVE(s, d, n) memcpy((char*)(uintptr_t)(d),(char*)(uintptr_t)(s),n) +#define __MOVE(s, d, n) memcpy((char*)(SYSTEM_ADDRESS)(d),(char*)(SYSTEM_ADDRESS)(s),n) #define __ASHF(x, n) SYSTEM_ASH((LONGINT)(x), (LONGINT)(n)) #define __SHORT(x, y) ((int)((U_LONGINT)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0))) #define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y))) @@ -211,7 +222,7 @@ extern void Heap_INCREF(); extern void Platform_Init(INTEGER argc, LONGINT argv); extern void Heap_FINALL(); -#define __INIT(argc, argv) static void *m; Platform_Init((INTEGER)argc, (LONGINT)(uintptr_t)&argv); +#define __INIT(argc, argv) static void *m; Platform_Init((INTEGER)argc, (LONGINT)(SYSTEM_ADDRESS)&argv); #define __REGMAIN(name, enum) m = Heap_REGMOD((CHAR*)name,enum) #define __FINI Heap_FINALL(); return 0 @@ -232,7 +243,7 @@ extern SYSTEM_PTR Heap_NEWREC (LONGINT tag); extern SYSTEM_PTR SYSTEM_NEWARR(LONGINT*, LONGINT, int, int, int, ...); #define __SYSNEW(p, len) p = Heap_NEWBLK((LONGINT)(len)) -#define __NEW(p, t) p = Heap_NEWREC((LONGINT)(uintptr_t)t##__typ) +#define __NEW(p, t) p = Heap_NEWREC((LONGINT)(SYSTEM_ADDRESS)t##__typ) #define __NEWARR SYSTEM_NEWARR @@ -263,20 +274,20 @@ extern SYSTEM_PTR SYSTEM_NEWARR(LONGINT*, LONGINT, int, int, int, ...); #define __INITYP(t, t0, level) \ t##__typ = (LONGINT*)&t##__desc.blksz; \ memcpy(t##__desc.basep, t0##__typ - __BASEOFF, level*sizeof(LONGINT)); \ - t##__desc.basep[level] = (LONGINT)(uintptr_t)t##__typ; \ - t##__desc.module = (LONGINT)(uintptr_t)m; \ + t##__desc.basep[level] = (LONGINT)(SYSTEM_ADDRESS)t##__typ; \ + t##__desc.module = (LONGINT)(SYSTEM_ADDRESS)m; \ if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ t##__desc.blksz = (t##__desc.blksz+5*sizeof(LONGINT)-1)/(4*sizeof(LONGINT))*(4*sizeof(LONGINT)); \ - Heap_REGTYP(m, (LONGINT)(uintptr_t)&t##__desc.next); \ + Heap_REGTYP(m, (LONGINT)(SYSTEM_ADDRESS)&t##__desc.next); \ SYSTEM_INHERIT(t##__typ, t0##__typ) -#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(LONGINT)(uintptr_t)typ##__typ) -#define __TYPEOF(p) ((LONGINT*)(uintptr_t)(*(((LONGINT*)(p))-1))) +#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(LONGINT)(SYSTEM_ADDRESS)typ##__typ) +#define __TYPEOF(p) ((LONGINT*)(SYSTEM_ADDRESS)(*(((LONGINT*)(p))-1))) #define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) // Oberon-2 type bound procedures support -#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(LONGINT)(uintptr_t)proc -#define __SEND(typ, num, funtyp, parlist) ((funtyp)((uintptr_t)*(typ-(__TPROC0OFF+num))))parlist +#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(LONGINT)(SYSTEM_ADDRESS)proc +#define __SEND(typ, num, funtyp, parlist) ((funtyp)((SYSTEM_ADDRESS)*(typ-(__TPROC0OFF+num))))parlist diff --git a/bootstrap/unix-44/Strings.c b/bootstrap/unix-44/Strings.c index d2713d0f..115456ea 100644 --- a/bootstrap/unix-44/Strings.c +++ b/bootstrap/unix-44/Strings.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" @@ -21,7 +21,7 @@ INTEGER Strings_Length (CHAR *s, LONGINT s__len) INTEGER i; __DUP(s, s__len, CHAR); i = 0; - while (((LONGINT)i < s__len && s[__X(i, s__len)] != 0x00)) { + while (((int)i < s__len && s[__X(i, s__len)] != 0x00)) { i += 1; } _o_result = i; @@ -36,11 +36,11 @@ void Strings_Append (CHAR *extra, LONGINT extra__len, CHAR *dest, LONGINT dest__ n1 = Strings_Length(dest, dest__len); n2 = Strings_Length(extra, extra__len); i = 0; - while ((i < n2 && (LONGINT)(i + n1) < dest__len)) { + while ((i < n2 && (int)(i + n1) < dest__len)) { dest[__X(i + n1, dest__len)] = extra[__X(i, extra__len)]; i += 1; } - if ((LONGINT)(i + n1) < dest__len) { + if ((int)(i + n1) < dest__len) { dest[__X(i + n1, dest__len)] = 0x00; } __DEL(extra); @@ -59,10 +59,10 @@ void Strings_Insert (CHAR *source, LONGINT source__len, INTEGER pos, CHAR *dest, Strings_Append(dest, dest__len, (void*)source, source__len); return; } - if ((LONGINT)(pos + n2) < dest__len) { + if ((int)(pos + n2) < dest__len) { i = n1; while (i >= pos) { - if ((LONGINT)(i + n2) < dest__len) { + if ((int)(i + n2) < dest__len) { dest[__X(i + n2, dest__len)] = dest[__X(i, dest__len)]; } i -= 1; @@ -91,7 +91,7 @@ void Strings_Delete (CHAR *s, LONGINT s__len, INTEGER pos, INTEGER n) s[__X(i - n, s__len)] = s[__X(i, s__len)]; i += 1; } - if ((LONGINT)(i - n) < s__len) { + if ((int)(i - n) < s__len) { s[__X(i - n, s__len)] = 0x00; } } else { @@ -121,7 +121,7 @@ void Strings_Extract (CHAR *source, LONGINT source__len, INTEGER pos, INTEGER n, return; } i = 0; - while (((((LONGINT)(pos + i) <= source__len && source[__X(pos + i, source__len)] != 0x00)) && i < n)) { + while (((((int)(pos + i) <= source__len && source[__X(pos + i, source__len)] != 0x00)) && i < n)) { if (i < destLen) { dest[__X(i, dest__len)] = source[__X(pos + i, source__len)]; } diff --git a/bootstrap/unix-44/Strings.h b/bootstrap/unix-44/Strings.h index 5f45d8a8..96dbb01d 100644 --- a/bootstrap/unix-44/Strings.h +++ b/bootstrap/unix-44/Strings.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Strings__h #define Strings__h diff --git a/bootstrap/unix-44/Texts.c b/bootstrap/unix-44/Texts.c index 0e6ee85e..9ab3b430 100644 --- a/bootstrap/unix-44/Texts.c +++ b/bootstrap/unix-44/Texts.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Files.h" #include "Modules.h" @@ -787,9 +787,9 @@ void Texts_Scan (Texts_Scanner *S, LONGINT *S__typ) (*S).s[__X(i, ((LONGINT)(64)))] = 0x00; (*S).len = i; (*S).class = 1; - } else if (ch == '\"') { + } else if (ch == '"') { Texts_Read((void*)&*S, S__typ, &ch); - while ((((ch != '\"' && ch >= ' ')) && i != 63)) { + while ((((ch != '"' && ch >= ' ')) && i != 63)) { (*S).s[__X(i, ((LONGINT)(64)))] = ch; i += 1; Texts_Read((void*)&*S, S__typ, &ch); @@ -839,7 +839,7 @@ void Texts_Scan (Texts_Scanner *S, LONGINT *S__typ) k -= 16; } while (j < i) { - k = __ASHL(k, 4) + (LONGINT)((int)d[__X(j, ((LONGINT)(32)))] - 48); + k = __ASHL(k, 4) + (int)((int)d[__X(j, ((LONGINT)(32)))] - 48); j += 1; } if (neg) { @@ -929,7 +929,7 @@ void Texts_Scan (Texts_Scanner *S, LONGINT *S__typ) (*S).class = 3; k = 0; do { - k = k * 10 + (LONGINT)((int)d[__X(j, ((LONGINT)(32)))] - 48); + k = k * 10 + (int)((int)d[__X(j, ((LONGINT)(32)))] - 48); j += 1; } while (!(j == i)); if (neg) { @@ -1067,7 +1067,7 @@ void Texts_WriteInt (Texts_Writer *W, LONGINT *W__typ, LONGINT x, LONGINT n) x0 = __DIV(x0, 10); i += 1; } while (!(x0 == 0)); - while (n > (LONGINT)i) { + while (n > (int)i) { Texts_Write(&*W, W__typ, ' '); n -= 1; } @@ -1319,7 +1319,7 @@ void Texts_WriteLongReal (Texts_Writer *W, LONGINT *W__typ, LONGREAL x, INTEGER } else { Texts_Write(&*W, W__typ, ' '); } - e = (int)__ASHR((LONGINT)(e - 1023) * 77, 8); + e = (int)__ASHR((int)(e - 1023) * 77, 8); if (e >= 0) { x = x / (LONGREAL)Reals_TenL(e); } else { diff --git a/bootstrap/unix-44/Texts.h b/bootstrap/unix-44/Texts.h index c8abf16a..777a6c22 100644 --- a/bootstrap/unix-44/Texts.h +++ b/bootstrap/unix-44/Texts.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Texts__h #define Texts__h diff --git a/bootstrap/unix-44/Vishap.c b/bootstrap/unix-44/Vishap.c index 74d0e984..4c9e3b45 100644 --- a/bootstrap/unix-44/Vishap.c +++ b/bootstrap/unix-44/Vishap.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkamSf */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkamSf */ #include "SYSTEM.h" #include "Configuration.h" #include "Heap.h" diff --git a/bootstrap/unix-44/errors.c b/bootstrap/unix-44/errors.c index f8ddb53a..68e433df 100644 --- a/bootstrap/unix-44/errors.c +++ b/bootstrap/unix-44/errors.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" typedef @@ -25,7 +25,7 @@ export void *errors__init(void) errors_errors[6][0] = 0x00; errors_errors[7][0] = 0x00; errors_errors[8][0] = 0x00; - __MOVE("\'=\' expected", errors_errors[9], 13); + __MOVE("'=' expected", errors_errors[9], 13); errors_errors[10][0] = 0x00; errors_errors[11][0] = 0x00; __MOVE("type definition starts with incorrect symbol", errors_errors[12], 45); @@ -34,28 +34,28 @@ export void *errors__init(void) __MOVE("declaration followed by incorrect symbol", errors_errors[15], 41); __MOVE("MODULE expected", errors_errors[16], 16); errors_errors[17][0] = 0x00; - __MOVE("\'.\' missing", errors_errors[18], 12); - __MOVE("\',\' missing", errors_errors[19], 12); - __MOVE("\':\' missing", errors_errors[20], 12); + __MOVE("'.' missing", errors_errors[18], 12); + __MOVE("',' missing", errors_errors[19], 12); + __MOVE("':' missing", errors_errors[20], 12); errors_errors[21][0] = 0x00; - __MOVE("\')\' missing", errors_errors[22], 12); - __MOVE("\']\' missing", errors_errors[23], 12); - __MOVE("\'}\' missing", errors_errors[24], 12); + __MOVE("')' missing", errors_errors[22], 12); + __MOVE("']' missing", errors_errors[23], 12); + __MOVE("'}' missing", errors_errors[24], 12); __MOVE("OF missing", errors_errors[25], 11); __MOVE("THEN missing", errors_errors[26], 13); __MOVE("DO missing", errors_errors[27], 11); __MOVE("TO missing", errors_errors[28], 11); errors_errors[29][0] = 0x00; - __MOVE("\'(\' missing", errors_errors[30], 12); + __MOVE("'(' missing", errors_errors[30], 12); errors_errors[31][0] = 0x00; errors_errors[32][0] = 0x00; errors_errors[33][0] = 0x00; - __MOVE("\':=\' missing", errors_errors[34], 13); - __MOVE("\',\' or OF expected", errors_errors[35], 19); + __MOVE("':=' missing", errors_errors[34], 13); + __MOVE("',' or OF expected", errors_errors[35], 19); errors_errors[36][0] = 0x00; errors_errors[37][0] = 0x00; __MOVE("identifier expected", errors_errors[38], 20); - __MOVE("\';\' missing", errors_errors[39], 12); + __MOVE("';' missing", errors_errors[39], 12); errors_errors[40][0] = 0x00; __MOVE("END missing", errors_errors[41], 12); errors_errors[42][0] = 0x00; @@ -131,10 +131,10 @@ export void *errors__init(void) __MOVE("operand is not a variable", errors_errors[112], 26); __MOVE("incompatible assignment", errors_errors[113], 24); __MOVE("string too long to be assigned", errors_errors[114], 31); - __MOVE("parameter doesn\'t match", errors_errors[115], 24); - __MOVE("number of parameters doesn\'t match", errors_errors[116], 35); - __MOVE("result type doesn\'t match", errors_errors[117], 26); - __MOVE("export mark doesn\'t match with forward declaration", errors_errors[118], 51); + __MOVE("parameter doesn't match", errors_errors[115], 24); + __MOVE("number of parameters doesn't match", errors_errors[116], 35); + __MOVE("result type doesn't match", errors_errors[117], 26); + __MOVE("export mark doesn't match with forward declaration", errors_errors[118], 51); __MOVE("redefinition textually precedes procedure bound to base type", errors_errors[119], 61); __MOVE("type of expression following IF, WHILE, UNTIL or ASSERT is not BOOLEAN", errors_errors[120], 71); __MOVE("called object is not a procedure (or is an interrupt procedure)", errors_errors[121], 64); @@ -194,5 +194,6 @@ export void *errors__init(void) __MOVE("implicit type cast", errors_errors[301], 19); __MOVE("inappropriate symbol file ignored", errors_errors[306], 34); __MOVE("no ELSE symbol after CASE statement sequence may lead to trap", errors_errors[307], 62); + __MOVE("SYSTEM.VAL result includes memory past end of source variable", errors_errors[308], 62); __ENDMOD; } diff --git a/bootstrap/unix-44/errors.h b/bootstrap/unix-44/errors.h index 5068083b..41d399ad 100644 --- a/bootstrap/unix-44/errors.h +++ b/bootstrap/unix-44/errors.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef errors__h #define errors__h diff --git a/bootstrap/unix-44/extTools.c b/bootstrap/unix-44/extTools.c index 03bd540b..4efd107a 100644 --- a/bootstrap/unix-44/extTools.c +++ b/bootstrap/unix-44/extTools.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Configuration.h" #include "Console.h" diff --git a/bootstrap/unix-44/extTools.h b/bootstrap/unix-44/extTools.h index 695ea164..fc4f0da1 100644 --- a/bootstrap/unix-44/extTools.h +++ b/bootstrap/unix-44/extTools.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef extTools__h #define extTools__h diff --git a/bootstrap/unix-44/vt100.c b/bootstrap/unix-44/vt100.c index c499aceb..d77b0b84 100644 --- a/bootstrap/unix-44/vt100.c +++ b/bootstrap/unix-44/vt100.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Console.h" #include "Strings.h" @@ -252,7 +252,7 @@ export void *vt100__init(void) __REGCMD("RCP", vt100_RCP); __REGCMD("SCP", vt100_SCP); /* BEGIN */ - __COPY("", vt100_CSI, ((LONGINT)(5))); + __COPY("\033", vt100_CSI, ((LONGINT)(5))); Strings_Append((CHAR*)"[", (LONGINT)2, (void*)vt100_CSI, ((LONGINT)(5))); __ENDMOD; } diff --git a/bootstrap/unix-44/vt100.h b/bootstrap/unix-44/vt100.h index 1aaeca77..4af04d6e 100644 --- a/bootstrap/unix-44/vt100.h +++ b/bootstrap/unix-44/vt100.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef vt100__h #define vt100__h diff --git a/bootstrap/unix-48/Configuration.c b/bootstrap/unix-48/Configuration.c index 1f5afbb7..821dff97 100644 --- a/bootstrap/unix-48/Configuration.c +++ b/bootstrap/unix-48/Configuration.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" @@ -13,6 +13,6 @@ export void *Configuration__init(void) __DEFMOD; __REGMOD("Configuration", 0); /* BEGIN */ - __MOVE("1.95 [2016/08/24] for gcc LP64 on cygwin", Configuration_versionLong, 41); + __MOVE("1.95 [2016/08/23] for gcc LP64 on cygwin", Configuration_versionLong, 41); __ENDMOD; } diff --git a/bootstrap/unix-48/Configuration.h b/bootstrap/unix-48/Configuration.h index eef3a15d..ec5e865a 100644 --- a/bootstrap/unix-48/Configuration.h +++ b/bootstrap/unix-48/Configuration.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Configuration__h #define Configuration__h diff --git a/bootstrap/unix-48/Console.c b/bootstrap/unix-48/Console.c index 5fa65e00..f9161937 100644 --- a/bootstrap/unix-48/Console.c +++ b/bootstrap/unix-48/Console.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Platform.h" @@ -21,7 +21,7 @@ export void Console_String (CHAR *s, LONGINT s__len); void Console_Flush (void) { INTEGER error; - error = Platform_Write(((LONGINT)(1)), (LONGINT)(uintptr_t)Console_line, Console_pos); + error = Platform_Write(((LONGINT)(1)), (LONGINT)(SYSTEM_ADDRESS)Console_line, Console_pos); Console_pos = 0; } diff --git a/bootstrap/unix-48/Console.h b/bootstrap/unix-48/Console.h index 53dbdfa8..5fdd4e4d 100644 --- a/bootstrap/unix-48/Console.h +++ b/bootstrap/unix-48/Console.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Console__h #define Console__h diff --git a/bootstrap/unix-48/Files.c b/bootstrap/unix-48/Files.c index 5d92e963..5a1dd875 100644 --- a/bootstrap/unix-48/Files.c +++ b/bootstrap/unix-48/Files.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #include "SYSTEM.h" #include "Configuration.h" #include "Console.h" @@ -257,7 +257,7 @@ static void Files_Flush (Files_Buffer buf) if (buf->org != f->pos) { error = Platform_Seek(f->fd, buf->org, Platform_SeekSet); } - error = Platform_Write(f->fd, (LONGINT)(uintptr_t)buf->data, buf->size); + error = Platform_Write(f->fd, (LONGINT)(SYSTEM_ADDRESS)buf->data, buf->size); if (error != 0) { Files_Err((CHAR*)"error writing file", (LONGINT)19, f, error); } @@ -656,7 +656,7 @@ void Files_ReadBytes (Files_Rider *r, LONGINT *r__typ, SYSTEM_BYTE *x, LONGINT x } else { min = n; } - __MOVE((LONGINT)(uintptr_t)buf->data + offset, (LONGINT)(uintptr_t)x + xpos, min); + __MOVE((LONGINT)(SYSTEM_ADDRESS)buf->data + offset, (LONGINT)(SYSTEM_ADDRESS)x + xpos, min); offset += min; (*r).offset = offset; xpos += min; @@ -721,7 +721,7 @@ void Files_WriteBytes (Files_Rider *r, LONGINT *r__typ, SYSTEM_BYTE *x, LONGINT } else { min = n; } - __MOVE((LONGINT)(uintptr_t)x + xpos, (LONGINT)(uintptr_t)buf->data + offset, min); + __MOVE((LONGINT)(SYSTEM_ADDRESS)x + xpos, (LONGINT)(SYSTEM_ADDRESS)buf->data + offset, min); offset += min; (*r).offset = offset; if (offset > buf->size) { @@ -772,15 +772,15 @@ void Files_Rename (CHAR *old, LONGINT old__len, CHAR *new, LONGINT new__len, INT *res = 3; return; } - error = Platform_Read(fdold, (LONGINT)(uintptr_t)buf, ((LONGINT)(4096)), &n); + error = Platform_Read(fdold, (LONGINT)(SYSTEM_ADDRESS)buf, ((LONGINT)(4096)), &n); while (n > 0) { - error = Platform_Write(fdnew, (LONGINT)(uintptr_t)buf, n); + error = Platform_Write(fdnew, (LONGINT)(SYSTEM_ADDRESS)buf, n); if (error != 0) { ignore = Platform_Close(fdold); ignore = Platform_Close(fdnew); Files_Err((CHAR*)"cannot move file", (LONGINT)17, NIL, error); } - error = Platform_Read(fdold, (LONGINT)(uintptr_t)buf, ((LONGINT)(4096)), &n); + error = Platform_Read(fdold, (LONGINT)(SYSTEM_ADDRESS)buf, ((LONGINT)(4096)), &n); } ignore = Platform_Close(fdold); ignore = Platform_Close(fdnew); @@ -838,7 +838,7 @@ static void Files_FlipBytes (SYSTEM_BYTE *src, LONGINT src__len, SYSTEM_BYTE *de j += 1; } } else { - __MOVE((LONGINT)(uintptr_t)src, (LONGINT)(uintptr_t)dest, src__len); + __MOVE((LONGINT)(SYSTEM_ADDRESS)src, (LONGINT)(SYSTEM_ADDRESS)dest, src__len); } } @@ -858,14 +858,16 @@ void Files_ReadLInt (Files_Rider *R, LONGINT *R__typ, LONGINT *x) { CHAR b[4]; Files_ReadBytes(&*R, R__typ, (void*)b, ((LONGINT)(4)), ((LONGINT)(4))); - *x = ((LONGINT)((int)b[0] + __ASHL((int)b[1], 8)) + __ASHL((LONGINT)b[2], 16)) + __ASHL((LONGINT)b[3], 24); + *x = ((int)((int)b[0] + __ASHL((int)b[1], 8)) + __ASHL((int)b[2], 16)) + __ASHL((int)b[3], 24); } void Files_ReadSet (Files_Rider *R, LONGINT *R__typ, SET *x) { CHAR b[4]; + LONGINT l; Files_ReadBytes(&*R, R__typ, (void*)b, ((LONGINT)(4)), ((LONGINT)(4))); - *x = (SET)(((LONGINT)((int)b[0] + __ASHL((int)b[1], 8)) + __ASHL((LONGINT)b[2], 16)) + __ASHL((LONGINT)b[3], 24)); + l = ((int)((int)b[0] + __ASHL((int)b[1], 8)) + __ASHL((int)b[2], 16)) + __ASHL((int)b[3], 24); + *x = (SET)l; } void Files_ReadReal (Files_Rider *R, LONGINT *R__typ, REAL *x) @@ -921,11 +923,11 @@ void Files_ReadNum (Files_Rider *R, LONGINT *R__typ, LONGINT *x) n = 0; Files_Read(&*R, R__typ, (void*)&ch); while ((int)ch >= 128) { - n += __ASH((LONGINT)((int)ch - 128), s); + n += __ASH((int)((int)ch - 128), s); s += 7; Files_Read(&*R, R__typ, (void*)&ch); } - n += __ASH((LONGINT)(__MASK((int)ch, -64) - __ASHL(__ASHR((int)ch, 6), 6)), s); + n += __ASH((int)(__MASK((int)ch, -64) - __ASHL(__ASHR((int)ch, 6), 6)), s); *x = n; } @@ -1006,7 +1008,7 @@ static void Files_Finalize (SYSTEM_PTR o) { Files_File f = NIL; LONGINT res; - f = (Files_File)(uintptr_t)o; + f = (Files_File)(SYSTEM_ADDRESS)o; if (f->fd >= 0) { Files_CloseOSFile(f); if (f->tempFile) { diff --git a/bootstrap/unix-48/Files.h b/bootstrap/unix-48/Files.h index b60e6242..a4a4ea8c 100644 --- a/bootstrap/unix-48/Files.h +++ b/bootstrap/unix-48/Files.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #ifndef Files__h #define Files__h diff --git a/bootstrap/unix-48/Heap.c b/bootstrap/unix-48/Heap.c index 4cabf8c6..30ec687a 100644 --- a/bootstrap/unix-48/Heap.c +++ b/bootstrap/unix-48/Heap.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tskSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tskSfF */ #include "SYSTEM.h" struct Heap__1 { @@ -101,7 +101,7 @@ export void Heap_Unlock (void); extern void *Heap__init(); extern LONGINT Platform_MainStackFrame; extern LONGINT Platform_OSAllocate(LONGINT size); -#define Heap_FetchAddress(pointer) (LONGINT)(uintptr_t)(*((void**)((uintptr_t)pointer))) +#define Heap_FetchAddress(pointer) (LONGINT)(SYSTEM_ADDRESS)(*((void**)((SYSTEM_ADDRESS)pointer))) #define Heap_HeapModuleInit() Heap__init() #define Heap_OSAllocate(size) Platform_OSAllocate(size) #define Heap_PlatformHalt(code) Platform_Halt(code) @@ -134,7 +134,7 @@ SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs) __COPY(name, m->name, ((LONGINT)(20))); m->refcnt = 0; m->enumPtrs = enumPtrs; - m->next = (Heap_Module)(uintptr_t)Heap_modules; + m->next = (Heap_Module)(SYSTEM_ADDRESS)Heap_modules; Heap_modules = (SYSTEM_PTR)m; _o_result = (void*)m; return _o_result; @@ -315,7 +315,7 @@ SYSTEM_PTR Heap_NEWREC (LONGINT tag) __PUT(adr + 8, 0, LONGINT); Heap_allocated += blksz; Heap_Unlock(); - _o_result = (SYSTEM_PTR)(uintptr_t)(adr + 4); + _o_result = (SYSTEM_PTR)(SYSTEM_ADDRESS)(adr + 4); return _o_result; } @@ -326,12 +326,12 @@ SYSTEM_PTR Heap_NEWBLK (LONGINT size) SYSTEM_PTR new; Heap_Lock(); blksz = __ASHL(__ASHR(size + 31, 4), 4); - new = Heap_NEWREC((LONGINT)(uintptr_t)&blksz); - tag = ((LONGINT)(uintptr_t)new + blksz) - 12; + new = Heap_NEWREC((LONGINT)(SYSTEM_ADDRESS)&blksz); + tag = ((LONGINT)(SYSTEM_ADDRESS)new + blksz) - 12; __PUT(tag - 4, 0, LONGINT); __PUT(tag, blksz, LONGINT); __PUT(tag + 4, -4, LONGINT); - __PUT((LONGINT)(uintptr_t)new - 4, tag, LONGINT); + __PUT((LONGINT)(SYSTEM_ADDRESS)new - 4, tag, LONGINT); Heap_Unlock(); _o_result = new; return _o_result; @@ -360,7 +360,7 @@ static void Heap_Mark (LONGINT q) __GET(tag, offset, LONGINT); fld = q + offset; p = Heap_FetchAddress(fld); - __PUT(fld, (SYSTEM_PTR)(uintptr_t)n, SYSTEM_PTR); + __PUT(fld, (SYSTEM_PTR)(SYSTEM_ADDRESS)n, SYSTEM_PTR); } else { fld = q + offset; n = Heap_FetchAddress(fld); @@ -369,7 +369,7 @@ static void Heap_Mark (LONGINT q) if (!__ODD(tagbits)) { __PUT(n - 4, tagbits + 1, LONGINT); __PUT(q - 4, tag + 1, LONGINT); - __PUT(fld, (SYSTEM_PTR)(uintptr_t)p, SYSTEM_PTR); + __PUT(fld, (SYSTEM_PTR)(SYSTEM_ADDRESS)p, SYSTEM_PTR); p = q; q = n; tag = tagbits; @@ -384,7 +384,7 @@ static void Heap_Mark (LONGINT q) static void Heap_MarkP (SYSTEM_PTR p) { - Heap_Mark((LONGINT)(uintptr_t)p); + Heap_Mark((LONGINT)(SYSTEM_ADDRESS)p); } static void Heap_Scan (void) @@ -553,7 +553,7 @@ static void Heap_Finalize (void) } else { prev->next = n->next; } - (*n->finalize)((SYSTEM_PTR)(uintptr_t)n->obj); + (*n->finalize)((SYSTEM_PTR)(SYSTEM_ADDRESS)n->obj); if (prev == NIL) { n = Heap_fin; } else { @@ -572,7 +572,7 @@ void Heap_FINALL (void) while (Heap_fin != NIL) { n = Heap_fin; Heap_fin = Heap_fin->next; - (*n->finalize)((SYSTEM_PTR)(uintptr_t)n->obj); + (*n->finalize)((SYSTEM_PTR)(SYSTEM_ADDRESS)n->obj); } } @@ -589,9 +589,9 @@ static void Heap_MarkStack (LONGINT n, LONGINT *cand, LONGINT cand__len) } if (n == 0) { nofcand = 0; - sp = (LONGINT)(uintptr_t)&frame; + sp = (LONGINT)(SYSTEM_ADDRESS)&frame; stack0 = Heap_PlatformMainStackFrame(); - inc = (LONGINT)(uintptr_t)&align.p - (LONGINT)(uintptr_t)&align; + inc = (LONGINT)(SYSTEM_ADDRESS)&align.p - (LONGINT)(SYSTEM_ADDRESS)&align; if (sp > stack0) { inc = -inc; } @@ -622,7 +622,7 @@ void Heap_GC (BOOLEAN markStack) LONGINT cand[10000]; if (Heap_lockdepth == 0 || (Heap_lockdepth == 1 && !markStack)) { Heap_Lock(); - m = (Heap_Module)(uintptr_t)Heap_modules; + m = (Heap_Module)(SYSTEM_ADDRESS)Heap_modules; while (m != NIL) { if (m->enumPtrs != NIL) { (*m->enumPtrs)(Heap_MarkP); @@ -699,7 +699,7 @@ void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize) { Heap_FinNode f; __NEW(f, Heap_FinDesc); - f->obj = (LONGINT)(uintptr_t)obj; + f->obj = (LONGINT)(SYSTEM_ADDRESS)obj; f->finalize = finalize; f->marked = 1; f->next = Heap_fin; diff --git a/bootstrap/unix-48/Heap.h b/bootstrap/unix-48/Heap.h index 38e549be..a2cab30c 100644 --- a/bootstrap/unix-48/Heap.h +++ b/bootstrap/unix-48/Heap.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tskSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tskSfF */ #ifndef Heap__h #define Heap__h diff --git a/bootstrap/unix-48/Modules.c b/bootstrap/unix-48/Modules.c index d5164a2a..330b7506 100644 --- a/bootstrap/unix-48/Modules.c +++ b/bootstrap/unix-48/Modules.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Console.h" #include "Heap.h" diff --git a/bootstrap/unix-48/Modules.h b/bootstrap/unix-48/Modules.h index 5e27b653..ac8ac89e 100644 --- a/bootstrap/unix-48/Modules.h +++ b/bootstrap/unix-48/Modules.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Modules__h #define Modules__h diff --git a/bootstrap/unix-48/OPB.c b/bootstrap/unix-48/OPB.c index d834a9e8..0f614e6a 100644 --- a/bootstrap/unix-48/OPB.c +++ b/bootstrap/unix-48/OPB.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "OPM.h" #include "OPS.h" @@ -34,7 +34,9 @@ export void OPB_In (OPT_Node *x, OPT_Node y); export void OPB_Index (OPT_Node *x, OPT_Node y); export void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ); static BOOLEAN OPB_IntToBool (LONGINT i); +static OPT_Struct OPB_IntType (LONGINT size); export void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y); +static LONGINT OPB_LongerSize (LONGINT i); export void OPB_MOp (SHORTINT op, OPT_Node *x); export OPT_Node OPB_NewBoolConst (BOOLEAN boolval); export OPT_Node OPB_NewIntConst (LONGINT intval); @@ -51,6 +53,8 @@ export void OPB_Return (OPT_Node *x, OPT_Object proc); export void OPB_SetElem (OPT_Node *x); static void OPB_SetIntType (OPT_Node node); export void OPB_SetRange (OPT_Node *x, OPT_Node y); +static LONGINT OPB_ShorterSize (LONGINT i); +static INTEGER OPB_SignedByteSize (LONGINT n); export void OPB_StFct (OPT_Node *par0, SHORTINT fctno, INTEGER parno); export void OPB_StPar0 (OPT_Node *par0, INTEGER fctno); export void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno); @@ -90,8 +94,8 @@ OPT_Node OPB_NewLeaf (OPT_Object obj) node = OPT_NewNode(9); break; default: - OPB_err(127); node = OPT_NewNode(0); + OPB_err(127); break; } node->obj = obj; @@ -220,21 +224,68 @@ OPT_Node OPB_EmptySet (void) return _o_result; } +static INTEGER OPB_SignedByteSize (LONGINT n) +{ + INTEGER _o_result; + INTEGER b; + if (n < 0) { + n = -(n + 1); + } + b = 1; + while ((b < 8 && __ASH(n, -(__ASHL(b, 3) - 1)) != 0)) { + b += 1; + } + _o_result = b; + return _o_result; +} + +static LONGINT OPB_ShorterSize (LONGINT i) +{ + LONGINT _o_result; + if (i >= (int)OPM_LIntSize) { + _o_result = OPM_IntSize; + return _o_result; + } else { + _o_result = OPM_SIntSize; + return _o_result; + } + __RETCHK; +} + +static LONGINT OPB_LongerSize (LONGINT i) +{ + LONGINT _o_result; + if (i <= (int)OPM_SIntSize) { + _o_result = OPM_IntSize; + return _o_result; + } else { + _o_result = OPM_LIntSize; + return _o_result; + } + __RETCHK; +} + +static OPT_Struct OPB_IntType (LONGINT size) +{ + OPT_Struct _o_result; + OPT_Struct result = NIL; + if (size <= OPT_sinttyp->size) { + result = OPT_sinttyp; + } else if (size <= OPT_inttyp->size) { + result = OPT_inttyp; + } else { + result = OPT_linttyp; + } + if (size > OPT_linttyp->size) { + OPB_err(203); + } + _o_result = result; + return _o_result; +} + static void OPB_SetIntType (OPT_Node node) { - LONGINT v; - v = node->conval->intval; - if ((OPM_MinSInt <= (LONGINT)v && (LONGINT)v <= OPM_MaxSInt)) { - node->typ = OPT_sinttyp; - } else if ((OPM_MinInt <= (LONGINT)v && (LONGINT)v <= OPM_MaxInt)) { - node->typ = OPT_inttyp; - } else if ((OPM_MinLInt <= v && v <= OPM_MaxLInt)) { - node->typ = OPT_linttyp; - } else { - OPB_err(203); - node->typ = OPT_sinttyp; - node->conval->intval = 1; - } + node->typ = OPB_IntType(OPB_SignedByteSize(node->conval->intval)); } OPT_Node OPB_NewIntConst (LONGINT intval) @@ -378,16 +429,16 @@ void OPB_Field (OPT_Node *x, OPT_Object y) } } -static struct TypTest__57 { +static struct TypTest__61 { OPT_Node *x; OPT_Object *obj; BOOLEAN *guard; - struct TypTest__57 *lnk; -} *TypTest__57_s; + struct TypTest__61 *lnk; +} *TypTest__61_s; -static void GTT__58 (OPT_Struct t0, OPT_Struct t1); +static void GTT__62 (OPT_Struct t0, OPT_Struct t1); -static void GTT__58 (OPT_Struct t0, OPT_Struct t1) +static void GTT__62 (OPT_Struct t0, OPT_Struct t1) { OPT_Node node = NIL; OPT_Struct t = NIL; @@ -400,54 +451,54 @@ static void GTT__58 (OPT_Struct t0, OPT_Struct t1) t1 = t1->BaseTyp; } if (t1 == t0 || t0->form == 0) { - if (*TypTest__57_s->guard) { - OPB_BindNodes(5, NIL, &*TypTest__57_s->x, NIL); - (*TypTest__57_s->x)->readonly = (*TypTest__57_s->x)->left->readonly; + if (*TypTest__61_s->guard) { + OPB_BindNodes(5, NIL, &*TypTest__61_s->x, NIL); + (*TypTest__61_s->x)->readonly = (*TypTest__61_s->x)->left->readonly; } else { node = OPT_NewNode(11); node->subcl = 16; - node->left = *TypTest__57_s->x; - node->obj = *TypTest__57_s->obj; - *TypTest__57_s->x = node; + node->left = *TypTest__61_s->x; + node->obj = *TypTest__61_s->obj; + *TypTest__61_s->x = node; } } else { OPB_err(85); } } else if (t0 != t1) { OPB_err(85); - } else if (!*TypTest__57_s->guard) { - if ((*TypTest__57_s->x)->class == 5) { + } else if (!*TypTest__61_s->guard) { + if ((*TypTest__61_s->x)->class == 5) { node = OPT_NewNode(11); node->subcl = 16; - node->left = *TypTest__57_s->x; - node->obj = *TypTest__57_s->obj; - *TypTest__57_s->x = node; + node->left = *TypTest__61_s->x; + node->obj = *TypTest__61_s->obj; + *TypTest__61_s->x = node; } else { - *TypTest__57_s->x = OPB_NewBoolConst(1); + *TypTest__61_s->x = OPB_NewBoolConst(1); } } } void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard) { - struct TypTest__57 _s; + struct TypTest__61 _s; _s.x = x; _s.obj = &obj; _s.guard = &guard; - _s.lnk = TypTest__57_s; - TypTest__57_s = &_s; + _s.lnk = TypTest__61_s; + TypTest__61_s = &_s; if (OPB_NotVar(*x)) { OPB_err(112); } else if ((*x)->typ->form == 13) { if (((*x)->typ->BaseTyp->comp != 4 && (*x)->typ != OPT_sysptrtyp)) { OPB_err(85); } else if (obj->typ->form == 13) { - GTT__58((*x)->typ->BaseTyp, obj->typ->BaseTyp); + GTT__62((*x)->typ->BaseTyp, obj->typ->BaseTyp); } else { OPB_err(86); } } else if (((((*x)->typ->comp == 4 && (*x)->class == 1)) && obj->typ->comp == 4)) { - GTT__58((*x)->typ, obj->typ); + GTT__62((*x)->typ, obj->typ); } else { OPB_err(87); } @@ -456,7 +507,7 @@ void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard) } else { (*x)->typ = OPT_booltyp; } - TypTest__57_s = _s.lnk; + TypTest__61_s = _s.lnk; } void OPB_In (OPT_Node *x, OPT_Node y) @@ -469,7 +520,7 @@ void OPB_In (OPT_Node *x, OPT_Node y) } else if ((__IN(f, 0x70) && y->typ->form == 9)) { if ((*x)->class == 7) { k = (*x)->conval->intval; - if (k < 0 || k > (LONGINT)OPM_MaxSet) { + if (k < 0 || k > (int)OPM_MaxSet) { OPB_err(202); } else if (y->class == 7) { (*x)->conval->intval = OPB_BoolToInt(__IN(k, y->conval->setval)); @@ -522,13 +573,13 @@ static void OPB_CheckRealType (INTEGER f, INTEGER nr, OPT_Const x) x->intval = -1; } -static struct MOp__28 { - struct MOp__28 *lnk; -} *MOp__28_s; +static struct MOp__30 { + struct MOp__30 *lnk; +} *MOp__30_s; -static OPT_Node NewOp__29 (SHORTINT op, OPT_Struct typ, OPT_Node z); +static OPT_Node NewOp__31 (SHORTINT op, OPT_Struct typ, OPT_Node z); -static OPT_Node NewOp__29 (SHORTINT op, OPT_Struct typ, OPT_Node z) +static OPT_Node NewOp__31 (SHORTINT op, OPT_Struct typ, OPT_Node z) { OPT_Node _o_result; OPT_Node node = NIL; @@ -545,9 +596,9 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) INTEGER f; OPT_Struct typ = NIL; OPT_Node z = NIL; - struct MOp__28 _s; - _s.lnk = MOp__28_s; - MOp__28_s = &_s; + struct MOp__30 _s; + _s.lnk = MOp__30_s; + MOp__30_s = &_s; z = *x; if (z->class == 8 || z->class == 9) { OPB_err(126); @@ -561,7 +612,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) z->conval->intval = OPB_BoolToInt(!OPB_IntToBool(z->conval->intval)); z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(98); @@ -589,7 +640,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) } z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(97); @@ -610,7 +661,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) } z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(111); @@ -622,7 +673,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) z->conval->intval = (int)__CAP((CHAR)z->conval->intval); z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(111); @@ -635,7 +686,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) z->conval->intval = OPB_BoolToInt(__ODD(z->conval->intval)); z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(111); @@ -648,7 +699,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) f = 10; } if (z->class < 7 || f == 10) { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } else { OPB_err(127); } @@ -657,7 +708,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) case 25: if ((__IN(f, 0x70) && z->class == 7)) { if ((0 <= z->conval->intval && z->conval->intval <= -1)) { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } else { OPB_err(219); } @@ -674,7 +725,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) } } *x = z; - MOp__28_s = _s.lnk; + MOp__30_s = _s.lnk; } static void OPB_CheckPtr (OPT_Node x, OPT_Node y) @@ -865,41 +916,13 @@ static void OPB_ConstOp (INTEGER op, OPT_Node x, OPT_Node y) __GUARDEQP(yval, OPT_ConstDesc) = *xval; } break; - case 4: + case 4: case 5: case 6: if (__IN(g, 0x70)) { - x->typ = y->typ; - } else if (g == 7) { - x->typ = OPT_realtyp; - xval->realval = xval->intval; - } else if (g == 8) { - x->typ = OPT_lrltyp; - xval->realval = xval->intval; - } else { - OPB_err(100); - y->typ = x->typ; - __GUARDEQP(yval, OPT_ConstDesc) = *xval; - } - break; - case 5: - if (g == 4) { - y->typ = OPT_inttyp; - } else if (__IN(g, 0x70)) { - x->typ = y->typ; - } else if (g == 7) { - x->typ = OPT_realtyp; - xval->realval = xval->intval; - } else if (g == 8) { - x->typ = OPT_lrltyp; - xval->realval = xval->intval; - } else { - OPB_err(100); - y->typ = x->typ; - __GUARDEQP(yval, OPT_ConstDesc) = *xval; - } - break; - case 6: - if (__IN(g, 0x70)) { - y->typ = OPT_linttyp; + if (x->typ->size <= y->typ->size) { + x->typ = y->typ; + } else { + x->typ = OPB_IntType(x->typ->size); + } } else if (g == 7) { x->typ = OPT_realtyp; xval->realval = xval->intval; @@ -1178,7 +1201,7 @@ static void OPB_Convert (OPT_Node *x, OPT_Struct typ) OPB_err(203); r = (LONGREAL)1; } - (*x)->conval->intval = __ENTIER(r); + (*x)->conval->intval = (int)__ENTIER(r); OPB_SetIntType(*x); } } @@ -1196,15 +1219,15 @@ static void OPB_Convert (OPT_Node *x, OPT_Struct typ) (*x)->typ = typ; } -static struct Op__38 { +static struct Op__40 { INTEGER *f, *g; - struct Op__38 *lnk; -} *Op__38_s; + struct Op__40 *lnk; +} *Op__40_s; -static void NewOp__39 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y); -static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y); +static void NewOp__41 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y); +static BOOLEAN strings__43 (OPT_Node *x, OPT_Node *y); -static void NewOp__39 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y) +static void NewOp__41 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y) { OPT_Node node = NIL; node = OPT_NewNode(12); @@ -1215,29 +1238,29 @@ static void NewOp__39 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y) *x = node; } -static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y) +static BOOLEAN strings__43 (OPT_Node *x, OPT_Node *y) { BOOLEAN _o_result; BOOLEAN ok, xCharArr, yCharArr; - xCharArr = (__IN((*x)->typ->comp, 0x0c) && (*x)->typ->BaseTyp->form == 3) || *Op__38_s->f == 10; - yCharArr = (__IN((*y)->typ->comp, 0x0c) && (*y)->typ->BaseTyp->form == 3) || *Op__38_s->g == 10; - if ((((xCharArr && *Op__38_s->g == 3)) && (*y)->class == 7)) { + xCharArr = (__IN((*x)->typ->comp, 0x0c) && (*x)->typ->BaseTyp->form == 3) || *Op__40_s->f == 10; + yCharArr = (__IN((*y)->typ->comp, 0x0c) && (*y)->typ->BaseTyp->form == 3) || *Op__40_s->g == 10; + if ((((xCharArr && *Op__40_s->g == 3)) && (*y)->class == 7)) { OPB_CharToString(*y); - *Op__38_s->g = 10; + *Op__40_s->g = 10; yCharArr = 1; } - if ((((yCharArr && *Op__38_s->f == 3)) && (*x)->class == 7)) { + if ((((yCharArr && *Op__40_s->f == 3)) && (*x)->class == 7)) { OPB_CharToString(*x); - *Op__38_s->f = 10; + *Op__40_s->f = 10; xCharArr = 1; } ok = (xCharArr && yCharArr); if (ok) { - if ((*Op__38_s->f == 10 && (*x)->conval->intval2 == 1)) { + if ((*Op__40_s->f == 10 && (*x)->conval->intval2 == 1)) { (*x)->typ = OPT_chartyp; (*x)->conval->intval = 0; OPB_Index(&*y, OPB_NewIntConst(((LONGINT)(0)))); - } else if ((*Op__38_s->g == 10 && (*y)->conval->intval2 == 1)) { + } else if ((*Op__40_s->g == 10 && (*y)->conval->intval2 == 1)) { (*y)->typ = OPT_chartyp; (*y)->conval->intval = 0; OPB_Index(&*x, OPB_NewIntConst(((LONGINT)(0)))); @@ -1254,11 +1277,11 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPT_Struct typ = NIL; BOOLEAN do_; LONGINT val; - struct Op__38 _s; + struct Op__40 _s; _s.f = &f; _s.g = &g; - _s.lnk = Op__38_s; - Op__38_s = &_s; + _s.lnk = Op__40_s; + Op__40_s = &_s; z = *x; if (((z->class == 8 || z->class == 9) || y->class == 8) || y->class == 9) { OPB_err(126); @@ -1276,15 +1299,8 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(100); } break; - case 4: - if (__IN(g, 0x01f0)) { - OPB_Convert(&z, y->typ); - } else { - OPB_err(100); - } - break; - case 5: - if (g == 4) { + case 4: case 5: case 6: + if ((__IN(g, 0x70) && y->typ->size < z->typ->size)) { OPB_Convert(&y, z->typ); } else if (__IN(g, 0x01f0)) { OPB_Convert(&z, y->typ); @@ -1292,15 +1308,6 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(100); } break; - case 6: - if (__IN(g, 0x70)) { - OPB_Convert(&y, z->typ); - } else if (__IN(g, 0x0180)) { - OPB_Convert(&z, y->typ); - } else { - OPB_err(100); - } - break; case 7: if (__IN(g, 0x70)) { OPB_Convert(&y, z->typ); @@ -1386,7 +1393,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) typ = OPT_undftyp; } if (do_) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 2: @@ -1405,7 +1412,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(102); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; case 3: do_ = 1; @@ -1428,7 +1435,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) typ = OPT_undftyp; } if (do_) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 4: @@ -1446,7 +1453,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(104); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; case 5: if (f == 2) { @@ -1456,7 +1463,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } else if ((y->class == 7 && OPB_IntToBool(y->conval->intval))) { } else { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } } else if (f != 0) { OPB_err(94); @@ -1479,7 +1486,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } if (do_) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 7: @@ -1488,7 +1495,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) typ = OPT_undftyp; } if ((!__IN(f, 0x70) || y->class != 7) || y->conval->intval != 0) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 8: @@ -1499,7 +1506,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } else if ((y->class == 7 && !OPB_IntToBool(y->conval->intval))) { } else { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } } else if (f != 0) { OPB_err(95); @@ -1507,16 +1514,16 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } break; case 9: case 10: - if (__IN(f, 0x6bff) || strings__41(&z, &y)) { + if (__IN(f, 0x6bff) || strings__43(&z, &y)) { typ = OPT_booltyp; } else { OPB_err(107); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; case 11: case 12: case 13: case 14: - if (__IN(f, 0x01f9) || strings__41(&z, &y)) { + if (__IN(f, 0x01f9) || strings__43(&z, &y)) { typ = OPT_booltyp; } else { OPM_LogWLn(); @@ -1525,7 +1532,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(108); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; default: OPM_LogWStr((CHAR*)"unhandled case in OPB.Op, op = ", (LONGINT)32); @@ -1535,7 +1542,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } *x = z; - Op__38_s = _s.lnk; + Op__40_s = _s.lnk; } void OPB_SetRange (OPT_Node *x, OPT_Node y) @@ -1546,13 +1553,13 @@ void OPB_SetRange (OPT_Node *x, OPT_Node y) } else if ((__IN((*x)->typ->form, 0x70) && __IN(y->typ->form, 0x70))) { if ((*x)->class == 7) { k = (*x)->conval->intval; - if (0 > k || k > (LONGINT)OPM_MaxSet) { + if (0 > k || k > (int)OPM_MaxSet) { OPB_err(202); } } if (y->class == 7) { l = y->conval->intval; - if (0 > l || l > (LONGINT)OPM_MaxSet) { + if (0 > l || l > (int)OPM_MaxSet) { OPB_err(202); } } @@ -1582,7 +1589,7 @@ void OPB_SetElem (OPT_Node *x) OPB_err(93); } else if ((*x)->class == 7) { k = (*x)->conval->intval; - if ((0 <= k && k <= (LONGINT)OPM_MaxSet)) { + if ((0 <= k && k <= (int)OPM_MaxSet)) { (*x)->conval->setval = __SETOF(k); } else { OPB_err(202); @@ -1596,8 +1603,9 @@ void OPB_SetElem (OPT_Node *x) static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) { + OPT_Struct y = NIL; INTEGER f, g; - OPT_Struct y = NIL, p = NIL, q = NIL; + OPT_Struct p = NIL, q = NIL; if (OPM_Verbose) { OPM_LogWLn(); OPM_LogWStr((CHAR*)"PROCEDURE CheckAssign", (LONGINT)22); @@ -1627,31 +1635,20 @@ static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) case 0: case 10: break; case 1: - if (!__IN(g, 0x1a)) { + if (!((__IN(g, 0x7a) && y->size == 1))) { OPB_err(113); } break; - case 2: case 3: case 4: case 9: + case 2: case 3: case 9: if (g != f) { OPB_err(113); } break; - case 5: - if (!__IN(g, 0x30)) { + case 4: case 5: case 6: + if (!__IN(g, 0x70) || x->size < y->size) { OPB_err(113); } break; - case 6: - if (OPM_LIntSize == 4) { - if (!__IN(g, 0x70)) { - OPB_err(113); - } - } else { - if (!__IN(g, 0x70)) { - OPB_err(113); - } - } - break; case 7: if (!__IN(g, 0xf0)) { OPB_err(113); @@ -1832,14 +1829,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) x = OPB_NewIntConst(((LONGINT)(0))); x->typ = OPT_chartyp; break; - case 4: - x = OPB_NewIntConst(OPM_MinSInt); - break; - case 5: - x = OPB_NewIntConst(OPM_MinInt); - break; - case 6: - x = OPB_NewIntConst(OPM_MinLInt); + case 4: case 5: case 6: + x = OPB_NewIntConst(OPM_SignedMinimum(x->typ->size)); break; case 9: x = OPB_NewIntConst(((LONGINT)(0))); @@ -1869,14 +1860,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) x = OPB_NewIntConst(((LONGINT)(255))); x->typ = OPT_chartyp; break; - case 4: - x = OPB_NewIntConst(OPM_MaxSInt); - break; - case 5: - x = OPB_NewIntConst(OPM_MaxInt); - break; - case 6: - x = OPB_NewIntConst(OPM_MaxLInt); + case 4: case 5: case 6: + x = OPB_NewIntConst(OPM_SignedMaximum(x->typ->size)); break; case 9: x = OPB_NewIntConst(OPM_MaxSet); @@ -1909,10 +1894,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) case 10: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if (f == 5) { - OPB_Convert(&x, OPT_sinttyp); - } else if (f == 6) { - OPB_Convert(&x, OPT_inttyp); + } else if ((__IN(f, 0x70) && x->typ->size > (int)OPM_SIntSize)) { + OPB_Convert(&x, OPB_IntType(OPB_ShorterSize(x->typ->size))); } else if (f == 8) { OPB_Convert(&x, OPT_realtyp); } else { @@ -1922,10 +1905,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) case 11: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if (f == 4) { - OPB_Convert(&x, OPT_inttyp); - } else if (f == 5) { - OPB_Convert(&x, OPT_linttyp); + } else if ((__IN(f, 0x70) && x->typ->size < (int)OPM_LIntSize)) { + OPB_Convert(&x, OPB_IntType(OPB_LongerSize(x->typ->size))); } else if (f == 7) { OPB_Convert(&x, OPT_lrltyp); } else if (f == 3) { @@ -1973,7 +1954,7 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - if (f != 6) { + if (x->typ->size != (int)OPM_LIntSize) { OPB_Convert(&x, OPT_linttyp); } } else { @@ -2011,9 +1992,9 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) case 24: case 25: case 28: case 31: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if ((x->class == 7 && __IN(f, 0x30))) { + } else if ((((x->class == 7 && __IN(f, 0x70))) && x->typ->size < OPT_linttyp->size)) { OPB_Convert(&x, OPT_linttyp); - } else if (!__IN(f, 0x2040)) { + } else if (!((__IN(x->typ->form, 0x2070) && x->typ->size == (int)OPM_PointerSize))) { OPB_err(111); x->typ = OPT_linttyp; } @@ -2062,13 +2043,13 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) *par0 = x; } -static struct StPar1__52 { - struct StPar1__52 *lnk; -} *StPar1__52_s; +static struct StPar1__56 { + struct StPar1__56 *lnk; +} *StPar1__56_s; -static OPT_Node NewOp__53 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right); +static OPT_Node NewOp__57 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right); -static OPT_Node NewOp__53 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right) +static OPT_Node NewOp__57 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right) { OPT_Node _o_result; OPT_Node node = NIL; @@ -2085,9 +2066,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) INTEGER f, L; OPT_Struct typ = NIL; OPT_Node p = NIL, t = NIL; - struct StPar1__52 _s; - _s.lnk = StPar1__52_s; - StPar1__52_s = &_s; + struct StPar1__56 _s; + _s.lnk = StPar1__56_s; + StPar1__56_s = &_s; p = *par0; f = x->typ->form; switch (fctno) { @@ -2103,7 +2084,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) OPB_err(111); } } - p = NewOp__53(19, fctno, p, x); + p = NewOp__57(19, fctno, p, x); p->typ = OPT_notyp; } break; @@ -2111,10 +2092,10 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - if ((x->class == 7 && (0 > x->conval->intval || x->conval->intval > (LONGINT)OPM_MaxSet))) { + if ((x->class == 7 && (0 > x->conval->intval || x->conval->intval > (int)OPM_MaxSet))) { OPB_err(202); } - p = NewOp__53(19, fctno, p, x); + p = NewOp__57(19, fctno, p, x); } else { OPB_err(111); } @@ -2123,7 +2104,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) case 17: if (!__IN(f, 0x70) || x->class != 7) { OPB_err(69); - } else if (f == 4) { + } else if (x->typ->size == 1) { L = (int)x->conval->intval; typ = p->typ; while ((L > 0 && __IN(typ->comp, 0x0c))) { @@ -2139,7 +2120,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) p = p->left; x->conval->intval += 1; } - p = NewOp__53(12, 19, p, x); + p = NewOp__57(12, 19, p, x); p->typ = OPT_linttyp; } else { p = x; @@ -2161,7 +2142,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) t = x; x = p; p = t; - p = NewOp__53(19, 18, p, x); + p = NewOp__57(19, 18, p, x); } else { OPB_err(111); } @@ -2187,7 +2168,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) } p->obj = NIL; } else { - p = NewOp__53(12, 17, p, x); + p = NewOp__57(12, 17, p, x); p->typ = OPT_linttyp; } } else { @@ -2218,9 +2199,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) OPB_err(111); } else { if (fctno == 22) { - p = NewOp__53(12, 27, p, x); + p = NewOp__57(12, 27, p, x); } else { - p = NewOp__53(12, 28, p, x); + p = NewOp__57(12, 28, p, x); } p->typ = p->left->typ; } @@ -2237,7 +2218,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) x = p; p = t; } - p = NewOp__53(19, fctno, p, x); + p = NewOp__57(19, fctno, p, x); } else { OPB_err(111); } @@ -2247,7 +2228,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - p = NewOp__53(12, 26, p, x); + p = NewOp__57(12, 26, p, x); } else { OPB_err(111); } @@ -2257,6 +2238,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (((x->class == 8 || x->class == 9) || __IN(f, 0x1401)) || x->typ->comp == 3) { OPB_err(126); } + if (x->typ->size < p->typ->size) { + OPB_err(-308); + } t = OPT_NewNode(11); t->subcl = 29; t->left = x; @@ -2268,7 +2252,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - p = NewOp__53(19, 30, p, x); + p = NewOp__57(19, 30, p, x); } else { OPB_err(111); } @@ -2277,9 +2261,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) case 31: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if ((x->class == 7 && __IN(f, 0x30))) { + } else if ((((x->class == 7 && __IN(f, 0x70))) && x->typ->size < OPT_linttyp->size)) { OPB_Convert(&x, OPT_linttyp); - } else if (!__IN(f, 0x2040)) { + } else if (!((__IN(x->typ->form, 0x2070) && x->typ->size == (int)OPM_PointerSize))) { OPB_err(111); x->typ = OPT_linttyp; } @@ -2314,7 +2298,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) break; } *par0 = p; - StPar1__52_s = _s.lnk; + StPar1__56_s = _s.lnk; } void OPB_StParN (OPT_Node *par0, OPT_Node x, INTEGER fctno, INTEGER n) @@ -2433,7 +2417,7 @@ static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpa ftyp = ftyp->BaseTyp; atyp = atyp->BaseTyp; if ((fvarpar && ftyp == OPT_bytetyp)) { - if (!__IN(f, 0x0c) || !__IN(atyp->form, 0x1e)) { + if (!__IN(f, 0x0c) || !((__IN(atyp->form, 0x7e) && atyp->size == 1))) { if (__IN(18, OPM_opt)) { OPB_err(-301); } @@ -2516,7 +2500,7 @@ void OPB_Param (OPT_Node ap, OPT_Object fp) OPB_err(111); } } else if ((fp->typ == OPT_sysptrtyp && ap->typ->form == 13)) { - } else if ((ap->typ != fp->typ && !((fp->typ->form == 1 && __IN(ap->typ->form, 0x18))))) { + } else if ((ap->typ != fp->typ && !((fp->typ->form == 1 && ((__IN(ap->typ->form, 0x7e) && ap->typ->size == 1)))))) { OPB_err(123); } else if ((fp->typ->form == 13 && ap->class == 5)) { OPB_err(123); diff --git a/bootstrap/unix-48/OPB.h b/bootstrap/unix-48/OPB.h index 4c37f01f..d1c88266 100644 --- a/bootstrap/unix-48/OPB.h +++ b/bootstrap/unix-48/OPB.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPB__h #define OPB__h diff --git a/bootstrap/unix-48/OPC.c b/bootstrap/unix-48/OPC.c index 417337c0..3abccc9a 100644 --- a/bootstrap/unix-48/OPC.c +++ b/bootstrap/unix-48/OPC.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Configuration.h" #include "OPM.h" @@ -16,12 +16,13 @@ static CHAR OPC_BodyNameExt[13]; export void OPC_Align (LONGINT *adr, LONGINT base); export void OPC_Andent (OPT_Struct typ); static void OPC_AnsiParamList (OPT_Object obj, BOOLEAN showParamNames); -export LONGINT OPC_Base (OPT_Struct typ); +export LONGINT OPC_BaseAlignment (OPT_Struct typ); export OPT_Object OPC_BaseTProc (OPT_Object obj); export void OPC_BegBlk (void); export void OPC_BegStat (void); static void OPC_CProcDefs (OPT_Object obj, INTEGER vis); export void OPC_Case (LONGINT caseVal, INTEGER form); +static void OPC_CharacterLiteral (LONGINT c); export void OPC_Cmp (INTEGER rel); export void OPC_CompleteIdent (OPT_Object obj); export void OPC_Constant (OPT_Const con, INTEGER form); @@ -73,8 +74,10 @@ static void OPC_PutBase (OPT_Struct typ); static void OPC_PutPtrOffsets (OPT_Struct typ, LONGINT adr, LONGINT *cnt); static void OPC_RegCmds (OPT_Object obj); export void OPC_SetInclude (BOOLEAN exclude); +export LONGINT OPC_SizeAlignment (LONGINT size); static void OPC_Stars (OPT_Struct typ, BOOLEAN *openClause); static void OPC_Str1 (CHAR *s, LONGINT s__len, LONGINT x); +static void OPC_StringLiteral (CHAR *s, LONGINT s__len, LONGINT l); export void OPC_TDescDecl (OPT_Struct typ); export void OPC_TypeDefs (OPT_Object obj, INTEGER vis); export void OPC_TypeOf (OPT_Object ap); @@ -315,7 +318,7 @@ void OPC_Andent (OPT_Struct typ) static BOOLEAN OPC_Undefined (OPT_Object obj) { BOOLEAN _o_result; - _o_result = (((obj->mnolev >= 0 && obj->linkadr != (LONGINT)(3 + OPM_currFile))) && obj->linkadr != 2) || obj->name[0] == 0x00; + _o_result = obj->name[0] == 0x00 || (((obj->mnolev >= 0 && obj->linkadr != (int)(3 + OPM_currFile))) && obj->linkadr != 2); return _o_result; } @@ -815,14 +818,15 @@ void OPC_TDescDecl (OPT_Struct typ) OPC_Andent(typ); OPC_Str1((CHAR*)", #", (LONGINT)4, typ->n + 1); OPC_Str1((CHAR*)", #) = {__TDFLDS(", (LONGINT)18, OPC_NofPtrs(typ)); - OPM_Write('\"'); + OPM_Write('"'); if (typ->strobj != NIL) { OPM_WriteStringVar((void*)typ->strobj->name, ((LONGINT)(256))); } - OPC_Str1((CHAR*)"\", #), {", (LONGINT)9, typ->size); + OPM_Write('"'); + OPC_Str1((CHAR*)", #), {", (LONGINT)8, typ->size); nofptrs = 0; OPC_PutPtrOffsets(typ, ((LONGINT)(0)), &nofptrs); - OPC_Str1((CHAR*)"#}}", (LONGINT)4, -((nofptrs + 1) * (LONGINT)OPM_LIntSize)); + OPC_Str1((CHAR*)"#}}", (LONGINT)4, -((nofptrs + 1) * (int)OPM_LIntSize)); OPC_EndStat(); } @@ -864,70 +868,37 @@ void OPC_Align (LONGINT *adr, LONGINT base) } } -LONGINT OPC_Base (OPT_Struct typ) +LONGINT OPC_SizeAlignment (LONGINT size) { LONGINT _o_result; - switch (typ->form) { - case 1: - _o_result = 1; - return _o_result; - break; - case 3: - _o_result = OPM_CharAlign; - return _o_result; - break; - case 2: - _o_result = OPM_BoolAlign; - return _o_result; - break; - case 4: - _o_result = OPM_SIntAlign; - return _o_result; - break; - case 5: - _o_result = OPM_IntAlign; - return _o_result; - break; - case 6: - _o_result = OPM_LIntAlign; - return _o_result; - break; - case 7: - _o_result = OPM_RealAlign; - return _o_result; - break; - case 8: - _o_result = OPM_LRealAlign; - return _o_result; - break; - case 9: - _o_result = OPM_SetAlign; - return _o_result; - break; - case 13: - _o_result = OPM_PointerAlign; - return _o_result; - break; - case 14: - _o_result = OPM_ProcAlign; - return _o_result; - break; - case 15: - if (typ->comp == 4) { - _o_result = __MASK(typ->align, -65536); - return _o_result; - } else { - _o_result = OPC_Base(typ->BaseTyp); - return _o_result; - } - break; - default: - OPM_LogWStr((CHAR*)"unhandled case in OPC.Base, typ^form = ", (LONGINT)40); - OPM_LogWNum(typ->form, ((LONGINT)(0))); - OPM_LogWLn(); - break; + LONGINT alignment; + if (size < (int)OPM_Alignment) { + alignment = 1; + while (alignment < size) { + alignment = __ASHL(alignment, 1); + } + } else { + alignment = OPM_Alignment; } - __RETCHK; + _o_result = alignment; + return _o_result; +} + +LONGINT OPC_BaseAlignment (OPT_Struct typ) +{ + LONGINT _o_result; + LONGINT alignment; + if (typ->form == 15) { + if (typ->comp == 4) { + alignment = __MASK(typ->align, -65536); + } else { + alignment = OPC_BaseAlignment(typ->BaseTyp); + } + } else { + alignment = OPC_SizeAlignment(typ->size); + } + _o_result = alignment; + return _o_result; } static void OPC_FillGap (LONGINT gap, LONGINT off, LONGINT align, LONGINT *n, LONGINT *curAlign) @@ -938,11 +909,11 @@ static void OPC_FillGap (LONGINT gap, LONGINT off, LONGINT align, LONGINT *n, LO if ((*curAlign < align && gap - (adr - off) >= align)) { gap -= (adr - off) + align; OPC_BegStat(); - if (align == (LONGINT)OPM_IntSize) { + if (align == (int)OPM_IntSize) { OPM_WriteString((CHAR*)"INTEGER", (LONGINT)8); - } else if (align == (LONGINT)OPM_LIntSize) { + } else if (align == (int)OPM_LIntSize) { OPM_WriteString((CHAR*)"LONGINT", (LONGINT)8); - } else if (align == (LONGINT)OPM_LRealSize) { + } else if (align == (int)OPM_LRealSize) { OPM_WriteString((CHAR*)"LONGREAL", (LONGINT)9); } OPC_Str1((CHAR*)" _prvt#", (LONGINT)8, *n); @@ -981,7 +952,7 @@ static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, LONGINT *off, LONGINT * } } else { adr = *off; - fldAlign = OPC_Base(fld->typ); + fldAlign = OPC_BaseAlignment(fld->typ); OPC_Align(&adr, fldAlign); gap = fld->adr - adr; if (fldAlign > *curAlign) { @@ -1007,7 +978,7 @@ static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, LONGINT *off, LONGINT * } } if (last) { - adr = typ->size - (LONGINT)__ASHR(typ->sysflag, 8); + adr = typ->size - (int)__ASHR(typ->sysflag, 8); if (adr == 0) { gap = 1; } else { @@ -1170,10 +1141,10 @@ static void OPC_Include (CHAR *name, LONGINT name__len) { __DUP(name, name__len, CHAR); OPM_WriteString((CHAR*)"#include ", (LONGINT)10); - OPM_Write('\"'); + OPM_Write('"'); OPM_WriteStringVar((void*)name, name__len); OPM_WriteString((CHAR*)".h", (LONGINT)3); - OPM_Write('\"'); + OPM_Write('"'); OPM_WriteLn(); __DEL(name); } @@ -1238,8 +1209,8 @@ void OPC_GenHdr (OPT_Node n) static void OPC_GenHeaderMsg (void) { INTEGER i; - OPM_WriteString((CHAR*)"/*", (LONGINT)3); - OPM_WriteString((CHAR*)" voc ", (LONGINT)6); + OPM_WriteString((CHAR*)"/* ", (LONGINT)4); + OPM_WriteString((CHAR*)"voc", (LONGINT)4); OPM_Write(' '); OPM_WriteString(Configuration_versionLong, ((LONGINT)(41))); OPM_Write(' '); @@ -1855,26 +1826,56 @@ void OPC_Cmp (INTEGER rel) } } +static void OPC_CharacterLiteral (LONGINT c) +{ + if (c < 32 || c > 126) { + OPM_WriteString((CHAR*)"0x", (LONGINT)3); + OPM_WriteHex(c); + } else { + OPM_Write('\''); + if ((c == 92 || c == 39) || c == 63) { + OPM_Write('\\'); + } + OPM_Write((CHAR)c); + OPM_Write('\''); + } +} + +static void OPC_StringLiteral (CHAR *s, LONGINT s__len, LONGINT l) +{ + LONGINT i; + INTEGER c; + __DUP(s, s__len, CHAR); + OPM_Write('"'); + i = 0; + while (i < l) { + c = (int)s[__X(i, s__len)]; + if (c < 32 || c > 126) { + OPM_Write('\\'); + OPM_Write((CHAR)(48 + __ASHR(c, 6))); + c = __MASK(c, -64); + OPM_Write((CHAR)(48 + __ASHR(c, 3))); + c = __MASK(c, -8); + OPM_Write((CHAR)(48 + c)); + } else { + if ((c == 92 || c == 34) || c == 63) { + OPM_Write('\\'); + } + OPM_Write((CHAR)c); + } + i += 1; + } + OPM_Write('"'); + __DEL(s); +} + void OPC_Case (LONGINT caseVal, INTEGER form) { CHAR ch; OPM_WriteString((CHAR*)"case ", (LONGINT)6); switch (form) { case 3: - ch = (CHAR)caseVal; - if ((ch >= ' ' && ch <= '~')) { - OPM_Write('\''); - if (((ch == '\\' || ch == '\?') || ch == '\'') || ch == '\"') { - OPM_Write('\\'); - OPM_Write(ch); - } else { - OPM_Write(ch); - } - OPM_Write('\''); - } else { - OPM_WriteString((CHAR*)"0x", (LONGINT)3); - OPM_WriteHex(caseVal); - } + OPC_CharacterLiteral(caseVal); break; case 4: case 5: case 6: OPM_WriteInt(caseVal); @@ -1932,8 +1933,7 @@ void OPC_Len (OPT_Object obj, OPT_Struct array, LONGINT dim) void OPC_Constant (OPT_Const con, INTEGER form) { - INTEGER i, len; - CHAR ch; + INTEGER i; SET s; LONGINT hex; BOOLEAN skipLeading; @@ -1945,18 +1945,7 @@ void OPC_Constant (OPT_Const con, INTEGER form) OPM_WriteInt(con->intval); break; case 3: - ch = (CHAR)con->intval; - if ((ch >= ' ' && ch <= '~')) { - OPM_Write('\''); - if (((ch == '\\' || ch == '\?') || ch == '\'') || ch == '\"') { - OPM_Write('\\'); - } - OPM_Write(ch); - OPM_Write('\''); - } else { - OPM_WriteString((CHAR*)"0x", (LONGINT)3); - OPM_WriteHex(con->intval); - } + OPC_CharacterLiteral(con->intval); break; case 4: case 5: case 6: OPM_WriteInt(con->intval); @@ -1991,18 +1980,7 @@ void OPC_Constant (OPT_Const con, INTEGER form) } break; case 10: - OPM_Write('\"'); - len = (int)con->intval2 - 1; - i = 0; - while (i < len) { - ch = (*con->ext)[__X(i, ((LONGINT)(256)))]; - if (((ch == '\\' || ch == '\?') || ch == '\'') || ch == '\"') { - OPM_Write('\\'); - } - OPM_Write(ch); - i += 1; - } - OPM_Write('\"'); + OPC_StringLiteral(*con->ext, ((LONGINT)(256)), con->intval2 - 1); break; case 11: OPM_WriteString((CHAR*)"NIL", (LONGINT)4); @@ -2015,74 +1993,74 @@ void OPC_Constant (OPT_Const con, INTEGER form) } } -static struct InitKeywords__47 { +static struct InitKeywords__48 { SHORTINT *n; - struct InitKeywords__47 *lnk; -} *InitKeywords__47_s; + struct InitKeywords__48 *lnk; +} *InitKeywords__48_s; -static void Enter__48 (CHAR *s, LONGINT s__len); +static void Enter__49 (CHAR *s, LONGINT s__len); -static void Enter__48 (CHAR *s, LONGINT s__len) +static void Enter__49 (CHAR *s, LONGINT s__len) { INTEGER h; __DUP(s, s__len, CHAR); h = OPC_PerfectHash((void*)s, s__len); - OPC_hashtab[__X(h, ((LONGINT)(105)))] = *InitKeywords__47_s->n; - __COPY(s, OPC_keytab[__X(*InitKeywords__47_s->n, ((LONGINT)(36)))], ((LONGINT)(9))); - *InitKeywords__47_s->n += 1; + OPC_hashtab[__X(h, ((LONGINT)(105)))] = *InitKeywords__48_s->n; + __COPY(s, OPC_keytab[__X(*InitKeywords__48_s->n, ((LONGINT)(36)))], ((LONGINT)(9))); + *InitKeywords__48_s->n += 1; __DEL(s); } static void OPC_InitKeywords (void) { SHORTINT n, i; - struct InitKeywords__47 _s; + struct InitKeywords__48 _s; _s.n = &n; - _s.lnk = InitKeywords__47_s; - InitKeywords__47_s = &_s; + _s.lnk = InitKeywords__48_s; + InitKeywords__48_s = &_s; n = 0; i = 0; while (i <= 104) { OPC_hashtab[__X(i, ((LONGINT)(105)))] = -1; i += 1; } - Enter__48((CHAR*)"asm", (LONGINT)4); - Enter__48((CHAR*)"auto", (LONGINT)5); - Enter__48((CHAR*)"break", (LONGINT)6); - Enter__48((CHAR*)"case", (LONGINT)5); - Enter__48((CHAR*)"char", (LONGINT)5); - Enter__48((CHAR*)"const", (LONGINT)6); - Enter__48((CHAR*)"continue", (LONGINT)9); - Enter__48((CHAR*)"default", (LONGINT)8); - Enter__48((CHAR*)"do", (LONGINT)3); - Enter__48((CHAR*)"double", (LONGINT)7); - Enter__48((CHAR*)"else", (LONGINT)5); - Enter__48((CHAR*)"enum", (LONGINT)5); - Enter__48((CHAR*)"extern", (LONGINT)7); - Enter__48((CHAR*)"export", (LONGINT)7); - Enter__48((CHAR*)"float", (LONGINT)6); - Enter__48((CHAR*)"for", (LONGINT)4); - Enter__48((CHAR*)"fortran", (LONGINT)8); - Enter__48((CHAR*)"goto", (LONGINT)5); - Enter__48((CHAR*)"if", (LONGINT)3); - Enter__48((CHAR*)"import", (LONGINT)7); - Enter__48((CHAR*)"int", (LONGINT)4); - Enter__48((CHAR*)"long", (LONGINT)5); - Enter__48((CHAR*)"register", (LONGINT)9); - Enter__48((CHAR*)"return", (LONGINT)7); - Enter__48((CHAR*)"short", (LONGINT)6); - Enter__48((CHAR*)"signed", (LONGINT)7); - Enter__48((CHAR*)"sizeof", (LONGINT)7); - Enter__48((CHAR*)"static", (LONGINT)7); - Enter__48((CHAR*)"struct", (LONGINT)7); - Enter__48((CHAR*)"switch", (LONGINT)7); - Enter__48((CHAR*)"typedef", (LONGINT)8); - Enter__48((CHAR*)"union", (LONGINT)6); - Enter__48((CHAR*)"unsigned", (LONGINT)9); - Enter__48((CHAR*)"void", (LONGINT)5); - Enter__48((CHAR*)"volatile", (LONGINT)9); - Enter__48((CHAR*)"while", (LONGINT)6); - InitKeywords__47_s = _s.lnk; + Enter__49((CHAR*)"asm", (LONGINT)4); + Enter__49((CHAR*)"auto", (LONGINT)5); + Enter__49((CHAR*)"break", (LONGINT)6); + Enter__49((CHAR*)"case", (LONGINT)5); + Enter__49((CHAR*)"char", (LONGINT)5); + Enter__49((CHAR*)"const", (LONGINT)6); + Enter__49((CHAR*)"continue", (LONGINT)9); + Enter__49((CHAR*)"default", (LONGINT)8); + Enter__49((CHAR*)"do", (LONGINT)3); + Enter__49((CHAR*)"double", (LONGINT)7); + Enter__49((CHAR*)"else", (LONGINT)5); + Enter__49((CHAR*)"enum", (LONGINT)5); + Enter__49((CHAR*)"extern", (LONGINT)7); + Enter__49((CHAR*)"export", (LONGINT)7); + Enter__49((CHAR*)"float", (LONGINT)6); + Enter__49((CHAR*)"for", (LONGINT)4); + Enter__49((CHAR*)"fortran", (LONGINT)8); + Enter__49((CHAR*)"goto", (LONGINT)5); + Enter__49((CHAR*)"if", (LONGINT)3); + Enter__49((CHAR*)"import", (LONGINT)7); + Enter__49((CHAR*)"int", (LONGINT)4); + Enter__49((CHAR*)"long", (LONGINT)5); + Enter__49((CHAR*)"register", (LONGINT)9); + Enter__49((CHAR*)"return", (LONGINT)7); + Enter__49((CHAR*)"short", (LONGINT)6); + Enter__49((CHAR*)"signed", (LONGINT)7); + Enter__49((CHAR*)"sizeof", (LONGINT)7); + Enter__49((CHAR*)"static", (LONGINT)7); + Enter__49((CHAR*)"struct", (LONGINT)7); + Enter__49((CHAR*)"switch", (LONGINT)7); + Enter__49((CHAR*)"typedef", (LONGINT)8); + Enter__49((CHAR*)"union", (LONGINT)6); + Enter__49((CHAR*)"unsigned", (LONGINT)9); + Enter__49((CHAR*)"void", (LONGINT)5); + Enter__49((CHAR*)"volatile", (LONGINT)9); + Enter__49((CHAR*)"while", (LONGINT)6); + InitKeywords__48_s = _s.lnk; } diff --git a/bootstrap/unix-48/OPC.h b/bootstrap/unix-48/OPC.h index 52ed8dab..b7d34a07 100644 --- a/bootstrap/unix-48/OPC.h +++ b/bootstrap/unix-48/OPC.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPC__h #define OPC__h @@ -11,7 +11,7 @@ import void OPC_Align (LONGINT *adr, LONGINT base); import void OPC_Andent (OPT_Struct typ); -import LONGINT OPC_Base (OPT_Struct typ); +import LONGINT OPC_BaseAlignment (OPT_Struct typ); import OPT_Object OPC_BaseTProc (OPT_Object obj); import void OPC_BegBlk (void); import void OPC_BegStat (void); @@ -40,6 +40,7 @@ import void OPC_InitTDesc (OPT_Struct typ); import void OPC_Len (OPT_Object obj, OPT_Struct array, LONGINT dim); import LONGINT OPC_NofPtrs (OPT_Struct typ); import void OPC_SetInclude (BOOLEAN exclude); +import LONGINT OPC_SizeAlignment (LONGINT size); import void OPC_TDescDecl (OPT_Struct typ); import void OPC_TypeDefs (OPT_Object obj, INTEGER vis); import void OPC_TypeOf (OPT_Object ap); diff --git a/bootstrap/unix-48/OPM.c b/bootstrap/unix-48/OPM.c index 8e5add20..bf683e41 100644 --- a/bootstrap/unix-48/OPM.c +++ b/bootstrap/unix-48/OPM.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Configuration.h" #include "Console.h" @@ -14,8 +14,8 @@ typedef static CHAR OPM_SourceFileName[256]; -export INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_CharAlign, OPM_BoolAlign, OPM_SIntAlign, OPM_IntAlign, OPM_LIntAlign, OPM_SetAlign, OPM_RealAlign, OPM_LRealAlign, OPM_PointerAlign, OPM_ProcAlign, OPM_RecAlign, OPM_MaxSet; -export LONGINT OPM_MinSInt, OPM_MinInt, OPM_MinLInt, OPM_MaxSInt, OPM_MaxInt, OPM_MaxLInt, OPM_MaxIndex; +export INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_MaxSet; +export LONGINT OPM_MaxIndex; export LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; export BOOLEAN OPM_noerr; export LONGINT OPM_curpos, OPM_errpos, OPM_breakpc; @@ -57,7 +57,6 @@ export void OPM_LogWNum (LONGINT i, LONGINT len); export void OPM_LogWStr (CHAR *s, LONGINT s__len); static void OPM_MakeFileName (CHAR *name, LONGINT name__len, CHAR *FName, LONGINT FName__len, CHAR *ext, LONGINT ext__len); export void OPM_Mark (INTEGER n, LONGINT pos); -static INTEGER OPM_Min (INTEGER a, INTEGER b); export void OPM_NewSym (CHAR *modName, LONGINT modName__len); export void OPM_OldSym (CHAR *modName, LONGINT modName__len, BOOLEAN *done); export void OPM_OpenFiles (CHAR *moduleName, LONGINT moduleName__len); @@ -65,6 +64,8 @@ export BOOLEAN OPM_OpenPar (void); export void OPM_RegisterNewSym (void); static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt); static void OPM_ShowLine (LONGINT pos); +export LONGINT OPM_SignedMaximum (LONGINT bytecount); +export LONGINT OPM_SignedMinimum (LONGINT bytecount); export void OPM_SymRCh (CHAR *ch); export LONGINT OPM_SymRInt (void); export void OPM_SymRLReal (LONGREAL *lr); @@ -85,7 +86,7 @@ export void OPM_WriteString (CHAR *s, LONGINT s__len); export void OPM_WriteStringVar (CHAR *s, LONGINT s__len); export BOOLEAN OPM_eofSF (void); export void OPM_err (INTEGER n); -static LONGINT OPM_minus (LONGINT i); +static LONGINT OPM_minusop (LONGINT i); static LONGINT OPM_power0 (LONGINT i, LONGINT j); @@ -117,50 +118,38 @@ static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) i = 1; while (s[__X(i, s__len)] != 0x00) { switch (s[__X(i, s__len)]) { - case 'e': - *opt = *opt ^ 0x0200; - break; - case 's': - *opt = *opt ^ 0x10; - break; - case 'm': - *opt = *opt ^ 0x0400; - break; - case 'x': - *opt = *opt ^ 0x01; - break; - case 'r': - *opt = *opt ^ 0x04; - break; - case 't': - *opt = *opt ^ 0x08; - break; case 'a': *opt = *opt ^ 0x80; break; - case 'k': - *opt = *opt ^ 0x40; - break; - case 'p': - *opt = *opt ^ 0x20; - break; - case 'S': - *opt = *opt ^ 0x2000; - break; case 'c': *opt = *opt ^ 0x4000; break; - case 'M': - *opt = *opt ^ 0x8000; + case 'e': + *opt = *opt ^ 0x0200; break; case 'f': *opt = *opt ^ 0x010000; break; - case 'F': - *opt = *opt ^ 0x020000; + case 'k': + *opt = *opt ^ 0x40; break; - case 'V': - *opt = *opt ^ 0x040000; + case 'm': + *opt = *opt ^ 0x0400; + break; + case 'p': + *opt = *opt ^ 0x20; + break; + case 'r': + *opt = *opt ^ 0x04; + break; + case 's': + *opt = *opt ^ 0x10; + break; + case 't': + *opt = *opt ^ 0x08; + break; + case 'x': + *opt = *opt ^ 0x01; break; case 'B': if (s[__X(i + 1, s__len)] != 0x00) { @@ -178,6 +167,19 @@ static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) __ASSERT(OPM_IntSize == 2 || OPM_IntSize == 4, 0); __ASSERT(OPM_PointerSize == 4 || OPM_PointerSize == 8, 0); __ASSERT(OPM_Alignment == 4 || OPM_Alignment == 8, 0); + Files_SetSearchPath((CHAR*)"", (LONGINT)1); + break; + case 'F': + *opt = *opt ^ 0x020000; + break; + case 'M': + *opt = *opt ^ 0x8000; + break; + case 'S': + *opt = *opt ^ 0x2000; + break; + case 'V': + *opt = *opt ^ 0x040000; break; default: OPM_LogWStr((CHAR*)" warning: option ", (LONGINT)19); @@ -227,17 +229,17 @@ BOOLEAN OPM_OpenPar (void) OPM_LogWLn(); OPM_LogWStr((CHAR*)" x - turn off array indices check", (LONGINT)35); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" a - don\'t check ASSERTs at runtime, use this option in tested production code", (LONGINT)80); + OPM_LogWStr((CHAR*)" a - don't check ASSERTs at runtime, use this option in tested production code", (LONGINT)80); OPM_LogWLn(); OPM_LogWStr((CHAR*)" p - turn off automatic pointer initialization", (LONGINT)48); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" t - don\'t check type guards (use in rare cases such as low-level modules where every cycle counts)", (LONGINT)101); + OPM_LogWStr((CHAR*)" t - don't check type guards (use in rare cases such as low-level modules where every cycle counts)", (LONGINT)101); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" S - don\'t call external assembler/compiler, only generate C code", (LONGINT)67); + OPM_LogWStr((CHAR*)" S - don't call external assembler/compiler, only generate C code", (LONGINT)67); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" c - don\'t call linker", (LONGINT)24); + OPM_LogWStr((CHAR*)" c - don't call linker", (LONGINT)24); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" f - don\'t use color output", (LONGINT)29); + OPM_LogWStr((CHAR*)" f - don't use color output", (LONGINT)29); OPM_LogWLn(); OPM_LogWStr((CHAR*)" F - force writing new symbol file in current directory", (LONGINT)57); OPM_LogWLn(); @@ -540,14 +542,17 @@ void OPM_FPrintSet (LONGINT *fp, SET set) void OPM_FPrintReal (LONGINT *fp, REAL real) { - OPM_FPrint(&*fp, __VAL(LONGINT, real)); + INTEGER i; + LONGINT l; + __GET((LONGINT)(SYSTEM_ADDRESS)&real, l, LONGINT); + OPM_FPrint(&*fp, l); } void OPM_FPrintLReal (LONGINT *fp, LONGREAL lr) { LONGINT l, h; - __GET((LONGINT)(uintptr_t)&lr, l, LONGINT); - __GET((LONGINT)(uintptr_t)&lr + 4, h, LONGINT); + __GET((LONGINT)(SYSTEM_ADDRESS)&lr, l, LONGINT); + __GET((LONGINT)(SYSTEM_ADDRESS)&lr + 4, h, LONGINT); OPM_FPrint(&*fp, l); OPM_FPrint(&*fp, h); } @@ -575,7 +580,7 @@ static void OPM_GetProperty (Texts_Scanner *S, LONGINT *S__typ, CHAR *name, LONG __DEL(name); } -static LONGINT OPM_minus (LONGINT i) +static LONGINT OPM_minusop (LONGINT i) { LONGINT _o_result; _o_result = -i; @@ -603,103 +608,62 @@ static void OPM_VerboseListSizes (void) OPM_LogWLn(); OPM_LogWStr((CHAR*)"CHAR ", (LONGINT)14); OPM_LogWNum(OPM_CharSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_CharAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"BOOLEAN ", (LONGINT)14); OPM_LogWNum(OPM_BoolSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_BoolAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"SHORTINT ", (LONGINT)14); OPM_LogWNum(OPM_SIntSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_SIntAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"INTEGER ", (LONGINT)14); OPM_LogWNum(OPM_IntSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_IntAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"LONGINT ", (LONGINT)14); OPM_LogWNum(OPM_LIntSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_LIntAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"SET ", (LONGINT)14); OPM_LogWNum(OPM_SetSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_SetAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"REAL ", (LONGINT)14); OPM_LogWNum(OPM_RealSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_RealAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"LONGREAL ", (LONGINT)14); OPM_LogWNum(OPM_LRealSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_LRealAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"PTR ", (LONGINT)14); OPM_LogWNum(OPM_PointerSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_PointerAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"PROC ", (LONGINT)14); OPM_LogWNum(OPM_ProcSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_ProcAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"RECORD ", (LONGINT)14); OPM_LogWNum(OPM_RecSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_RecAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Min shortint ", (LONGINT)14); - OPM_LogWNum(OPM_MinSInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Max shortint ", (LONGINT)14); - OPM_LogWNum(OPM_MaxSInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Min integer ", (LONGINT)14); - OPM_LogWNum(OPM_MinInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Max integer ", (LONGINT)14); - OPM_LogWNum(OPM_MaxInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Min longint ", (LONGINT)14); - OPM_LogWNum(OPM_MinLInt, ((LONGINT)(4))); - OPM_LogWLn(); } -static INTEGER OPM_Min (INTEGER a, INTEGER b) +LONGINT OPM_SignedMaximum (LONGINT bytecount) { - INTEGER _o_result; - if (a < b) { - _o_result = a; - return _o_result; - } else { - _o_result = b; - return _o_result; - } - __RETCHK; + LONGINT _o_result; + LONGINT result; + result = 1; + result = __LSH(result, __ASHL(bytecount, 3) - 1, LONGINT); + _o_result = result - 1; + return _o_result; +} + +LONGINT OPM_SignedMinimum (LONGINT bytecount) +{ + LONGINT _o_result; + _o_result = -OPM_SignedMaximum(bytecount) - 1; + return _o_result; } static void OPM_GetProperties (void) { - LONGINT base; OPM_ProcSize = OPM_PointerSize; OPM_LIntSize = __ASHL(OPM_IntSize, 1); OPM_SetSize = OPM_LIntSize; - OPM_CharAlign = OPM_Min(OPM_Alignment, OPM_CharSize); - OPM_BoolAlign = OPM_Min(OPM_Alignment, OPM_BoolSize); - OPM_SIntAlign = OPM_Min(OPM_Alignment, OPM_SIntSize); - OPM_RecAlign = OPM_Min(OPM_Alignment, OPM_RecSize); - OPM_RealAlign = OPM_Min(OPM_Alignment, OPM_RealSize); - OPM_LRealAlign = OPM_Min(OPM_Alignment, OPM_LRealSize); - OPM_PointerAlign = OPM_Min(OPM_Alignment, OPM_PointerSize); - OPM_ProcAlign = OPM_Min(OPM_Alignment, OPM_ProcSize); - OPM_IntAlign = OPM_Min(OPM_Alignment, OPM_IntSize); - OPM_LIntAlign = OPM_Min(OPM_Alignment, OPM_LIntSize); - OPM_SetAlign = OPM_Min(OPM_Alignment, OPM_SetSize); - base = -2; - OPM_MinSInt = __ASH(base, __ASHL(OPM_SIntSize, 3) - 2); - OPM_MaxSInt = OPM_minus(OPM_MinSInt + 1); - OPM_MinInt = __ASH(base, __ASHL(OPM_IntSize, 3) - 2); - OPM_MaxInt = OPM_minus(OPM_MinInt + 1); - OPM_MinLInt = __ASH(base, __ASHL(OPM_LIntSize, 3) - 2); - OPM_MaxLInt = OPM_minus(OPM_MinLInt + 1); if (OPM_RealSize == 4) { OPM_MaxReal = 3.40282346000000e+038; } else if (OPM_RealSize == 8) { @@ -713,7 +677,7 @@ static void OPM_GetProperties (void) OPM_MinReal = -OPM_MaxReal; OPM_MinLReal = -OPM_MaxLReal; OPM_MaxSet = __ASHL(OPM_SetSize, 3) - 1; - OPM_MaxIndex = OPM_MaxLInt; + OPM_MaxIndex = OPM_SignedMaximum(OPM_PointerSize); if (OPM_Verbose) { OPM_VerboseListSizes(); } @@ -875,7 +839,7 @@ void OPM_WriteInt (LONGINT i) { CHAR s[20]; LONGINT i1, k; - if (i == OPM_MinInt || i == OPM_MinLInt) { + if (i == OPM_SignedMinimum(OPM_IntSize) || i == OPM_SignedMinimum(OPM_LIntSize)) { OPM_Write('('); OPM_WriteInt(i + 1); OPM_WriteString((CHAR*)"-1)", (LONGINT)4); @@ -908,13 +872,13 @@ void OPM_WriteReal (LONGREAL r, CHAR suffx) CHAR s[32]; CHAR ch; INTEGER i; - if ((((r < OPM_MaxLInt && r > OPM_MinLInt)) && r == (__ENTIER(r)))) { + if ((((r < OPM_SignedMaximum(OPM_LIntSize) && r > OPM_SignedMinimum(OPM_LIntSize))) && r == ((int)__ENTIER(r)))) { if (suffx == 'f') { OPM_WriteString((CHAR*)"(REAL)", (LONGINT)7); } else { OPM_WriteString((CHAR*)"(LONGREAL)", (LONGINT)11); } - OPM_WriteInt(__ENTIER(r)); + OPM_WriteInt((int)__ENTIER(r)); } else { Texts_OpenWriter(&W, Texts_Writer__typ); if (suffx == 'f') { diff --git a/bootstrap/unix-48/OPM.h b/bootstrap/unix-48/OPM.h index db46c598..ed914bff 100644 --- a/bootstrap/unix-48/OPM.h +++ b/bootstrap/unix-48/OPM.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPM__h #define OPM__h @@ -6,8 +6,8 @@ #include "SYSTEM.h" -import INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_CharAlign, OPM_BoolAlign, OPM_SIntAlign, OPM_IntAlign, OPM_LIntAlign, OPM_SetAlign, OPM_RealAlign, OPM_LRealAlign, OPM_PointerAlign, OPM_ProcAlign, OPM_RecAlign, OPM_MaxSet; -import LONGINT OPM_MinSInt, OPM_MinInt, OPM_MinLInt, OPM_MaxSInt, OPM_MaxInt, OPM_MaxLInt, OPM_MaxIndex; +import INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_MaxSet; +import LONGINT OPM_MaxIndex; import LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; import BOOLEAN OPM_noerr; import LONGINT OPM_curpos, OPM_errpos, OPM_breakpc; @@ -38,6 +38,8 @@ import void OPM_OldSym (CHAR *modName, LONGINT modName__len, BOOLEAN *done); import void OPM_OpenFiles (CHAR *moduleName, LONGINT moduleName__len); import BOOLEAN OPM_OpenPar (void); import void OPM_RegisterNewSym (void); +import LONGINT OPM_SignedMaximum (LONGINT bytecount); +import LONGINT OPM_SignedMinimum (LONGINT bytecount); import void OPM_SymRCh (CHAR *ch); import LONGINT OPM_SymRInt (void); import void OPM_SymRLReal (LONGREAL *lr); diff --git a/bootstrap/unix-48/OPP.c b/bootstrap/unix-48/OPP.c index ffe3dff2..01d2144d 100644 --- a/bootstrap/unix-48/OPP.c +++ b/bootstrap/unix-48/OPP.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "OPB.h" #include "OPM.h" @@ -438,10 +438,10 @@ static void OPP_TypeDecl (OPT_Struct *typ, OPT_Struct *banned) if (OPP_sym == 38) { OPP_qualident(&id); if (id->mode == 5) { - if (id->typ != *banned) { - *typ = id->typ; - } else { + if (id->typ == *banned) { OPP_err(58); + } else { + *typ = id->typ; } } else { OPP_err(52); @@ -1783,6 +1783,24 @@ void OPP_Module (OPT_Node *prog, SET opt) if (OPP_sym == 63) { OPS_Get(&OPP_sym); } else { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Unexpected symbol found when MODULE expected:", (LONGINT)46); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" sym: ", (LONGINT)15); + OPM_LogWNum(OPP_sym, ((LONGINT)(1))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.name: ", (LONGINT)15); + OPM_LogWStr(OPS_name, ((LONGINT)(256))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.str: ", (LONGINT)15); + OPM_LogWStr(OPS_str, ((LONGINT)(256))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.numtyp: ", (LONGINT)15); + OPM_LogWNum(OPS_numtyp, ((LONGINT)(1))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.intval: ", (LONGINT)15); + OPM_LogWNum(OPS_intval, ((LONGINT)(1))); + OPM_LogWLn(); OPP_err(16); } if (OPP_sym == 38) { diff --git a/bootstrap/unix-48/OPP.h b/bootstrap/unix-48/OPP.h index 40e2def4..bf56b7d7 100644 --- a/bootstrap/unix-48/OPP.h +++ b/bootstrap/unix-48/OPP.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPP__h #define OPP__h diff --git a/bootstrap/unix-48/OPS.c b/bootstrap/unix-48/OPS.c index efed04c6..cacf9256 100644 --- a/bootstrap/unix-48/OPS.c +++ b/bootstrap/unix-48/OPS.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #include "SYSTEM.h" #include "OPM.h" @@ -173,7 +173,7 @@ static void OPS_Number (void) OPS_numtyp = 1; if (n <= 2) { while (i < n) { - OPS_intval = __ASHL(OPS_intval, 4) + (LONGINT)Ord__7(dig[i], 1); + OPS_intval = __ASHL(OPS_intval, 4) + (int)Ord__7(dig[i], 1); i += 1; } } else { @@ -188,7 +188,7 @@ static void OPS_Number (void) OPS_intval = -1; } while (i < n) { - OPS_intval = __ASHL(OPS_intval, 4) + (LONGINT)Ord__7(dig[i], 1); + OPS_intval = __ASHL(OPS_intval, 4) + (int)Ord__7(dig[i], 1); i += 1; } } else { @@ -199,8 +199,8 @@ static void OPS_Number (void) while (i < n) { d = Ord__7(dig[i], 0); i += 1; - if (OPS_intval <= __DIV(2147483647 - (LONGINT)d, 10)) { - OPS_intval = OPS_intval * 10 + (LONGINT)d; + if (OPS_intval <= __DIV(2147483647 - (int)d, 10)) { + OPS_intval = OPS_intval * 10 + (int)d; } else { OPS_err(203); } @@ -325,7 +325,7 @@ void OPS_Get (SHORTINT *sym) } } switch (OPS_ch) { - case '\"': case '\'': + case '"': case '\'': OPS_Str(&s); break; case '#': diff --git a/bootstrap/unix-48/OPS.h b/bootstrap/unix-48/OPS.h index dae6e457..e901bcfc 100644 --- a/bootstrap/unix-48/OPS.h +++ b/bootstrap/unix-48/OPS.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #ifndef OPS__h #define OPS__h diff --git a/bootstrap/unix-48/OPT.c b/bootstrap/unix-48/OPT.c index 8c943c20..b32d0ebd 100644 --- a/bootstrap/unix-48/OPT.c +++ b/bootstrap/unix-48/OPT.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "OPM.h" #include "OPS.h" @@ -849,7 +849,7 @@ static void OPT_InConstant (LONGINT f, OPT_Const conval) conval->intval = 0; break; default: - OPM_LogWStr((CHAR*)"unhandled case in OPT.InConstant(), f = ", (LONGINT)41); + OPM_LogWStr((CHAR*)"unhandled case in InConstant(), f = ", (LONGINT)37); OPM_LogWNum(f, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1072,7 +1072,7 @@ static void OPT_InStruct (OPT_Struct *typ) OPT_InSign(mno, &(*typ)->BaseTyp, &(*typ)->link); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.InStruct, tag = ", (LONGINT)39); + OPM_LogWStr((CHAR*)"unhandled case at InStruct, tag = ", (LONGINT)35); OPM_LogWNum(tag, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1175,7 +1175,7 @@ static OPT_Object OPT_InObj (SHORTINT mno) } break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.InObj, tag = ", (LONGINT)36); + OPM_LogWStr((CHAR*)"unhandled case at InObj, tag = ", (LONGINT)32); OPM_LogWNum(tag, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1464,14 +1464,14 @@ static void OPT_OutStr (OPT_Struct typ) OPM_SymWInt(((LONGINT)(18))); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutStr, typ^.comp = ", (LONGINT)43); + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.comp = ", (LONGINT)39); OPM_LogWNum(typ->comp, ((LONGINT)(0))); OPM_LogWLn(); break; } break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutStr, typ^.form = ", (LONGINT)43); + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.form = ", (LONGINT)39); OPM_LogWNum(typ->form, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1536,7 +1536,7 @@ static void OPT_OutObj (OPT_Object obj) OPT_FPrintErr(obj, 251); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutObj, obj^.history = ", (LONGINT)46); + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj^.history = ", (LONGINT)42); OPM_LogWNum(obj->history, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1592,7 +1592,7 @@ static void OPT_OutObj (OPT_Object obj) OPT_OutName((void*)obj->name, ((LONGINT)(256))); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutObj, obj.mode = ", (LONGINT)42); + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj.mode = ", (LONGINT)38); OPM_LogWNum(obj->mode, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1809,6 +1809,7 @@ export void *OPT__init(void) OPT_syslink = OPT_topScope->right; OPT_universe = OPT_topScope; OPT_topScope->right = NIL; + OPT_EnterTyp((CHAR*)"BOOLEAN", 2, OPM_BoolSize, &OPT_booltyp); OPT_EnterTyp((CHAR*)"CHAR", 3, OPM_CharSize, &OPT_chartyp); OPT_EnterTyp((CHAR*)"SET", 9, OPM_SetSize, &OPT_settyp); OPT_EnterTyp((CHAR*)"REAL", 7, OPM_RealSize, &OPT_realtyp); @@ -1816,7 +1817,6 @@ export void *OPT__init(void) OPT_EnterTyp((CHAR*)"LONGINT", 6, OPM_LIntSize, &OPT_linttyp); OPT_EnterTyp((CHAR*)"LONGREAL", 8, OPM_LRealSize, &OPT_lrltyp); OPT_EnterTyp((CHAR*)"SHORTINT", 4, OPM_SIntSize, &OPT_sinttyp); - OPT_EnterTyp((CHAR*)"BOOLEAN", 2, OPM_BoolSize, &OPT_booltyp); OPT_EnterBoolConst((CHAR*)"FALSE", ((LONGINT)(0))); OPT_EnterBoolConst((CHAR*)"TRUE", ((LONGINT)(1))); OPT_EnterProc((CHAR*)"HALT", 0); diff --git a/bootstrap/unix-48/OPT.h b/bootstrap/unix-48/OPT.h index 45816124..41b3e7ec 100644 --- a/bootstrap/unix-48/OPT.h +++ b/bootstrap/unix-48/OPT.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPT__h #define OPT__h @@ -59,8 +59,7 @@ typedef INTEGER ref, sysflag; LONGINT n, size, align, txtpos; BOOLEAN allocated, pbused, pvused; - char _prvt0[8]; - LONGINT pbfp, pvfp; + char _prvt0[16]; OPT_Struct BaseTyp; OPT_Object link, strobj; } OPT_StrDesc; diff --git a/bootstrap/unix-48/OPV.c b/bootstrap/unix-48/OPV.c index 23bff9c0..cf646f5e 100644 --- a/bootstrap/unix-48/OPV.c +++ b/bootstrap/unix-48/OPV.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "OPC.h" #include "OPM.h" @@ -23,7 +23,7 @@ export LONGINT *OPV_ExitInfo__typ; static void OPV_ActualPar (OPT_Node n, OPT_Object fp); export void OPV_AdrAndSize (OPT_Object topScope); static void OPV_CaseStat (OPT_Node n, OPT_Object outerProc); -static void OPV_Convert (OPT_Node n, INTEGER form, INTEGER prec); +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INTEGER prec); static void OPV_DefineTDescs (OPT_Node n); static void OPV_Entier (OPT_Node n, INTEGER prec); static void OPV_GetTProcNum (OPT_Object obj); @@ -38,6 +38,7 @@ static LONGINT OPV_NaturalAlignment (LONGINT size, LONGINT max); static void OPV_NewArr (OPT_Node d, OPT_Node x); static INTEGER OPV_Precedence (INTEGER class, INTEGER subclass, INTEGER form, INTEGER comp); static BOOLEAN OPV_SideEffects (OPT_Node n); +static void OPV_SizeCast (LONGINT size); static void OPV_Stamp (OPS_Name s); static OPT_Object OPV_SuperProc (OPT_Node n); static void OPV_Traverse (OPT_Object obj, OPT_Object outerScope, BOOLEAN exported); @@ -82,10 +83,10 @@ void OPV_TypSize (OPT_Struct typ) btyp = typ->BaseTyp; if (btyp == NIL) { offset = 0; - base = OPM_RecAlign; + base = OPC_SizeAlignment(OPM_RecSize); } else { OPV_TypSize(btyp); - offset = btyp->size - (LONGINT)__ASHR(btyp->sysflag, 8); + offset = btyp->size - (int)__ASHR(btyp->sysflag, 8); base = btyp->align; } fld = typ->link; @@ -93,7 +94,7 @@ void OPV_TypSize (OPT_Struct typ) btyp = fld->typ; OPV_TypSize(btyp); size = btyp->size; - fbase = OPC_Base(btyp); + fbase = OPC_BaseAlignment(btyp); OPC_Align(&offset, fbase); fld->adr = offset; offset += size; @@ -107,7 +108,7 @@ void OPV_TypSize (OPT_Struct typ) offset = 1; } if (OPM_RecSize == 0) { - base = OPV_NaturalAlignment(offset, OPM_RecAlign); + base = OPV_NaturalAlignment(offset, OPC_SizeAlignment(OPM_RecSize)); } OPC_Align(&offset, base); if ((typ->strobj == NIL && __MASK(typ->align, -65536) == 0)) { @@ -332,7 +333,7 @@ static INTEGER OPV_Precedence (INTEGER class, INTEGER subclass, INTEGER form, IN return _o_result; break; default: - OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence Nmop, subclass = ", (LONGINT)51); + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Nmop, subclass = ", (LONGINT)55); OPM_LogWNum(subclass, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -402,7 +403,7 @@ static INTEGER OPV_Precedence (INTEGER class, INTEGER subclass, INTEGER form, IN return _o_result; break; default: - OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence Ndop, subclass = ", (LONGINT)51); + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Ndop, subclass = ", (LONGINT)55); OPM_LogWNum(subclass, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -465,41 +466,26 @@ static void OPV_Entier (OPT_Node n, INTEGER prec) } } -static void OPV_Convert (OPT_Node n, INTEGER form, INTEGER prec) +static void OPV_SizeCast (LONGINT size) { - INTEGER from; + if (size <= 4) { + OPM_WriteString((CHAR*)"(int)", (LONGINT)6); + } else { + OPM_WriteString((CHAR*)"(SYSTEM_INT64)", (LONGINT)15); + } +} + +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INTEGER prec) +{ + INTEGER from, to; from = n->typ->form; - if (form == 9) { + to = newtype->form; + if (to == 9) { OPM_WriteString((CHAR*)"__SETOF(", (LONGINT)9); OPV_Entier(n, -1); OPM_Write(')'); - } else if (form == 6) { - if (from < 6) { - OPM_WriteString((CHAR*)"(LONGINT)", (LONGINT)10); - } - OPV_Entier(n, 9); - } else if (form == 5) { - if (from < 5) { - OPM_WriteString((CHAR*)"(int)", (LONGINT)6); - OPV_expr(n, 9); - } else { - if (__IN(2, OPM_opt)) { - OPM_WriteString((CHAR*)"__SHORT", (LONGINT)8); - if (OPV_SideEffects(n)) { - OPM_Write('F'); - } - OPM_Write('('); - OPV_Entier(n, -1); - OPM_WriteString((CHAR*)", ", (LONGINT)3); - OPM_WriteInt(OPM_MaxInt + 1); - OPM_Write(')'); - } else { - OPM_WriteString((CHAR*)"(int)", (LONGINT)6); - OPV_Entier(n, 9); - } - } - } else if (form == 4) { - if (__IN(2, OPM_opt)) { + } else if (__IN(to, 0x70)) { + if ((newtype->size < n->typ->size && __IN(2, OPM_opt))) { OPM_WriteString((CHAR*)"__SHORT", (LONGINT)8); if (OPV_SideEffects(n)) { OPM_Write('F'); @@ -507,13 +493,15 @@ static void OPV_Convert (OPT_Node n, INTEGER form, INTEGER prec) OPM_Write('('); OPV_Entier(n, -1); OPM_WriteString((CHAR*)", ", (LONGINT)3); - OPM_WriteInt(OPM_MaxSInt + 1); + OPM_WriteInt(OPM_SignedMaximum(newtype->size) + 1); OPM_Write(')'); } else { - OPM_WriteString((CHAR*)"(int)", (LONGINT)6); + if (newtype->size != n->typ->size) { + OPV_SizeCast(newtype->size); + } OPV_Entier(n, 9); } - } else if (form == 3) { + } else if (to == 3) { if (__IN(2, OPM_opt)) { OPM_WriteString((CHAR*)"__CHR", (LONGINT)6); if (OPV_SideEffects(n)) { @@ -576,7 +564,7 @@ static void OPV_design (OPT_Node n, INTEGER prec) OPT_Struct typ = NIL; INTEGER class, designPrec, comp; OPT_Node d = NIL, x = NIL; - INTEGER dims, i, _for__26; + INTEGER dims, i, _for__27; comp = n->typ->comp; obj = n->obj; class = n->class; @@ -652,15 +640,15 @@ static void OPV_design (OPT_Node n, INTEGER prec) } x = x->left; } - _for__26 = dims; + _for__27 = dims; i = 1; - while (i <= _for__26) { + while (i <= _for__27) { OPM_Write(')'); i += 1; } if (n->typ->comp == 3) { OPM_Write(')'); - while ((LONGINT)i < __ASHR(d->typ->size - 4, 2)) { + while ((int)i < __ASHR(d->typ->size - 4, 2)) { OPM_WriteString((CHAR*)" * ", (LONGINT)4); OPV_Len(d, i); i += 1; @@ -795,7 +783,7 @@ static void OPV_ActualPar (OPT_Node n, OPT_Object fp) } if ((((mode == 2 && n->class == 11)) && n->subcl == 29)) { OPV_expr(n->left, prec); - } else if ((((((form == 6 && n->class == 7)) && n->conval->intval <= OPM_MaxInt)) && n->conval->intval >= OPM_MinInt)) { + } else if ((((((form == 6 && n->class == 7)) && n->conval->intval <= OPM_SignedMaximum(OPM_IntSize))) && n->conval->intval >= OPM_SignedMinimum(OPM_IntSize))) { OPM_WriteString((CHAR*)"((LONGINT)(", (LONGINT)12); OPV_expr(n, prec); OPM_WriteString((CHAR*)"))", (LONGINT)3); @@ -914,7 +902,7 @@ static void OPV_expr (OPT_Node n, INTEGER prec) OPM_Write(')'); break; case 20: - OPV_Convert(l, form, exprPrec); + OPV_Convert(l, n->typ, exprPrec); break; case 21: if (OPV_SideEffects(l)) { @@ -943,7 +931,7 @@ static void OPV_expr (OPT_Node n, INTEGER prec) OPM_Write(')'); break; case 24: - OPM_WriteString((CHAR*)"(LONGINT)(uintptr_t)", (LONGINT)21); + OPM_WriteString((CHAR*)"(LONGINT)(SYSTEM_ADDRESS)", (LONGINT)26); if (l->class == 1) { OPC_CompleteIdent(l->obj); } else { @@ -954,20 +942,16 @@ static void OPV_expr (OPT_Node n, INTEGER prec) } break; case 29: - if ((((__IN(n->typ->form, 0x6240) && __IN(l->typ->form, 0x6240))) && n->typ->size == l->typ->size) || !__IN(l->class, 0x17)) { + if (!__IN(l->class, 0x17) || (((__IN(n->typ->form, 0x6240) && __IN(l->typ->form, 0x6240))) && n->typ->size == l->typ->size)) { OPM_Write('('); OPC_Ident(n->typ->strobj); OPM_Write(')'); if (__IN(n->typ->form, 0x6000) || __IN(l->typ->form, 0x6000)) { - OPM_WriteString((CHAR*)"(uintptr_t)", (LONGINT)12); + OPM_WriteString((CHAR*)"(SYSTEM_ADDRESS)", (LONGINT)17); } OPV_expr(l, exprPrec); } else { - if (__IN(n->typ->form, 0x6000) || __IN(l->typ->form, 0x6000)) { - OPM_WriteString((CHAR*)"__VALP(", (LONGINT)8); - } else { - OPM_WriteString((CHAR*)"__VAL(", (LONGINT)7); - } + OPM_WriteString((CHAR*)"__VAL(", (LONGINT)7); OPC_Ident(n->typ->strobj); OPM_WriteString((CHAR*)", ", (LONGINT)3); OPV_expr(l, -1); @@ -1326,7 +1310,7 @@ static void OPV_NewArr (OPT_Node d, OPT_Node x) OPM_WriteInt(base->size); OPM_WriteString((CHAR*)"))", (LONGINT)3); OPM_WriteString((CHAR*)", ", (LONGINT)3); - OPM_WriteInt(OPC_Base(base)); + OPM_WriteInt(OPC_BaseAlignment(base)); OPM_WriteString((CHAR*)", ", (LONGINT)3); OPM_WriteInt(nofdim); OPM_WriteString((CHAR*)", ", (LONGINT)3); diff --git a/bootstrap/unix-48/OPV.h b/bootstrap/unix-48/OPV.h index 0de9e6cc..04828b2f 100644 --- a/bootstrap/unix-48/OPV.h +++ b/bootstrap/unix-48/OPV.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPV__h #define OPV__h diff --git a/bootstrap/unix-48/Platform.c b/bootstrap/unix-48/Platform.c index 3cce2026..74c43788 100644 --- a/bootstrap/unix-48/Platform.c +++ b/bootstrap/unix-48/Platform.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" typedef @@ -118,14 +118,14 @@ export BOOLEAN Platform_getEnv (CHAR *var, LONGINT var__len, CHAR *val, LONGINT #define Platform_EXDEV() EXDEV extern void Heap_InitHeap(); #define Platform_HeapInitHeap() Heap_InitHeap() -#define Platform_allocate(size) (LONGINT)(uintptr_t)((void*)malloc((size_t)size)) +#define Platform_allocate(size) (LONGINT)(SYSTEM_ADDRESS)((void*)malloc((size_t)size)) #define Platform_chdir(n, n__len) chdir((char*)n) #define Platform_closefile(fd) close(fd) #define Platform_err() errno #define Platform_errc(c) write(1, &c, 1) #define Platform_errstring(s, s__len) write(1, s, s__len-1) #define Platform_exit(code) exit(code) -#define Platform_free(address) free((void*)(uintptr_t)address) +#define Platform_free(address) free((void*)(SYSTEM_ADDRESS)address) #define Platform_fstat(fd) fstat(fd, &s) #define Platform_fsync(fd) fsync(fd) #define Platform_ftruncate(fd, l) ftruncate(fd, l) @@ -138,13 +138,13 @@ extern void Heap_InitHeap(); #define Platform_opennew(n, n__len) open((char*)n, O_CREAT | O_TRUNC | O_RDWR, 0664) #define Platform_openro(n, n__len) open((char*)n, O_RDONLY) #define Platform_openrw(n, n__len) open((char*)n, O_RDWR) -#define Platform_readfile(fd, p, l) read(fd, (void*)(uintptr_t)(p), l) +#define Platform_readfile(fd, p, l) read(fd, (void*)(SYSTEM_ADDRESS)(p), l) #define Platform_rename(o, o__len, n, n__len) rename((char*)o, (char*)n) #define Platform_sectotm(s) struct tm *time = localtime((time_t*)&s) #define Platform_seekcur() SEEK_CUR #define Platform_seekend() SEEK_END #define Platform_seekset() SEEK_SET -#define Platform_sethandler(s, h) SystemSetHandler(s, (uintptr_t)h) +#define Platform_sethandler(s, h) SystemSetHandler(s, (SYSTEM_ADDRESS)h) #define Platform_stat(n, n__len) stat((char*)n, &s) #define Platform_statdev() (LONGINT)s.st_dev #define Platform_statino() (LONGINT)s.st_ino @@ -161,7 +161,7 @@ extern void Heap_InitHeap(); #define Platform_tvsec() tv.tv_sec #define Platform_tvusec() tv.tv_usec #define Platform_unlink(n, n__len) unlink((char*)n) -#define Platform_writefile(fd, p, l) write(fd, (void*)(uintptr_t)(p), l) +#define Platform_writefile(fd, p, l) write(fd, (void*)(SYSTEM_ADDRESS)(p), l) BOOLEAN Platform_TooManyFiles (INTEGER e) { @@ -229,7 +229,7 @@ void Platform_Init (INTEGER argc, LONGINT argvadr) Platform_ArgVecPtr av = NIL; Platform_MainStackFrame = argvadr; Platform_ArgCount = argc; - av = (Platform_ArgVecPtr)(uintptr_t)argvadr; + av = (Platform_ArgVecPtr)(SYSTEM_ADDRESS)argvadr; Platform_ArgVector = (*av)[0]; Platform_HaltCode = -128; Platform_HeapInitHeap(); @@ -262,7 +262,7 @@ void Platform_GetArg (INTEGER n, CHAR *val, LONGINT val__len) { Platform_ArgVec av = NIL; if (n < Platform_ArgCount) { - av = (Platform_ArgVec)(uintptr_t)Platform_ArgVector; + av = (Platform_ArgVec)(SYSTEM_ADDRESS)Platform_ArgVector; __COPY(*(*av)[__X(n, ((LONGINT)(1024)))], val, val__len); } } @@ -529,7 +529,7 @@ INTEGER Platform_Read (LONGINT h, LONGINT p, LONGINT l, LONGINT *n) INTEGER Platform_ReadBuf (LONGINT h, SYSTEM_BYTE *b, LONGINT b__len, LONGINT *n) { INTEGER _o_result; - *n = Platform_readfile(h, (LONGINT)(uintptr_t)b, b__len); + *n = Platform_readfile(h, (LONGINT)(SYSTEM_ADDRESS)b, b__len); if (*n < 0) { *n = 0; _o_result = Platform_err(); @@ -765,7 +765,7 @@ static void Platform_TestLittleEndian (void) { INTEGER i; i = 1; - __GET((LONGINT)(uintptr_t)&i, Platform_LittleEndian, BOOLEAN); + __GET((LONGINT)(SYSTEM_ADDRESS)&i, Platform_LittleEndian, BOOLEAN); } __TDESC(Platform_FileIdentity, 1, 0) = {__TDFLDS("FileIdentity", 12), {-4}}; diff --git a/bootstrap/unix-48/Platform.h b/bootstrap/unix-48/Platform.h index 581da770..dd5ce434 100644 --- a/bootstrap/unix-48/Platform.h +++ b/bootstrap/unix-48/Platform.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Platform__h #define Platform__h diff --git a/bootstrap/unix-48/Reals.c b/bootstrap/unix-48/Reals.c index 0f1c3a92..2323e34d 100644 --- a/bootstrap/unix-48/Reals.c +++ b/bootstrap/unix-48/Reals.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" @@ -58,7 +58,7 @@ INTEGER Reals_Expo (REAL x) { INTEGER _o_result; INTEGER i; - __GET((LONGINT)(uintptr_t)&x + 2, i, INTEGER); + __GET((LONGINT)(SYSTEM_ADDRESS)&x + 2, i, INTEGER); _o_result = __MASK(__ASHR(i, 7), -256); return _o_result; } @@ -66,17 +66,17 @@ INTEGER Reals_Expo (REAL x) void Reals_SetExpo (REAL *x, INTEGER ex) { CHAR c; - __GET((LONGINT)(uintptr_t)x + 3, c, CHAR); - __PUT((LONGINT)(uintptr_t)x + 3, (CHAR)(__ASHL(__ASHR((int)c, 7), 7) + __MASK(__ASHR(ex, 1), -128)), CHAR); - __GET((LONGINT)(uintptr_t)x + 2, c, CHAR); - __PUT((LONGINT)(uintptr_t)x + 2, (CHAR)(__MASK((int)c, -128) + __ASHL(__MASK(ex, -2), 7)), CHAR); + __GET((LONGINT)(SYSTEM_ADDRESS)x + 3, c, CHAR); + __PUT((LONGINT)(SYSTEM_ADDRESS)x + 3, (CHAR)(__ASHL(__ASHR((int)c, 7), 7) + __MASK(__ASHR(ex, 1), -128)), CHAR); + __GET((LONGINT)(SYSTEM_ADDRESS)x + 2, c, CHAR); + __PUT((LONGINT)(SYSTEM_ADDRESS)x + 2, (CHAR)(__MASK((int)c, -128) + __ASHL(__MASK(ex, -2), 7)), CHAR); } INTEGER Reals_ExpoL (LONGREAL x) { INTEGER _o_result; INTEGER i; - __GET((LONGINT)(uintptr_t)&x + 6, i, INTEGER); + __GET((LONGINT)(SYSTEM_ADDRESS)&x + 6, i, INTEGER); _o_result = __MASK(__ASHR(i, 4), -2048); return _o_result; } @@ -89,8 +89,8 @@ void Reals_ConvertL (LONGREAL x, INTEGER n, CHAR *d, LONGINT d__len) } k = 0; if (n > 9) { - i = __ENTIER(x / (LONGREAL)(LONGREAL)1000000000); - j = __ENTIER(x - i * (LONGREAL)1000000000); + i = (int)__ENTIER(x / (LONGREAL)(LONGREAL)1000000000); + j = (int)__ENTIER(x - i * (LONGREAL)1000000000); if (j < 0) { j = 0; } @@ -100,9 +100,9 @@ void Reals_ConvertL (LONGREAL x, INTEGER n, CHAR *d, LONGINT d__len) k += 1; } } else { - i = __ENTIER(x); + i = (int)__ENTIER(x); } - while (k < (LONGINT)n) { + while (k < (int)n) { d[__X(k, d__len)] = (CHAR)(__MOD(i, 10) + 48); i = __DIV(i, 10); k += 1; @@ -134,7 +134,7 @@ static void Reals_BytesToHex (SYSTEM_BYTE *b, LONGINT b__len, SYSTEM_BYTE *d, LO CHAR by; i = 0; l = b__len; - while ((LONGINT)i < l) { + while ((int)i < l) { by = __VAL(CHAR, b[__X(i, b__len)]); d[__X(__ASHL(i, 1), d__len)] = Reals_ToHex(__ASHR((int)by, 4)); d[__X(__ASHL(i, 1) + 1, d__len)] = Reals_ToHex(__MASK((int)by, -16)); diff --git a/bootstrap/unix-48/Reals.h b/bootstrap/unix-48/Reals.h index 4a783296..7e6b534c 100644 --- a/bootstrap/unix-48/Reals.h +++ b/bootstrap/unix-48/Reals.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Reals__h #define Reals__h diff --git a/bootstrap/unix-48/SYSTEM.c b/bootstrap/unix-48/SYSTEM.c index 50e91c6d..33511a70 100644 --- a/bootstrap/unix-48/SYSTEM.c +++ b/bootstrap/unix-48/SYSTEM.c @@ -35,7 +35,7 @@ void SYSTEM_INHERIT(LONGINT *t, LONGINT *t0) void SYSTEM_ENUMP(void *adr, LONGINT n, void (*P)()) { while (n > 0) { - P((LONGINT)(uintptr_t)(*((void**)(adr)))); + P((LONGINT)(SYSTEM_ADDRESS)(*((void**)(adr)))); adr = ((void**)adr) + 1; n--; } @@ -106,7 +106,7 @@ SYSTEM_PTR SYSTEM_NEWARR(LONGINT *typ, LONGINT elemsz, int elemalgn, int nofdim, else if (typ == (LONGINT*)POINTER__typ) { /* element type is a pointer */ x = Heap_NEWBLK(size + nofelems * sizeof(LONGINT)); - p = (LONGINT*)(uintptr_t)x[-1]; + p = (LONGINT*)(SYSTEM_ADDRESS)x[-1]; p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */ while (n <= nofelems) {*p = n*sizeof(LONGINT); p++; n++;} @@ -119,7 +119,7 @@ SYSTEM_PTR SYSTEM_NEWARR(LONGINT *typ, LONGINT elemsz, int elemalgn, int nofdim, while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */ nptr = nofelems * nofptrs; /* total number of pointers */ x = Heap_NEWBLK(size + nptr * sizeof(LONGINT)); - p = (LONGINT*)(uintptr_t)x[- 1]; + p = (LONGINT*)(SYSTEM_ADDRESS)x[- 1]; p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ p -= nptr - 1; n = 0; off = dataoff; while (n < nofelems) {i = 0; @@ -155,7 +155,7 @@ typedef void (*SystemSignalHandler)(INTEGER); // = Platform_SignalHandler // (Ignore other signals) } - void SystemSetHandler(int s, uintptr_t h) { + void SystemSetHandler(int s, SYSTEM_ADDRESS h) { if (s >= 2 && s <= 4) { int needtosetsystemhandler = handler[s-2] == 0; handler[s-2] = (SystemSignalHandler)h; @@ -194,12 +194,12 @@ typedef void (*SystemSignalHandler)(INTEGER); // = Platform_SignalHandler } } - void SystemSetInterruptHandler(uintptr_t h) { + void SystemSetInterruptHandler(SYSTEM_ADDRESS h) { EnsureConsoleCtrlHandler(); SystemInterruptHandler = (SystemSignalHandler)h; } - void SystemSetQuitHandler(uintptr_t h) { + void SystemSetQuitHandler(SYSTEM_ADDRESS h) { EnsureConsoleCtrlHandler(); SystemQuitHandler = (SystemSignalHandler)h; } diff --git a/bootstrap/unix-48/SYSTEM.h b/bootstrap/unix-48/SYSTEM.h index 949951ac..6377745e 100644 --- a/bootstrap/unix-48/SYSTEM.h +++ b/bootstrap/unix-48/SYSTEM.h @@ -1,28 +1,38 @@ #ifndef SYSTEM__h #define SYSTEM__h -#ifndef _WIN32 - - // Building for a Unix/Linux based system - #include // For memcpy ... - #include // For uintptr_t ... - +#if defined(_WIN64) + typedef long long SYSTEM_INT64; + typedef unsigned long long SYSTEM_CARD64; #else - - // Building for Windows platform with either mingw under cygwin, or the MS C compiler - #ifdef _WIN64 - typedef unsigned long long size_t; - typedef unsigned long long uintptr_t; - #else - typedef unsigned int size_t; - typedef unsigned int uintptr_t; - #endif /* _WIN64 */ - - typedef unsigned int uint32_t; - void * __cdecl memcpy(void * dest, const void * source, size_t size); - + typedef long SYSTEM_INT64; + typedef unsigned long SYSTEM_CARD64; #endif +typedef int SYSTEM_INT32; +typedef unsigned int SYSTEM_CARD32; +typedef short int SYSTEM_INT16; +typedef unsigned short int SYSTEM_CARD16; +typedef signed char SYSTEM_INT8; +typedef unsigned char SYSTEM_CARD8; + +#if (__SIZEOF_POINTER__ == 8) || defined(_WIN64) || defined(__LP64__) + #if defined(_WIN64) + typedef unsigned long long size_t; + #else + typedef unsigned long size_t; + #endif +#else + typedef unsigned int size_t; +#endif + +#define SYSTEM_ADDRESS size_t +#define _SIZE_T_DECLARED // For FreeBSD +#define _SIZE_T_DEFINED_ // For OpenBSD + +void *memcpy(void *dest, const void *source, SYSTEM_ADDRESS size); + + // The compiler uses 'import' and 'export' which translate to 'extern' and // nothing respectively. @@ -70,6 +80,7 @@ typedef unsigned char U_SHORTINT; #endif typedef U_LONGINT SET; +typedef U_LONGINT U_SET; // OS Memory allocation interfaces are in PlatformXXX.Mod @@ -96,10 +107,10 @@ extern LONGINT SYSTEM_ENTIER (double x); // Signal handling in SYSTEM.c #ifndef _WIN32 - extern void SystemSetHandler(int s, uintptr_t h); + extern void SystemSetHandler(int s, SYSTEM_ADDRESS h); #else - extern void SystemSetInterruptHandler(uintptr_t h); - extern void SystemSetQuitHandler (uintptr_t h); + extern void SystemSetInterruptHandler(SYSTEM_ADDRESS h); + extern void SystemSetQuitHandler (SYSTEM_ADDRESS h); #endif @@ -122,20 +133,20 @@ static int __str_cmp(CHAR *x, CHAR *y){ #define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d; LONGINT _i=0,_t=n-1; \ while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;} -#define __DUP(x, l, t) x=(void*)memcpy((void*)(uintptr_t)Platform_OSAllocate(l*sizeof(t)),x,l*sizeof(t)) +#define __DUP(x, l, t) x=(void*)memcpy((void*)(SYSTEM_ADDRESS)Platform_OSAllocate(l*sizeof(t)),x,l*sizeof(t)) #define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) -#define __DEL(x) Platform_OSFree((LONGINT)(uintptr_t)x) +#define __DEL(x) Platform_OSFree((LONGINT)(SYSTEM_ADDRESS)x) /* SYSTEM ops */ -#define __VAL(t, x) ((t)(x)) -#define __VALP(t, x) ((t)(uintptr_t)(x)) +#define __VAL(t, x) (*(t*)&(x)) -#define __GET(a, x, t) x= *(t*)(uintptr_t)(a) -#define __PUT(a, x, t) *(t*)(uintptr_t)(a)=x + +#define __GET(a, x, t) x= *(t*)(SYSTEM_ADDRESS)(a) +#define __PUT(a, x, t) *(t*)(SYSTEM_ADDRESS)(a)=x #define __LSHL(x, n, t) ((t)((U_##t)(x)<<(n))) #define __LSHR(x, n, t) ((t)((U_##t)(x)>>(n))) @@ -150,7 +161,7 @@ static int __str_cmp(CHAR *x, CHAR *y){ #define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t)) #define __BIT(x, n) (*(U_LONGINT*)(x)>>(n)&1) -#define __MOVE(s, d, n) memcpy((char*)(uintptr_t)(d),(char*)(uintptr_t)(s),n) +#define __MOVE(s, d, n) memcpy((char*)(SYSTEM_ADDRESS)(d),(char*)(SYSTEM_ADDRESS)(s),n) #define __ASHF(x, n) SYSTEM_ASH((LONGINT)(x), (LONGINT)(n)) #define __SHORT(x, y) ((int)((U_LONGINT)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0))) #define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y))) @@ -211,7 +222,7 @@ extern void Heap_INCREF(); extern void Platform_Init(INTEGER argc, LONGINT argv); extern void Heap_FINALL(); -#define __INIT(argc, argv) static void *m; Platform_Init((INTEGER)argc, (LONGINT)(uintptr_t)&argv); +#define __INIT(argc, argv) static void *m; Platform_Init((INTEGER)argc, (LONGINT)(SYSTEM_ADDRESS)&argv); #define __REGMAIN(name, enum) m = Heap_REGMOD((CHAR*)name,enum) #define __FINI Heap_FINALL(); return 0 @@ -232,7 +243,7 @@ extern SYSTEM_PTR Heap_NEWREC (LONGINT tag); extern SYSTEM_PTR SYSTEM_NEWARR(LONGINT*, LONGINT, int, int, int, ...); #define __SYSNEW(p, len) p = Heap_NEWBLK((LONGINT)(len)) -#define __NEW(p, t) p = Heap_NEWREC((LONGINT)(uintptr_t)t##__typ) +#define __NEW(p, t) p = Heap_NEWREC((LONGINT)(SYSTEM_ADDRESS)t##__typ) #define __NEWARR SYSTEM_NEWARR @@ -263,20 +274,20 @@ extern SYSTEM_PTR SYSTEM_NEWARR(LONGINT*, LONGINT, int, int, int, ...); #define __INITYP(t, t0, level) \ t##__typ = (LONGINT*)&t##__desc.blksz; \ memcpy(t##__desc.basep, t0##__typ - __BASEOFF, level*sizeof(LONGINT)); \ - t##__desc.basep[level] = (LONGINT)(uintptr_t)t##__typ; \ - t##__desc.module = (LONGINT)(uintptr_t)m; \ + t##__desc.basep[level] = (LONGINT)(SYSTEM_ADDRESS)t##__typ; \ + t##__desc.module = (LONGINT)(SYSTEM_ADDRESS)m; \ if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ t##__desc.blksz = (t##__desc.blksz+5*sizeof(LONGINT)-1)/(4*sizeof(LONGINT))*(4*sizeof(LONGINT)); \ - Heap_REGTYP(m, (LONGINT)(uintptr_t)&t##__desc.next); \ + Heap_REGTYP(m, (LONGINT)(SYSTEM_ADDRESS)&t##__desc.next); \ SYSTEM_INHERIT(t##__typ, t0##__typ) -#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(LONGINT)(uintptr_t)typ##__typ) -#define __TYPEOF(p) ((LONGINT*)(uintptr_t)(*(((LONGINT*)(p))-1))) +#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(LONGINT)(SYSTEM_ADDRESS)typ##__typ) +#define __TYPEOF(p) ((LONGINT*)(SYSTEM_ADDRESS)(*(((LONGINT*)(p))-1))) #define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) // Oberon-2 type bound procedures support -#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(LONGINT)(uintptr_t)proc -#define __SEND(typ, num, funtyp, parlist) ((funtyp)((uintptr_t)*(typ-(__TPROC0OFF+num))))parlist +#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(LONGINT)(SYSTEM_ADDRESS)proc +#define __SEND(typ, num, funtyp, parlist) ((funtyp)((SYSTEM_ADDRESS)*(typ-(__TPROC0OFF+num))))parlist diff --git a/bootstrap/unix-48/Strings.c b/bootstrap/unix-48/Strings.c index d2713d0f..115456ea 100644 --- a/bootstrap/unix-48/Strings.c +++ b/bootstrap/unix-48/Strings.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" @@ -21,7 +21,7 @@ INTEGER Strings_Length (CHAR *s, LONGINT s__len) INTEGER i; __DUP(s, s__len, CHAR); i = 0; - while (((LONGINT)i < s__len && s[__X(i, s__len)] != 0x00)) { + while (((int)i < s__len && s[__X(i, s__len)] != 0x00)) { i += 1; } _o_result = i; @@ -36,11 +36,11 @@ void Strings_Append (CHAR *extra, LONGINT extra__len, CHAR *dest, LONGINT dest__ n1 = Strings_Length(dest, dest__len); n2 = Strings_Length(extra, extra__len); i = 0; - while ((i < n2 && (LONGINT)(i + n1) < dest__len)) { + while ((i < n2 && (int)(i + n1) < dest__len)) { dest[__X(i + n1, dest__len)] = extra[__X(i, extra__len)]; i += 1; } - if ((LONGINT)(i + n1) < dest__len) { + if ((int)(i + n1) < dest__len) { dest[__X(i + n1, dest__len)] = 0x00; } __DEL(extra); @@ -59,10 +59,10 @@ void Strings_Insert (CHAR *source, LONGINT source__len, INTEGER pos, CHAR *dest, Strings_Append(dest, dest__len, (void*)source, source__len); return; } - if ((LONGINT)(pos + n2) < dest__len) { + if ((int)(pos + n2) < dest__len) { i = n1; while (i >= pos) { - if ((LONGINT)(i + n2) < dest__len) { + if ((int)(i + n2) < dest__len) { dest[__X(i + n2, dest__len)] = dest[__X(i, dest__len)]; } i -= 1; @@ -91,7 +91,7 @@ void Strings_Delete (CHAR *s, LONGINT s__len, INTEGER pos, INTEGER n) s[__X(i - n, s__len)] = s[__X(i, s__len)]; i += 1; } - if ((LONGINT)(i - n) < s__len) { + if ((int)(i - n) < s__len) { s[__X(i - n, s__len)] = 0x00; } } else { @@ -121,7 +121,7 @@ void Strings_Extract (CHAR *source, LONGINT source__len, INTEGER pos, INTEGER n, return; } i = 0; - while (((((LONGINT)(pos + i) <= source__len && source[__X(pos + i, source__len)] != 0x00)) && i < n)) { + while (((((int)(pos + i) <= source__len && source[__X(pos + i, source__len)] != 0x00)) && i < n)) { if (i < destLen) { dest[__X(i, dest__len)] = source[__X(pos + i, source__len)]; } diff --git a/bootstrap/unix-48/Strings.h b/bootstrap/unix-48/Strings.h index 5f45d8a8..96dbb01d 100644 --- a/bootstrap/unix-48/Strings.h +++ b/bootstrap/unix-48/Strings.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Strings__h #define Strings__h diff --git a/bootstrap/unix-48/Texts.c b/bootstrap/unix-48/Texts.c index 2dab1e0f..cfe34ca7 100644 --- a/bootstrap/unix-48/Texts.c +++ b/bootstrap/unix-48/Texts.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Files.h" #include "Modules.h" @@ -787,9 +787,9 @@ void Texts_Scan (Texts_Scanner *S, LONGINT *S__typ) (*S).s[__X(i, ((LONGINT)(64)))] = 0x00; (*S).len = i; (*S).class = 1; - } else if (ch == '\"') { + } else if (ch == '"') { Texts_Read((void*)&*S, S__typ, &ch); - while ((((ch != '\"' && ch >= ' ')) && i != 63)) { + while ((((ch != '"' && ch >= ' ')) && i != 63)) { (*S).s[__X(i, ((LONGINT)(64)))] = ch; i += 1; Texts_Read((void*)&*S, S__typ, &ch); @@ -839,7 +839,7 @@ void Texts_Scan (Texts_Scanner *S, LONGINT *S__typ) k -= 16; } while (j < i) { - k = __ASHL(k, 4) + (LONGINT)((int)d[__X(j, ((LONGINT)(32)))] - 48); + k = __ASHL(k, 4) + (int)((int)d[__X(j, ((LONGINT)(32)))] - 48); j += 1; } if (neg) { @@ -929,7 +929,7 @@ void Texts_Scan (Texts_Scanner *S, LONGINT *S__typ) (*S).class = 3; k = 0; do { - k = k * 10 + (LONGINT)((int)d[__X(j, ((LONGINT)(32)))] - 48); + k = k * 10 + (int)((int)d[__X(j, ((LONGINT)(32)))] - 48); j += 1; } while (!(j == i)); if (neg) { @@ -1067,7 +1067,7 @@ void Texts_WriteInt (Texts_Writer *W, LONGINT *W__typ, LONGINT x, LONGINT n) x0 = __DIV(x0, 10); i += 1; } while (!(x0 == 0)); - while (n > (LONGINT)i) { + while (n > (int)i) { Texts_Write(&*W, W__typ, ' '); n -= 1; } @@ -1319,7 +1319,7 @@ void Texts_WriteLongReal (Texts_Writer *W, LONGINT *W__typ, LONGREAL x, INTEGER } else { Texts_Write(&*W, W__typ, ' '); } - e = (int)__ASHR((LONGINT)(e - 1023) * 77, 8); + e = (int)__ASHR((int)(e - 1023) * 77, 8); if (e >= 0) { x = x / (LONGREAL)Reals_TenL(e); } else { diff --git a/bootstrap/unix-48/Texts.h b/bootstrap/unix-48/Texts.h index 189403c9..632b644a 100644 --- a/bootstrap/unix-48/Texts.h +++ b/bootstrap/unix-48/Texts.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Texts__h #define Texts__h diff --git a/bootstrap/unix-48/Vishap.c b/bootstrap/unix-48/Vishap.c index 74d0e984..4c9e3b45 100644 --- a/bootstrap/unix-48/Vishap.c +++ b/bootstrap/unix-48/Vishap.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkamSf */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkamSf */ #include "SYSTEM.h" #include "Configuration.h" #include "Heap.h" diff --git a/bootstrap/unix-48/errors.c b/bootstrap/unix-48/errors.c index f8ddb53a..68e433df 100644 --- a/bootstrap/unix-48/errors.c +++ b/bootstrap/unix-48/errors.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" typedef @@ -25,7 +25,7 @@ export void *errors__init(void) errors_errors[6][0] = 0x00; errors_errors[7][0] = 0x00; errors_errors[8][0] = 0x00; - __MOVE("\'=\' expected", errors_errors[9], 13); + __MOVE("'=' expected", errors_errors[9], 13); errors_errors[10][0] = 0x00; errors_errors[11][0] = 0x00; __MOVE("type definition starts with incorrect symbol", errors_errors[12], 45); @@ -34,28 +34,28 @@ export void *errors__init(void) __MOVE("declaration followed by incorrect symbol", errors_errors[15], 41); __MOVE("MODULE expected", errors_errors[16], 16); errors_errors[17][0] = 0x00; - __MOVE("\'.\' missing", errors_errors[18], 12); - __MOVE("\',\' missing", errors_errors[19], 12); - __MOVE("\':\' missing", errors_errors[20], 12); + __MOVE("'.' missing", errors_errors[18], 12); + __MOVE("',' missing", errors_errors[19], 12); + __MOVE("':' missing", errors_errors[20], 12); errors_errors[21][0] = 0x00; - __MOVE("\')\' missing", errors_errors[22], 12); - __MOVE("\']\' missing", errors_errors[23], 12); - __MOVE("\'}\' missing", errors_errors[24], 12); + __MOVE("')' missing", errors_errors[22], 12); + __MOVE("']' missing", errors_errors[23], 12); + __MOVE("'}' missing", errors_errors[24], 12); __MOVE("OF missing", errors_errors[25], 11); __MOVE("THEN missing", errors_errors[26], 13); __MOVE("DO missing", errors_errors[27], 11); __MOVE("TO missing", errors_errors[28], 11); errors_errors[29][0] = 0x00; - __MOVE("\'(\' missing", errors_errors[30], 12); + __MOVE("'(' missing", errors_errors[30], 12); errors_errors[31][0] = 0x00; errors_errors[32][0] = 0x00; errors_errors[33][0] = 0x00; - __MOVE("\':=\' missing", errors_errors[34], 13); - __MOVE("\',\' or OF expected", errors_errors[35], 19); + __MOVE("':=' missing", errors_errors[34], 13); + __MOVE("',' or OF expected", errors_errors[35], 19); errors_errors[36][0] = 0x00; errors_errors[37][0] = 0x00; __MOVE("identifier expected", errors_errors[38], 20); - __MOVE("\';\' missing", errors_errors[39], 12); + __MOVE("';' missing", errors_errors[39], 12); errors_errors[40][0] = 0x00; __MOVE("END missing", errors_errors[41], 12); errors_errors[42][0] = 0x00; @@ -131,10 +131,10 @@ export void *errors__init(void) __MOVE("operand is not a variable", errors_errors[112], 26); __MOVE("incompatible assignment", errors_errors[113], 24); __MOVE("string too long to be assigned", errors_errors[114], 31); - __MOVE("parameter doesn\'t match", errors_errors[115], 24); - __MOVE("number of parameters doesn\'t match", errors_errors[116], 35); - __MOVE("result type doesn\'t match", errors_errors[117], 26); - __MOVE("export mark doesn\'t match with forward declaration", errors_errors[118], 51); + __MOVE("parameter doesn't match", errors_errors[115], 24); + __MOVE("number of parameters doesn't match", errors_errors[116], 35); + __MOVE("result type doesn't match", errors_errors[117], 26); + __MOVE("export mark doesn't match with forward declaration", errors_errors[118], 51); __MOVE("redefinition textually precedes procedure bound to base type", errors_errors[119], 61); __MOVE("type of expression following IF, WHILE, UNTIL or ASSERT is not BOOLEAN", errors_errors[120], 71); __MOVE("called object is not a procedure (or is an interrupt procedure)", errors_errors[121], 64); @@ -194,5 +194,6 @@ export void *errors__init(void) __MOVE("implicit type cast", errors_errors[301], 19); __MOVE("inappropriate symbol file ignored", errors_errors[306], 34); __MOVE("no ELSE symbol after CASE statement sequence may lead to trap", errors_errors[307], 62); + __MOVE("SYSTEM.VAL result includes memory past end of source variable", errors_errors[308], 62); __ENDMOD; } diff --git a/bootstrap/unix-48/errors.h b/bootstrap/unix-48/errors.h index 5068083b..41d399ad 100644 --- a/bootstrap/unix-48/errors.h +++ b/bootstrap/unix-48/errors.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef errors__h #define errors__h diff --git a/bootstrap/unix-48/extTools.c b/bootstrap/unix-48/extTools.c index 03bd540b..4efd107a 100644 --- a/bootstrap/unix-48/extTools.c +++ b/bootstrap/unix-48/extTools.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Configuration.h" #include "Console.h" diff --git a/bootstrap/unix-48/extTools.h b/bootstrap/unix-48/extTools.h index 695ea164..fc4f0da1 100644 --- a/bootstrap/unix-48/extTools.h +++ b/bootstrap/unix-48/extTools.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef extTools__h #define extTools__h diff --git a/bootstrap/unix-48/vt100.c b/bootstrap/unix-48/vt100.c index c499aceb..d77b0b84 100644 --- a/bootstrap/unix-48/vt100.c +++ b/bootstrap/unix-48/vt100.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Console.h" #include "Strings.h" @@ -252,7 +252,7 @@ export void *vt100__init(void) __REGCMD("RCP", vt100_RCP); __REGCMD("SCP", vt100_SCP); /* BEGIN */ - __COPY("", vt100_CSI, ((LONGINT)(5))); + __COPY("\033", vt100_CSI, ((LONGINT)(5))); Strings_Append((CHAR*)"[", (LONGINT)2, (void*)vt100_CSI, ((LONGINT)(5))); __ENDMOD; } diff --git a/bootstrap/unix-48/vt100.h b/bootstrap/unix-48/vt100.h index 1aaeca77..4af04d6e 100644 --- a/bootstrap/unix-48/vt100.h +++ b/bootstrap/unix-48/vt100.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef vt100__h #define vt100__h diff --git a/bootstrap/unix-88/Configuration.c b/bootstrap/unix-88/Configuration.c index 951bea6e..47f1ffc7 100644 --- a/bootstrap/unix-88/Configuration.c +++ b/bootstrap/unix-88/Configuration.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" @@ -14,6 +14,6 @@ export void *Configuration__init(void) __DEFMOD; __REGMOD("Configuration", 0); /* BEGIN */ - __MOVE("1.95 [2016/08/24] for gcc LP64 on cygwin", Configuration_versionLong, 41); + __MOVE("1.95 [2016/08/23] for gcc LP64 on cygwin", Configuration_versionLong, 41); __ENDMOD; } diff --git a/bootstrap/unix-88/Configuration.h b/bootstrap/unix-88/Configuration.h index 15594379..ba0bbd99 100644 --- a/bootstrap/unix-88/Configuration.h +++ b/bootstrap/unix-88/Configuration.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Configuration__h #define Configuration__h diff --git a/bootstrap/unix-88/Console.c b/bootstrap/unix-88/Console.c index 29555980..b39e6cf3 100644 --- a/bootstrap/unix-88/Console.c +++ b/bootstrap/unix-88/Console.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "Platform.h" @@ -22,7 +22,7 @@ export void Console_String (CHAR *s, LONGINT s__len); void Console_Flush (void) { INTEGER error; - error = Platform_Write(((LONGINT)(1)), (LONGINT)(uintptr_t)Console_line, Console_pos); + error = Platform_Write(((LONGINT)(1)), (LONGINT)(SYSTEM_ADDRESS)Console_line, Console_pos); Console_pos = 0; } diff --git a/bootstrap/unix-88/Console.h b/bootstrap/unix-88/Console.h index 11152de0..4606384c 100644 --- a/bootstrap/unix-88/Console.h +++ b/bootstrap/unix-88/Console.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Console__h #define Console__h diff --git a/bootstrap/unix-88/Files.c b/bootstrap/unix-88/Files.c index be91d89c..1b144711 100644 --- a/bootstrap/unix-88/Files.c +++ b/bootstrap/unix-88/Files.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #define LARGE #include "SYSTEM.h" #include "Configuration.h" @@ -258,7 +258,7 @@ static void Files_Flush (Files_Buffer buf) if (buf->org != f->pos) { error = Platform_Seek(f->fd, buf->org, Platform_SeekSet); } - error = Platform_Write(f->fd, (LONGINT)(uintptr_t)buf->data, buf->size); + error = Platform_Write(f->fd, (LONGINT)(SYSTEM_ADDRESS)buf->data, buf->size); if (error != 0) { Files_Err((CHAR*)"error writing file", (LONGINT)19, f, error); } @@ -657,7 +657,7 @@ void Files_ReadBytes (Files_Rider *r, LONGINT *r__typ, SYSTEM_BYTE *x, LONGINT x } else { min = n; } - __MOVE((LONGINT)(uintptr_t)buf->data + offset, (LONGINT)(uintptr_t)x + xpos, min); + __MOVE((LONGINT)(SYSTEM_ADDRESS)buf->data + offset, (LONGINT)(SYSTEM_ADDRESS)x + xpos, min); offset += min; (*r).offset = offset; xpos += min; @@ -722,7 +722,7 @@ void Files_WriteBytes (Files_Rider *r, LONGINT *r__typ, SYSTEM_BYTE *x, LONGINT } else { min = n; } - __MOVE((LONGINT)(uintptr_t)x + xpos, (LONGINT)(uintptr_t)buf->data + offset, min); + __MOVE((LONGINT)(SYSTEM_ADDRESS)x + xpos, (LONGINT)(SYSTEM_ADDRESS)buf->data + offset, min); offset += min; (*r).offset = offset; if (offset > buf->size) { @@ -773,15 +773,15 @@ void Files_Rename (CHAR *old, LONGINT old__len, CHAR *new, LONGINT new__len, INT *res = 3; return; } - error = Platform_Read(fdold, (LONGINT)(uintptr_t)buf, ((LONGINT)(4096)), &n); + error = Platform_Read(fdold, (LONGINT)(SYSTEM_ADDRESS)buf, ((LONGINT)(4096)), &n); while (n > 0) { - error = Platform_Write(fdnew, (LONGINT)(uintptr_t)buf, n); + error = Platform_Write(fdnew, (LONGINT)(SYSTEM_ADDRESS)buf, n); if (error != 0) { ignore = Platform_Close(fdold); ignore = Platform_Close(fdnew); Files_Err((CHAR*)"cannot move file", (LONGINT)17, NIL, error); } - error = Platform_Read(fdold, (LONGINT)(uintptr_t)buf, ((LONGINT)(4096)), &n); + error = Platform_Read(fdold, (LONGINT)(SYSTEM_ADDRESS)buf, ((LONGINT)(4096)), &n); } ignore = Platform_Close(fdold); ignore = Platform_Close(fdnew); @@ -839,7 +839,7 @@ static void Files_FlipBytes (SYSTEM_BYTE *src, LONGINT src__len, SYSTEM_BYTE *de j += 1; } } else { - __MOVE((LONGINT)(uintptr_t)src, (LONGINT)(uintptr_t)dest, src__len); + __MOVE((LONGINT)(SYSTEM_ADDRESS)src, (LONGINT)(SYSTEM_ADDRESS)dest, src__len); } } @@ -865,8 +865,10 @@ void Files_ReadLInt (Files_Rider *R, LONGINT *R__typ, LONGINT *x) void Files_ReadSet (Files_Rider *R, LONGINT *R__typ, SET *x) { CHAR b[4]; + LONGINT l; Files_ReadBytes(&*R, R__typ, (void*)b, ((LONGINT)(4)), ((LONGINT)(4))); - *x = (SET)((((int)b[0] + __ASHL((int)b[1], 8)) + __ASHL((int)b[2], 16)) + __ASHL((int)b[3], 24)); + l = (((int)b[0] + __ASHL((int)b[1], 8)) + __ASHL((int)b[2], 16)) + __ASHL((int)b[3], 24); + *x = (SET)l; } void Files_ReadReal (Files_Rider *R, LONGINT *R__typ, REAL *x) @@ -922,11 +924,11 @@ void Files_ReadNum (Files_Rider *R, LONGINT *R__typ, LONGINT *x) n = 0; Files_Read(&*R, R__typ, (void*)&ch); while ((int)ch >= 128) { - n += __ASH((LONGINT)((int)ch - 128), s); + n += __ASH((SYSTEM_INT64)((int)ch - 128), s); s += 7; Files_Read(&*R, R__typ, (void*)&ch); } - n += __ASH((LONGINT)(__MASK((int)ch, -64) - __ASHL(__ASHR((int)ch, 6), 6)), s); + n += __ASH((SYSTEM_INT64)(__MASK((int)ch, -64) - __ASHL(__ASHR((int)ch, 6), 6)), s); *x = n; } @@ -1007,7 +1009,7 @@ static void Files_Finalize (SYSTEM_PTR o) { Files_File f = NIL; LONGINT res; - f = (Files_File)(uintptr_t)o; + f = (Files_File)(SYSTEM_ADDRESS)o; if (f->fd >= 0) { Files_CloseOSFile(f); if (f->tempFile) { diff --git a/bootstrap/unix-88/Files.h b/bootstrap/unix-88/Files.h index 6dcba157..62487a35 100644 --- a/bootstrap/unix-88/Files.h +++ b/bootstrap/unix-88/Files.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #ifndef Files__h #define Files__h diff --git a/bootstrap/unix-88/Heap.c b/bootstrap/unix-88/Heap.c index 69ba4ffb..9873a734 100644 --- a/bootstrap/unix-88/Heap.c +++ b/bootstrap/unix-88/Heap.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tskSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tskSfF */ #define LARGE #include "SYSTEM.h" @@ -102,7 +102,7 @@ export void Heap_Unlock (void); extern void *Heap__init(); extern LONGINT Platform_MainStackFrame; extern LONGINT Platform_OSAllocate(LONGINT size); -#define Heap_FetchAddress(pointer) (LONGINT)(uintptr_t)(*((void**)((uintptr_t)pointer))) +#define Heap_FetchAddress(pointer) (LONGINT)(SYSTEM_ADDRESS)(*((void**)((SYSTEM_ADDRESS)pointer))) #define Heap_HeapModuleInit() Heap__init() #define Heap_OSAllocate(size) Platform_OSAllocate(size) #define Heap_PlatformHalt(code) Platform_Halt(code) @@ -135,7 +135,7 @@ SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs) __COPY(name, m->name, ((LONGINT)(20))); m->refcnt = 0; m->enumPtrs = enumPtrs; - m->next = (Heap_Module)(uintptr_t)Heap_modules; + m->next = (Heap_Module)(SYSTEM_ADDRESS)Heap_modules; Heap_modules = (SYSTEM_PTR)m; _o_result = (void*)m; return _o_result; @@ -316,7 +316,7 @@ SYSTEM_PTR Heap_NEWREC (LONGINT tag) __PUT(adr + 16, 0, LONGINT); Heap_allocated += blksz; Heap_Unlock(); - _o_result = (SYSTEM_PTR)(uintptr_t)(adr + 8); + _o_result = (SYSTEM_PTR)(SYSTEM_ADDRESS)(adr + 8); return _o_result; } @@ -327,12 +327,12 @@ SYSTEM_PTR Heap_NEWBLK (LONGINT size) SYSTEM_PTR new; Heap_Lock(); blksz = __ASHL(__ASHR(size + 63, 5), 5); - new = Heap_NEWREC((LONGINT)(uintptr_t)&blksz); - tag = ((LONGINT)(uintptr_t)new + blksz) - 24; + new = Heap_NEWREC((LONGINT)(SYSTEM_ADDRESS)&blksz); + tag = ((LONGINT)(SYSTEM_ADDRESS)new + blksz) - 24; __PUT(tag - 8, 0, LONGINT); __PUT(tag, blksz, LONGINT); __PUT(tag + 8, -8, LONGINT); - __PUT((LONGINT)(uintptr_t)new - 8, tag, LONGINT); + __PUT((LONGINT)(SYSTEM_ADDRESS)new - 8, tag, LONGINT); Heap_Unlock(); _o_result = new; return _o_result; @@ -361,7 +361,7 @@ static void Heap_Mark (LONGINT q) __GET(tag, offset, LONGINT); fld = q + offset; p = Heap_FetchAddress(fld); - __PUT(fld, (SYSTEM_PTR)(uintptr_t)n, SYSTEM_PTR); + __PUT(fld, (SYSTEM_PTR)(SYSTEM_ADDRESS)n, SYSTEM_PTR); } else { fld = q + offset; n = Heap_FetchAddress(fld); @@ -370,7 +370,7 @@ static void Heap_Mark (LONGINT q) if (!__ODD(tagbits)) { __PUT(n - 8, tagbits + 1, LONGINT); __PUT(q - 8, tag + 1, LONGINT); - __PUT(fld, (SYSTEM_PTR)(uintptr_t)p, SYSTEM_PTR); + __PUT(fld, (SYSTEM_PTR)(SYSTEM_ADDRESS)p, SYSTEM_PTR); p = q; q = n; tag = tagbits; @@ -385,7 +385,7 @@ static void Heap_Mark (LONGINT q) static void Heap_MarkP (SYSTEM_PTR p) { - Heap_Mark((LONGINT)(uintptr_t)p); + Heap_Mark((LONGINT)(SYSTEM_ADDRESS)p); } static void Heap_Scan (void) @@ -554,7 +554,7 @@ static void Heap_Finalize (void) } else { prev->next = n->next; } - (*n->finalize)((SYSTEM_PTR)(uintptr_t)n->obj); + (*n->finalize)((SYSTEM_PTR)(SYSTEM_ADDRESS)n->obj); if (prev == NIL) { n = Heap_fin; } else { @@ -573,7 +573,7 @@ void Heap_FINALL (void) while (Heap_fin != NIL) { n = Heap_fin; Heap_fin = Heap_fin->next; - (*n->finalize)((SYSTEM_PTR)(uintptr_t)n->obj); + (*n->finalize)((SYSTEM_PTR)(SYSTEM_ADDRESS)n->obj); } } @@ -590,9 +590,9 @@ static void Heap_MarkStack (LONGINT n, LONGINT *cand, LONGINT cand__len) } if (n == 0) { nofcand = 0; - sp = (LONGINT)(uintptr_t)&frame; + sp = (LONGINT)(SYSTEM_ADDRESS)&frame; stack0 = Heap_PlatformMainStackFrame(); - inc = (LONGINT)(uintptr_t)&align.p - (LONGINT)(uintptr_t)&align; + inc = (LONGINT)(SYSTEM_ADDRESS)&align.p - (LONGINT)(SYSTEM_ADDRESS)&align; if (sp > stack0) { inc = -inc; } @@ -623,7 +623,7 @@ void Heap_GC (BOOLEAN markStack) LONGINT cand[10000]; if (Heap_lockdepth == 0 || (Heap_lockdepth == 1 && !markStack)) { Heap_Lock(); - m = (Heap_Module)(uintptr_t)Heap_modules; + m = (Heap_Module)(SYSTEM_ADDRESS)Heap_modules; while (m != NIL) { if (m->enumPtrs != NIL) { (*m->enumPtrs)(Heap_MarkP); @@ -700,7 +700,7 @@ void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize) { Heap_FinNode f; __NEW(f, Heap_FinDesc); - f->obj = (LONGINT)(uintptr_t)obj; + f->obj = (LONGINT)(SYSTEM_ADDRESS)obj; f->finalize = finalize; f->marked = 1; f->next = Heap_fin; diff --git a/bootstrap/unix-88/Heap.h b/bootstrap/unix-88/Heap.h index 40db2aca..b1ff5968 100644 --- a/bootstrap/unix-88/Heap.h +++ b/bootstrap/unix-88/Heap.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tskSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tskSfF */ #ifndef Heap__h #define Heap__h diff --git a/bootstrap/unix-88/Modules.c b/bootstrap/unix-88/Modules.c index eaf370c4..0c836ead 100644 --- a/bootstrap/unix-88/Modules.c +++ b/bootstrap/unix-88/Modules.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "Console.h" diff --git a/bootstrap/unix-88/Modules.h b/bootstrap/unix-88/Modules.h index d273cf1a..6e6ded2e 100644 --- a/bootstrap/unix-88/Modules.h +++ b/bootstrap/unix-88/Modules.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Modules__h #define Modules__h diff --git a/bootstrap/unix-88/OPB.c b/bootstrap/unix-88/OPB.c index 2fccfe61..f4bdb1a8 100644 --- a/bootstrap/unix-88/OPB.c +++ b/bootstrap/unix-88/OPB.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "OPM.h" @@ -35,7 +35,9 @@ export void OPB_In (OPT_Node *x, OPT_Node y); export void OPB_Index (OPT_Node *x, OPT_Node y); export void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ); static BOOLEAN OPB_IntToBool (LONGINT i); +static OPT_Struct OPB_IntType (LONGINT size); export void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y); +static LONGINT OPB_LongerSize (LONGINT i); export void OPB_MOp (SHORTINT op, OPT_Node *x); export OPT_Node OPB_NewBoolConst (BOOLEAN boolval); export OPT_Node OPB_NewIntConst (LONGINT intval); @@ -52,6 +54,8 @@ export void OPB_Return (OPT_Node *x, OPT_Object proc); export void OPB_SetElem (OPT_Node *x); static void OPB_SetIntType (OPT_Node node); export void OPB_SetRange (OPT_Node *x, OPT_Node y); +static LONGINT OPB_ShorterSize (LONGINT i); +static INTEGER OPB_SignedByteSize (LONGINT n); export void OPB_StFct (OPT_Node *par0, SHORTINT fctno, INTEGER parno); export void OPB_StPar0 (OPT_Node *par0, INTEGER fctno); export void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno); @@ -91,8 +95,8 @@ OPT_Node OPB_NewLeaf (OPT_Object obj) node = OPT_NewNode(9); break; default: - OPB_err(127); node = OPT_NewNode(0); + OPB_err(127); break; } node->obj = obj; @@ -221,21 +225,68 @@ OPT_Node OPB_EmptySet (void) return _o_result; } +static INTEGER OPB_SignedByteSize (LONGINT n) +{ + INTEGER _o_result; + INTEGER b; + if (n < 0) { + n = -(n + 1); + } + b = 1; + while ((b < 8 && __ASH(n, -(__ASHL(b, 3) - 1)) != 0)) { + b += 1; + } + _o_result = b; + return _o_result; +} + +static LONGINT OPB_ShorterSize (LONGINT i) +{ + LONGINT _o_result; + if (i >= (SYSTEM_INT64)OPM_LIntSize) { + _o_result = OPM_IntSize; + return _o_result; + } else { + _o_result = OPM_SIntSize; + return _o_result; + } + __RETCHK; +} + +static LONGINT OPB_LongerSize (LONGINT i) +{ + LONGINT _o_result; + if (i <= (SYSTEM_INT64)OPM_SIntSize) { + _o_result = OPM_IntSize; + return _o_result; + } else { + _o_result = OPM_LIntSize; + return _o_result; + } + __RETCHK; +} + +static OPT_Struct OPB_IntType (LONGINT size) +{ + OPT_Struct _o_result; + OPT_Struct result = NIL; + if (size <= OPT_sinttyp->size) { + result = OPT_sinttyp; + } else if (size <= OPT_inttyp->size) { + result = OPT_inttyp; + } else { + result = OPT_linttyp; + } + if (size > OPT_linttyp->size) { + OPB_err(203); + } + _o_result = result; + return _o_result; +} + static void OPB_SetIntType (OPT_Node node) { - LONGINT v; - v = node->conval->intval; - if ((OPM_MinSInt <= (LONGINT)v && (LONGINT)v <= OPM_MaxSInt)) { - node->typ = OPT_sinttyp; - } else if ((OPM_MinInt <= (LONGINT)v && (LONGINT)v <= OPM_MaxInt)) { - node->typ = OPT_inttyp; - } else if ((OPM_MinLInt <= v && v <= OPM_MaxLInt)) { - node->typ = OPT_linttyp; - } else { - OPB_err(203); - node->typ = OPT_sinttyp; - node->conval->intval = 1; - } + node->typ = OPB_IntType(OPB_SignedByteSize(node->conval->intval)); } OPT_Node OPB_NewIntConst (LONGINT intval) @@ -379,16 +430,16 @@ void OPB_Field (OPT_Node *x, OPT_Object y) } } -static struct TypTest__57 { +static struct TypTest__61 { OPT_Node *x; OPT_Object *obj; BOOLEAN *guard; - struct TypTest__57 *lnk; -} *TypTest__57_s; + struct TypTest__61 *lnk; +} *TypTest__61_s; -static void GTT__58 (OPT_Struct t0, OPT_Struct t1); +static void GTT__62 (OPT_Struct t0, OPT_Struct t1); -static void GTT__58 (OPT_Struct t0, OPT_Struct t1) +static void GTT__62 (OPT_Struct t0, OPT_Struct t1) { OPT_Node node = NIL; OPT_Struct t = NIL; @@ -401,54 +452,54 @@ static void GTT__58 (OPT_Struct t0, OPT_Struct t1) t1 = t1->BaseTyp; } if (t1 == t0 || t0->form == 0) { - if (*TypTest__57_s->guard) { - OPB_BindNodes(5, NIL, &*TypTest__57_s->x, NIL); - (*TypTest__57_s->x)->readonly = (*TypTest__57_s->x)->left->readonly; + if (*TypTest__61_s->guard) { + OPB_BindNodes(5, NIL, &*TypTest__61_s->x, NIL); + (*TypTest__61_s->x)->readonly = (*TypTest__61_s->x)->left->readonly; } else { node = OPT_NewNode(11); node->subcl = 16; - node->left = *TypTest__57_s->x; - node->obj = *TypTest__57_s->obj; - *TypTest__57_s->x = node; + node->left = *TypTest__61_s->x; + node->obj = *TypTest__61_s->obj; + *TypTest__61_s->x = node; } } else { OPB_err(85); } } else if (t0 != t1) { OPB_err(85); - } else if (!*TypTest__57_s->guard) { - if ((*TypTest__57_s->x)->class == 5) { + } else if (!*TypTest__61_s->guard) { + if ((*TypTest__61_s->x)->class == 5) { node = OPT_NewNode(11); node->subcl = 16; - node->left = *TypTest__57_s->x; - node->obj = *TypTest__57_s->obj; - *TypTest__57_s->x = node; + node->left = *TypTest__61_s->x; + node->obj = *TypTest__61_s->obj; + *TypTest__61_s->x = node; } else { - *TypTest__57_s->x = OPB_NewBoolConst(1); + *TypTest__61_s->x = OPB_NewBoolConst(1); } } } void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard) { - struct TypTest__57 _s; + struct TypTest__61 _s; _s.x = x; _s.obj = &obj; _s.guard = &guard; - _s.lnk = TypTest__57_s; - TypTest__57_s = &_s; + _s.lnk = TypTest__61_s; + TypTest__61_s = &_s; if (OPB_NotVar(*x)) { OPB_err(112); } else if ((*x)->typ->form == 13) { if (((*x)->typ->BaseTyp->comp != 4 && (*x)->typ != OPT_sysptrtyp)) { OPB_err(85); } else if (obj->typ->form == 13) { - GTT__58((*x)->typ->BaseTyp, obj->typ->BaseTyp); + GTT__62((*x)->typ->BaseTyp, obj->typ->BaseTyp); } else { OPB_err(86); } } else if (((((*x)->typ->comp == 4 && (*x)->class == 1)) && obj->typ->comp == 4)) { - GTT__58((*x)->typ, obj->typ); + GTT__62((*x)->typ, obj->typ); } else { OPB_err(87); } @@ -457,7 +508,7 @@ void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard) } else { (*x)->typ = OPT_booltyp; } - TypTest__57_s = _s.lnk; + TypTest__61_s = _s.lnk; } void OPB_In (OPT_Node *x, OPT_Node y) @@ -470,7 +521,7 @@ void OPB_In (OPT_Node *x, OPT_Node y) } else if ((__IN(f, 0x70) && y->typ->form == 9)) { if ((*x)->class == 7) { k = (*x)->conval->intval; - if (k < 0 || k > (LONGINT)OPM_MaxSet) { + if (k < 0 || k > (SYSTEM_INT64)OPM_MaxSet) { OPB_err(202); } else if (y->class == 7) { (*x)->conval->intval = OPB_BoolToInt(__IN(k, y->conval->setval)); @@ -523,13 +574,13 @@ static void OPB_CheckRealType (INTEGER f, INTEGER nr, OPT_Const x) x->intval = -1; } -static struct MOp__28 { - struct MOp__28 *lnk; -} *MOp__28_s; +static struct MOp__30 { + struct MOp__30 *lnk; +} *MOp__30_s; -static OPT_Node NewOp__29 (SHORTINT op, OPT_Struct typ, OPT_Node z); +static OPT_Node NewOp__31 (SHORTINT op, OPT_Struct typ, OPT_Node z); -static OPT_Node NewOp__29 (SHORTINT op, OPT_Struct typ, OPT_Node z) +static OPT_Node NewOp__31 (SHORTINT op, OPT_Struct typ, OPT_Node z) { OPT_Node _o_result; OPT_Node node = NIL; @@ -546,9 +597,9 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) INTEGER f; OPT_Struct typ = NIL; OPT_Node z = NIL; - struct MOp__28 _s; - _s.lnk = MOp__28_s; - MOp__28_s = &_s; + struct MOp__30 _s; + _s.lnk = MOp__30_s; + MOp__30_s = &_s; z = *x; if (z->class == 8 || z->class == 9) { OPB_err(126); @@ -562,7 +613,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) z->conval->intval = OPB_BoolToInt(!OPB_IntToBool(z->conval->intval)); z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(98); @@ -590,7 +641,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) } z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(97); @@ -611,7 +662,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) } z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(111); @@ -623,7 +674,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) z->conval->intval = (int)__CAP((CHAR)z->conval->intval); z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(111); @@ -636,7 +687,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) z->conval->intval = OPB_BoolToInt(__ODD(z->conval->intval)); z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(111); @@ -649,7 +700,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) f = 10; } if (z->class < 7 || f == 10) { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } else { OPB_err(127); } @@ -658,7 +709,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) case 25: if ((__IN(f, 0x70) && z->class == 7)) { if ((0 <= z->conval->intval && z->conval->intval <= -1)) { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } else { OPB_err(219); } @@ -675,7 +726,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) } } *x = z; - MOp__28_s = _s.lnk; + MOp__30_s = _s.lnk; } static void OPB_CheckPtr (OPT_Node x, OPT_Node y) @@ -866,41 +917,13 @@ static void OPB_ConstOp (INTEGER op, OPT_Node x, OPT_Node y) __GUARDEQP(yval, OPT_ConstDesc) = *xval; } break; - case 4: + case 4: case 5: case 6: if (__IN(g, 0x70)) { - x->typ = y->typ; - } else if (g == 7) { - x->typ = OPT_realtyp; - xval->realval = xval->intval; - } else if (g == 8) { - x->typ = OPT_lrltyp; - xval->realval = xval->intval; - } else { - OPB_err(100); - y->typ = x->typ; - __GUARDEQP(yval, OPT_ConstDesc) = *xval; - } - break; - case 5: - if (g == 4) { - y->typ = OPT_inttyp; - } else if (__IN(g, 0x70)) { - x->typ = y->typ; - } else if (g == 7) { - x->typ = OPT_realtyp; - xval->realval = xval->intval; - } else if (g == 8) { - x->typ = OPT_lrltyp; - xval->realval = xval->intval; - } else { - OPB_err(100); - y->typ = x->typ; - __GUARDEQP(yval, OPT_ConstDesc) = *xval; - } - break; - case 6: - if (__IN(g, 0x70)) { - y->typ = OPT_linttyp; + if (x->typ->size <= y->typ->size) { + x->typ = y->typ; + } else { + x->typ = OPB_IntType(x->typ->size); + } } else if (g == 7) { x->typ = OPT_realtyp; xval->realval = xval->intval; @@ -1197,15 +1220,15 @@ static void OPB_Convert (OPT_Node *x, OPT_Struct typ) (*x)->typ = typ; } -static struct Op__38 { +static struct Op__40 { INTEGER *f, *g; - struct Op__38 *lnk; -} *Op__38_s; + struct Op__40 *lnk; +} *Op__40_s; -static void NewOp__39 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y); -static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y); +static void NewOp__41 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y); +static BOOLEAN strings__43 (OPT_Node *x, OPT_Node *y); -static void NewOp__39 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y) +static void NewOp__41 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y) { OPT_Node node = NIL; node = OPT_NewNode(12); @@ -1216,29 +1239,29 @@ static void NewOp__39 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y) *x = node; } -static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y) +static BOOLEAN strings__43 (OPT_Node *x, OPT_Node *y) { BOOLEAN _o_result; BOOLEAN ok, xCharArr, yCharArr; - xCharArr = (__IN((*x)->typ->comp, 0x0c) && (*x)->typ->BaseTyp->form == 3) || *Op__38_s->f == 10; - yCharArr = (__IN((*y)->typ->comp, 0x0c) && (*y)->typ->BaseTyp->form == 3) || *Op__38_s->g == 10; - if ((((xCharArr && *Op__38_s->g == 3)) && (*y)->class == 7)) { + xCharArr = (__IN((*x)->typ->comp, 0x0c) && (*x)->typ->BaseTyp->form == 3) || *Op__40_s->f == 10; + yCharArr = (__IN((*y)->typ->comp, 0x0c) && (*y)->typ->BaseTyp->form == 3) || *Op__40_s->g == 10; + if ((((xCharArr && *Op__40_s->g == 3)) && (*y)->class == 7)) { OPB_CharToString(*y); - *Op__38_s->g = 10; + *Op__40_s->g = 10; yCharArr = 1; } - if ((((yCharArr && *Op__38_s->f == 3)) && (*x)->class == 7)) { + if ((((yCharArr && *Op__40_s->f == 3)) && (*x)->class == 7)) { OPB_CharToString(*x); - *Op__38_s->f = 10; + *Op__40_s->f = 10; xCharArr = 1; } ok = (xCharArr && yCharArr); if (ok) { - if ((*Op__38_s->f == 10 && (*x)->conval->intval2 == 1)) { + if ((*Op__40_s->f == 10 && (*x)->conval->intval2 == 1)) { (*x)->typ = OPT_chartyp; (*x)->conval->intval = 0; OPB_Index(&*y, OPB_NewIntConst(((LONGINT)(0)))); - } else if ((*Op__38_s->g == 10 && (*y)->conval->intval2 == 1)) { + } else if ((*Op__40_s->g == 10 && (*y)->conval->intval2 == 1)) { (*y)->typ = OPT_chartyp; (*y)->conval->intval = 0; OPB_Index(&*x, OPB_NewIntConst(((LONGINT)(0)))); @@ -1255,11 +1278,11 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPT_Struct typ = NIL; BOOLEAN do_; LONGINT val; - struct Op__38 _s; + struct Op__40 _s; _s.f = &f; _s.g = &g; - _s.lnk = Op__38_s; - Op__38_s = &_s; + _s.lnk = Op__40_s; + Op__40_s = &_s; z = *x; if (((z->class == 8 || z->class == 9) || y->class == 8) || y->class == 9) { OPB_err(126); @@ -1277,15 +1300,8 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(100); } break; - case 4: - if (__IN(g, 0x01f0)) { - OPB_Convert(&z, y->typ); - } else { - OPB_err(100); - } - break; - case 5: - if (g == 4) { + case 4: case 5: case 6: + if ((__IN(g, 0x70) && y->typ->size < z->typ->size)) { OPB_Convert(&y, z->typ); } else if (__IN(g, 0x01f0)) { OPB_Convert(&z, y->typ); @@ -1293,15 +1309,6 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(100); } break; - case 6: - if (__IN(g, 0x70)) { - OPB_Convert(&y, z->typ); - } else if (__IN(g, 0x0180)) { - OPB_Convert(&z, y->typ); - } else { - OPB_err(100); - } - break; case 7: if (__IN(g, 0x70)) { OPB_Convert(&y, z->typ); @@ -1387,7 +1394,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) typ = OPT_undftyp; } if (do_) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 2: @@ -1406,7 +1413,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(102); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; case 3: do_ = 1; @@ -1429,7 +1436,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) typ = OPT_undftyp; } if (do_) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 4: @@ -1447,7 +1454,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(104); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; case 5: if (f == 2) { @@ -1457,7 +1464,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } else if ((y->class == 7 && OPB_IntToBool(y->conval->intval))) { } else { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } } else if (f != 0) { OPB_err(94); @@ -1480,7 +1487,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } if (do_) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 7: @@ -1489,7 +1496,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) typ = OPT_undftyp; } if ((!__IN(f, 0x70) || y->class != 7) || y->conval->intval != 0) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 8: @@ -1500,7 +1507,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } else if ((y->class == 7 && !OPB_IntToBool(y->conval->intval))) { } else { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } } else if (f != 0) { OPB_err(95); @@ -1508,16 +1515,16 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } break; case 9: case 10: - if (__IN(f, 0x6bff) || strings__41(&z, &y)) { + if (__IN(f, 0x6bff) || strings__43(&z, &y)) { typ = OPT_booltyp; } else { OPB_err(107); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; case 11: case 12: case 13: case 14: - if (__IN(f, 0x01f9) || strings__41(&z, &y)) { + if (__IN(f, 0x01f9) || strings__43(&z, &y)) { typ = OPT_booltyp; } else { OPM_LogWLn(); @@ -1526,7 +1533,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(108); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; default: OPM_LogWStr((CHAR*)"unhandled case in OPB.Op, op = ", (LONGINT)32); @@ -1536,7 +1543,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } *x = z; - Op__38_s = _s.lnk; + Op__40_s = _s.lnk; } void OPB_SetRange (OPT_Node *x, OPT_Node y) @@ -1547,13 +1554,13 @@ void OPB_SetRange (OPT_Node *x, OPT_Node y) } else if ((__IN((*x)->typ->form, 0x70) && __IN(y->typ->form, 0x70))) { if ((*x)->class == 7) { k = (*x)->conval->intval; - if (0 > k || k > (LONGINT)OPM_MaxSet) { + if (0 > k || k > (SYSTEM_INT64)OPM_MaxSet) { OPB_err(202); } } if (y->class == 7) { l = y->conval->intval; - if (0 > l || l > (LONGINT)OPM_MaxSet) { + if (0 > l || l > (SYSTEM_INT64)OPM_MaxSet) { OPB_err(202); } } @@ -1583,7 +1590,7 @@ void OPB_SetElem (OPT_Node *x) OPB_err(93); } else if ((*x)->class == 7) { k = (*x)->conval->intval; - if ((0 <= k && k <= (LONGINT)OPM_MaxSet)) { + if ((0 <= k && k <= (SYSTEM_INT64)OPM_MaxSet)) { (*x)->conval->setval = __SETOF(k); } else { OPB_err(202); @@ -1597,8 +1604,9 @@ void OPB_SetElem (OPT_Node *x) static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) { + OPT_Struct y = NIL; INTEGER f, g; - OPT_Struct y = NIL, p = NIL, q = NIL; + OPT_Struct p = NIL, q = NIL; if (OPM_Verbose) { OPM_LogWLn(); OPM_LogWStr((CHAR*)"PROCEDURE CheckAssign", (LONGINT)22); @@ -1628,31 +1636,20 @@ static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) case 0: case 10: break; case 1: - if (!__IN(g, 0x1a)) { + if (!((__IN(g, 0x7a) && y->size == 1))) { OPB_err(113); } break; - case 2: case 3: case 4: case 9: + case 2: case 3: case 9: if (g != f) { OPB_err(113); } break; - case 5: - if (!__IN(g, 0x30)) { + case 4: case 5: case 6: + if (!__IN(g, 0x70) || x->size < y->size) { OPB_err(113); } break; - case 6: - if (OPM_LIntSize == 4) { - if (!__IN(g, 0x70)) { - OPB_err(113); - } - } else { - if (!__IN(g, 0x70)) { - OPB_err(113); - } - } - break; case 7: if (!__IN(g, 0xf0)) { OPB_err(113); @@ -1833,14 +1830,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) x = OPB_NewIntConst(((LONGINT)(0))); x->typ = OPT_chartyp; break; - case 4: - x = OPB_NewIntConst(OPM_MinSInt); - break; - case 5: - x = OPB_NewIntConst(OPM_MinInt); - break; - case 6: - x = OPB_NewIntConst(OPM_MinLInt); + case 4: case 5: case 6: + x = OPB_NewIntConst(OPM_SignedMinimum(x->typ->size)); break; case 9: x = OPB_NewIntConst(((LONGINT)(0))); @@ -1870,14 +1861,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) x = OPB_NewIntConst(((LONGINT)(255))); x->typ = OPT_chartyp; break; - case 4: - x = OPB_NewIntConst(OPM_MaxSInt); - break; - case 5: - x = OPB_NewIntConst(OPM_MaxInt); - break; - case 6: - x = OPB_NewIntConst(OPM_MaxLInt); + case 4: case 5: case 6: + x = OPB_NewIntConst(OPM_SignedMaximum(x->typ->size)); break; case 9: x = OPB_NewIntConst(OPM_MaxSet); @@ -1910,10 +1895,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) case 10: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if (f == 5) { - OPB_Convert(&x, OPT_sinttyp); - } else if (f == 6) { - OPB_Convert(&x, OPT_inttyp); + } else if ((__IN(f, 0x70) && x->typ->size > (SYSTEM_INT64)OPM_SIntSize)) { + OPB_Convert(&x, OPB_IntType(OPB_ShorterSize(x->typ->size))); } else if (f == 8) { OPB_Convert(&x, OPT_realtyp); } else { @@ -1923,10 +1906,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) case 11: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if (f == 4) { - OPB_Convert(&x, OPT_inttyp); - } else if (f == 5) { - OPB_Convert(&x, OPT_linttyp); + } else if ((__IN(f, 0x70) && x->typ->size < (SYSTEM_INT64)OPM_LIntSize)) { + OPB_Convert(&x, OPB_IntType(OPB_LongerSize(x->typ->size))); } else if (f == 7) { OPB_Convert(&x, OPT_lrltyp); } else if (f == 3) { @@ -1974,7 +1955,7 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - if (f != 6) { + if (x->typ->size != (SYSTEM_INT64)OPM_LIntSize) { OPB_Convert(&x, OPT_linttyp); } } else { @@ -2012,9 +1993,9 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) case 24: case 25: case 28: case 31: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if ((x->class == 7 && __IN(f, 0x30))) { + } else if ((((x->class == 7 && __IN(f, 0x70))) && x->typ->size < OPT_linttyp->size)) { OPB_Convert(&x, OPT_linttyp); - } else if (!__IN(f, 0x2040)) { + } else if (!((__IN(x->typ->form, 0x2070) && x->typ->size == (SYSTEM_INT64)OPM_PointerSize))) { OPB_err(111); x->typ = OPT_linttyp; } @@ -2063,13 +2044,13 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) *par0 = x; } -static struct StPar1__52 { - struct StPar1__52 *lnk; -} *StPar1__52_s; +static struct StPar1__56 { + struct StPar1__56 *lnk; +} *StPar1__56_s; -static OPT_Node NewOp__53 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right); +static OPT_Node NewOp__57 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right); -static OPT_Node NewOp__53 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right) +static OPT_Node NewOp__57 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right) { OPT_Node _o_result; OPT_Node node = NIL; @@ -2086,9 +2067,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) INTEGER f, L; OPT_Struct typ = NIL; OPT_Node p = NIL, t = NIL; - struct StPar1__52 _s; - _s.lnk = StPar1__52_s; - StPar1__52_s = &_s; + struct StPar1__56 _s; + _s.lnk = StPar1__56_s; + StPar1__56_s = &_s; p = *par0; f = x->typ->form; switch (fctno) { @@ -2104,7 +2085,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) OPB_err(111); } } - p = NewOp__53(19, fctno, p, x); + p = NewOp__57(19, fctno, p, x); p->typ = OPT_notyp; } break; @@ -2112,10 +2093,10 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - if ((x->class == 7 && (0 > x->conval->intval || x->conval->intval > (LONGINT)OPM_MaxSet))) { + if ((x->class == 7 && (0 > x->conval->intval || x->conval->intval > (SYSTEM_INT64)OPM_MaxSet))) { OPB_err(202); } - p = NewOp__53(19, fctno, p, x); + p = NewOp__57(19, fctno, p, x); } else { OPB_err(111); } @@ -2124,7 +2105,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) case 17: if (!__IN(f, 0x70) || x->class != 7) { OPB_err(69); - } else if (f == 4) { + } else if (x->typ->size == 1) { L = (int)x->conval->intval; typ = p->typ; while ((L > 0 && __IN(typ->comp, 0x0c))) { @@ -2140,7 +2121,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) p = p->left; x->conval->intval += 1; } - p = NewOp__53(12, 19, p, x); + p = NewOp__57(12, 19, p, x); p->typ = OPT_linttyp; } else { p = x; @@ -2162,7 +2143,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) t = x; x = p; p = t; - p = NewOp__53(19, 18, p, x); + p = NewOp__57(19, 18, p, x); } else { OPB_err(111); } @@ -2188,7 +2169,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) } p->obj = NIL; } else { - p = NewOp__53(12, 17, p, x); + p = NewOp__57(12, 17, p, x); p->typ = OPT_linttyp; } } else { @@ -2219,9 +2200,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) OPB_err(111); } else { if (fctno == 22) { - p = NewOp__53(12, 27, p, x); + p = NewOp__57(12, 27, p, x); } else { - p = NewOp__53(12, 28, p, x); + p = NewOp__57(12, 28, p, x); } p->typ = p->left->typ; } @@ -2238,7 +2219,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) x = p; p = t; } - p = NewOp__53(19, fctno, p, x); + p = NewOp__57(19, fctno, p, x); } else { OPB_err(111); } @@ -2248,7 +2229,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - p = NewOp__53(12, 26, p, x); + p = NewOp__57(12, 26, p, x); } else { OPB_err(111); } @@ -2258,6 +2239,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (((x->class == 8 || x->class == 9) || __IN(f, 0x1401)) || x->typ->comp == 3) { OPB_err(126); } + if (x->typ->size < p->typ->size) { + OPB_err(-308); + } t = OPT_NewNode(11); t->subcl = 29; t->left = x; @@ -2269,7 +2253,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - p = NewOp__53(19, 30, p, x); + p = NewOp__57(19, 30, p, x); } else { OPB_err(111); } @@ -2278,9 +2262,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) case 31: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if ((x->class == 7 && __IN(f, 0x30))) { + } else if ((((x->class == 7 && __IN(f, 0x70))) && x->typ->size < OPT_linttyp->size)) { OPB_Convert(&x, OPT_linttyp); - } else if (!__IN(f, 0x2040)) { + } else if (!((__IN(x->typ->form, 0x2070) && x->typ->size == (SYSTEM_INT64)OPM_PointerSize))) { OPB_err(111); x->typ = OPT_linttyp; } @@ -2315,7 +2299,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) break; } *par0 = p; - StPar1__52_s = _s.lnk; + StPar1__56_s = _s.lnk; } void OPB_StParN (OPT_Node *par0, OPT_Node x, INTEGER fctno, INTEGER n) @@ -2434,7 +2418,7 @@ static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpa ftyp = ftyp->BaseTyp; atyp = atyp->BaseTyp; if ((fvarpar && ftyp == OPT_bytetyp)) { - if (!__IN(f, 0x0c) || !__IN(atyp->form, 0x1e)) { + if (!__IN(f, 0x0c) || !((__IN(atyp->form, 0x7e) && atyp->size == 1))) { if (__IN(18, OPM_opt)) { OPB_err(-301); } @@ -2517,7 +2501,7 @@ void OPB_Param (OPT_Node ap, OPT_Object fp) OPB_err(111); } } else if ((fp->typ == OPT_sysptrtyp && ap->typ->form == 13)) { - } else if ((ap->typ != fp->typ && !((fp->typ->form == 1 && __IN(ap->typ->form, 0x18))))) { + } else if ((ap->typ != fp->typ && !((fp->typ->form == 1 && ((__IN(ap->typ->form, 0x7e) && ap->typ->size == 1)))))) { OPB_err(123); } else if ((fp->typ->form == 13 && ap->class == 5)) { OPB_err(123); diff --git a/bootstrap/unix-88/OPB.h b/bootstrap/unix-88/OPB.h index 48c946c5..af419f75 100644 --- a/bootstrap/unix-88/OPB.h +++ b/bootstrap/unix-88/OPB.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPB__h #define OPB__h diff --git a/bootstrap/unix-88/OPC.c b/bootstrap/unix-88/OPC.c index 40697da9..bb9b75e6 100644 --- a/bootstrap/unix-88/OPC.c +++ b/bootstrap/unix-88/OPC.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "Configuration.h" @@ -17,12 +17,13 @@ static CHAR OPC_BodyNameExt[13]; export void OPC_Align (LONGINT *adr, LONGINT base); export void OPC_Andent (OPT_Struct typ); static void OPC_AnsiParamList (OPT_Object obj, BOOLEAN showParamNames); -export LONGINT OPC_Base (OPT_Struct typ); +export LONGINT OPC_BaseAlignment (OPT_Struct typ); export OPT_Object OPC_BaseTProc (OPT_Object obj); export void OPC_BegBlk (void); export void OPC_BegStat (void); static void OPC_CProcDefs (OPT_Object obj, INTEGER vis); export void OPC_Case (LONGINT caseVal, INTEGER form); +static void OPC_CharacterLiteral (LONGINT c); export void OPC_Cmp (INTEGER rel); export void OPC_CompleteIdent (OPT_Object obj); export void OPC_Constant (OPT_Const con, INTEGER form); @@ -74,8 +75,10 @@ static void OPC_PutBase (OPT_Struct typ); static void OPC_PutPtrOffsets (OPT_Struct typ, LONGINT adr, LONGINT *cnt); static void OPC_RegCmds (OPT_Object obj); export void OPC_SetInclude (BOOLEAN exclude); +export LONGINT OPC_SizeAlignment (LONGINT size); static void OPC_Stars (OPT_Struct typ, BOOLEAN *openClause); static void OPC_Str1 (CHAR *s, LONGINT s__len, LONGINT x); +static void OPC_StringLiteral (CHAR *s, LONGINT s__len, LONGINT l); export void OPC_TDescDecl (OPT_Struct typ); export void OPC_TypeDefs (OPT_Object obj, INTEGER vis); export void OPC_TypeOf (OPT_Object ap); @@ -316,7 +319,7 @@ void OPC_Andent (OPT_Struct typ) static BOOLEAN OPC_Undefined (OPT_Object obj) { BOOLEAN _o_result; - _o_result = (((obj->mnolev >= 0 && obj->linkadr != (LONGINT)(3 + OPM_currFile))) && obj->linkadr != 2) || obj->name[0] == 0x00; + _o_result = obj->name[0] == 0x00 || (((obj->mnolev >= 0 && obj->linkadr != (SYSTEM_INT64)(3 + OPM_currFile))) && obj->linkadr != 2); return _o_result; } @@ -816,14 +819,15 @@ void OPC_TDescDecl (OPT_Struct typ) OPC_Andent(typ); OPC_Str1((CHAR*)", #", (LONGINT)4, typ->n + 1); OPC_Str1((CHAR*)", #) = {__TDFLDS(", (LONGINT)18, OPC_NofPtrs(typ)); - OPM_Write('\"'); + OPM_Write('"'); if (typ->strobj != NIL) { OPM_WriteStringVar((void*)typ->strobj->name, ((LONGINT)(256))); } - OPC_Str1((CHAR*)"\", #), {", (LONGINT)9, typ->size); + OPM_Write('"'); + OPC_Str1((CHAR*)", #), {", (LONGINT)8, typ->size); nofptrs = 0; OPC_PutPtrOffsets(typ, ((LONGINT)(0)), &nofptrs); - OPC_Str1((CHAR*)"#}}", (LONGINT)4, -((nofptrs + 1) * (LONGINT)OPM_LIntSize)); + OPC_Str1((CHAR*)"#}}", (LONGINT)4, -((nofptrs + 1) * (SYSTEM_INT64)OPM_LIntSize)); OPC_EndStat(); } @@ -865,70 +869,37 @@ void OPC_Align (LONGINT *adr, LONGINT base) } } -LONGINT OPC_Base (OPT_Struct typ) +LONGINT OPC_SizeAlignment (LONGINT size) { LONGINT _o_result; - switch (typ->form) { - case 1: - _o_result = 1; - return _o_result; - break; - case 3: - _o_result = OPM_CharAlign; - return _o_result; - break; - case 2: - _o_result = OPM_BoolAlign; - return _o_result; - break; - case 4: - _o_result = OPM_SIntAlign; - return _o_result; - break; - case 5: - _o_result = OPM_IntAlign; - return _o_result; - break; - case 6: - _o_result = OPM_LIntAlign; - return _o_result; - break; - case 7: - _o_result = OPM_RealAlign; - return _o_result; - break; - case 8: - _o_result = OPM_LRealAlign; - return _o_result; - break; - case 9: - _o_result = OPM_SetAlign; - return _o_result; - break; - case 13: - _o_result = OPM_PointerAlign; - return _o_result; - break; - case 14: - _o_result = OPM_ProcAlign; - return _o_result; - break; - case 15: - if (typ->comp == 4) { - _o_result = __MASK(typ->align, -65536); - return _o_result; - } else { - _o_result = OPC_Base(typ->BaseTyp); - return _o_result; - } - break; - default: - OPM_LogWStr((CHAR*)"unhandled case in OPC.Base, typ^form = ", (LONGINT)40); - OPM_LogWNum(typ->form, ((LONGINT)(0))); - OPM_LogWLn(); - break; + LONGINT alignment; + if (size < (SYSTEM_INT64)OPM_Alignment) { + alignment = 1; + while (alignment < size) { + alignment = __ASHL(alignment, 1); + } + } else { + alignment = OPM_Alignment; } - __RETCHK; + _o_result = alignment; + return _o_result; +} + +LONGINT OPC_BaseAlignment (OPT_Struct typ) +{ + LONGINT _o_result; + LONGINT alignment; + if (typ->form == 15) { + if (typ->comp == 4) { + alignment = __MASK(typ->align, -65536); + } else { + alignment = OPC_BaseAlignment(typ->BaseTyp); + } + } else { + alignment = OPC_SizeAlignment(typ->size); + } + _o_result = alignment; + return _o_result; } static void OPC_FillGap (LONGINT gap, LONGINT off, LONGINT align, LONGINT *n, LONGINT *curAlign) @@ -939,11 +910,11 @@ static void OPC_FillGap (LONGINT gap, LONGINT off, LONGINT align, LONGINT *n, LO if ((*curAlign < align && gap - (adr - off) >= align)) { gap -= (adr - off) + align; OPC_BegStat(); - if (align == (LONGINT)OPM_IntSize) { + if (align == (SYSTEM_INT64)OPM_IntSize) { OPM_WriteString((CHAR*)"INTEGER", (LONGINT)8); - } else if (align == (LONGINT)OPM_LIntSize) { + } else if (align == (SYSTEM_INT64)OPM_LIntSize) { OPM_WriteString((CHAR*)"LONGINT", (LONGINT)8); - } else if (align == (LONGINT)OPM_LRealSize) { + } else if (align == (SYSTEM_INT64)OPM_LRealSize) { OPM_WriteString((CHAR*)"LONGREAL", (LONGINT)9); } OPC_Str1((CHAR*)" _prvt#", (LONGINT)8, *n); @@ -982,7 +953,7 @@ static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, LONGINT *off, LONGINT * } } else { adr = *off; - fldAlign = OPC_Base(fld->typ); + fldAlign = OPC_BaseAlignment(fld->typ); OPC_Align(&adr, fldAlign); gap = fld->adr - adr; if (fldAlign > *curAlign) { @@ -1008,7 +979,7 @@ static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, LONGINT *off, LONGINT * } } if (last) { - adr = typ->size - (LONGINT)__ASHR(typ->sysflag, 8); + adr = typ->size - (SYSTEM_INT64)__ASHR(typ->sysflag, 8); if (adr == 0) { gap = 1; } else { @@ -1171,10 +1142,10 @@ static void OPC_Include (CHAR *name, LONGINT name__len) { __DUP(name, name__len, CHAR); OPM_WriteString((CHAR*)"#include ", (LONGINT)10); - OPM_Write('\"'); + OPM_Write('"'); OPM_WriteStringVar((void*)name, name__len); OPM_WriteString((CHAR*)".h", (LONGINT)3); - OPM_Write('\"'); + OPM_Write('"'); OPM_WriteLn(); __DEL(name); } @@ -1239,8 +1210,8 @@ void OPC_GenHdr (OPT_Node n) static void OPC_GenHeaderMsg (void) { INTEGER i; - OPM_WriteString((CHAR*)"/*", (LONGINT)3); - OPM_WriteString((CHAR*)" voc ", (LONGINT)6); + OPM_WriteString((CHAR*)"/* ", (LONGINT)4); + OPM_WriteString((CHAR*)"voc", (LONGINT)4); OPM_Write(' '); OPM_WriteString(Configuration_versionLong, ((LONGINT)(41))); OPM_Write(' '); @@ -1856,26 +1827,56 @@ void OPC_Cmp (INTEGER rel) } } +static void OPC_CharacterLiteral (LONGINT c) +{ + if (c < 32 || c > 126) { + OPM_WriteString((CHAR*)"0x", (LONGINT)3); + OPM_WriteHex(c); + } else { + OPM_Write('\''); + if ((c == 92 || c == 39) || c == 63) { + OPM_Write('\\'); + } + OPM_Write((CHAR)c); + OPM_Write('\''); + } +} + +static void OPC_StringLiteral (CHAR *s, LONGINT s__len, LONGINT l) +{ + LONGINT i; + INTEGER c; + __DUP(s, s__len, CHAR); + OPM_Write('"'); + i = 0; + while (i < l) { + c = (int)s[__X(i, s__len)]; + if (c < 32 || c > 126) { + OPM_Write('\\'); + OPM_Write((CHAR)(48 + __ASHR(c, 6))); + c = __MASK(c, -64); + OPM_Write((CHAR)(48 + __ASHR(c, 3))); + c = __MASK(c, -8); + OPM_Write((CHAR)(48 + c)); + } else { + if ((c == 92 || c == 34) || c == 63) { + OPM_Write('\\'); + } + OPM_Write((CHAR)c); + } + i += 1; + } + OPM_Write('"'); + __DEL(s); +} + void OPC_Case (LONGINT caseVal, INTEGER form) { CHAR ch; OPM_WriteString((CHAR*)"case ", (LONGINT)6); switch (form) { case 3: - ch = (CHAR)caseVal; - if ((ch >= ' ' && ch <= '~')) { - OPM_Write('\''); - if (((ch == '\\' || ch == '\?') || ch == '\'') || ch == '\"') { - OPM_Write('\\'); - OPM_Write(ch); - } else { - OPM_Write(ch); - } - OPM_Write('\''); - } else { - OPM_WriteString((CHAR*)"0x", (LONGINT)3); - OPM_WriteHex(caseVal); - } + OPC_CharacterLiteral(caseVal); break; case 4: case 5: case 6: OPM_WriteInt(caseVal); @@ -1933,8 +1934,7 @@ void OPC_Len (OPT_Object obj, OPT_Struct array, LONGINT dim) void OPC_Constant (OPT_Const con, INTEGER form) { - INTEGER i, len; - CHAR ch; + INTEGER i; SET s; LONGINT hex; BOOLEAN skipLeading; @@ -1946,18 +1946,7 @@ void OPC_Constant (OPT_Const con, INTEGER form) OPM_WriteInt(con->intval); break; case 3: - ch = (CHAR)con->intval; - if ((ch >= ' ' && ch <= '~')) { - OPM_Write('\''); - if (((ch == '\\' || ch == '\?') || ch == '\'') || ch == '\"') { - OPM_Write('\\'); - } - OPM_Write(ch); - OPM_Write('\''); - } else { - OPM_WriteString((CHAR*)"0x", (LONGINT)3); - OPM_WriteHex(con->intval); - } + OPC_CharacterLiteral(con->intval); break; case 4: case 5: case 6: OPM_WriteInt(con->intval); @@ -1992,18 +1981,7 @@ void OPC_Constant (OPT_Const con, INTEGER form) } break; case 10: - OPM_Write('\"'); - len = (int)con->intval2 - 1; - i = 0; - while (i < len) { - ch = (*con->ext)[__X(i, ((LONGINT)(256)))]; - if (((ch == '\\' || ch == '\?') || ch == '\'') || ch == '\"') { - OPM_Write('\\'); - } - OPM_Write(ch); - i += 1; - } - OPM_Write('\"'); + OPC_StringLiteral(*con->ext, ((LONGINT)(256)), con->intval2 - 1); break; case 11: OPM_WriteString((CHAR*)"NIL", (LONGINT)4); @@ -2016,74 +1994,74 @@ void OPC_Constant (OPT_Const con, INTEGER form) } } -static struct InitKeywords__47 { +static struct InitKeywords__48 { SHORTINT *n; - struct InitKeywords__47 *lnk; -} *InitKeywords__47_s; + struct InitKeywords__48 *lnk; +} *InitKeywords__48_s; -static void Enter__48 (CHAR *s, LONGINT s__len); +static void Enter__49 (CHAR *s, LONGINT s__len); -static void Enter__48 (CHAR *s, LONGINT s__len) +static void Enter__49 (CHAR *s, LONGINT s__len) { INTEGER h; __DUP(s, s__len, CHAR); h = OPC_PerfectHash((void*)s, s__len); - OPC_hashtab[__X(h, ((LONGINT)(105)))] = *InitKeywords__47_s->n; - __COPY(s, OPC_keytab[__X(*InitKeywords__47_s->n, ((LONGINT)(36)))], ((LONGINT)(9))); - *InitKeywords__47_s->n += 1; + OPC_hashtab[__X(h, ((LONGINT)(105)))] = *InitKeywords__48_s->n; + __COPY(s, OPC_keytab[__X(*InitKeywords__48_s->n, ((LONGINT)(36)))], ((LONGINT)(9))); + *InitKeywords__48_s->n += 1; __DEL(s); } static void OPC_InitKeywords (void) { SHORTINT n, i; - struct InitKeywords__47 _s; + struct InitKeywords__48 _s; _s.n = &n; - _s.lnk = InitKeywords__47_s; - InitKeywords__47_s = &_s; + _s.lnk = InitKeywords__48_s; + InitKeywords__48_s = &_s; n = 0; i = 0; while (i <= 104) { OPC_hashtab[__X(i, ((LONGINT)(105)))] = -1; i += 1; } - Enter__48((CHAR*)"asm", (LONGINT)4); - Enter__48((CHAR*)"auto", (LONGINT)5); - Enter__48((CHAR*)"break", (LONGINT)6); - Enter__48((CHAR*)"case", (LONGINT)5); - Enter__48((CHAR*)"char", (LONGINT)5); - Enter__48((CHAR*)"const", (LONGINT)6); - Enter__48((CHAR*)"continue", (LONGINT)9); - Enter__48((CHAR*)"default", (LONGINT)8); - Enter__48((CHAR*)"do", (LONGINT)3); - Enter__48((CHAR*)"double", (LONGINT)7); - Enter__48((CHAR*)"else", (LONGINT)5); - Enter__48((CHAR*)"enum", (LONGINT)5); - Enter__48((CHAR*)"extern", (LONGINT)7); - Enter__48((CHAR*)"export", (LONGINT)7); - Enter__48((CHAR*)"float", (LONGINT)6); - Enter__48((CHAR*)"for", (LONGINT)4); - Enter__48((CHAR*)"fortran", (LONGINT)8); - Enter__48((CHAR*)"goto", (LONGINT)5); - Enter__48((CHAR*)"if", (LONGINT)3); - Enter__48((CHAR*)"import", (LONGINT)7); - Enter__48((CHAR*)"int", (LONGINT)4); - Enter__48((CHAR*)"long", (LONGINT)5); - Enter__48((CHAR*)"register", (LONGINT)9); - Enter__48((CHAR*)"return", (LONGINT)7); - Enter__48((CHAR*)"short", (LONGINT)6); - Enter__48((CHAR*)"signed", (LONGINT)7); - Enter__48((CHAR*)"sizeof", (LONGINT)7); - Enter__48((CHAR*)"static", (LONGINT)7); - Enter__48((CHAR*)"struct", (LONGINT)7); - Enter__48((CHAR*)"switch", (LONGINT)7); - Enter__48((CHAR*)"typedef", (LONGINT)8); - Enter__48((CHAR*)"union", (LONGINT)6); - Enter__48((CHAR*)"unsigned", (LONGINT)9); - Enter__48((CHAR*)"void", (LONGINT)5); - Enter__48((CHAR*)"volatile", (LONGINT)9); - Enter__48((CHAR*)"while", (LONGINT)6); - InitKeywords__47_s = _s.lnk; + Enter__49((CHAR*)"asm", (LONGINT)4); + Enter__49((CHAR*)"auto", (LONGINT)5); + Enter__49((CHAR*)"break", (LONGINT)6); + Enter__49((CHAR*)"case", (LONGINT)5); + Enter__49((CHAR*)"char", (LONGINT)5); + Enter__49((CHAR*)"const", (LONGINT)6); + Enter__49((CHAR*)"continue", (LONGINT)9); + Enter__49((CHAR*)"default", (LONGINT)8); + Enter__49((CHAR*)"do", (LONGINT)3); + Enter__49((CHAR*)"double", (LONGINT)7); + Enter__49((CHAR*)"else", (LONGINT)5); + Enter__49((CHAR*)"enum", (LONGINT)5); + Enter__49((CHAR*)"extern", (LONGINT)7); + Enter__49((CHAR*)"export", (LONGINT)7); + Enter__49((CHAR*)"float", (LONGINT)6); + Enter__49((CHAR*)"for", (LONGINT)4); + Enter__49((CHAR*)"fortran", (LONGINT)8); + Enter__49((CHAR*)"goto", (LONGINT)5); + Enter__49((CHAR*)"if", (LONGINT)3); + Enter__49((CHAR*)"import", (LONGINT)7); + Enter__49((CHAR*)"int", (LONGINT)4); + Enter__49((CHAR*)"long", (LONGINT)5); + Enter__49((CHAR*)"register", (LONGINT)9); + Enter__49((CHAR*)"return", (LONGINT)7); + Enter__49((CHAR*)"short", (LONGINT)6); + Enter__49((CHAR*)"signed", (LONGINT)7); + Enter__49((CHAR*)"sizeof", (LONGINT)7); + Enter__49((CHAR*)"static", (LONGINT)7); + Enter__49((CHAR*)"struct", (LONGINT)7); + Enter__49((CHAR*)"switch", (LONGINT)7); + Enter__49((CHAR*)"typedef", (LONGINT)8); + Enter__49((CHAR*)"union", (LONGINT)6); + Enter__49((CHAR*)"unsigned", (LONGINT)9); + Enter__49((CHAR*)"void", (LONGINT)5); + Enter__49((CHAR*)"volatile", (LONGINT)9); + Enter__49((CHAR*)"while", (LONGINT)6); + InitKeywords__48_s = _s.lnk; } diff --git a/bootstrap/unix-88/OPC.h b/bootstrap/unix-88/OPC.h index 58679d74..37a86252 100644 --- a/bootstrap/unix-88/OPC.h +++ b/bootstrap/unix-88/OPC.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPC__h #define OPC__h @@ -12,7 +12,7 @@ import void OPC_Align (LONGINT *adr, LONGINT base); import void OPC_Andent (OPT_Struct typ); -import LONGINT OPC_Base (OPT_Struct typ); +import LONGINT OPC_BaseAlignment (OPT_Struct typ); import OPT_Object OPC_BaseTProc (OPT_Object obj); import void OPC_BegBlk (void); import void OPC_BegStat (void); @@ -41,6 +41,7 @@ import void OPC_InitTDesc (OPT_Struct typ); import void OPC_Len (OPT_Object obj, OPT_Struct array, LONGINT dim); import LONGINT OPC_NofPtrs (OPT_Struct typ); import void OPC_SetInclude (BOOLEAN exclude); +import LONGINT OPC_SizeAlignment (LONGINT size); import void OPC_TDescDecl (OPT_Struct typ); import void OPC_TypeDefs (OPT_Object obj, INTEGER vis); import void OPC_TypeOf (OPT_Object ap); diff --git a/bootstrap/unix-88/OPM.c b/bootstrap/unix-88/OPM.c index 40d53974..50047c9e 100644 --- a/bootstrap/unix-88/OPM.c +++ b/bootstrap/unix-88/OPM.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "Configuration.h" @@ -15,8 +15,8 @@ typedef static CHAR OPM_SourceFileName[256]; -export INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_CharAlign, OPM_BoolAlign, OPM_SIntAlign, OPM_IntAlign, OPM_LIntAlign, OPM_SetAlign, OPM_RealAlign, OPM_LRealAlign, OPM_PointerAlign, OPM_ProcAlign, OPM_RecAlign, OPM_MaxSet; -export LONGINT OPM_MinSInt, OPM_MinInt, OPM_MinLInt, OPM_MaxSInt, OPM_MaxInt, OPM_MaxLInt, OPM_MaxIndex; +export INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_MaxSet; +export LONGINT OPM_MaxIndex; export LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; export BOOLEAN OPM_noerr; export LONGINT OPM_curpos, OPM_errpos, OPM_breakpc; @@ -58,7 +58,6 @@ export void OPM_LogWNum (LONGINT i, LONGINT len); export void OPM_LogWStr (CHAR *s, LONGINT s__len); static void OPM_MakeFileName (CHAR *name, LONGINT name__len, CHAR *FName, LONGINT FName__len, CHAR *ext, LONGINT ext__len); export void OPM_Mark (INTEGER n, LONGINT pos); -static INTEGER OPM_Min (INTEGER a, INTEGER b); export void OPM_NewSym (CHAR *modName, LONGINT modName__len); export void OPM_OldSym (CHAR *modName, LONGINT modName__len, BOOLEAN *done); export void OPM_OpenFiles (CHAR *moduleName, LONGINT moduleName__len); @@ -66,6 +65,8 @@ export BOOLEAN OPM_OpenPar (void); export void OPM_RegisterNewSym (void); static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt); static void OPM_ShowLine (LONGINT pos); +export LONGINT OPM_SignedMaximum (LONGINT bytecount); +export LONGINT OPM_SignedMinimum (LONGINT bytecount); export void OPM_SymRCh (CHAR *ch); export LONGINT OPM_SymRInt (void); export void OPM_SymRLReal (LONGREAL *lr); @@ -86,7 +87,7 @@ export void OPM_WriteString (CHAR *s, LONGINT s__len); export void OPM_WriteStringVar (CHAR *s, LONGINT s__len); export BOOLEAN OPM_eofSF (void); export void OPM_err (INTEGER n); -static LONGINT OPM_minus (LONGINT i); +static LONGINT OPM_minusop (LONGINT i); static LONGINT OPM_power0 (LONGINT i, LONGINT j); @@ -118,50 +119,38 @@ static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) i = 1; while (s[__X(i, s__len)] != 0x00) { switch (s[__X(i, s__len)]) { - case 'e': - *opt = *opt ^ 0x0200; - break; - case 's': - *opt = *opt ^ 0x10; - break; - case 'm': - *opt = *opt ^ 0x0400; - break; - case 'x': - *opt = *opt ^ 0x01; - break; - case 'r': - *opt = *opt ^ 0x04; - break; - case 't': - *opt = *opt ^ 0x08; - break; case 'a': *opt = *opt ^ 0x80; break; - case 'k': - *opt = *opt ^ 0x40; - break; - case 'p': - *opt = *opt ^ 0x20; - break; - case 'S': - *opt = *opt ^ 0x2000; - break; case 'c': *opt = *opt ^ 0x4000; break; - case 'M': - *opt = *opt ^ 0x8000; + case 'e': + *opt = *opt ^ 0x0200; break; case 'f': *opt = *opt ^ 0x010000; break; - case 'F': - *opt = *opt ^ 0x020000; + case 'k': + *opt = *opt ^ 0x40; break; - case 'V': - *opt = *opt ^ 0x040000; + case 'm': + *opt = *opt ^ 0x0400; + break; + case 'p': + *opt = *opt ^ 0x20; + break; + case 'r': + *opt = *opt ^ 0x04; + break; + case 's': + *opt = *opt ^ 0x10; + break; + case 't': + *opt = *opt ^ 0x08; + break; + case 'x': + *opt = *opt ^ 0x01; break; case 'B': if (s[__X(i + 1, s__len)] != 0x00) { @@ -179,6 +168,19 @@ static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) __ASSERT(OPM_IntSize == 2 || OPM_IntSize == 4, 0); __ASSERT(OPM_PointerSize == 4 || OPM_PointerSize == 8, 0); __ASSERT(OPM_Alignment == 4 || OPM_Alignment == 8, 0); + Files_SetSearchPath((CHAR*)"", (LONGINT)1); + break; + case 'F': + *opt = *opt ^ 0x020000; + break; + case 'M': + *opt = *opt ^ 0x8000; + break; + case 'S': + *opt = *opt ^ 0x2000; + break; + case 'V': + *opt = *opt ^ 0x040000; break; default: OPM_LogWStr((CHAR*)" warning: option ", (LONGINT)19); @@ -228,17 +230,17 @@ BOOLEAN OPM_OpenPar (void) OPM_LogWLn(); OPM_LogWStr((CHAR*)" x - turn off array indices check", (LONGINT)35); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" a - don\'t check ASSERTs at runtime, use this option in tested production code", (LONGINT)80); + OPM_LogWStr((CHAR*)" a - don't check ASSERTs at runtime, use this option in tested production code", (LONGINT)80); OPM_LogWLn(); OPM_LogWStr((CHAR*)" p - turn off automatic pointer initialization", (LONGINT)48); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" t - don\'t check type guards (use in rare cases such as low-level modules where every cycle counts)", (LONGINT)101); + OPM_LogWStr((CHAR*)" t - don't check type guards (use in rare cases such as low-level modules where every cycle counts)", (LONGINT)101); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" S - don\'t call external assembler/compiler, only generate C code", (LONGINT)67); + OPM_LogWStr((CHAR*)" S - don't call external assembler/compiler, only generate C code", (LONGINT)67); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" c - don\'t call linker", (LONGINT)24); + OPM_LogWStr((CHAR*)" c - don't call linker", (LONGINT)24); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" f - don\'t use color output", (LONGINT)29); + OPM_LogWStr((CHAR*)" f - don't use color output", (LONGINT)29); OPM_LogWLn(); OPM_LogWStr((CHAR*)" F - force writing new symbol file in current directory", (LONGINT)57); OPM_LogWLn(); @@ -541,16 +543,17 @@ void OPM_FPrintSet (LONGINT *fp, SET set) void OPM_FPrintReal (LONGINT *fp, REAL real) { - OPM_FPrint(&*fp, __VAL(LONGINT, real)); + INTEGER i; + LONGINT l; + __GET((LONGINT)(SYSTEM_ADDRESS)&real, i, INTEGER); + l = i; + OPM_FPrint(&*fp, l); } void OPM_FPrintLReal (LONGINT *fp, LONGREAL lr) { LONGINT l, h; - __GET((LONGINT)(uintptr_t)&lr, l, LONGINT); - __GET((LONGINT)(uintptr_t)&lr + 4, h, LONGINT); - OPM_FPrint(&*fp, l); - OPM_FPrint(&*fp, h); + OPM_FPrint(&*fp, __VAL(LONGINT, lr)); } static void OPM_GetProperty (Texts_Scanner *S, LONGINT *S__typ, CHAR *name, LONGINT name__len, INTEGER *size, INTEGER *align) @@ -576,7 +579,7 @@ static void OPM_GetProperty (Texts_Scanner *S, LONGINT *S__typ, CHAR *name, LONG __DEL(name); } -static LONGINT OPM_minus (LONGINT i) +static LONGINT OPM_minusop (LONGINT i) { LONGINT _o_result; _o_result = -i; @@ -604,103 +607,62 @@ static void OPM_VerboseListSizes (void) OPM_LogWLn(); OPM_LogWStr((CHAR*)"CHAR ", (LONGINT)14); OPM_LogWNum(OPM_CharSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_CharAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"BOOLEAN ", (LONGINT)14); OPM_LogWNum(OPM_BoolSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_BoolAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"SHORTINT ", (LONGINT)14); OPM_LogWNum(OPM_SIntSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_SIntAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"INTEGER ", (LONGINT)14); OPM_LogWNum(OPM_IntSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_IntAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"LONGINT ", (LONGINT)14); OPM_LogWNum(OPM_LIntSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_LIntAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"SET ", (LONGINT)14); OPM_LogWNum(OPM_SetSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_SetAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"REAL ", (LONGINT)14); OPM_LogWNum(OPM_RealSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_RealAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"LONGREAL ", (LONGINT)14); OPM_LogWNum(OPM_LRealSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_LRealAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"PTR ", (LONGINT)14); OPM_LogWNum(OPM_PointerSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_PointerAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"PROC ", (LONGINT)14); OPM_LogWNum(OPM_ProcSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_ProcAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"RECORD ", (LONGINT)14); OPM_LogWNum(OPM_RecSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_RecAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Min shortint ", (LONGINT)14); - OPM_LogWNum(OPM_MinSInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Max shortint ", (LONGINT)14); - OPM_LogWNum(OPM_MaxSInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Min integer ", (LONGINT)14); - OPM_LogWNum(OPM_MinInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Max integer ", (LONGINT)14); - OPM_LogWNum(OPM_MaxInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Min longint ", (LONGINT)14); - OPM_LogWNum(OPM_MinLInt, ((LONGINT)(4))); - OPM_LogWLn(); } -static INTEGER OPM_Min (INTEGER a, INTEGER b) +LONGINT OPM_SignedMaximum (LONGINT bytecount) { - INTEGER _o_result; - if (a < b) { - _o_result = a; - return _o_result; - } else { - _o_result = b; - return _o_result; - } - __RETCHK; + LONGINT _o_result; + LONGINT result; + result = 1; + result = __LSH(result, __ASHL(bytecount, 3) - 1, LONGINT); + _o_result = result - 1; + return _o_result; +} + +LONGINT OPM_SignedMinimum (LONGINT bytecount) +{ + LONGINT _o_result; + _o_result = -OPM_SignedMaximum(bytecount) - 1; + return _o_result; } static void OPM_GetProperties (void) { - LONGINT base; OPM_ProcSize = OPM_PointerSize; OPM_LIntSize = __ASHL(OPM_IntSize, 1); OPM_SetSize = OPM_LIntSize; - OPM_CharAlign = OPM_Min(OPM_Alignment, OPM_CharSize); - OPM_BoolAlign = OPM_Min(OPM_Alignment, OPM_BoolSize); - OPM_SIntAlign = OPM_Min(OPM_Alignment, OPM_SIntSize); - OPM_RecAlign = OPM_Min(OPM_Alignment, OPM_RecSize); - OPM_RealAlign = OPM_Min(OPM_Alignment, OPM_RealSize); - OPM_LRealAlign = OPM_Min(OPM_Alignment, OPM_LRealSize); - OPM_PointerAlign = OPM_Min(OPM_Alignment, OPM_PointerSize); - OPM_ProcAlign = OPM_Min(OPM_Alignment, OPM_ProcSize); - OPM_IntAlign = OPM_Min(OPM_Alignment, OPM_IntSize); - OPM_LIntAlign = OPM_Min(OPM_Alignment, OPM_LIntSize); - OPM_SetAlign = OPM_Min(OPM_Alignment, OPM_SetSize); - base = -2; - OPM_MinSInt = __ASH(base, __ASHL(OPM_SIntSize, 3) - 2); - OPM_MaxSInt = OPM_minus(OPM_MinSInt + 1); - OPM_MinInt = __ASH(base, __ASHL(OPM_IntSize, 3) - 2); - OPM_MaxInt = OPM_minus(OPM_MinInt + 1); - OPM_MinLInt = __ASH(base, __ASHL(OPM_LIntSize, 3) - 2); - OPM_MaxLInt = OPM_minus(OPM_MinLInt + 1); if (OPM_RealSize == 4) { OPM_MaxReal = 3.40282346000000e+038; } else if (OPM_RealSize == 8) { @@ -714,7 +676,7 @@ static void OPM_GetProperties (void) OPM_MinReal = -OPM_MaxReal; OPM_MinLReal = -OPM_MaxLReal; OPM_MaxSet = __ASHL(OPM_SetSize, 3) - 1; - OPM_MaxIndex = OPM_MaxLInt; + OPM_MaxIndex = OPM_SignedMaximum(OPM_PointerSize); if (OPM_Verbose) { OPM_VerboseListSizes(); } @@ -876,7 +838,7 @@ void OPM_WriteInt (LONGINT i) { CHAR s[20]; LONGINT i1, k; - if (i == OPM_MinInt || i == OPM_MinLInt) { + if (i == OPM_SignedMinimum(OPM_IntSize) || i == OPM_SignedMinimum(OPM_LIntSize)) { OPM_Write('('); OPM_WriteInt(i + 1); OPM_WriteString((CHAR*)"-1)", (LONGINT)4); @@ -909,7 +871,7 @@ void OPM_WriteReal (LONGREAL r, CHAR suffx) CHAR s[32]; CHAR ch; INTEGER i; - if ((((r < OPM_MaxLInt && r > OPM_MinLInt)) && r == (__ENTIER(r)))) { + if ((((r < OPM_SignedMaximum(OPM_LIntSize) && r > OPM_SignedMinimum(OPM_LIntSize))) && r == (__ENTIER(r)))) { if (suffx == 'f') { OPM_WriteString((CHAR*)"(REAL)", (LONGINT)7); } else { diff --git a/bootstrap/unix-88/OPM.h b/bootstrap/unix-88/OPM.h index 2e93dfcf..1706f8f1 100644 --- a/bootstrap/unix-88/OPM.h +++ b/bootstrap/unix-88/OPM.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPM__h #define OPM__h @@ -7,8 +7,8 @@ #include "SYSTEM.h" -import INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_CharAlign, OPM_BoolAlign, OPM_SIntAlign, OPM_IntAlign, OPM_LIntAlign, OPM_SetAlign, OPM_RealAlign, OPM_LRealAlign, OPM_PointerAlign, OPM_ProcAlign, OPM_RecAlign, OPM_MaxSet; -import LONGINT OPM_MinSInt, OPM_MinInt, OPM_MinLInt, OPM_MaxSInt, OPM_MaxInt, OPM_MaxLInt, OPM_MaxIndex; +import INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_MaxSet; +import LONGINT OPM_MaxIndex; import LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; import BOOLEAN OPM_noerr; import LONGINT OPM_curpos, OPM_errpos, OPM_breakpc; @@ -39,6 +39,8 @@ import void OPM_OldSym (CHAR *modName, LONGINT modName__len, BOOLEAN *done); import void OPM_OpenFiles (CHAR *moduleName, LONGINT moduleName__len); import BOOLEAN OPM_OpenPar (void); import void OPM_RegisterNewSym (void); +import LONGINT OPM_SignedMaximum (LONGINT bytecount); +import LONGINT OPM_SignedMinimum (LONGINT bytecount); import void OPM_SymRCh (CHAR *ch); import LONGINT OPM_SymRInt (void); import void OPM_SymRLReal (LONGREAL *lr); diff --git a/bootstrap/unix-88/OPP.c b/bootstrap/unix-88/OPP.c index 9ce53b1f..be7c13b5 100644 --- a/bootstrap/unix-88/OPP.c +++ b/bootstrap/unix-88/OPP.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "OPB.h" @@ -439,10 +439,10 @@ static void OPP_TypeDecl (OPT_Struct *typ, OPT_Struct *banned) if (OPP_sym == 38) { OPP_qualident(&id); if (id->mode == 5) { - if (id->typ != *banned) { - *typ = id->typ; - } else { + if (id->typ == *banned) { OPP_err(58); + } else { + *typ = id->typ; } } else { OPP_err(52); @@ -1784,6 +1784,24 @@ void OPP_Module (OPT_Node *prog, SET opt) if (OPP_sym == 63) { OPS_Get(&OPP_sym); } else { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Unexpected symbol found when MODULE expected:", (LONGINT)46); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" sym: ", (LONGINT)15); + OPM_LogWNum(OPP_sym, ((LONGINT)(1))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.name: ", (LONGINT)15); + OPM_LogWStr(OPS_name, ((LONGINT)(256))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.str: ", (LONGINT)15); + OPM_LogWStr(OPS_str, ((LONGINT)(256))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.numtyp: ", (LONGINT)15); + OPM_LogWNum(OPS_numtyp, ((LONGINT)(1))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.intval: ", (LONGINT)15); + OPM_LogWNum(OPS_intval, ((LONGINT)(1))); + OPM_LogWLn(); OPP_err(16); } if (OPP_sym == 38) { diff --git a/bootstrap/unix-88/OPP.h b/bootstrap/unix-88/OPP.h index 372c5f88..0b3b1b2c 100644 --- a/bootstrap/unix-88/OPP.h +++ b/bootstrap/unix-88/OPP.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPP__h #define OPP__h diff --git a/bootstrap/unix-88/OPS.c b/bootstrap/unix-88/OPS.c index 8276ecf9..cc04e014 100644 --- a/bootstrap/unix-88/OPS.c +++ b/bootstrap/unix-88/OPS.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #define LARGE #include "SYSTEM.h" #include "OPM.h" @@ -174,7 +174,7 @@ static void OPS_Number (void) OPS_numtyp = 1; if (n <= 2) { while (i < n) { - OPS_intval = __ASHL(OPS_intval, 4) + (LONGINT)Ord__7(dig[i], 1); + OPS_intval = __ASHL(OPS_intval, 4) + (SYSTEM_INT64)Ord__7(dig[i], 1); i += 1; } } else { @@ -189,7 +189,7 @@ static void OPS_Number (void) OPS_intval = -1; } while (i < n) { - OPS_intval = __ASHL(OPS_intval, 4) + (LONGINT)Ord__7(dig[i], 1); + OPS_intval = __ASHL(OPS_intval, 4) + (SYSTEM_INT64)Ord__7(dig[i], 1); i += 1; } } else { @@ -200,8 +200,8 @@ static void OPS_Number (void) while (i < n) { d = Ord__7(dig[i], 0); i += 1; - if (OPS_intval <= __DIV(9223372036854775807 - (LONGINT)d, 10)) { - OPS_intval = OPS_intval * 10 + (LONGINT)d; + if (OPS_intval <= __DIV(9223372036854775807 - (SYSTEM_INT64)d, 10)) { + OPS_intval = OPS_intval * 10 + (SYSTEM_INT64)d; } else { OPS_err(203); } @@ -326,7 +326,7 @@ void OPS_Get (SHORTINT *sym) } } switch (OPS_ch) { - case '\"': case '\'': + case '"': case '\'': OPS_Str(&s); break; case '#': diff --git a/bootstrap/unix-88/OPS.h b/bootstrap/unix-88/OPS.h index 8f1581bb..32148c49 100644 --- a/bootstrap/unix-88/OPS.h +++ b/bootstrap/unix-88/OPS.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #ifndef OPS__h #define OPS__h diff --git a/bootstrap/unix-88/OPT.c b/bootstrap/unix-88/OPT.c index 7f03064b..a0d41c71 100644 --- a/bootstrap/unix-88/OPT.c +++ b/bootstrap/unix-88/OPT.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "OPM.h" @@ -850,7 +850,7 @@ static void OPT_InConstant (LONGINT f, OPT_Const conval) conval->intval = 0; break; default: - OPM_LogWStr((CHAR*)"unhandled case in OPT.InConstant(), f = ", (LONGINT)41); + OPM_LogWStr((CHAR*)"unhandled case in InConstant(), f = ", (LONGINT)37); OPM_LogWNum(f, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1073,7 +1073,7 @@ static void OPT_InStruct (OPT_Struct *typ) OPT_InSign(mno, &(*typ)->BaseTyp, &(*typ)->link); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.InStruct, tag = ", (LONGINT)39); + OPM_LogWStr((CHAR*)"unhandled case at InStruct, tag = ", (LONGINT)35); OPM_LogWNum(tag, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1176,7 +1176,7 @@ static OPT_Object OPT_InObj (SHORTINT mno) } break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.InObj, tag = ", (LONGINT)36); + OPM_LogWStr((CHAR*)"unhandled case at InObj, tag = ", (LONGINT)32); OPM_LogWNum(tag, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1465,14 +1465,14 @@ static void OPT_OutStr (OPT_Struct typ) OPM_SymWInt(((LONGINT)(18))); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutStr, typ^.comp = ", (LONGINT)43); + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.comp = ", (LONGINT)39); OPM_LogWNum(typ->comp, ((LONGINT)(0))); OPM_LogWLn(); break; } break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutStr, typ^.form = ", (LONGINT)43); + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.form = ", (LONGINT)39); OPM_LogWNum(typ->form, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1537,7 +1537,7 @@ static void OPT_OutObj (OPT_Object obj) OPT_FPrintErr(obj, 251); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutObj, obj^.history = ", (LONGINT)46); + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj^.history = ", (LONGINT)42); OPM_LogWNum(obj->history, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1593,7 +1593,7 @@ static void OPT_OutObj (OPT_Object obj) OPT_OutName((void*)obj->name, ((LONGINT)(256))); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutObj, obj.mode = ", (LONGINT)42); + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj.mode = ", (LONGINT)38); OPM_LogWNum(obj->mode, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1810,6 +1810,7 @@ export void *OPT__init(void) OPT_syslink = OPT_topScope->right; OPT_universe = OPT_topScope; OPT_topScope->right = NIL; + OPT_EnterTyp((CHAR*)"BOOLEAN", 2, OPM_BoolSize, &OPT_booltyp); OPT_EnterTyp((CHAR*)"CHAR", 3, OPM_CharSize, &OPT_chartyp); OPT_EnterTyp((CHAR*)"SET", 9, OPM_SetSize, &OPT_settyp); OPT_EnterTyp((CHAR*)"REAL", 7, OPM_RealSize, &OPT_realtyp); @@ -1817,7 +1818,6 @@ export void *OPT__init(void) OPT_EnterTyp((CHAR*)"LONGINT", 6, OPM_LIntSize, &OPT_linttyp); OPT_EnterTyp((CHAR*)"LONGREAL", 8, OPM_LRealSize, &OPT_lrltyp); OPT_EnterTyp((CHAR*)"SHORTINT", 4, OPM_SIntSize, &OPT_sinttyp); - OPT_EnterTyp((CHAR*)"BOOLEAN", 2, OPM_BoolSize, &OPT_booltyp); OPT_EnterBoolConst((CHAR*)"FALSE", ((LONGINT)(0))); OPT_EnterBoolConst((CHAR*)"TRUE", ((LONGINT)(1))); OPT_EnterProc((CHAR*)"HALT", 0); diff --git a/bootstrap/unix-88/OPT.h b/bootstrap/unix-88/OPT.h index 7e03d42c..ab2c4684 100644 --- a/bootstrap/unix-88/OPT.h +++ b/bootstrap/unix-88/OPT.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPT__h #define OPT__h @@ -60,8 +60,7 @@ typedef INTEGER ref, sysflag; LONGINT n, size, align, txtpos; BOOLEAN allocated, pbused, pvused; - char _prvt0[8]; - LONGINT pbfp, pvfp; + char _prvt0[24]; OPT_Struct BaseTyp; OPT_Object link, strobj; } OPT_StrDesc; diff --git a/bootstrap/unix-88/OPV.c b/bootstrap/unix-88/OPV.c index c86ba15e..ae14f629 100644 --- a/bootstrap/unix-88/OPV.c +++ b/bootstrap/unix-88/OPV.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "OPC.h" @@ -24,7 +24,7 @@ export LONGINT *OPV_ExitInfo__typ; static void OPV_ActualPar (OPT_Node n, OPT_Object fp); export void OPV_AdrAndSize (OPT_Object topScope); static void OPV_CaseStat (OPT_Node n, OPT_Object outerProc); -static void OPV_Convert (OPT_Node n, INTEGER form, INTEGER prec); +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INTEGER prec); static void OPV_DefineTDescs (OPT_Node n); static void OPV_Entier (OPT_Node n, INTEGER prec); static void OPV_GetTProcNum (OPT_Object obj); @@ -39,6 +39,7 @@ static LONGINT OPV_NaturalAlignment (LONGINT size, LONGINT max); static void OPV_NewArr (OPT_Node d, OPT_Node x); static INTEGER OPV_Precedence (INTEGER class, INTEGER subclass, INTEGER form, INTEGER comp); static BOOLEAN OPV_SideEffects (OPT_Node n); +static void OPV_SizeCast (LONGINT size); static void OPV_Stamp (OPS_Name s); static OPT_Object OPV_SuperProc (OPT_Node n); static void OPV_Traverse (OPT_Object obj, OPT_Object outerScope, BOOLEAN exported); @@ -83,10 +84,10 @@ void OPV_TypSize (OPT_Struct typ) btyp = typ->BaseTyp; if (btyp == NIL) { offset = 0; - base = OPM_RecAlign; + base = OPC_SizeAlignment(OPM_RecSize); } else { OPV_TypSize(btyp); - offset = btyp->size - (LONGINT)__ASHR(btyp->sysflag, 8); + offset = btyp->size - (SYSTEM_INT64)__ASHR(btyp->sysflag, 8); base = btyp->align; } fld = typ->link; @@ -94,7 +95,7 @@ void OPV_TypSize (OPT_Struct typ) btyp = fld->typ; OPV_TypSize(btyp); size = btyp->size; - fbase = OPC_Base(btyp); + fbase = OPC_BaseAlignment(btyp); OPC_Align(&offset, fbase); fld->adr = offset; offset += size; @@ -108,7 +109,7 @@ void OPV_TypSize (OPT_Struct typ) offset = 1; } if (OPM_RecSize == 0) { - base = OPV_NaturalAlignment(offset, OPM_RecAlign); + base = OPV_NaturalAlignment(offset, OPC_SizeAlignment(OPM_RecSize)); } OPC_Align(&offset, base); if ((typ->strobj == NIL && __MASK(typ->align, -65536) == 0)) { @@ -333,7 +334,7 @@ static INTEGER OPV_Precedence (INTEGER class, INTEGER subclass, INTEGER form, IN return _o_result; break; default: - OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence Nmop, subclass = ", (LONGINT)51); + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Nmop, subclass = ", (LONGINT)55); OPM_LogWNum(subclass, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -403,7 +404,7 @@ static INTEGER OPV_Precedence (INTEGER class, INTEGER subclass, INTEGER form, IN return _o_result; break; default: - OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence Ndop, subclass = ", (LONGINT)51); + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Ndop, subclass = ", (LONGINT)55); OPM_LogWNum(subclass, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -466,41 +467,26 @@ static void OPV_Entier (OPT_Node n, INTEGER prec) } } -static void OPV_Convert (OPT_Node n, INTEGER form, INTEGER prec) +static void OPV_SizeCast (LONGINT size) { - INTEGER from; + if (size <= 4) { + OPM_WriteString((CHAR*)"(int)", (LONGINT)6); + } else { + OPM_WriteString((CHAR*)"(SYSTEM_INT64)", (LONGINT)15); + } +} + +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INTEGER prec) +{ + INTEGER from, to; from = n->typ->form; - if (form == 9) { + to = newtype->form; + if (to == 9) { OPM_WriteString((CHAR*)"__SETOF(", (LONGINT)9); OPV_Entier(n, -1); OPM_Write(')'); - } else if (form == 6) { - if (from < 6) { - OPM_WriteString((CHAR*)"(LONGINT)", (LONGINT)10); - } - OPV_Entier(n, 9); - } else if (form == 5) { - if (from < 5) { - OPM_WriteString((CHAR*)"(int)", (LONGINT)6); - OPV_expr(n, 9); - } else { - if (__IN(2, OPM_opt)) { - OPM_WriteString((CHAR*)"__SHORT", (LONGINT)8); - if (OPV_SideEffects(n)) { - OPM_Write('F'); - } - OPM_Write('('); - OPV_Entier(n, -1); - OPM_WriteString((CHAR*)", ", (LONGINT)3); - OPM_WriteInt(OPM_MaxInt + 1); - OPM_Write(')'); - } else { - OPM_WriteString((CHAR*)"(int)", (LONGINT)6); - OPV_Entier(n, 9); - } - } - } else if (form == 4) { - if (__IN(2, OPM_opt)) { + } else if (__IN(to, 0x70)) { + if ((newtype->size < n->typ->size && __IN(2, OPM_opt))) { OPM_WriteString((CHAR*)"__SHORT", (LONGINT)8); if (OPV_SideEffects(n)) { OPM_Write('F'); @@ -508,13 +494,15 @@ static void OPV_Convert (OPT_Node n, INTEGER form, INTEGER prec) OPM_Write('('); OPV_Entier(n, -1); OPM_WriteString((CHAR*)", ", (LONGINT)3); - OPM_WriteInt(OPM_MaxSInt + 1); + OPM_WriteInt(OPM_SignedMaximum(newtype->size) + 1); OPM_Write(')'); } else { - OPM_WriteString((CHAR*)"(int)", (LONGINT)6); + if (newtype->size != n->typ->size) { + OPV_SizeCast(newtype->size); + } OPV_Entier(n, 9); } - } else if (form == 3) { + } else if (to == 3) { if (__IN(2, OPM_opt)) { OPM_WriteString((CHAR*)"__CHR", (LONGINT)6); if (OPV_SideEffects(n)) { @@ -577,7 +565,7 @@ static void OPV_design (OPT_Node n, INTEGER prec) OPT_Struct typ = NIL; INTEGER class, designPrec, comp; OPT_Node d = NIL, x = NIL; - INTEGER dims, i, _for__26; + INTEGER dims, i, _for__27; comp = n->typ->comp; obj = n->obj; class = n->class; @@ -653,15 +641,15 @@ static void OPV_design (OPT_Node n, INTEGER prec) } x = x->left; } - _for__26 = dims; + _for__27 = dims; i = 1; - while (i <= _for__26) { + while (i <= _for__27) { OPM_Write(')'); i += 1; } if (n->typ->comp == 3) { OPM_Write(')'); - while ((LONGINT)i < __ASHR(d->typ->size - 4, 2)) { + while ((SYSTEM_INT64)i < __ASHR(d->typ->size - 4, 2)) { OPM_WriteString((CHAR*)" * ", (LONGINT)4); OPV_Len(d, i); i += 1; @@ -796,7 +784,7 @@ static void OPV_ActualPar (OPT_Node n, OPT_Object fp) } if ((((mode == 2 && n->class == 11)) && n->subcl == 29)) { OPV_expr(n->left, prec); - } else if ((((((form == 6 && n->class == 7)) && n->conval->intval <= OPM_MaxInt)) && n->conval->intval >= OPM_MinInt)) { + } else if ((((((form == 6 && n->class == 7)) && n->conval->intval <= OPM_SignedMaximum(OPM_IntSize))) && n->conval->intval >= OPM_SignedMinimum(OPM_IntSize))) { OPM_WriteString((CHAR*)"((LONGINT)(", (LONGINT)12); OPV_expr(n, prec); OPM_WriteString((CHAR*)"))", (LONGINT)3); @@ -915,7 +903,7 @@ static void OPV_expr (OPT_Node n, INTEGER prec) OPM_Write(')'); break; case 20: - OPV_Convert(l, form, exprPrec); + OPV_Convert(l, n->typ, exprPrec); break; case 21: if (OPV_SideEffects(l)) { @@ -944,7 +932,7 @@ static void OPV_expr (OPT_Node n, INTEGER prec) OPM_Write(')'); break; case 24: - OPM_WriteString((CHAR*)"(LONGINT)(uintptr_t)", (LONGINT)21); + OPM_WriteString((CHAR*)"(LONGINT)(SYSTEM_ADDRESS)", (LONGINT)26); if (l->class == 1) { OPC_CompleteIdent(l->obj); } else { @@ -955,20 +943,16 @@ static void OPV_expr (OPT_Node n, INTEGER prec) } break; case 29: - if ((((__IN(n->typ->form, 0x6240) && __IN(l->typ->form, 0x6240))) && n->typ->size == l->typ->size) || !__IN(l->class, 0x17)) { + if (!__IN(l->class, 0x17) || (((__IN(n->typ->form, 0x6240) && __IN(l->typ->form, 0x6240))) && n->typ->size == l->typ->size)) { OPM_Write('('); OPC_Ident(n->typ->strobj); OPM_Write(')'); if (__IN(n->typ->form, 0x6000) || __IN(l->typ->form, 0x6000)) { - OPM_WriteString((CHAR*)"(uintptr_t)", (LONGINT)12); + OPM_WriteString((CHAR*)"(SYSTEM_ADDRESS)", (LONGINT)17); } OPV_expr(l, exprPrec); } else { - if (__IN(n->typ->form, 0x6000) || __IN(l->typ->form, 0x6000)) { - OPM_WriteString((CHAR*)"__VALP(", (LONGINT)8); - } else { - OPM_WriteString((CHAR*)"__VAL(", (LONGINT)7); - } + OPM_WriteString((CHAR*)"__VAL(", (LONGINT)7); OPC_Ident(n->typ->strobj); OPM_WriteString((CHAR*)", ", (LONGINT)3); OPV_expr(l, -1); @@ -1327,7 +1311,7 @@ static void OPV_NewArr (OPT_Node d, OPT_Node x) OPM_WriteInt(base->size); OPM_WriteString((CHAR*)"))", (LONGINT)3); OPM_WriteString((CHAR*)", ", (LONGINT)3); - OPM_WriteInt(OPC_Base(base)); + OPM_WriteInt(OPC_BaseAlignment(base)); OPM_WriteString((CHAR*)", ", (LONGINT)3); OPM_WriteInt(nofdim); OPM_WriteString((CHAR*)", ", (LONGINT)3); diff --git a/bootstrap/unix-88/OPV.h b/bootstrap/unix-88/OPV.h index eeb89a76..4eba5b89 100644 --- a/bootstrap/unix-88/OPV.h +++ b/bootstrap/unix-88/OPV.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPV__h #define OPV__h diff --git a/bootstrap/unix-88/Platform.c b/bootstrap/unix-88/Platform.c index 842c232d..c1a0ea9e 100644 --- a/bootstrap/unix-88/Platform.c +++ b/bootstrap/unix-88/Platform.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" @@ -119,14 +119,14 @@ export BOOLEAN Platform_getEnv (CHAR *var, LONGINT var__len, CHAR *val, LONGINT #define Platform_EXDEV() EXDEV extern void Heap_InitHeap(); #define Platform_HeapInitHeap() Heap_InitHeap() -#define Platform_allocate(size) (LONGINT)(uintptr_t)((void*)malloc((size_t)size)) +#define Platform_allocate(size) (LONGINT)(SYSTEM_ADDRESS)((void*)malloc((size_t)size)) #define Platform_chdir(n, n__len) chdir((char*)n) #define Platform_closefile(fd) close(fd) #define Platform_err() errno #define Platform_errc(c) write(1, &c, 1) #define Platform_errstring(s, s__len) write(1, s, s__len-1) #define Platform_exit(code) exit(code) -#define Platform_free(address) free((void*)(uintptr_t)address) +#define Platform_free(address) free((void*)(SYSTEM_ADDRESS)address) #define Platform_fstat(fd) fstat(fd, &s) #define Platform_fsync(fd) fsync(fd) #define Platform_ftruncate(fd, l) ftruncate(fd, l) @@ -139,13 +139,13 @@ extern void Heap_InitHeap(); #define Platform_opennew(n, n__len) open((char*)n, O_CREAT | O_TRUNC | O_RDWR, 0664) #define Platform_openro(n, n__len) open((char*)n, O_RDONLY) #define Platform_openrw(n, n__len) open((char*)n, O_RDWR) -#define Platform_readfile(fd, p, l) read(fd, (void*)(uintptr_t)(p), l) +#define Platform_readfile(fd, p, l) read(fd, (void*)(SYSTEM_ADDRESS)(p), l) #define Platform_rename(o, o__len, n, n__len) rename((char*)o, (char*)n) #define Platform_sectotm(s) struct tm *time = localtime((time_t*)&s) #define Platform_seekcur() SEEK_CUR #define Platform_seekend() SEEK_END #define Platform_seekset() SEEK_SET -#define Platform_sethandler(s, h) SystemSetHandler(s, (uintptr_t)h) +#define Platform_sethandler(s, h) SystemSetHandler(s, (SYSTEM_ADDRESS)h) #define Platform_stat(n, n__len) stat((char*)n, &s) #define Platform_statdev() (LONGINT)s.st_dev #define Platform_statino() (LONGINT)s.st_ino @@ -162,7 +162,7 @@ extern void Heap_InitHeap(); #define Platform_tvsec() tv.tv_sec #define Platform_tvusec() tv.tv_usec #define Platform_unlink(n, n__len) unlink((char*)n) -#define Platform_writefile(fd, p, l) write(fd, (void*)(uintptr_t)(p), l) +#define Platform_writefile(fd, p, l) write(fd, (void*)(SYSTEM_ADDRESS)(p), l) BOOLEAN Platform_TooManyFiles (INTEGER e) { @@ -230,7 +230,7 @@ void Platform_Init (INTEGER argc, LONGINT argvadr) Platform_ArgVecPtr av = NIL; Platform_MainStackFrame = argvadr; Platform_ArgCount = argc; - av = (Platform_ArgVecPtr)(uintptr_t)argvadr; + av = (Platform_ArgVecPtr)(SYSTEM_ADDRESS)argvadr; Platform_ArgVector = (*av)[0]; Platform_HaltCode = -128; Platform_HeapInitHeap(); @@ -263,7 +263,7 @@ void Platform_GetArg (INTEGER n, CHAR *val, LONGINT val__len) { Platform_ArgVec av = NIL; if (n < Platform_ArgCount) { - av = (Platform_ArgVec)(uintptr_t)Platform_ArgVector; + av = (Platform_ArgVec)(SYSTEM_ADDRESS)Platform_ArgVector; __COPY(*(*av)[__X(n, ((LONGINT)(1024)))], val, val__len); } } @@ -530,7 +530,7 @@ INTEGER Platform_Read (LONGINT h, LONGINT p, LONGINT l, LONGINT *n) INTEGER Platform_ReadBuf (LONGINT h, SYSTEM_BYTE *b, LONGINT b__len, LONGINT *n) { INTEGER _o_result; - *n = Platform_readfile(h, (LONGINT)(uintptr_t)b, b__len); + *n = Platform_readfile(h, (LONGINT)(SYSTEM_ADDRESS)b, b__len); if (*n < 0) { *n = 0; _o_result = Platform_err(); @@ -766,7 +766,7 @@ static void Platform_TestLittleEndian (void) { INTEGER i; i = 1; - __GET((LONGINT)(uintptr_t)&i, Platform_LittleEndian, BOOLEAN); + __GET((LONGINT)(SYSTEM_ADDRESS)&i, Platform_LittleEndian, BOOLEAN); } __TDESC(Platform_FileIdentity, 1, 0) = {__TDFLDS("FileIdentity", 24), {-8}}; diff --git a/bootstrap/unix-88/Platform.h b/bootstrap/unix-88/Platform.h index bdb39b1d..49702e6d 100644 --- a/bootstrap/unix-88/Platform.h +++ b/bootstrap/unix-88/Platform.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Platform__h #define Platform__h diff --git a/bootstrap/unix-88/Reals.c b/bootstrap/unix-88/Reals.c index 0fb9a236..8b61d8cd 100644 --- a/bootstrap/unix-88/Reals.c +++ b/bootstrap/unix-88/Reals.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" @@ -59,7 +59,7 @@ INTEGER Reals_Expo (REAL x) { INTEGER _o_result; INTEGER i; - __GET((LONGINT)(uintptr_t)&x + 2, i, INTEGER); + __GET((LONGINT)(SYSTEM_ADDRESS)&x + 2, i, INTEGER); _o_result = __MASK(__ASHR(i, 7), -256); return _o_result; } @@ -67,17 +67,17 @@ INTEGER Reals_Expo (REAL x) void Reals_SetExpo (REAL *x, INTEGER ex) { CHAR c; - __GET((LONGINT)(uintptr_t)x + 3, c, CHAR); - __PUT((LONGINT)(uintptr_t)x + 3, (CHAR)(__ASHL(__ASHR((int)c, 7), 7) + __MASK(__ASHR(ex, 1), -128)), CHAR); - __GET((LONGINT)(uintptr_t)x + 2, c, CHAR); - __PUT((LONGINT)(uintptr_t)x + 2, (CHAR)(__MASK((int)c, -128) + __ASHL(__MASK(ex, -2), 7)), CHAR); + __GET((LONGINT)(SYSTEM_ADDRESS)x + 3, c, CHAR); + __PUT((LONGINT)(SYSTEM_ADDRESS)x + 3, (CHAR)(__ASHL(__ASHR((int)c, 7), 7) + __MASK(__ASHR(ex, 1), -128)), CHAR); + __GET((LONGINT)(SYSTEM_ADDRESS)x + 2, c, CHAR); + __PUT((LONGINT)(SYSTEM_ADDRESS)x + 2, (CHAR)(__MASK((int)c, -128) + __ASHL(__MASK(ex, -2), 7)), CHAR); } INTEGER Reals_ExpoL (LONGREAL x) { INTEGER _o_result; INTEGER i; - __GET((LONGINT)(uintptr_t)&x + 6, i, INTEGER); + __GET((LONGINT)(SYSTEM_ADDRESS)&x + 6, i, INTEGER); _o_result = __MASK(__ASHR(i, 4), -2048); return _o_result; } @@ -90,7 +90,7 @@ void Reals_ConvertL (LONGREAL x, INTEGER n, CHAR *d, LONGINT d__len) } k = 0; i = __ENTIER(x); - while (k < (LONGINT)n) { + while (k < (SYSTEM_INT64)n) { d[__X(k, d__len)] = (CHAR)(__MOD(i, 10) + 48); i = __DIV(i, 10); k += 1; @@ -122,7 +122,7 @@ static void Reals_BytesToHex (SYSTEM_BYTE *b, LONGINT b__len, SYSTEM_BYTE *d, LO CHAR by; i = 0; l = b__len; - while ((LONGINT)i < l) { + while ((SYSTEM_INT64)i < l) { by = __VAL(CHAR, b[__X(i, b__len)]); d[__X(__ASHL(i, 1), d__len)] = Reals_ToHex(__ASHR((int)by, 4)); d[__X(__ASHL(i, 1) + 1, d__len)] = Reals_ToHex(__MASK((int)by, -16)); diff --git a/bootstrap/unix-88/Reals.h b/bootstrap/unix-88/Reals.h index db522698..ff21c192 100644 --- a/bootstrap/unix-88/Reals.h +++ b/bootstrap/unix-88/Reals.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Reals__h #define Reals__h diff --git a/bootstrap/unix-88/SYSTEM.c b/bootstrap/unix-88/SYSTEM.c index 50e91c6d..33511a70 100644 --- a/bootstrap/unix-88/SYSTEM.c +++ b/bootstrap/unix-88/SYSTEM.c @@ -35,7 +35,7 @@ void SYSTEM_INHERIT(LONGINT *t, LONGINT *t0) void SYSTEM_ENUMP(void *adr, LONGINT n, void (*P)()) { while (n > 0) { - P((LONGINT)(uintptr_t)(*((void**)(adr)))); + P((LONGINT)(SYSTEM_ADDRESS)(*((void**)(adr)))); adr = ((void**)adr) + 1; n--; } @@ -106,7 +106,7 @@ SYSTEM_PTR SYSTEM_NEWARR(LONGINT *typ, LONGINT elemsz, int elemalgn, int nofdim, else if (typ == (LONGINT*)POINTER__typ) { /* element type is a pointer */ x = Heap_NEWBLK(size + nofelems * sizeof(LONGINT)); - p = (LONGINT*)(uintptr_t)x[-1]; + p = (LONGINT*)(SYSTEM_ADDRESS)x[-1]; p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */ while (n <= nofelems) {*p = n*sizeof(LONGINT); p++; n++;} @@ -119,7 +119,7 @@ SYSTEM_PTR SYSTEM_NEWARR(LONGINT *typ, LONGINT elemsz, int elemalgn, int nofdim, while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */ nptr = nofelems * nofptrs; /* total number of pointers */ x = Heap_NEWBLK(size + nptr * sizeof(LONGINT)); - p = (LONGINT*)(uintptr_t)x[- 1]; + p = (LONGINT*)(SYSTEM_ADDRESS)x[- 1]; p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ p -= nptr - 1; n = 0; off = dataoff; while (n < nofelems) {i = 0; @@ -155,7 +155,7 @@ typedef void (*SystemSignalHandler)(INTEGER); // = Platform_SignalHandler // (Ignore other signals) } - void SystemSetHandler(int s, uintptr_t h) { + void SystemSetHandler(int s, SYSTEM_ADDRESS h) { if (s >= 2 && s <= 4) { int needtosetsystemhandler = handler[s-2] == 0; handler[s-2] = (SystemSignalHandler)h; @@ -194,12 +194,12 @@ typedef void (*SystemSignalHandler)(INTEGER); // = Platform_SignalHandler } } - void SystemSetInterruptHandler(uintptr_t h) { + void SystemSetInterruptHandler(SYSTEM_ADDRESS h) { EnsureConsoleCtrlHandler(); SystemInterruptHandler = (SystemSignalHandler)h; } - void SystemSetQuitHandler(uintptr_t h) { + void SystemSetQuitHandler(SYSTEM_ADDRESS h) { EnsureConsoleCtrlHandler(); SystemQuitHandler = (SystemSignalHandler)h; } diff --git a/bootstrap/unix-88/SYSTEM.h b/bootstrap/unix-88/SYSTEM.h index 949951ac..6377745e 100644 --- a/bootstrap/unix-88/SYSTEM.h +++ b/bootstrap/unix-88/SYSTEM.h @@ -1,28 +1,38 @@ #ifndef SYSTEM__h #define SYSTEM__h -#ifndef _WIN32 - - // Building for a Unix/Linux based system - #include // For memcpy ... - #include // For uintptr_t ... - +#if defined(_WIN64) + typedef long long SYSTEM_INT64; + typedef unsigned long long SYSTEM_CARD64; #else - - // Building for Windows platform with either mingw under cygwin, or the MS C compiler - #ifdef _WIN64 - typedef unsigned long long size_t; - typedef unsigned long long uintptr_t; - #else - typedef unsigned int size_t; - typedef unsigned int uintptr_t; - #endif /* _WIN64 */ - - typedef unsigned int uint32_t; - void * __cdecl memcpy(void * dest, const void * source, size_t size); - + typedef long SYSTEM_INT64; + typedef unsigned long SYSTEM_CARD64; #endif +typedef int SYSTEM_INT32; +typedef unsigned int SYSTEM_CARD32; +typedef short int SYSTEM_INT16; +typedef unsigned short int SYSTEM_CARD16; +typedef signed char SYSTEM_INT8; +typedef unsigned char SYSTEM_CARD8; + +#if (__SIZEOF_POINTER__ == 8) || defined(_WIN64) || defined(__LP64__) + #if defined(_WIN64) + typedef unsigned long long size_t; + #else + typedef unsigned long size_t; + #endif +#else + typedef unsigned int size_t; +#endif + +#define SYSTEM_ADDRESS size_t +#define _SIZE_T_DECLARED // For FreeBSD +#define _SIZE_T_DEFINED_ // For OpenBSD + +void *memcpy(void *dest, const void *source, SYSTEM_ADDRESS size); + + // The compiler uses 'import' and 'export' which translate to 'extern' and // nothing respectively. @@ -70,6 +80,7 @@ typedef unsigned char U_SHORTINT; #endif typedef U_LONGINT SET; +typedef U_LONGINT U_SET; // OS Memory allocation interfaces are in PlatformXXX.Mod @@ -96,10 +107,10 @@ extern LONGINT SYSTEM_ENTIER (double x); // Signal handling in SYSTEM.c #ifndef _WIN32 - extern void SystemSetHandler(int s, uintptr_t h); + extern void SystemSetHandler(int s, SYSTEM_ADDRESS h); #else - extern void SystemSetInterruptHandler(uintptr_t h); - extern void SystemSetQuitHandler (uintptr_t h); + extern void SystemSetInterruptHandler(SYSTEM_ADDRESS h); + extern void SystemSetQuitHandler (SYSTEM_ADDRESS h); #endif @@ -122,20 +133,20 @@ static int __str_cmp(CHAR *x, CHAR *y){ #define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d; LONGINT _i=0,_t=n-1; \ while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;} -#define __DUP(x, l, t) x=(void*)memcpy((void*)(uintptr_t)Platform_OSAllocate(l*sizeof(t)),x,l*sizeof(t)) +#define __DUP(x, l, t) x=(void*)memcpy((void*)(SYSTEM_ADDRESS)Platform_OSAllocate(l*sizeof(t)),x,l*sizeof(t)) #define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) -#define __DEL(x) Platform_OSFree((LONGINT)(uintptr_t)x) +#define __DEL(x) Platform_OSFree((LONGINT)(SYSTEM_ADDRESS)x) /* SYSTEM ops */ -#define __VAL(t, x) ((t)(x)) -#define __VALP(t, x) ((t)(uintptr_t)(x)) +#define __VAL(t, x) (*(t*)&(x)) -#define __GET(a, x, t) x= *(t*)(uintptr_t)(a) -#define __PUT(a, x, t) *(t*)(uintptr_t)(a)=x + +#define __GET(a, x, t) x= *(t*)(SYSTEM_ADDRESS)(a) +#define __PUT(a, x, t) *(t*)(SYSTEM_ADDRESS)(a)=x #define __LSHL(x, n, t) ((t)((U_##t)(x)<<(n))) #define __LSHR(x, n, t) ((t)((U_##t)(x)>>(n))) @@ -150,7 +161,7 @@ static int __str_cmp(CHAR *x, CHAR *y){ #define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t)) #define __BIT(x, n) (*(U_LONGINT*)(x)>>(n)&1) -#define __MOVE(s, d, n) memcpy((char*)(uintptr_t)(d),(char*)(uintptr_t)(s),n) +#define __MOVE(s, d, n) memcpy((char*)(SYSTEM_ADDRESS)(d),(char*)(SYSTEM_ADDRESS)(s),n) #define __ASHF(x, n) SYSTEM_ASH((LONGINT)(x), (LONGINT)(n)) #define __SHORT(x, y) ((int)((U_LONGINT)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0))) #define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y))) @@ -211,7 +222,7 @@ extern void Heap_INCREF(); extern void Platform_Init(INTEGER argc, LONGINT argv); extern void Heap_FINALL(); -#define __INIT(argc, argv) static void *m; Platform_Init((INTEGER)argc, (LONGINT)(uintptr_t)&argv); +#define __INIT(argc, argv) static void *m; Platform_Init((INTEGER)argc, (LONGINT)(SYSTEM_ADDRESS)&argv); #define __REGMAIN(name, enum) m = Heap_REGMOD((CHAR*)name,enum) #define __FINI Heap_FINALL(); return 0 @@ -232,7 +243,7 @@ extern SYSTEM_PTR Heap_NEWREC (LONGINT tag); extern SYSTEM_PTR SYSTEM_NEWARR(LONGINT*, LONGINT, int, int, int, ...); #define __SYSNEW(p, len) p = Heap_NEWBLK((LONGINT)(len)) -#define __NEW(p, t) p = Heap_NEWREC((LONGINT)(uintptr_t)t##__typ) +#define __NEW(p, t) p = Heap_NEWREC((LONGINT)(SYSTEM_ADDRESS)t##__typ) #define __NEWARR SYSTEM_NEWARR @@ -263,20 +274,20 @@ extern SYSTEM_PTR SYSTEM_NEWARR(LONGINT*, LONGINT, int, int, int, ...); #define __INITYP(t, t0, level) \ t##__typ = (LONGINT*)&t##__desc.blksz; \ memcpy(t##__desc.basep, t0##__typ - __BASEOFF, level*sizeof(LONGINT)); \ - t##__desc.basep[level] = (LONGINT)(uintptr_t)t##__typ; \ - t##__desc.module = (LONGINT)(uintptr_t)m; \ + t##__desc.basep[level] = (LONGINT)(SYSTEM_ADDRESS)t##__typ; \ + t##__desc.module = (LONGINT)(SYSTEM_ADDRESS)m; \ if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ t##__desc.blksz = (t##__desc.blksz+5*sizeof(LONGINT)-1)/(4*sizeof(LONGINT))*(4*sizeof(LONGINT)); \ - Heap_REGTYP(m, (LONGINT)(uintptr_t)&t##__desc.next); \ + Heap_REGTYP(m, (LONGINT)(SYSTEM_ADDRESS)&t##__desc.next); \ SYSTEM_INHERIT(t##__typ, t0##__typ) -#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(LONGINT)(uintptr_t)typ##__typ) -#define __TYPEOF(p) ((LONGINT*)(uintptr_t)(*(((LONGINT*)(p))-1))) +#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(LONGINT)(SYSTEM_ADDRESS)typ##__typ) +#define __TYPEOF(p) ((LONGINT*)(SYSTEM_ADDRESS)(*(((LONGINT*)(p))-1))) #define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) // Oberon-2 type bound procedures support -#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(LONGINT)(uintptr_t)proc -#define __SEND(typ, num, funtyp, parlist) ((funtyp)((uintptr_t)*(typ-(__TPROC0OFF+num))))parlist +#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(LONGINT)(SYSTEM_ADDRESS)proc +#define __SEND(typ, num, funtyp, parlist) ((funtyp)((SYSTEM_ADDRESS)*(typ-(__TPROC0OFF+num))))parlist diff --git a/bootstrap/unix-88/Strings.c b/bootstrap/unix-88/Strings.c index 962b86a0..20a14540 100644 --- a/bootstrap/unix-88/Strings.c +++ b/bootstrap/unix-88/Strings.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" @@ -22,7 +22,7 @@ INTEGER Strings_Length (CHAR *s, LONGINT s__len) INTEGER i; __DUP(s, s__len, CHAR); i = 0; - while (((LONGINT)i < s__len && s[__X(i, s__len)] != 0x00)) { + while (((SYSTEM_INT64)i < s__len && s[__X(i, s__len)] != 0x00)) { i += 1; } _o_result = i; @@ -37,11 +37,11 @@ void Strings_Append (CHAR *extra, LONGINT extra__len, CHAR *dest, LONGINT dest__ n1 = Strings_Length(dest, dest__len); n2 = Strings_Length(extra, extra__len); i = 0; - while ((i < n2 && (LONGINT)(i + n1) < dest__len)) { + while ((i < n2 && (SYSTEM_INT64)(i + n1) < dest__len)) { dest[__X(i + n1, dest__len)] = extra[__X(i, extra__len)]; i += 1; } - if ((LONGINT)(i + n1) < dest__len) { + if ((SYSTEM_INT64)(i + n1) < dest__len) { dest[__X(i + n1, dest__len)] = 0x00; } __DEL(extra); @@ -60,10 +60,10 @@ void Strings_Insert (CHAR *source, LONGINT source__len, INTEGER pos, CHAR *dest, Strings_Append(dest, dest__len, (void*)source, source__len); return; } - if ((LONGINT)(pos + n2) < dest__len) { + if ((SYSTEM_INT64)(pos + n2) < dest__len) { i = n1; while (i >= pos) { - if ((LONGINT)(i + n2) < dest__len) { + if ((SYSTEM_INT64)(i + n2) < dest__len) { dest[__X(i + n2, dest__len)] = dest[__X(i, dest__len)]; } i -= 1; @@ -92,7 +92,7 @@ void Strings_Delete (CHAR *s, LONGINT s__len, INTEGER pos, INTEGER n) s[__X(i - n, s__len)] = s[__X(i, s__len)]; i += 1; } - if ((LONGINT)(i - n) < s__len) { + if ((SYSTEM_INT64)(i - n) < s__len) { s[__X(i - n, s__len)] = 0x00; } } else { @@ -122,7 +122,7 @@ void Strings_Extract (CHAR *source, LONGINT source__len, INTEGER pos, INTEGER n, return; } i = 0; - while (((((LONGINT)(pos + i) <= source__len && source[__X(pos + i, source__len)] != 0x00)) && i < n)) { + while (((((SYSTEM_INT64)(pos + i) <= source__len && source[__X(pos + i, source__len)] != 0x00)) && i < n)) { if (i < destLen) { dest[__X(i, dest__len)] = source[__X(pos + i, source__len)]; } diff --git a/bootstrap/unix-88/Strings.h b/bootstrap/unix-88/Strings.h index 549337ee..d64d3478 100644 --- a/bootstrap/unix-88/Strings.h +++ b/bootstrap/unix-88/Strings.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Strings__h #define Strings__h diff --git a/bootstrap/unix-88/Texts.c b/bootstrap/unix-88/Texts.c index fe673ac8..a1fb81c0 100644 --- a/bootstrap/unix-88/Texts.c +++ b/bootstrap/unix-88/Texts.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "Files.h" @@ -788,9 +788,9 @@ void Texts_Scan (Texts_Scanner *S, LONGINT *S__typ) (*S).s[__X(i, ((LONGINT)(64)))] = 0x00; (*S).len = i; (*S).class = 1; - } else if (ch == '\"') { + } else if (ch == '"') { Texts_Read((void*)&*S, S__typ, &ch); - while ((((ch != '\"' && ch >= ' ')) && i != 63)) { + while ((((ch != '"' && ch >= ' ')) && i != 63)) { (*S).s[__X(i, ((LONGINT)(64)))] = ch; i += 1; Texts_Read((void*)&*S, S__typ, &ch); @@ -840,7 +840,7 @@ void Texts_Scan (Texts_Scanner *S, LONGINT *S__typ) k -= 16; } while (j < i) { - k = __ASHL(k, 4) + (LONGINT)((int)d[__X(j, ((LONGINT)(32)))] - 48); + k = __ASHL(k, 4) + (SYSTEM_INT64)((int)d[__X(j, ((LONGINT)(32)))] - 48); j += 1; } if (neg) { @@ -930,7 +930,7 @@ void Texts_Scan (Texts_Scanner *S, LONGINT *S__typ) (*S).class = 3; k = 0; do { - k = k * 10 + (LONGINT)((int)d[__X(j, ((LONGINT)(32)))] - 48); + k = k * 10 + (SYSTEM_INT64)((int)d[__X(j, ((LONGINT)(32)))] - 48); j += 1; } while (!(j == i)); if (neg) { @@ -1068,7 +1068,7 @@ void Texts_WriteInt (Texts_Writer *W, LONGINT *W__typ, LONGINT x, LONGINT n) x0 = __DIV(x0, 10); i += 1; } while (!(x0 == 0)); - while (n > (LONGINT)i) { + while (n > (SYSTEM_INT64)i) { Texts_Write(&*W, W__typ, ' '); n -= 1; } @@ -1320,7 +1320,7 @@ void Texts_WriteLongReal (Texts_Writer *W, LONGINT *W__typ, LONGREAL x, INTEGER } else { Texts_Write(&*W, W__typ, ' '); } - e = (int)__ASHR((LONGINT)(e - 1023) * 77, 8); + e = (int)__ASHR((SYSTEM_INT64)(e - 1023) * 77, 8); if (e >= 0) { x = x / (LONGREAL)Reals_TenL(e); } else { diff --git a/bootstrap/unix-88/Texts.h b/bootstrap/unix-88/Texts.h index dcee9f40..bca5665d 100644 --- a/bootstrap/unix-88/Texts.h +++ b/bootstrap/unix-88/Texts.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Texts__h #define Texts__h diff --git a/bootstrap/unix-88/Vishap.c b/bootstrap/unix-88/Vishap.c index ccb3e59e..6eda4f2c 100644 --- a/bootstrap/unix-88/Vishap.c +++ b/bootstrap/unix-88/Vishap.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkamSf */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkamSf */ #define LARGE #include "SYSTEM.h" #include "Configuration.h" diff --git a/bootstrap/unix-88/errors.c b/bootstrap/unix-88/errors.c index 9b9ec275..48246ffa 100644 --- a/bootstrap/unix-88/errors.c +++ b/bootstrap/unix-88/errors.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" @@ -26,7 +26,7 @@ export void *errors__init(void) errors_errors[6][0] = 0x00; errors_errors[7][0] = 0x00; errors_errors[8][0] = 0x00; - __MOVE("\'=\' expected", errors_errors[9], 13); + __MOVE("'=' expected", errors_errors[9], 13); errors_errors[10][0] = 0x00; errors_errors[11][0] = 0x00; __MOVE("type definition starts with incorrect symbol", errors_errors[12], 45); @@ -35,28 +35,28 @@ export void *errors__init(void) __MOVE("declaration followed by incorrect symbol", errors_errors[15], 41); __MOVE("MODULE expected", errors_errors[16], 16); errors_errors[17][0] = 0x00; - __MOVE("\'.\' missing", errors_errors[18], 12); - __MOVE("\',\' missing", errors_errors[19], 12); - __MOVE("\':\' missing", errors_errors[20], 12); + __MOVE("'.' missing", errors_errors[18], 12); + __MOVE("',' missing", errors_errors[19], 12); + __MOVE("':' missing", errors_errors[20], 12); errors_errors[21][0] = 0x00; - __MOVE("\')\' missing", errors_errors[22], 12); - __MOVE("\']\' missing", errors_errors[23], 12); - __MOVE("\'}\' missing", errors_errors[24], 12); + __MOVE("')' missing", errors_errors[22], 12); + __MOVE("']' missing", errors_errors[23], 12); + __MOVE("'}' missing", errors_errors[24], 12); __MOVE("OF missing", errors_errors[25], 11); __MOVE("THEN missing", errors_errors[26], 13); __MOVE("DO missing", errors_errors[27], 11); __MOVE("TO missing", errors_errors[28], 11); errors_errors[29][0] = 0x00; - __MOVE("\'(\' missing", errors_errors[30], 12); + __MOVE("'(' missing", errors_errors[30], 12); errors_errors[31][0] = 0x00; errors_errors[32][0] = 0x00; errors_errors[33][0] = 0x00; - __MOVE("\':=\' missing", errors_errors[34], 13); - __MOVE("\',\' or OF expected", errors_errors[35], 19); + __MOVE("':=' missing", errors_errors[34], 13); + __MOVE("',' or OF expected", errors_errors[35], 19); errors_errors[36][0] = 0x00; errors_errors[37][0] = 0x00; __MOVE("identifier expected", errors_errors[38], 20); - __MOVE("\';\' missing", errors_errors[39], 12); + __MOVE("';' missing", errors_errors[39], 12); errors_errors[40][0] = 0x00; __MOVE("END missing", errors_errors[41], 12); errors_errors[42][0] = 0x00; @@ -132,10 +132,10 @@ export void *errors__init(void) __MOVE("operand is not a variable", errors_errors[112], 26); __MOVE("incompatible assignment", errors_errors[113], 24); __MOVE("string too long to be assigned", errors_errors[114], 31); - __MOVE("parameter doesn\'t match", errors_errors[115], 24); - __MOVE("number of parameters doesn\'t match", errors_errors[116], 35); - __MOVE("result type doesn\'t match", errors_errors[117], 26); - __MOVE("export mark doesn\'t match with forward declaration", errors_errors[118], 51); + __MOVE("parameter doesn't match", errors_errors[115], 24); + __MOVE("number of parameters doesn't match", errors_errors[116], 35); + __MOVE("result type doesn't match", errors_errors[117], 26); + __MOVE("export mark doesn't match with forward declaration", errors_errors[118], 51); __MOVE("redefinition textually precedes procedure bound to base type", errors_errors[119], 61); __MOVE("type of expression following IF, WHILE, UNTIL or ASSERT is not BOOLEAN", errors_errors[120], 71); __MOVE("called object is not a procedure (or is an interrupt procedure)", errors_errors[121], 64); @@ -195,5 +195,6 @@ export void *errors__init(void) __MOVE("implicit type cast", errors_errors[301], 19); __MOVE("inappropriate symbol file ignored", errors_errors[306], 34); __MOVE("no ELSE symbol after CASE statement sequence may lead to trap", errors_errors[307], 62); + __MOVE("SYSTEM.VAL result includes memory past end of source variable", errors_errors[308], 62); __ENDMOD; } diff --git a/bootstrap/unix-88/errors.h b/bootstrap/unix-88/errors.h index fdf34cf1..9081238a 100644 --- a/bootstrap/unix-88/errors.h +++ b/bootstrap/unix-88/errors.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef errors__h #define errors__h diff --git a/bootstrap/unix-88/extTools.c b/bootstrap/unix-88/extTools.c index 521538ae..4005b0a6 100644 --- a/bootstrap/unix-88/extTools.c +++ b/bootstrap/unix-88/extTools.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "Configuration.h" diff --git a/bootstrap/unix-88/extTools.h b/bootstrap/unix-88/extTools.h index de353aeb..6ac1ab91 100644 --- a/bootstrap/unix-88/extTools.h +++ b/bootstrap/unix-88/extTools.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef extTools__h #define extTools__h diff --git a/bootstrap/unix-88/vt100.c b/bootstrap/unix-88/vt100.c index 1b8568fe..a9110e8a 100644 --- a/bootstrap/unix-88/vt100.c +++ b/bootstrap/unix-88/vt100.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "Console.h" @@ -253,7 +253,7 @@ export void *vt100__init(void) __REGCMD("RCP", vt100_RCP); __REGCMD("SCP", vt100_SCP); /* BEGIN */ - __COPY("", vt100_CSI, ((LONGINT)(5))); + __COPY("\033", vt100_CSI, ((LONGINT)(5))); Strings_Append((CHAR*)"[", (LONGINT)2, (void*)vt100_CSI, ((LONGINT)(5))); __ENDMOD; } diff --git a/bootstrap/unix-88/vt100.h b/bootstrap/unix-88/vt100.h index 2d276238..801bc8f9 100644 --- a/bootstrap/unix-88/vt100.h +++ b/bootstrap/unix-88/vt100.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef vt100__h #define vt100__h diff --git a/bootstrap/windows-48/Configuration.c b/bootstrap/windows-48/Configuration.c index 1f5afbb7..821dff97 100644 --- a/bootstrap/windows-48/Configuration.c +++ b/bootstrap/windows-48/Configuration.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" @@ -13,6 +13,6 @@ export void *Configuration__init(void) __DEFMOD; __REGMOD("Configuration", 0); /* BEGIN */ - __MOVE("1.95 [2016/08/24] for gcc LP64 on cygwin", Configuration_versionLong, 41); + __MOVE("1.95 [2016/08/23] for gcc LP64 on cygwin", Configuration_versionLong, 41); __ENDMOD; } diff --git a/bootstrap/windows-48/Configuration.h b/bootstrap/windows-48/Configuration.h index eef3a15d..ec5e865a 100644 --- a/bootstrap/windows-48/Configuration.h +++ b/bootstrap/windows-48/Configuration.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Configuration__h #define Configuration__h diff --git a/bootstrap/windows-48/Console.c b/bootstrap/windows-48/Console.c index b1cc9707..ebd86b8d 100644 --- a/bootstrap/windows-48/Console.c +++ b/bootstrap/windows-48/Console.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Platform.h" @@ -21,7 +21,7 @@ export void Console_String (CHAR *s, LONGINT s__len); void Console_Flush (void) { INTEGER error; - error = Platform_Write(Platform_StdOut, (LONGINT)(uintptr_t)Console_line, Console_pos); + error = Platform_Write(Platform_StdOut, (LONGINT)(SYSTEM_ADDRESS)Console_line, Console_pos); Console_pos = 0; } diff --git a/bootstrap/windows-48/Console.h b/bootstrap/windows-48/Console.h index 53dbdfa8..5fdd4e4d 100644 --- a/bootstrap/windows-48/Console.h +++ b/bootstrap/windows-48/Console.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Console__h #define Console__h diff --git a/bootstrap/windows-48/Files.c b/bootstrap/windows-48/Files.c index 49be5f7c..1f3a8e9c 100644 --- a/bootstrap/windows-48/Files.c +++ b/bootstrap/windows-48/Files.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #include "SYSTEM.h" #include "Configuration.h" #include "Console.h" @@ -257,7 +257,7 @@ static void Files_Flush (Files_Buffer buf) if (buf->org != f->pos) { error = Platform_Seek(f->fd, buf->org, Platform_SeekSet); } - error = Platform_Write(f->fd, (LONGINT)(uintptr_t)buf->data, buf->size); + error = Platform_Write(f->fd, (LONGINT)(SYSTEM_ADDRESS)buf->data, buf->size); if (error != 0) { Files_Err((CHAR*)"error writing file", (LONGINT)19, f, error); } @@ -656,7 +656,7 @@ void Files_ReadBytes (Files_Rider *r, LONGINT *r__typ, SYSTEM_BYTE *x, LONGINT x } else { min = n; } - __MOVE((LONGINT)(uintptr_t)buf->data + offset, (LONGINT)(uintptr_t)x + xpos, min); + __MOVE((LONGINT)(SYSTEM_ADDRESS)buf->data + offset, (LONGINT)(SYSTEM_ADDRESS)x + xpos, min); offset += min; (*r).offset = offset; xpos += min; @@ -721,7 +721,7 @@ void Files_WriteBytes (Files_Rider *r, LONGINT *r__typ, SYSTEM_BYTE *x, LONGINT } else { min = n; } - __MOVE((LONGINT)(uintptr_t)x + xpos, (LONGINT)(uintptr_t)buf->data + offset, min); + __MOVE((LONGINT)(SYSTEM_ADDRESS)x + xpos, (LONGINT)(SYSTEM_ADDRESS)buf->data + offset, min); offset += min; (*r).offset = offset; if (offset > buf->size) { @@ -772,15 +772,15 @@ void Files_Rename (CHAR *old, LONGINT old__len, CHAR *new, LONGINT new__len, INT *res = 3; return; } - error = Platform_Read(fdold, (LONGINT)(uintptr_t)buf, ((LONGINT)(4096)), &n); + error = Platform_Read(fdold, (LONGINT)(SYSTEM_ADDRESS)buf, ((LONGINT)(4096)), &n); while (n > 0) { - error = Platform_Write(fdnew, (LONGINT)(uintptr_t)buf, n); + error = Platform_Write(fdnew, (LONGINT)(SYSTEM_ADDRESS)buf, n); if (error != 0) { ignore = Platform_Close(fdold); ignore = Platform_Close(fdnew); Files_Err((CHAR*)"cannot move file", (LONGINT)17, NIL, error); } - error = Platform_Read(fdold, (LONGINT)(uintptr_t)buf, ((LONGINT)(4096)), &n); + error = Platform_Read(fdold, (LONGINT)(SYSTEM_ADDRESS)buf, ((LONGINT)(4096)), &n); } ignore = Platform_Close(fdold); ignore = Platform_Close(fdnew); @@ -838,7 +838,7 @@ static void Files_FlipBytes (SYSTEM_BYTE *src, LONGINT src__len, SYSTEM_BYTE *de j += 1; } } else { - __MOVE((LONGINT)(uintptr_t)src, (LONGINT)(uintptr_t)dest, src__len); + __MOVE((LONGINT)(SYSTEM_ADDRESS)src, (LONGINT)(SYSTEM_ADDRESS)dest, src__len); } } @@ -858,14 +858,16 @@ void Files_ReadLInt (Files_Rider *R, LONGINT *R__typ, LONGINT *x) { CHAR b[4]; Files_ReadBytes(&*R, R__typ, (void*)b, ((LONGINT)(4)), ((LONGINT)(4))); - *x = ((LONGINT)((int)b[0] + __ASHL((int)b[1], 8)) + __ASHL((LONGINT)b[2], 16)) + __ASHL((LONGINT)b[3], 24); + *x = ((int)((int)b[0] + __ASHL((int)b[1], 8)) + __ASHL((int)b[2], 16)) + __ASHL((int)b[3], 24); } void Files_ReadSet (Files_Rider *R, LONGINT *R__typ, SET *x) { CHAR b[4]; + LONGINT l; Files_ReadBytes(&*R, R__typ, (void*)b, ((LONGINT)(4)), ((LONGINT)(4))); - *x = (SET)(((LONGINT)((int)b[0] + __ASHL((int)b[1], 8)) + __ASHL((LONGINT)b[2], 16)) + __ASHL((LONGINT)b[3], 24)); + l = ((int)((int)b[0] + __ASHL((int)b[1], 8)) + __ASHL((int)b[2], 16)) + __ASHL((int)b[3], 24); + *x = (SET)l; } void Files_ReadReal (Files_Rider *R, LONGINT *R__typ, REAL *x) @@ -921,11 +923,11 @@ void Files_ReadNum (Files_Rider *R, LONGINT *R__typ, LONGINT *x) n = 0; Files_Read(&*R, R__typ, (void*)&ch); while ((int)ch >= 128) { - n += __ASH((LONGINT)((int)ch - 128), s); + n += __ASH((int)((int)ch - 128), s); s += 7; Files_Read(&*R, R__typ, (void*)&ch); } - n += __ASH((LONGINT)(__MASK((int)ch, -64) - __ASHL(__ASHR((int)ch, 6), 6)), s); + n += __ASH((int)(__MASK((int)ch, -64) - __ASHL(__ASHR((int)ch, 6), 6)), s); *x = n; } @@ -1006,7 +1008,7 @@ static void Files_Finalize (SYSTEM_PTR o) { Files_File f = NIL; LONGINT res; - f = (Files_File)(uintptr_t)o; + f = (Files_File)(SYSTEM_ADDRESS)o; if (f->fd >= 0) { Files_CloseOSFile(f); if (f->tempFile) { diff --git a/bootstrap/windows-48/Files.h b/bootstrap/windows-48/Files.h index 10a35cd2..868f24df 100644 --- a/bootstrap/windows-48/Files.h +++ b/bootstrap/windows-48/Files.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #ifndef Files__h #define Files__h diff --git a/bootstrap/windows-48/Heap.c b/bootstrap/windows-48/Heap.c index 4cabf8c6..30ec687a 100644 --- a/bootstrap/windows-48/Heap.c +++ b/bootstrap/windows-48/Heap.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tskSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tskSfF */ #include "SYSTEM.h" struct Heap__1 { @@ -101,7 +101,7 @@ export void Heap_Unlock (void); extern void *Heap__init(); extern LONGINT Platform_MainStackFrame; extern LONGINT Platform_OSAllocate(LONGINT size); -#define Heap_FetchAddress(pointer) (LONGINT)(uintptr_t)(*((void**)((uintptr_t)pointer))) +#define Heap_FetchAddress(pointer) (LONGINT)(SYSTEM_ADDRESS)(*((void**)((SYSTEM_ADDRESS)pointer))) #define Heap_HeapModuleInit() Heap__init() #define Heap_OSAllocate(size) Platform_OSAllocate(size) #define Heap_PlatformHalt(code) Platform_Halt(code) @@ -134,7 +134,7 @@ SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs) __COPY(name, m->name, ((LONGINT)(20))); m->refcnt = 0; m->enumPtrs = enumPtrs; - m->next = (Heap_Module)(uintptr_t)Heap_modules; + m->next = (Heap_Module)(SYSTEM_ADDRESS)Heap_modules; Heap_modules = (SYSTEM_PTR)m; _o_result = (void*)m; return _o_result; @@ -315,7 +315,7 @@ SYSTEM_PTR Heap_NEWREC (LONGINT tag) __PUT(adr + 8, 0, LONGINT); Heap_allocated += blksz; Heap_Unlock(); - _o_result = (SYSTEM_PTR)(uintptr_t)(adr + 4); + _o_result = (SYSTEM_PTR)(SYSTEM_ADDRESS)(adr + 4); return _o_result; } @@ -326,12 +326,12 @@ SYSTEM_PTR Heap_NEWBLK (LONGINT size) SYSTEM_PTR new; Heap_Lock(); blksz = __ASHL(__ASHR(size + 31, 4), 4); - new = Heap_NEWREC((LONGINT)(uintptr_t)&blksz); - tag = ((LONGINT)(uintptr_t)new + blksz) - 12; + new = Heap_NEWREC((LONGINT)(SYSTEM_ADDRESS)&blksz); + tag = ((LONGINT)(SYSTEM_ADDRESS)new + blksz) - 12; __PUT(tag - 4, 0, LONGINT); __PUT(tag, blksz, LONGINT); __PUT(tag + 4, -4, LONGINT); - __PUT((LONGINT)(uintptr_t)new - 4, tag, LONGINT); + __PUT((LONGINT)(SYSTEM_ADDRESS)new - 4, tag, LONGINT); Heap_Unlock(); _o_result = new; return _o_result; @@ -360,7 +360,7 @@ static void Heap_Mark (LONGINT q) __GET(tag, offset, LONGINT); fld = q + offset; p = Heap_FetchAddress(fld); - __PUT(fld, (SYSTEM_PTR)(uintptr_t)n, SYSTEM_PTR); + __PUT(fld, (SYSTEM_PTR)(SYSTEM_ADDRESS)n, SYSTEM_PTR); } else { fld = q + offset; n = Heap_FetchAddress(fld); @@ -369,7 +369,7 @@ static void Heap_Mark (LONGINT q) if (!__ODD(tagbits)) { __PUT(n - 4, tagbits + 1, LONGINT); __PUT(q - 4, tag + 1, LONGINT); - __PUT(fld, (SYSTEM_PTR)(uintptr_t)p, SYSTEM_PTR); + __PUT(fld, (SYSTEM_PTR)(SYSTEM_ADDRESS)p, SYSTEM_PTR); p = q; q = n; tag = tagbits; @@ -384,7 +384,7 @@ static void Heap_Mark (LONGINT q) static void Heap_MarkP (SYSTEM_PTR p) { - Heap_Mark((LONGINT)(uintptr_t)p); + Heap_Mark((LONGINT)(SYSTEM_ADDRESS)p); } static void Heap_Scan (void) @@ -553,7 +553,7 @@ static void Heap_Finalize (void) } else { prev->next = n->next; } - (*n->finalize)((SYSTEM_PTR)(uintptr_t)n->obj); + (*n->finalize)((SYSTEM_PTR)(SYSTEM_ADDRESS)n->obj); if (prev == NIL) { n = Heap_fin; } else { @@ -572,7 +572,7 @@ void Heap_FINALL (void) while (Heap_fin != NIL) { n = Heap_fin; Heap_fin = Heap_fin->next; - (*n->finalize)((SYSTEM_PTR)(uintptr_t)n->obj); + (*n->finalize)((SYSTEM_PTR)(SYSTEM_ADDRESS)n->obj); } } @@ -589,9 +589,9 @@ static void Heap_MarkStack (LONGINT n, LONGINT *cand, LONGINT cand__len) } if (n == 0) { nofcand = 0; - sp = (LONGINT)(uintptr_t)&frame; + sp = (LONGINT)(SYSTEM_ADDRESS)&frame; stack0 = Heap_PlatformMainStackFrame(); - inc = (LONGINT)(uintptr_t)&align.p - (LONGINT)(uintptr_t)&align; + inc = (LONGINT)(SYSTEM_ADDRESS)&align.p - (LONGINT)(SYSTEM_ADDRESS)&align; if (sp > stack0) { inc = -inc; } @@ -622,7 +622,7 @@ void Heap_GC (BOOLEAN markStack) LONGINT cand[10000]; if (Heap_lockdepth == 0 || (Heap_lockdepth == 1 && !markStack)) { Heap_Lock(); - m = (Heap_Module)(uintptr_t)Heap_modules; + m = (Heap_Module)(SYSTEM_ADDRESS)Heap_modules; while (m != NIL) { if (m->enumPtrs != NIL) { (*m->enumPtrs)(Heap_MarkP); @@ -699,7 +699,7 @@ void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize) { Heap_FinNode f; __NEW(f, Heap_FinDesc); - f->obj = (LONGINT)(uintptr_t)obj; + f->obj = (LONGINT)(SYSTEM_ADDRESS)obj; f->finalize = finalize; f->marked = 1; f->next = Heap_fin; diff --git a/bootstrap/windows-48/Heap.h b/bootstrap/windows-48/Heap.h index 38e549be..a2cab30c 100644 --- a/bootstrap/windows-48/Heap.h +++ b/bootstrap/windows-48/Heap.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tskSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tskSfF */ #ifndef Heap__h #define Heap__h diff --git a/bootstrap/windows-48/Modules.c b/bootstrap/windows-48/Modules.c index d5164a2a..330b7506 100644 --- a/bootstrap/windows-48/Modules.c +++ b/bootstrap/windows-48/Modules.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Console.h" #include "Heap.h" diff --git a/bootstrap/windows-48/Modules.h b/bootstrap/windows-48/Modules.h index 5e27b653..ac8ac89e 100644 --- a/bootstrap/windows-48/Modules.h +++ b/bootstrap/windows-48/Modules.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Modules__h #define Modules__h diff --git a/bootstrap/windows-48/OPB.c b/bootstrap/windows-48/OPB.c index d834a9e8..0f614e6a 100644 --- a/bootstrap/windows-48/OPB.c +++ b/bootstrap/windows-48/OPB.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "OPM.h" #include "OPS.h" @@ -34,7 +34,9 @@ export void OPB_In (OPT_Node *x, OPT_Node y); export void OPB_Index (OPT_Node *x, OPT_Node y); export void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ); static BOOLEAN OPB_IntToBool (LONGINT i); +static OPT_Struct OPB_IntType (LONGINT size); export void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y); +static LONGINT OPB_LongerSize (LONGINT i); export void OPB_MOp (SHORTINT op, OPT_Node *x); export OPT_Node OPB_NewBoolConst (BOOLEAN boolval); export OPT_Node OPB_NewIntConst (LONGINT intval); @@ -51,6 +53,8 @@ export void OPB_Return (OPT_Node *x, OPT_Object proc); export void OPB_SetElem (OPT_Node *x); static void OPB_SetIntType (OPT_Node node); export void OPB_SetRange (OPT_Node *x, OPT_Node y); +static LONGINT OPB_ShorterSize (LONGINT i); +static INTEGER OPB_SignedByteSize (LONGINT n); export void OPB_StFct (OPT_Node *par0, SHORTINT fctno, INTEGER parno); export void OPB_StPar0 (OPT_Node *par0, INTEGER fctno); export void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno); @@ -90,8 +94,8 @@ OPT_Node OPB_NewLeaf (OPT_Object obj) node = OPT_NewNode(9); break; default: - OPB_err(127); node = OPT_NewNode(0); + OPB_err(127); break; } node->obj = obj; @@ -220,21 +224,68 @@ OPT_Node OPB_EmptySet (void) return _o_result; } +static INTEGER OPB_SignedByteSize (LONGINT n) +{ + INTEGER _o_result; + INTEGER b; + if (n < 0) { + n = -(n + 1); + } + b = 1; + while ((b < 8 && __ASH(n, -(__ASHL(b, 3) - 1)) != 0)) { + b += 1; + } + _o_result = b; + return _o_result; +} + +static LONGINT OPB_ShorterSize (LONGINT i) +{ + LONGINT _o_result; + if (i >= (int)OPM_LIntSize) { + _o_result = OPM_IntSize; + return _o_result; + } else { + _o_result = OPM_SIntSize; + return _o_result; + } + __RETCHK; +} + +static LONGINT OPB_LongerSize (LONGINT i) +{ + LONGINT _o_result; + if (i <= (int)OPM_SIntSize) { + _o_result = OPM_IntSize; + return _o_result; + } else { + _o_result = OPM_LIntSize; + return _o_result; + } + __RETCHK; +} + +static OPT_Struct OPB_IntType (LONGINT size) +{ + OPT_Struct _o_result; + OPT_Struct result = NIL; + if (size <= OPT_sinttyp->size) { + result = OPT_sinttyp; + } else if (size <= OPT_inttyp->size) { + result = OPT_inttyp; + } else { + result = OPT_linttyp; + } + if (size > OPT_linttyp->size) { + OPB_err(203); + } + _o_result = result; + return _o_result; +} + static void OPB_SetIntType (OPT_Node node) { - LONGINT v; - v = node->conval->intval; - if ((OPM_MinSInt <= (LONGINT)v && (LONGINT)v <= OPM_MaxSInt)) { - node->typ = OPT_sinttyp; - } else if ((OPM_MinInt <= (LONGINT)v && (LONGINT)v <= OPM_MaxInt)) { - node->typ = OPT_inttyp; - } else if ((OPM_MinLInt <= v && v <= OPM_MaxLInt)) { - node->typ = OPT_linttyp; - } else { - OPB_err(203); - node->typ = OPT_sinttyp; - node->conval->intval = 1; - } + node->typ = OPB_IntType(OPB_SignedByteSize(node->conval->intval)); } OPT_Node OPB_NewIntConst (LONGINT intval) @@ -378,16 +429,16 @@ void OPB_Field (OPT_Node *x, OPT_Object y) } } -static struct TypTest__57 { +static struct TypTest__61 { OPT_Node *x; OPT_Object *obj; BOOLEAN *guard; - struct TypTest__57 *lnk; -} *TypTest__57_s; + struct TypTest__61 *lnk; +} *TypTest__61_s; -static void GTT__58 (OPT_Struct t0, OPT_Struct t1); +static void GTT__62 (OPT_Struct t0, OPT_Struct t1); -static void GTT__58 (OPT_Struct t0, OPT_Struct t1) +static void GTT__62 (OPT_Struct t0, OPT_Struct t1) { OPT_Node node = NIL; OPT_Struct t = NIL; @@ -400,54 +451,54 @@ static void GTT__58 (OPT_Struct t0, OPT_Struct t1) t1 = t1->BaseTyp; } if (t1 == t0 || t0->form == 0) { - if (*TypTest__57_s->guard) { - OPB_BindNodes(5, NIL, &*TypTest__57_s->x, NIL); - (*TypTest__57_s->x)->readonly = (*TypTest__57_s->x)->left->readonly; + if (*TypTest__61_s->guard) { + OPB_BindNodes(5, NIL, &*TypTest__61_s->x, NIL); + (*TypTest__61_s->x)->readonly = (*TypTest__61_s->x)->left->readonly; } else { node = OPT_NewNode(11); node->subcl = 16; - node->left = *TypTest__57_s->x; - node->obj = *TypTest__57_s->obj; - *TypTest__57_s->x = node; + node->left = *TypTest__61_s->x; + node->obj = *TypTest__61_s->obj; + *TypTest__61_s->x = node; } } else { OPB_err(85); } } else if (t0 != t1) { OPB_err(85); - } else if (!*TypTest__57_s->guard) { - if ((*TypTest__57_s->x)->class == 5) { + } else if (!*TypTest__61_s->guard) { + if ((*TypTest__61_s->x)->class == 5) { node = OPT_NewNode(11); node->subcl = 16; - node->left = *TypTest__57_s->x; - node->obj = *TypTest__57_s->obj; - *TypTest__57_s->x = node; + node->left = *TypTest__61_s->x; + node->obj = *TypTest__61_s->obj; + *TypTest__61_s->x = node; } else { - *TypTest__57_s->x = OPB_NewBoolConst(1); + *TypTest__61_s->x = OPB_NewBoolConst(1); } } } void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard) { - struct TypTest__57 _s; + struct TypTest__61 _s; _s.x = x; _s.obj = &obj; _s.guard = &guard; - _s.lnk = TypTest__57_s; - TypTest__57_s = &_s; + _s.lnk = TypTest__61_s; + TypTest__61_s = &_s; if (OPB_NotVar(*x)) { OPB_err(112); } else if ((*x)->typ->form == 13) { if (((*x)->typ->BaseTyp->comp != 4 && (*x)->typ != OPT_sysptrtyp)) { OPB_err(85); } else if (obj->typ->form == 13) { - GTT__58((*x)->typ->BaseTyp, obj->typ->BaseTyp); + GTT__62((*x)->typ->BaseTyp, obj->typ->BaseTyp); } else { OPB_err(86); } } else if (((((*x)->typ->comp == 4 && (*x)->class == 1)) && obj->typ->comp == 4)) { - GTT__58((*x)->typ, obj->typ); + GTT__62((*x)->typ, obj->typ); } else { OPB_err(87); } @@ -456,7 +507,7 @@ void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard) } else { (*x)->typ = OPT_booltyp; } - TypTest__57_s = _s.lnk; + TypTest__61_s = _s.lnk; } void OPB_In (OPT_Node *x, OPT_Node y) @@ -469,7 +520,7 @@ void OPB_In (OPT_Node *x, OPT_Node y) } else if ((__IN(f, 0x70) && y->typ->form == 9)) { if ((*x)->class == 7) { k = (*x)->conval->intval; - if (k < 0 || k > (LONGINT)OPM_MaxSet) { + if (k < 0 || k > (int)OPM_MaxSet) { OPB_err(202); } else if (y->class == 7) { (*x)->conval->intval = OPB_BoolToInt(__IN(k, y->conval->setval)); @@ -522,13 +573,13 @@ static void OPB_CheckRealType (INTEGER f, INTEGER nr, OPT_Const x) x->intval = -1; } -static struct MOp__28 { - struct MOp__28 *lnk; -} *MOp__28_s; +static struct MOp__30 { + struct MOp__30 *lnk; +} *MOp__30_s; -static OPT_Node NewOp__29 (SHORTINT op, OPT_Struct typ, OPT_Node z); +static OPT_Node NewOp__31 (SHORTINT op, OPT_Struct typ, OPT_Node z); -static OPT_Node NewOp__29 (SHORTINT op, OPT_Struct typ, OPT_Node z) +static OPT_Node NewOp__31 (SHORTINT op, OPT_Struct typ, OPT_Node z) { OPT_Node _o_result; OPT_Node node = NIL; @@ -545,9 +596,9 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) INTEGER f; OPT_Struct typ = NIL; OPT_Node z = NIL; - struct MOp__28 _s; - _s.lnk = MOp__28_s; - MOp__28_s = &_s; + struct MOp__30 _s; + _s.lnk = MOp__30_s; + MOp__30_s = &_s; z = *x; if (z->class == 8 || z->class == 9) { OPB_err(126); @@ -561,7 +612,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) z->conval->intval = OPB_BoolToInt(!OPB_IntToBool(z->conval->intval)); z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(98); @@ -589,7 +640,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) } z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(97); @@ -610,7 +661,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) } z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(111); @@ -622,7 +673,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) z->conval->intval = (int)__CAP((CHAR)z->conval->intval); z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(111); @@ -635,7 +686,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) z->conval->intval = OPB_BoolToInt(__ODD(z->conval->intval)); z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(111); @@ -648,7 +699,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) f = 10; } if (z->class < 7 || f == 10) { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } else { OPB_err(127); } @@ -657,7 +708,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) case 25: if ((__IN(f, 0x70) && z->class == 7)) { if ((0 <= z->conval->intval && z->conval->intval <= -1)) { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } else { OPB_err(219); } @@ -674,7 +725,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) } } *x = z; - MOp__28_s = _s.lnk; + MOp__30_s = _s.lnk; } static void OPB_CheckPtr (OPT_Node x, OPT_Node y) @@ -865,41 +916,13 @@ static void OPB_ConstOp (INTEGER op, OPT_Node x, OPT_Node y) __GUARDEQP(yval, OPT_ConstDesc) = *xval; } break; - case 4: + case 4: case 5: case 6: if (__IN(g, 0x70)) { - x->typ = y->typ; - } else if (g == 7) { - x->typ = OPT_realtyp; - xval->realval = xval->intval; - } else if (g == 8) { - x->typ = OPT_lrltyp; - xval->realval = xval->intval; - } else { - OPB_err(100); - y->typ = x->typ; - __GUARDEQP(yval, OPT_ConstDesc) = *xval; - } - break; - case 5: - if (g == 4) { - y->typ = OPT_inttyp; - } else if (__IN(g, 0x70)) { - x->typ = y->typ; - } else if (g == 7) { - x->typ = OPT_realtyp; - xval->realval = xval->intval; - } else if (g == 8) { - x->typ = OPT_lrltyp; - xval->realval = xval->intval; - } else { - OPB_err(100); - y->typ = x->typ; - __GUARDEQP(yval, OPT_ConstDesc) = *xval; - } - break; - case 6: - if (__IN(g, 0x70)) { - y->typ = OPT_linttyp; + if (x->typ->size <= y->typ->size) { + x->typ = y->typ; + } else { + x->typ = OPB_IntType(x->typ->size); + } } else if (g == 7) { x->typ = OPT_realtyp; xval->realval = xval->intval; @@ -1178,7 +1201,7 @@ static void OPB_Convert (OPT_Node *x, OPT_Struct typ) OPB_err(203); r = (LONGREAL)1; } - (*x)->conval->intval = __ENTIER(r); + (*x)->conval->intval = (int)__ENTIER(r); OPB_SetIntType(*x); } } @@ -1196,15 +1219,15 @@ static void OPB_Convert (OPT_Node *x, OPT_Struct typ) (*x)->typ = typ; } -static struct Op__38 { +static struct Op__40 { INTEGER *f, *g; - struct Op__38 *lnk; -} *Op__38_s; + struct Op__40 *lnk; +} *Op__40_s; -static void NewOp__39 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y); -static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y); +static void NewOp__41 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y); +static BOOLEAN strings__43 (OPT_Node *x, OPT_Node *y); -static void NewOp__39 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y) +static void NewOp__41 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y) { OPT_Node node = NIL; node = OPT_NewNode(12); @@ -1215,29 +1238,29 @@ static void NewOp__39 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y) *x = node; } -static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y) +static BOOLEAN strings__43 (OPT_Node *x, OPT_Node *y) { BOOLEAN _o_result; BOOLEAN ok, xCharArr, yCharArr; - xCharArr = (__IN((*x)->typ->comp, 0x0c) && (*x)->typ->BaseTyp->form == 3) || *Op__38_s->f == 10; - yCharArr = (__IN((*y)->typ->comp, 0x0c) && (*y)->typ->BaseTyp->form == 3) || *Op__38_s->g == 10; - if ((((xCharArr && *Op__38_s->g == 3)) && (*y)->class == 7)) { + xCharArr = (__IN((*x)->typ->comp, 0x0c) && (*x)->typ->BaseTyp->form == 3) || *Op__40_s->f == 10; + yCharArr = (__IN((*y)->typ->comp, 0x0c) && (*y)->typ->BaseTyp->form == 3) || *Op__40_s->g == 10; + if ((((xCharArr && *Op__40_s->g == 3)) && (*y)->class == 7)) { OPB_CharToString(*y); - *Op__38_s->g = 10; + *Op__40_s->g = 10; yCharArr = 1; } - if ((((yCharArr && *Op__38_s->f == 3)) && (*x)->class == 7)) { + if ((((yCharArr && *Op__40_s->f == 3)) && (*x)->class == 7)) { OPB_CharToString(*x); - *Op__38_s->f = 10; + *Op__40_s->f = 10; xCharArr = 1; } ok = (xCharArr && yCharArr); if (ok) { - if ((*Op__38_s->f == 10 && (*x)->conval->intval2 == 1)) { + if ((*Op__40_s->f == 10 && (*x)->conval->intval2 == 1)) { (*x)->typ = OPT_chartyp; (*x)->conval->intval = 0; OPB_Index(&*y, OPB_NewIntConst(((LONGINT)(0)))); - } else if ((*Op__38_s->g == 10 && (*y)->conval->intval2 == 1)) { + } else if ((*Op__40_s->g == 10 && (*y)->conval->intval2 == 1)) { (*y)->typ = OPT_chartyp; (*y)->conval->intval = 0; OPB_Index(&*x, OPB_NewIntConst(((LONGINT)(0)))); @@ -1254,11 +1277,11 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPT_Struct typ = NIL; BOOLEAN do_; LONGINT val; - struct Op__38 _s; + struct Op__40 _s; _s.f = &f; _s.g = &g; - _s.lnk = Op__38_s; - Op__38_s = &_s; + _s.lnk = Op__40_s; + Op__40_s = &_s; z = *x; if (((z->class == 8 || z->class == 9) || y->class == 8) || y->class == 9) { OPB_err(126); @@ -1276,15 +1299,8 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(100); } break; - case 4: - if (__IN(g, 0x01f0)) { - OPB_Convert(&z, y->typ); - } else { - OPB_err(100); - } - break; - case 5: - if (g == 4) { + case 4: case 5: case 6: + if ((__IN(g, 0x70) && y->typ->size < z->typ->size)) { OPB_Convert(&y, z->typ); } else if (__IN(g, 0x01f0)) { OPB_Convert(&z, y->typ); @@ -1292,15 +1308,6 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(100); } break; - case 6: - if (__IN(g, 0x70)) { - OPB_Convert(&y, z->typ); - } else if (__IN(g, 0x0180)) { - OPB_Convert(&z, y->typ); - } else { - OPB_err(100); - } - break; case 7: if (__IN(g, 0x70)) { OPB_Convert(&y, z->typ); @@ -1386,7 +1393,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) typ = OPT_undftyp; } if (do_) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 2: @@ -1405,7 +1412,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(102); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; case 3: do_ = 1; @@ -1428,7 +1435,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) typ = OPT_undftyp; } if (do_) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 4: @@ -1446,7 +1453,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(104); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; case 5: if (f == 2) { @@ -1456,7 +1463,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } else if ((y->class == 7 && OPB_IntToBool(y->conval->intval))) { } else { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } } else if (f != 0) { OPB_err(94); @@ -1479,7 +1486,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } if (do_) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 7: @@ -1488,7 +1495,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) typ = OPT_undftyp; } if ((!__IN(f, 0x70) || y->class != 7) || y->conval->intval != 0) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 8: @@ -1499,7 +1506,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } else if ((y->class == 7 && !OPB_IntToBool(y->conval->intval))) { } else { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } } else if (f != 0) { OPB_err(95); @@ -1507,16 +1514,16 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } break; case 9: case 10: - if (__IN(f, 0x6bff) || strings__41(&z, &y)) { + if (__IN(f, 0x6bff) || strings__43(&z, &y)) { typ = OPT_booltyp; } else { OPB_err(107); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; case 11: case 12: case 13: case 14: - if (__IN(f, 0x01f9) || strings__41(&z, &y)) { + if (__IN(f, 0x01f9) || strings__43(&z, &y)) { typ = OPT_booltyp; } else { OPM_LogWLn(); @@ -1525,7 +1532,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(108); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; default: OPM_LogWStr((CHAR*)"unhandled case in OPB.Op, op = ", (LONGINT)32); @@ -1535,7 +1542,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } *x = z; - Op__38_s = _s.lnk; + Op__40_s = _s.lnk; } void OPB_SetRange (OPT_Node *x, OPT_Node y) @@ -1546,13 +1553,13 @@ void OPB_SetRange (OPT_Node *x, OPT_Node y) } else if ((__IN((*x)->typ->form, 0x70) && __IN(y->typ->form, 0x70))) { if ((*x)->class == 7) { k = (*x)->conval->intval; - if (0 > k || k > (LONGINT)OPM_MaxSet) { + if (0 > k || k > (int)OPM_MaxSet) { OPB_err(202); } } if (y->class == 7) { l = y->conval->intval; - if (0 > l || l > (LONGINT)OPM_MaxSet) { + if (0 > l || l > (int)OPM_MaxSet) { OPB_err(202); } } @@ -1582,7 +1589,7 @@ void OPB_SetElem (OPT_Node *x) OPB_err(93); } else if ((*x)->class == 7) { k = (*x)->conval->intval; - if ((0 <= k && k <= (LONGINT)OPM_MaxSet)) { + if ((0 <= k && k <= (int)OPM_MaxSet)) { (*x)->conval->setval = __SETOF(k); } else { OPB_err(202); @@ -1596,8 +1603,9 @@ void OPB_SetElem (OPT_Node *x) static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) { + OPT_Struct y = NIL; INTEGER f, g; - OPT_Struct y = NIL, p = NIL, q = NIL; + OPT_Struct p = NIL, q = NIL; if (OPM_Verbose) { OPM_LogWLn(); OPM_LogWStr((CHAR*)"PROCEDURE CheckAssign", (LONGINT)22); @@ -1627,31 +1635,20 @@ static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) case 0: case 10: break; case 1: - if (!__IN(g, 0x1a)) { + if (!((__IN(g, 0x7a) && y->size == 1))) { OPB_err(113); } break; - case 2: case 3: case 4: case 9: + case 2: case 3: case 9: if (g != f) { OPB_err(113); } break; - case 5: - if (!__IN(g, 0x30)) { + case 4: case 5: case 6: + if (!__IN(g, 0x70) || x->size < y->size) { OPB_err(113); } break; - case 6: - if (OPM_LIntSize == 4) { - if (!__IN(g, 0x70)) { - OPB_err(113); - } - } else { - if (!__IN(g, 0x70)) { - OPB_err(113); - } - } - break; case 7: if (!__IN(g, 0xf0)) { OPB_err(113); @@ -1832,14 +1829,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) x = OPB_NewIntConst(((LONGINT)(0))); x->typ = OPT_chartyp; break; - case 4: - x = OPB_NewIntConst(OPM_MinSInt); - break; - case 5: - x = OPB_NewIntConst(OPM_MinInt); - break; - case 6: - x = OPB_NewIntConst(OPM_MinLInt); + case 4: case 5: case 6: + x = OPB_NewIntConst(OPM_SignedMinimum(x->typ->size)); break; case 9: x = OPB_NewIntConst(((LONGINT)(0))); @@ -1869,14 +1860,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) x = OPB_NewIntConst(((LONGINT)(255))); x->typ = OPT_chartyp; break; - case 4: - x = OPB_NewIntConst(OPM_MaxSInt); - break; - case 5: - x = OPB_NewIntConst(OPM_MaxInt); - break; - case 6: - x = OPB_NewIntConst(OPM_MaxLInt); + case 4: case 5: case 6: + x = OPB_NewIntConst(OPM_SignedMaximum(x->typ->size)); break; case 9: x = OPB_NewIntConst(OPM_MaxSet); @@ -1909,10 +1894,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) case 10: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if (f == 5) { - OPB_Convert(&x, OPT_sinttyp); - } else if (f == 6) { - OPB_Convert(&x, OPT_inttyp); + } else if ((__IN(f, 0x70) && x->typ->size > (int)OPM_SIntSize)) { + OPB_Convert(&x, OPB_IntType(OPB_ShorterSize(x->typ->size))); } else if (f == 8) { OPB_Convert(&x, OPT_realtyp); } else { @@ -1922,10 +1905,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) case 11: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if (f == 4) { - OPB_Convert(&x, OPT_inttyp); - } else if (f == 5) { - OPB_Convert(&x, OPT_linttyp); + } else if ((__IN(f, 0x70) && x->typ->size < (int)OPM_LIntSize)) { + OPB_Convert(&x, OPB_IntType(OPB_LongerSize(x->typ->size))); } else if (f == 7) { OPB_Convert(&x, OPT_lrltyp); } else if (f == 3) { @@ -1973,7 +1954,7 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - if (f != 6) { + if (x->typ->size != (int)OPM_LIntSize) { OPB_Convert(&x, OPT_linttyp); } } else { @@ -2011,9 +1992,9 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) case 24: case 25: case 28: case 31: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if ((x->class == 7 && __IN(f, 0x30))) { + } else if ((((x->class == 7 && __IN(f, 0x70))) && x->typ->size < OPT_linttyp->size)) { OPB_Convert(&x, OPT_linttyp); - } else if (!__IN(f, 0x2040)) { + } else if (!((__IN(x->typ->form, 0x2070) && x->typ->size == (int)OPM_PointerSize))) { OPB_err(111); x->typ = OPT_linttyp; } @@ -2062,13 +2043,13 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) *par0 = x; } -static struct StPar1__52 { - struct StPar1__52 *lnk; -} *StPar1__52_s; +static struct StPar1__56 { + struct StPar1__56 *lnk; +} *StPar1__56_s; -static OPT_Node NewOp__53 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right); +static OPT_Node NewOp__57 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right); -static OPT_Node NewOp__53 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right) +static OPT_Node NewOp__57 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right) { OPT_Node _o_result; OPT_Node node = NIL; @@ -2085,9 +2066,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) INTEGER f, L; OPT_Struct typ = NIL; OPT_Node p = NIL, t = NIL; - struct StPar1__52 _s; - _s.lnk = StPar1__52_s; - StPar1__52_s = &_s; + struct StPar1__56 _s; + _s.lnk = StPar1__56_s; + StPar1__56_s = &_s; p = *par0; f = x->typ->form; switch (fctno) { @@ -2103,7 +2084,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) OPB_err(111); } } - p = NewOp__53(19, fctno, p, x); + p = NewOp__57(19, fctno, p, x); p->typ = OPT_notyp; } break; @@ -2111,10 +2092,10 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - if ((x->class == 7 && (0 > x->conval->intval || x->conval->intval > (LONGINT)OPM_MaxSet))) { + if ((x->class == 7 && (0 > x->conval->intval || x->conval->intval > (int)OPM_MaxSet))) { OPB_err(202); } - p = NewOp__53(19, fctno, p, x); + p = NewOp__57(19, fctno, p, x); } else { OPB_err(111); } @@ -2123,7 +2104,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) case 17: if (!__IN(f, 0x70) || x->class != 7) { OPB_err(69); - } else if (f == 4) { + } else if (x->typ->size == 1) { L = (int)x->conval->intval; typ = p->typ; while ((L > 0 && __IN(typ->comp, 0x0c))) { @@ -2139,7 +2120,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) p = p->left; x->conval->intval += 1; } - p = NewOp__53(12, 19, p, x); + p = NewOp__57(12, 19, p, x); p->typ = OPT_linttyp; } else { p = x; @@ -2161,7 +2142,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) t = x; x = p; p = t; - p = NewOp__53(19, 18, p, x); + p = NewOp__57(19, 18, p, x); } else { OPB_err(111); } @@ -2187,7 +2168,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) } p->obj = NIL; } else { - p = NewOp__53(12, 17, p, x); + p = NewOp__57(12, 17, p, x); p->typ = OPT_linttyp; } } else { @@ -2218,9 +2199,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) OPB_err(111); } else { if (fctno == 22) { - p = NewOp__53(12, 27, p, x); + p = NewOp__57(12, 27, p, x); } else { - p = NewOp__53(12, 28, p, x); + p = NewOp__57(12, 28, p, x); } p->typ = p->left->typ; } @@ -2237,7 +2218,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) x = p; p = t; } - p = NewOp__53(19, fctno, p, x); + p = NewOp__57(19, fctno, p, x); } else { OPB_err(111); } @@ -2247,7 +2228,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - p = NewOp__53(12, 26, p, x); + p = NewOp__57(12, 26, p, x); } else { OPB_err(111); } @@ -2257,6 +2238,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (((x->class == 8 || x->class == 9) || __IN(f, 0x1401)) || x->typ->comp == 3) { OPB_err(126); } + if (x->typ->size < p->typ->size) { + OPB_err(-308); + } t = OPT_NewNode(11); t->subcl = 29; t->left = x; @@ -2268,7 +2252,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - p = NewOp__53(19, 30, p, x); + p = NewOp__57(19, 30, p, x); } else { OPB_err(111); } @@ -2277,9 +2261,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) case 31: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if ((x->class == 7 && __IN(f, 0x30))) { + } else if ((((x->class == 7 && __IN(f, 0x70))) && x->typ->size < OPT_linttyp->size)) { OPB_Convert(&x, OPT_linttyp); - } else if (!__IN(f, 0x2040)) { + } else if (!((__IN(x->typ->form, 0x2070) && x->typ->size == (int)OPM_PointerSize))) { OPB_err(111); x->typ = OPT_linttyp; } @@ -2314,7 +2298,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) break; } *par0 = p; - StPar1__52_s = _s.lnk; + StPar1__56_s = _s.lnk; } void OPB_StParN (OPT_Node *par0, OPT_Node x, INTEGER fctno, INTEGER n) @@ -2433,7 +2417,7 @@ static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpa ftyp = ftyp->BaseTyp; atyp = atyp->BaseTyp; if ((fvarpar && ftyp == OPT_bytetyp)) { - if (!__IN(f, 0x0c) || !__IN(atyp->form, 0x1e)) { + if (!__IN(f, 0x0c) || !((__IN(atyp->form, 0x7e) && atyp->size == 1))) { if (__IN(18, OPM_opt)) { OPB_err(-301); } @@ -2516,7 +2500,7 @@ void OPB_Param (OPT_Node ap, OPT_Object fp) OPB_err(111); } } else if ((fp->typ == OPT_sysptrtyp && ap->typ->form == 13)) { - } else if ((ap->typ != fp->typ && !((fp->typ->form == 1 && __IN(ap->typ->form, 0x18))))) { + } else if ((ap->typ != fp->typ && !((fp->typ->form == 1 && ((__IN(ap->typ->form, 0x7e) && ap->typ->size == 1)))))) { OPB_err(123); } else if ((fp->typ->form == 13 && ap->class == 5)) { OPB_err(123); diff --git a/bootstrap/windows-48/OPB.h b/bootstrap/windows-48/OPB.h index 4c37f01f..d1c88266 100644 --- a/bootstrap/windows-48/OPB.h +++ b/bootstrap/windows-48/OPB.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPB__h #define OPB__h diff --git a/bootstrap/windows-48/OPC.c b/bootstrap/windows-48/OPC.c index 417337c0..3abccc9a 100644 --- a/bootstrap/windows-48/OPC.c +++ b/bootstrap/windows-48/OPC.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Configuration.h" #include "OPM.h" @@ -16,12 +16,13 @@ static CHAR OPC_BodyNameExt[13]; export void OPC_Align (LONGINT *adr, LONGINT base); export void OPC_Andent (OPT_Struct typ); static void OPC_AnsiParamList (OPT_Object obj, BOOLEAN showParamNames); -export LONGINT OPC_Base (OPT_Struct typ); +export LONGINT OPC_BaseAlignment (OPT_Struct typ); export OPT_Object OPC_BaseTProc (OPT_Object obj); export void OPC_BegBlk (void); export void OPC_BegStat (void); static void OPC_CProcDefs (OPT_Object obj, INTEGER vis); export void OPC_Case (LONGINT caseVal, INTEGER form); +static void OPC_CharacterLiteral (LONGINT c); export void OPC_Cmp (INTEGER rel); export void OPC_CompleteIdent (OPT_Object obj); export void OPC_Constant (OPT_Const con, INTEGER form); @@ -73,8 +74,10 @@ static void OPC_PutBase (OPT_Struct typ); static void OPC_PutPtrOffsets (OPT_Struct typ, LONGINT adr, LONGINT *cnt); static void OPC_RegCmds (OPT_Object obj); export void OPC_SetInclude (BOOLEAN exclude); +export LONGINT OPC_SizeAlignment (LONGINT size); static void OPC_Stars (OPT_Struct typ, BOOLEAN *openClause); static void OPC_Str1 (CHAR *s, LONGINT s__len, LONGINT x); +static void OPC_StringLiteral (CHAR *s, LONGINT s__len, LONGINT l); export void OPC_TDescDecl (OPT_Struct typ); export void OPC_TypeDefs (OPT_Object obj, INTEGER vis); export void OPC_TypeOf (OPT_Object ap); @@ -315,7 +318,7 @@ void OPC_Andent (OPT_Struct typ) static BOOLEAN OPC_Undefined (OPT_Object obj) { BOOLEAN _o_result; - _o_result = (((obj->mnolev >= 0 && obj->linkadr != (LONGINT)(3 + OPM_currFile))) && obj->linkadr != 2) || obj->name[0] == 0x00; + _o_result = obj->name[0] == 0x00 || (((obj->mnolev >= 0 && obj->linkadr != (int)(3 + OPM_currFile))) && obj->linkadr != 2); return _o_result; } @@ -815,14 +818,15 @@ void OPC_TDescDecl (OPT_Struct typ) OPC_Andent(typ); OPC_Str1((CHAR*)", #", (LONGINT)4, typ->n + 1); OPC_Str1((CHAR*)", #) = {__TDFLDS(", (LONGINT)18, OPC_NofPtrs(typ)); - OPM_Write('\"'); + OPM_Write('"'); if (typ->strobj != NIL) { OPM_WriteStringVar((void*)typ->strobj->name, ((LONGINT)(256))); } - OPC_Str1((CHAR*)"\", #), {", (LONGINT)9, typ->size); + OPM_Write('"'); + OPC_Str1((CHAR*)", #), {", (LONGINT)8, typ->size); nofptrs = 0; OPC_PutPtrOffsets(typ, ((LONGINT)(0)), &nofptrs); - OPC_Str1((CHAR*)"#}}", (LONGINT)4, -((nofptrs + 1) * (LONGINT)OPM_LIntSize)); + OPC_Str1((CHAR*)"#}}", (LONGINT)4, -((nofptrs + 1) * (int)OPM_LIntSize)); OPC_EndStat(); } @@ -864,70 +868,37 @@ void OPC_Align (LONGINT *adr, LONGINT base) } } -LONGINT OPC_Base (OPT_Struct typ) +LONGINT OPC_SizeAlignment (LONGINT size) { LONGINT _o_result; - switch (typ->form) { - case 1: - _o_result = 1; - return _o_result; - break; - case 3: - _o_result = OPM_CharAlign; - return _o_result; - break; - case 2: - _o_result = OPM_BoolAlign; - return _o_result; - break; - case 4: - _o_result = OPM_SIntAlign; - return _o_result; - break; - case 5: - _o_result = OPM_IntAlign; - return _o_result; - break; - case 6: - _o_result = OPM_LIntAlign; - return _o_result; - break; - case 7: - _o_result = OPM_RealAlign; - return _o_result; - break; - case 8: - _o_result = OPM_LRealAlign; - return _o_result; - break; - case 9: - _o_result = OPM_SetAlign; - return _o_result; - break; - case 13: - _o_result = OPM_PointerAlign; - return _o_result; - break; - case 14: - _o_result = OPM_ProcAlign; - return _o_result; - break; - case 15: - if (typ->comp == 4) { - _o_result = __MASK(typ->align, -65536); - return _o_result; - } else { - _o_result = OPC_Base(typ->BaseTyp); - return _o_result; - } - break; - default: - OPM_LogWStr((CHAR*)"unhandled case in OPC.Base, typ^form = ", (LONGINT)40); - OPM_LogWNum(typ->form, ((LONGINT)(0))); - OPM_LogWLn(); - break; + LONGINT alignment; + if (size < (int)OPM_Alignment) { + alignment = 1; + while (alignment < size) { + alignment = __ASHL(alignment, 1); + } + } else { + alignment = OPM_Alignment; } - __RETCHK; + _o_result = alignment; + return _o_result; +} + +LONGINT OPC_BaseAlignment (OPT_Struct typ) +{ + LONGINT _o_result; + LONGINT alignment; + if (typ->form == 15) { + if (typ->comp == 4) { + alignment = __MASK(typ->align, -65536); + } else { + alignment = OPC_BaseAlignment(typ->BaseTyp); + } + } else { + alignment = OPC_SizeAlignment(typ->size); + } + _o_result = alignment; + return _o_result; } static void OPC_FillGap (LONGINT gap, LONGINT off, LONGINT align, LONGINT *n, LONGINT *curAlign) @@ -938,11 +909,11 @@ static void OPC_FillGap (LONGINT gap, LONGINT off, LONGINT align, LONGINT *n, LO if ((*curAlign < align && gap - (adr - off) >= align)) { gap -= (adr - off) + align; OPC_BegStat(); - if (align == (LONGINT)OPM_IntSize) { + if (align == (int)OPM_IntSize) { OPM_WriteString((CHAR*)"INTEGER", (LONGINT)8); - } else if (align == (LONGINT)OPM_LIntSize) { + } else if (align == (int)OPM_LIntSize) { OPM_WriteString((CHAR*)"LONGINT", (LONGINT)8); - } else if (align == (LONGINT)OPM_LRealSize) { + } else if (align == (int)OPM_LRealSize) { OPM_WriteString((CHAR*)"LONGREAL", (LONGINT)9); } OPC_Str1((CHAR*)" _prvt#", (LONGINT)8, *n); @@ -981,7 +952,7 @@ static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, LONGINT *off, LONGINT * } } else { adr = *off; - fldAlign = OPC_Base(fld->typ); + fldAlign = OPC_BaseAlignment(fld->typ); OPC_Align(&adr, fldAlign); gap = fld->adr - adr; if (fldAlign > *curAlign) { @@ -1007,7 +978,7 @@ static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, LONGINT *off, LONGINT * } } if (last) { - adr = typ->size - (LONGINT)__ASHR(typ->sysflag, 8); + adr = typ->size - (int)__ASHR(typ->sysflag, 8); if (adr == 0) { gap = 1; } else { @@ -1170,10 +1141,10 @@ static void OPC_Include (CHAR *name, LONGINT name__len) { __DUP(name, name__len, CHAR); OPM_WriteString((CHAR*)"#include ", (LONGINT)10); - OPM_Write('\"'); + OPM_Write('"'); OPM_WriteStringVar((void*)name, name__len); OPM_WriteString((CHAR*)".h", (LONGINT)3); - OPM_Write('\"'); + OPM_Write('"'); OPM_WriteLn(); __DEL(name); } @@ -1238,8 +1209,8 @@ void OPC_GenHdr (OPT_Node n) static void OPC_GenHeaderMsg (void) { INTEGER i; - OPM_WriteString((CHAR*)"/*", (LONGINT)3); - OPM_WriteString((CHAR*)" voc ", (LONGINT)6); + OPM_WriteString((CHAR*)"/* ", (LONGINT)4); + OPM_WriteString((CHAR*)"voc", (LONGINT)4); OPM_Write(' '); OPM_WriteString(Configuration_versionLong, ((LONGINT)(41))); OPM_Write(' '); @@ -1855,26 +1826,56 @@ void OPC_Cmp (INTEGER rel) } } +static void OPC_CharacterLiteral (LONGINT c) +{ + if (c < 32 || c > 126) { + OPM_WriteString((CHAR*)"0x", (LONGINT)3); + OPM_WriteHex(c); + } else { + OPM_Write('\''); + if ((c == 92 || c == 39) || c == 63) { + OPM_Write('\\'); + } + OPM_Write((CHAR)c); + OPM_Write('\''); + } +} + +static void OPC_StringLiteral (CHAR *s, LONGINT s__len, LONGINT l) +{ + LONGINT i; + INTEGER c; + __DUP(s, s__len, CHAR); + OPM_Write('"'); + i = 0; + while (i < l) { + c = (int)s[__X(i, s__len)]; + if (c < 32 || c > 126) { + OPM_Write('\\'); + OPM_Write((CHAR)(48 + __ASHR(c, 6))); + c = __MASK(c, -64); + OPM_Write((CHAR)(48 + __ASHR(c, 3))); + c = __MASK(c, -8); + OPM_Write((CHAR)(48 + c)); + } else { + if ((c == 92 || c == 34) || c == 63) { + OPM_Write('\\'); + } + OPM_Write((CHAR)c); + } + i += 1; + } + OPM_Write('"'); + __DEL(s); +} + void OPC_Case (LONGINT caseVal, INTEGER form) { CHAR ch; OPM_WriteString((CHAR*)"case ", (LONGINT)6); switch (form) { case 3: - ch = (CHAR)caseVal; - if ((ch >= ' ' && ch <= '~')) { - OPM_Write('\''); - if (((ch == '\\' || ch == '\?') || ch == '\'') || ch == '\"') { - OPM_Write('\\'); - OPM_Write(ch); - } else { - OPM_Write(ch); - } - OPM_Write('\''); - } else { - OPM_WriteString((CHAR*)"0x", (LONGINT)3); - OPM_WriteHex(caseVal); - } + OPC_CharacterLiteral(caseVal); break; case 4: case 5: case 6: OPM_WriteInt(caseVal); @@ -1932,8 +1933,7 @@ void OPC_Len (OPT_Object obj, OPT_Struct array, LONGINT dim) void OPC_Constant (OPT_Const con, INTEGER form) { - INTEGER i, len; - CHAR ch; + INTEGER i; SET s; LONGINT hex; BOOLEAN skipLeading; @@ -1945,18 +1945,7 @@ void OPC_Constant (OPT_Const con, INTEGER form) OPM_WriteInt(con->intval); break; case 3: - ch = (CHAR)con->intval; - if ((ch >= ' ' && ch <= '~')) { - OPM_Write('\''); - if (((ch == '\\' || ch == '\?') || ch == '\'') || ch == '\"') { - OPM_Write('\\'); - } - OPM_Write(ch); - OPM_Write('\''); - } else { - OPM_WriteString((CHAR*)"0x", (LONGINT)3); - OPM_WriteHex(con->intval); - } + OPC_CharacterLiteral(con->intval); break; case 4: case 5: case 6: OPM_WriteInt(con->intval); @@ -1991,18 +1980,7 @@ void OPC_Constant (OPT_Const con, INTEGER form) } break; case 10: - OPM_Write('\"'); - len = (int)con->intval2 - 1; - i = 0; - while (i < len) { - ch = (*con->ext)[__X(i, ((LONGINT)(256)))]; - if (((ch == '\\' || ch == '\?') || ch == '\'') || ch == '\"') { - OPM_Write('\\'); - } - OPM_Write(ch); - i += 1; - } - OPM_Write('\"'); + OPC_StringLiteral(*con->ext, ((LONGINT)(256)), con->intval2 - 1); break; case 11: OPM_WriteString((CHAR*)"NIL", (LONGINT)4); @@ -2015,74 +1993,74 @@ void OPC_Constant (OPT_Const con, INTEGER form) } } -static struct InitKeywords__47 { +static struct InitKeywords__48 { SHORTINT *n; - struct InitKeywords__47 *lnk; -} *InitKeywords__47_s; + struct InitKeywords__48 *lnk; +} *InitKeywords__48_s; -static void Enter__48 (CHAR *s, LONGINT s__len); +static void Enter__49 (CHAR *s, LONGINT s__len); -static void Enter__48 (CHAR *s, LONGINT s__len) +static void Enter__49 (CHAR *s, LONGINT s__len) { INTEGER h; __DUP(s, s__len, CHAR); h = OPC_PerfectHash((void*)s, s__len); - OPC_hashtab[__X(h, ((LONGINT)(105)))] = *InitKeywords__47_s->n; - __COPY(s, OPC_keytab[__X(*InitKeywords__47_s->n, ((LONGINT)(36)))], ((LONGINT)(9))); - *InitKeywords__47_s->n += 1; + OPC_hashtab[__X(h, ((LONGINT)(105)))] = *InitKeywords__48_s->n; + __COPY(s, OPC_keytab[__X(*InitKeywords__48_s->n, ((LONGINT)(36)))], ((LONGINT)(9))); + *InitKeywords__48_s->n += 1; __DEL(s); } static void OPC_InitKeywords (void) { SHORTINT n, i; - struct InitKeywords__47 _s; + struct InitKeywords__48 _s; _s.n = &n; - _s.lnk = InitKeywords__47_s; - InitKeywords__47_s = &_s; + _s.lnk = InitKeywords__48_s; + InitKeywords__48_s = &_s; n = 0; i = 0; while (i <= 104) { OPC_hashtab[__X(i, ((LONGINT)(105)))] = -1; i += 1; } - Enter__48((CHAR*)"asm", (LONGINT)4); - Enter__48((CHAR*)"auto", (LONGINT)5); - Enter__48((CHAR*)"break", (LONGINT)6); - Enter__48((CHAR*)"case", (LONGINT)5); - Enter__48((CHAR*)"char", (LONGINT)5); - Enter__48((CHAR*)"const", (LONGINT)6); - Enter__48((CHAR*)"continue", (LONGINT)9); - Enter__48((CHAR*)"default", (LONGINT)8); - Enter__48((CHAR*)"do", (LONGINT)3); - Enter__48((CHAR*)"double", (LONGINT)7); - Enter__48((CHAR*)"else", (LONGINT)5); - Enter__48((CHAR*)"enum", (LONGINT)5); - Enter__48((CHAR*)"extern", (LONGINT)7); - Enter__48((CHAR*)"export", (LONGINT)7); - Enter__48((CHAR*)"float", (LONGINT)6); - Enter__48((CHAR*)"for", (LONGINT)4); - Enter__48((CHAR*)"fortran", (LONGINT)8); - Enter__48((CHAR*)"goto", (LONGINT)5); - Enter__48((CHAR*)"if", (LONGINT)3); - Enter__48((CHAR*)"import", (LONGINT)7); - Enter__48((CHAR*)"int", (LONGINT)4); - Enter__48((CHAR*)"long", (LONGINT)5); - Enter__48((CHAR*)"register", (LONGINT)9); - Enter__48((CHAR*)"return", (LONGINT)7); - Enter__48((CHAR*)"short", (LONGINT)6); - Enter__48((CHAR*)"signed", (LONGINT)7); - Enter__48((CHAR*)"sizeof", (LONGINT)7); - Enter__48((CHAR*)"static", (LONGINT)7); - Enter__48((CHAR*)"struct", (LONGINT)7); - Enter__48((CHAR*)"switch", (LONGINT)7); - Enter__48((CHAR*)"typedef", (LONGINT)8); - Enter__48((CHAR*)"union", (LONGINT)6); - Enter__48((CHAR*)"unsigned", (LONGINT)9); - Enter__48((CHAR*)"void", (LONGINT)5); - Enter__48((CHAR*)"volatile", (LONGINT)9); - Enter__48((CHAR*)"while", (LONGINT)6); - InitKeywords__47_s = _s.lnk; + Enter__49((CHAR*)"asm", (LONGINT)4); + Enter__49((CHAR*)"auto", (LONGINT)5); + Enter__49((CHAR*)"break", (LONGINT)6); + Enter__49((CHAR*)"case", (LONGINT)5); + Enter__49((CHAR*)"char", (LONGINT)5); + Enter__49((CHAR*)"const", (LONGINT)6); + Enter__49((CHAR*)"continue", (LONGINT)9); + Enter__49((CHAR*)"default", (LONGINT)8); + Enter__49((CHAR*)"do", (LONGINT)3); + Enter__49((CHAR*)"double", (LONGINT)7); + Enter__49((CHAR*)"else", (LONGINT)5); + Enter__49((CHAR*)"enum", (LONGINT)5); + Enter__49((CHAR*)"extern", (LONGINT)7); + Enter__49((CHAR*)"export", (LONGINT)7); + Enter__49((CHAR*)"float", (LONGINT)6); + Enter__49((CHAR*)"for", (LONGINT)4); + Enter__49((CHAR*)"fortran", (LONGINT)8); + Enter__49((CHAR*)"goto", (LONGINT)5); + Enter__49((CHAR*)"if", (LONGINT)3); + Enter__49((CHAR*)"import", (LONGINT)7); + Enter__49((CHAR*)"int", (LONGINT)4); + Enter__49((CHAR*)"long", (LONGINT)5); + Enter__49((CHAR*)"register", (LONGINT)9); + Enter__49((CHAR*)"return", (LONGINT)7); + Enter__49((CHAR*)"short", (LONGINT)6); + Enter__49((CHAR*)"signed", (LONGINT)7); + Enter__49((CHAR*)"sizeof", (LONGINT)7); + Enter__49((CHAR*)"static", (LONGINT)7); + Enter__49((CHAR*)"struct", (LONGINT)7); + Enter__49((CHAR*)"switch", (LONGINT)7); + Enter__49((CHAR*)"typedef", (LONGINT)8); + Enter__49((CHAR*)"union", (LONGINT)6); + Enter__49((CHAR*)"unsigned", (LONGINT)9); + Enter__49((CHAR*)"void", (LONGINT)5); + Enter__49((CHAR*)"volatile", (LONGINT)9); + Enter__49((CHAR*)"while", (LONGINT)6); + InitKeywords__48_s = _s.lnk; } diff --git a/bootstrap/windows-48/OPC.h b/bootstrap/windows-48/OPC.h index 52ed8dab..b7d34a07 100644 --- a/bootstrap/windows-48/OPC.h +++ b/bootstrap/windows-48/OPC.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPC__h #define OPC__h @@ -11,7 +11,7 @@ import void OPC_Align (LONGINT *adr, LONGINT base); import void OPC_Andent (OPT_Struct typ); -import LONGINT OPC_Base (OPT_Struct typ); +import LONGINT OPC_BaseAlignment (OPT_Struct typ); import OPT_Object OPC_BaseTProc (OPT_Object obj); import void OPC_BegBlk (void); import void OPC_BegStat (void); @@ -40,6 +40,7 @@ import void OPC_InitTDesc (OPT_Struct typ); import void OPC_Len (OPT_Object obj, OPT_Struct array, LONGINT dim); import LONGINT OPC_NofPtrs (OPT_Struct typ); import void OPC_SetInclude (BOOLEAN exclude); +import LONGINT OPC_SizeAlignment (LONGINT size); import void OPC_TDescDecl (OPT_Struct typ); import void OPC_TypeDefs (OPT_Object obj, INTEGER vis); import void OPC_TypeOf (OPT_Object ap); diff --git a/bootstrap/windows-48/OPM.c b/bootstrap/windows-48/OPM.c index 8e5add20..bf683e41 100644 --- a/bootstrap/windows-48/OPM.c +++ b/bootstrap/windows-48/OPM.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Configuration.h" #include "Console.h" @@ -14,8 +14,8 @@ typedef static CHAR OPM_SourceFileName[256]; -export INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_CharAlign, OPM_BoolAlign, OPM_SIntAlign, OPM_IntAlign, OPM_LIntAlign, OPM_SetAlign, OPM_RealAlign, OPM_LRealAlign, OPM_PointerAlign, OPM_ProcAlign, OPM_RecAlign, OPM_MaxSet; -export LONGINT OPM_MinSInt, OPM_MinInt, OPM_MinLInt, OPM_MaxSInt, OPM_MaxInt, OPM_MaxLInt, OPM_MaxIndex; +export INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_MaxSet; +export LONGINT OPM_MaxIndex; export LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; export BOOLEAN OPM_noerr; export LONGINT OPM_curpos, OPM_errpos, OPM_breakpc; @@ -57,7 +57,6 @@ export void OPM_LogWNum (LONGINT i, LONGINT len); export void OPM_LogWStr (CHAR *s, LONGINT s__len); static void OPM_MakeFileName (CHAR *name, LONGINT name__len, CHAR *FName, LONGINT FName__len, CHAR *ext, LONGINT ext__len); export void OPM_Mark (INTEGER n, LONGINT pos); -static INTEGER OPM_Min (INTEGER a, INTEGER b); export void OPM_NewSym (CHAR *modName, LONGINT modName__len); export void OPM_OldSym (CHAR *modName, LONGINT modName__len, BOOLEAN *done); export void OPM_OpenFiles (CHAR *moduleName, LONGINT moduleName__len); @@ -65,6 +64,8 @@ export BOOLEAN OPM_OpenPar (void); export void OPM_RegisterNewSym (void); static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt); static void OPM_ShowLine (LONGINT pos); +export LONGINT OPM_SignedMaximum (LONGINT bytecount); +export LONGINT OPM_SignedMinimum (LONGINT bytecount); export void OPM_SymRCh (CHAR *ch); export LONGINT OPM_SymRInt (void); export void OPM_SymRLReal (LONGREAL *lr); @@ -85,7 +86,7 @@ export void OPM_WriteString (CHAR *s, LONGINT s__len); export void OPM_WriteStringVar (CHAR *s, LONGINT s__len); export BOOLEAN OPM_eofSF (void); export void OPM_err (INTEGER n); -static LONGINT OPM_minus (LONGINT i); +static LONGINT OPM_minusop (LONGINT i); static LONGINT OPM_power0 (LONGINT i, LONGINT j); @@ -117,50 +118,38 @@ static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) i = 1; while (s[__X(i, s__len)] != 0x00) { switch (s[__X(i, s__len)]) { - case 'e': - *opt = *opt ^ 0x0200; - break; - case 's': - *opt = *opt ^ 0x10; - break; - case 'm': - *opt = *opt ^ 0x0400; - break; - case 'x': - *opt = *opt ^ 0x01; - break; - case 'r': - *opt = *opt ^ 0x04; - break; - case 't': - *opt = *opt ^ 0x08; - break; case 'a': *opt = *opt ^ 0x80; break; - case 'k': - *opt = *opt ^ 0x40; - break; - case 'p': - *opt = *opt ^ 0x20; - break; - case 'S': - *opt = *opt ^ 0x2000; - break; case 'c': *opt = *opt ^ 0x4000; break; - case 'M': - *opt = *opt ^ 0x8000; + case 'e': + *opt = *opt ^ 0x0200; break; case 'f': *opt = *opt ^ 0x010000; break; - case 'F': - *opt = *opt ^ 0x020000; + case 'k': + *opt = *opt ^ 0x40; break; - case 'V': - *opt = *opt ^ 0x040000; + case 'm': + *opt = *opt ^ 0x0400; + break; + case 'p': + *opt = *opt ^ 0x20; + break; + case 'r': + *opt = *opt ^ 0x04; + break; + case 's': + *opt = *opt ^ 0x10; + break; + case 't': + *opt = *opt ^ 0x08; + break; + case 'x': + *opt = *opt ^ 0x01; break; case 'B': if (s[__X(i + 1, s__len)] != 0x00) { @@ -178,6 +167,19 @@ static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) __ASSERT(OPM_IntSize == 2 || OPM_IntSize == 4, 0); __ASSERT(OPM_PointerSize == 4 || OPM_PointerSize == 8, 0); __ASSERT(OPM_Alignment == 4 || OPM_Alignment == 8, 0); + Files_SetSearchPath((CHAR*)"", (LONGINT)1); + break; + case 'F': + *opt = *opt ^ 0x020000; + break; + case 'M': + *opt = *opt ^ 0x8000; + break; + case 'S': + *opt = *opt ^ 0x2000; + break; + case 'V': + *opt = *opt ^ 0x040000; break; default: OPM_LogWStr((CHAR*)" warning: option ", (LONGINT)19); @@ -227,17 +229,17 @@ BOOLEAN OPM_OpenPar (void) OPM_LogWLn(); OPM_LogWStr((CHAR*)" x - turn off array indices check", (LONGINT)35); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" a - don\'t check ASSERTs at runtime, use this option in tested production code", (LONGINT)80); + OPM_LogWStr((CHAR*)" a - don't check ASSERTs at runtime, use this option in tested production code", (LONGINT)80); OPM_LogWLn(); OPM_LogWStr((CHAR*)" p - turn off automatic pointer initialization", (LONGINT)48); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" t - don\'t check type guards (use in rare cases such as low-level modules where every cycle counts)", (LONGINT)101); + OPM_LogWStr((CHAR*)" t - don't check type guards (use in rare cases such as low-level modules where every cycle counts)", (LONGINT)101); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" S - don\'t call external assembler/compiler, only generate C code", (LONGINT)67); + OPM_LogWStr((CHAR*)" S - don't call external assembler/compiler, only generate C code", (LONGINT)67); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" c - don\'t call linker", (LONGINT)24); + OPM_LogWStr((CHAR*)" c - don't call linker", (LONGINT)24); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" f - don\'t use color output", (LONGINT)29); + OPM_LogWStr((CHAR*)" f - don't use color output", (LONGINT)29); OPM_LogWLn(); OPM_LogWStr((CHAR*)" F - force writing new symbol file in current directory", (LONGINT)57); OPM_LogWLn(); @@ -540,14 +542,17 @@ void OPM_FPrintSet (LONGINT *fp, SET set) void OPM_FPrintReal (LONGINT *fp, REAL real) { - OPM_FPrint(&*fp, __VAL(LONGINT, real)); + INTEGER i; + LONGINT l; + __GET((LONGINT)(SYSTEM_ADDRESS)&real, l, LONGINT); + OPM_FPrint(&*fp, l); } void OPM_FPrintLReal (LONGINT *fp, LONGREAL lr) { LONGINT l, h; - __GET((LONGINT)(uintptr_t)&lr, l, LONGINT); - __GET((LONGINT)(uintptr_t)&lr + 4, h, LONGINT); + __GET((LONGINT)(SYSTEM_ADDRESS)&lr, l, LONGINT); + __GET((LONGINT)(SYSTEM_ADDRESS)&lr + 4, h, LONGINT); OPM_FPrint(&*fp, l); OPM_FPrint(&*fp, h); } @@ -575,7 +580,7 @@ static void OPM_GetProperty (Texts_Scanner *S, LONGINT *S__typ, CHAR *name, LONG __DEL(name); } -static LONGINT OPM_minus (LONGINT i) +static LONGINT OPM_minusop (LONGINT i) { LONGINT _o_result; _o_result = -i; @@ -603,103 +608,62 @@ static void OPM_VerboseListSizes (void) OPM_LogWLn(); OPM_LogWStr((CHAR*)"CHAR ", (LONGINT)14); OPM_LogWNum(OPM_CharSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_CharAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"BOOLEAN ", (LONGINT)14); OPM_LogWNum(OPM_BoolSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_BoolAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"SHORTINT ", (LONGINT)14); OPM_LogWNum(OPM_SIntSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_SIntAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"INTEGER ", (LONGINT)14); OPM_LogWNum(OPM_IntSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_IntAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"LONGINT ", (LONGINT)14); OPM_LogWNum(OPM_LIntSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_LIntAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"SET ", (LONGINT)14); OPM_LogWNum(OPM_SetSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_SetAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"REAL ", (LONGINT)14); OPM_LogWNum(OPM_RealSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_RealAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"LONGREAL ", (LONGINT)14); OPM_LogWNum(OPM_LRealSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_LRealAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"PTR ", (LONGINT)14); OPM_LogWNum(OPM_PointerSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_PointerAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"PROC ", (LONGINT)14); OPM_LogWNum(OPM_ProcSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_ProcAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"RECORD ", (LONGINT)14); OPM_LogWNum(OPM_RecSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_RecAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Min shortint ", (LONGINT)14); - OPM_LogWNum(OPM_MinSInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Max shortint ", (LONGINT)14); - OPM_LogWNum(OPM_MaxSInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Min integer ", (LONGINT)14); - OPM_LogWNum(OPM_MinInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Max integer ", (LONGINT)14); - OPM_LogWNum(OPM_MaxInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Min longint ", (LONGINT)14); - OPM_LogWNum(OPM_MinLInt, ((LONGINT)(4))); - OPM_LogWLn(); } -static INTEGER OPM_Min (INTEGER a, INTEGER b) +LONGINT OPM_SignedMaximum (LONGINT bytecount) { - INTEGER _o_result; - if (a < b) { - _o_result = a; - return _o_result; - } else { - _o_result = b; - return _o_result; - } - __RETCHK; + LONGINT _o_result; + LONGINT result; + result = 1; + result = __LSH(result, __ASHL(bytecount, 3) - 1, LONGINT); + _o_result = result - 1; + return _o_result; +} + +LONGINT OPM_SignedMinimum (LONGINT bytecount) +{ + LONGINT _o_result; + _o_result = -OPM_SignedMaximum(bytecount) - 1; + return _o_result; } static void OPM_GetProperties (void) { - LONGINT base; OPM_ProcSize = OPM_PointerSize; OPM_LIntSize = __ASHL(OPM_IntSize, 1); OPM_SetSize = OPM_LIntSize; - OPM_CharAlign = OPM_Min(OPM_Alignment, OPM_CharSize); - OPM_BoolAlign = OPM_Min(OPM_Alignment, OPM_BoolSize); - OPM_SIntAlign = OPM_Min(OPM_Alignment, OPM_SIntSize); - OPM_RecAlign = OPM_Min(OPM_Alignment, OPM_RecSize); - OPM_RealAlign = OPM_Min(OPM_Alignment, OPM_RealSize); - OPM_LRealAlign = OPM_Min(OPM_Alignment, OPM_LRealSize); - OPM_PointerAlign = OPM_Min(OPM_Alignment, OPM_PointerSize); - OPM_ProcAlign = OPM_Min(OPM_Alignment, OPM_ProcSize); - OPM_IntAlign = OPM_Min(OPM_Alignment, OPM_IntSize); - OPM_LIntAlign = OPM_Min(OPM_Alignment, OPM_LIntSize); - OPM_SetAlign = OPM_Min(OPM_Alignment, OPM_SetSize); - base = -2; - OPM_MinSInt = __ASH(base, __ASHL(OPM_SIntSize, 3) - 2); - OPM_MaxSInt = OPM_minus(OPM_MinSInt + 1); - OPM_MinInt = __ASH(base, __ASHL(OPM_IntSize, 3) - 2); - OPM_MaxInt = OPM_minus(OPM_MinInt + 1); - OPM_MinLInt = __ASH(base, __ASHL(OPM_LIntSize, 3) - 2); - OPM_MaxLInt = OPM_minus(OPM_MinLInt + 1); if (OPM_RealSize == 4) { OPM_MaxReal = 3.40282346000000e+038; } else if (OPM_RealSize == 8) { @@ -713,7 +677,7 @@ static void OPM_GetProperties (void) OPM_MinReal = -OPM_MaxReal; OPM_MinLReal = -OPM_MaxLReal; OPM_MaxSet = __ASHL(OPM_SetSize, 3) - 1; - OPM_MaxIndex = OPM_MaxLInt; + OPM_MaxIndex = OPM_SignedMaximum(OPM_PointerSize); if (OPM_Verbose) { OPM_VerboseListSizes(); } @@ -875,7 +839,7 @@ void OPM_WriteInt (LONGINT i) { CHAR s[20]; LONGINT i1, k; - if (i == OPM_MinInt || i == OPM_MinLInt) { + if (i == OPM_SignedMinimum(OPM_IntSize) || i == OPM_SignedMinimum(OPM_LIntSize)) { OPM_Write('('); OPM_WriteInt(i + 1); OPM_WriteString((CHAR*)"-1)", (LONGINT)4); @@ -908,13 +872,13 @@ void OPM_WriteReal (LONGREAL r, CHAR suffx) CHAR s[32]; CHAR ch; INTEGER i; - if ((((r < OPM_MaxLInt && r > OPM_MinLInt)) && r == (__ENTIER(r)))) { + if ((((r < OPM_SignedMaximum(OPM_LIntSize) && r > OPM_SignedMinimum(OPM_LIntSize))) && r == ((int)__ENTIER(r)))) { if (suffx == 'f') { OPM_WriteString((CHAR*)"(REAL)", (LONGINT)7); } else { OPM_WriteString((CHAR*)"(LONGREAL)", (LONGINT)11); } - OPM_WriteInt(__ENTIER(r)); + OPM_WriteInt((int)__ENTIER(r)); } else { Texts_OpenWriter(&W, Texts_Writer__typ); if (suffx == 'f') { diff --git a/bootstrap/windows-48/OPM.h b/bootstrap/windows-48/OPM.h index db46c598..ed914bff 100644 --- a/bootstrap/windows-48/OPM.h +++ b/bootstrap/windows-48/OPM.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPM__h #define OPM__h @@ -6,8 +6,8 @@ #include "SYSTEM.h" -import INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_CharAlign, OPM_BoolAlign, OPM_SIntAlign, OPM_IntAlign, OPM_LIntAlign, OPM_SetAlign, OPM_RealAlign, OPM_LRealAlign, OPM_PointerAlign, OPM_ProcAlign, OPM_RecAlign, OPM_MaxSet; -import LONGINT OPM_MinSInt, OPM_MinInt, OPM_MinLInt, OPM_MaxSInt, OPM_MaxInt, OPM_MaxLInt, OPM_MaxIndex; +import INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_MaxSet; +import LONGINT OPM_MaxIndex; import LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; import BOOLEAN OPM_noerr; import LONGINT OPM_curpos, OPM_errpos, OPM_breakpc; @@ -38,6 +38,8 @@ import void OPM_OldSym (CHAR *modName, LONGINT modName__len, BOOLEAN *done); import void OPM_OpenFiles (CHAR *moduleName, LONGINT moduleName__len); import BOOLEAN OPM_OpenPar (void); import void OPM_RegisterNewSym (void); +import LONGINT OPM_SignedMaximum (LONGINT bytecount); +import LONGINT OPM_SignedMinimum (LONGINT bytecount); import void OPM_SymRCh (CHAR *ch); import LONGINT OPM_SymRInt (void); import void OPM_SymRLReal (LONGREAL *lr); diff --git a/bootstrap/windows-48/OPP.c b/bootstrap/windows-48/OPP.c index ffe3dff2..01d2144d 100644 --- a/bootstrap/windows-48/OPP.c +++ b/bootstrap/windows-48/OPP.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "OPB.h" #include "OPM.h" @@ -438,10 +438,10 @@ static void OPP_TypeDecl (OPT_Struct *typ, OPT_Struct *banned) if (OPP_sym == 38) { OPP_qualident(&id); if (id->mode == 5) { - if (id->typ != *banned) { - *typ = id->typ; - } else { + if (id->typ == *banned) { OPP_err(58); + } else { + *typ = id->typ; } } else { OPP_err(52); @@ -1783,6 +1783,24 @@ void OPP_Module (OPT_Node *prog, SET opt) if (OPP_sym == 63) { OPS_Get(&OPP_sym); } else { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Unexpected symbol found when MODULE expected:", (LONGINT)46); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" sym: ", (LONGINT)15); + OPM_LogWNum(OPP_sym, ((LONGINT)(1))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.name: ", (LONGINT)15); + OPM_LogWStr(OPS_name, ((LONGINT)(256))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.str: ", (LONGINT)15); + OPM_LogWStr(OPS_str, ((LONGINT)(256))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.numtyp: ", (LONGINT)15); + OPM_LogWNum(OPS_numtyp, ((LONGINT)(1))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.intval: ", (LONGINT)15); + OPM_LogWNum(OPS_intval, ((LONGINT)(1))); + OPM_LogWLn(); OPP_err(16); } if (OPP_sym == 38) { diff --git a/bootstrap/windows-48/OPP.h b/bootstrap/windows-48/OPP.h index 40e2def4..bf56b7d7 100644 --- a/bootstrap/windows-48/OPP.h +++ b/bootstrap/windows-48/OPP.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPP__h #define OPP__h diff --git a/bootstrap/windows-48/OPS.c b/bootstrap/windows-48/OPS.c index efed04c6..cacf9256 100644 --- a/bootstrap/windows-48/OPS.c +++ b/bootstrap/windows-48/OPS.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #include "SYSTEM.h" #include "OPM.h" @@ -173,7 +173,7 @@ static void OPS_Number (void) OPS_numtyp = 1; if (n <= 2) { while (i < n) { - OPS_intval = __ASHL(OPS_intval, 4) + (LONGINT)Ord__7(dig[i], 1); + OPS_intval = __ASHL(OPS_intval, 4) + (int)Ord__7(dig[i], 1); i += 1; } } else { @@ -188,7 +188,7 @@ static void OPS_Number (void) OPS_intval = -1; } while (i < n) { - OPS_intval = __ASHL(OPS_intval, 4) + (LONGINT)Ord__7(dig[i], 1); + OPS_intval = __ASHL(OPS_intval, 4) + (int)Ord__7(dig[i], 1); i += 1; } } else { @@ -199,8 +199,8 @@ static void OPS_Number (void) while (i < n) { d = Ord__7(dig[i], 0); i += 1; - if (OPS_intval <= __DIV(2147483647 - (LONGINT)d, 10)) { - OPS_intval = OPS_intval * 10 + (LONGINT)d; + if (OPS_intval <= __DIV(2147483647 - (int)d, 10)) { + OPS_intval = OPS_intval * 10 + (int)d; } else { OPS_err(203); } @@ -325,7 +325,7 @@ void OPS_Get (SHORTINT *sym) } } switch (OPS_ch) { - case '\"': case '\'': + case '"': case '\'': OPS_Str(&s); break; case '#': diff --git a/bootstrap/windows-48/OPS.h b/bootstrap/windows-48/OPS.h index dae6e457..e901bcfc 100644 --- a/bootstrap/windows-48/OPS.h +++ b/bootstrap/windows-48/OPS.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #ifndef OPS__h #define OPS__h diff --git a/bootstrap/windows-48/OPT.c b/bootstrap/windows-48/OPT.c index 8c943c20..b32d0ebd 100644 --- a/bootstrap/windows-48/OPT.c +++ b/bootstrap/windows-48/OPT.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "OPM.h" #include "OPS.h" @@ -849,7 +849,7 @@ static void OPT_InConstant (LONGINT f, OPT_Const conval) conval->intval = 0; break; default: - OPM_LogWStr((CHAR*)"unhandled case in OPT.InConstant(), f = ", (LONGINT)41); + OPM_LogWStr((CHAR*)"unhandled case in InConstant(), f = ", (LONGINT)37); OPM_LogWNum(f, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1072,7 +1072,7 @@ static void OPT_InStruct (OPT_Struct *typ) OPT_InSign(mno, &(*typ)->BaseTyp, &(*typ)->link); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.InStruct, tag = ", (LONGINT)39); + OPM_LogWStr((CHAR*)"unhandled case at InStruct, tag = ", (LONGINT)35); OPM_LogWNum(tag, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1175,7 +1175,7 @@ static OPT_Object OPT_InObj (SHORTINT mno) } break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.InObj, tag = ", (LONGINT)36); + OPM_LogWStr((CHAR*)"unhandled case at InObj, tag = ", (LONGINT)32); OPM_LogWNum(tag, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1464,14 +1464,14 @@ static void OPT_OutStr (OPT_Struct typ) OPM_SymWInt(((LONGINT)(18))); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutStr, typ^.comp = ", (LONGINT)43); + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.comp = ", (LONGINT)39); OPM_LogWNum(typ->comp, ((LONGINT)(0))); OPM_LogWLn(); break; } break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutStr, typ^.form = ", (LONGINT)43); + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.form = ", (LONGINT)39); OPM_LogWNum(typ->form, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1536,7 +1536,7 @@ static void OPT_OutObj (OPT_Object obj) OPT_FPrintErr(obj, 251); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutObj, obj^.history = ", (LONGINT)46); + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj^.history = ", (LONGINT)42); OPM_LogWNum(obj->history, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1592,7 +1592,7 @@ static void OPT_OutObj (OPT_Object obj) OPT_OutName((void*)obj->name, ((LONGINT)(256))); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutObj, obj.mode = ", (LONGINT)42); + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj.mode = ", (LONGINT)38); OPM_LogWNum(obj->mode, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1809,6 +1809,7 @@ export void *OPT__init(void) OPT_syslink = OPT_topScope->right; OPT_universe = OPT_topScope; OPT_topScope->right = NIL; + OPT_EnterTyp((CHAR*)"BOOLEAN", 2, OPM_BoolSize, &OPT_booltyp); OPT_EnterTyp((CHAR*)"CHAR", 3, OPM_CharSize, &OPT_chartyp); OPT_EnterTyp((CHAR*)"SET", 9, OPM_SetSize, &OPT_settyp); OPT_EnterTyp((CHAR*)"REAL", 7, OPM_RealSize, &OPT_realtyp); @@ -1816,7 +1817,6 @@ export void *OPT__init(void) OPT_EnterTyp((CHAR*)"LONGINT", 6, OPM_LIntSize, &OPT_linttyp); OPT_EnterTyp((CHAR*)"LONGREAL", 8, OPM_LRealSize, &OPT_lrltyp); OPT_EnterTyp((CHAR*)"SHORTINT", 4, OPM_SIntSize, &OPT_sinttyp); - OPT_EnterTyp((CHAR*)"BOOLEAN", 2, OPM_BoolSize, &OPT_booltyp); OPT_EnterBoolConst((CHAR*)"FALSE", ((LONGINT)(0))); OPT_EnterBoolConst((CHAR*)"TRUE", ((LONGINT)(1))); OPT_EnterProc((CHAR*)"HALT", 0); diff --git a/bootstrap/windows-48/OPT.h b/bootstrap/windows-48/OPT.h index 45816124..41b3e7ec 100644 --- a/bootstrap/windows-48/OPT.h +++ b/bootstrap/windows-48/OPT.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPT__h #define OPT__h @@ -59,8 +59,7 @@ typedef INTEGER ref, sysflag; LONGINT n, size, align, txtpos; BOOLEAN allocated, pbused, pvused; - char _prvt0[8]; - LONGINT pbfp, pvfp; + char _prvt0[16]; OPT_Struct BaseTyp; OPT_Object link, strobj; } OPT_StrDesc; diff --git a/bootstrap/windows-48/OPV.c b/bootstrap/windows-48/OPV.c index 23bff9c0..cf646f5e 100644 --- a/bootstrap/windows-48/OPV.c +++ b/bootstrap/windows-48/OPV.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "OPC.h" #include "OPM.h" @@ -23,7 +23,7 @@ export LONGINT *OPV_ExitInfo__typ; static void OPV_ActualPar (OPT_Node n, OPT_Object fp); export void OPV_AdrAndSize (OPT_Object topScope); static void OPV_CaseStat (OPT_Node n, OPT_Object outerProc); -static void OPV_Convert (OPT_Node n, INTEGER form, INTEGER prec); +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INTEGER prec); static void OPV_DefineTDescs (OPT_Node n); static void OPV_Entier (OPT_Node n, INTEGER prec); static void OPV_GetTProcNum (OPT_Object obj); @@ -38,6 +38,7 @@ static LONGINT OPV_NaturalAlignment (LONGINT size, LONGINT max); static void OPV_NewArr (OPT_Node d, OPT_Node x); static INTEGER OPV_Precedence (INTEGER class, INTEGER subclass, INTEGER form, INTEGER comp); static BOOLEAN OPV_SideEffects (OPT_Node n); +static void OPV_SizeCast (LONGINT size); static void OPV_Stamp (OPS_Name s); static OPT_Object OPV_SuperProc (OPT_Node n); static void OPV_Traverse (OPT_Object obj, OPT_Object outerScope, BOOLEAN exported); @@ -82,10 +83,10 @@ void OPV_TypSize (OPT_Struct typ) btyp = typ->BaseTyp; if (btyp == NIL) { offset = 0; - base = OPM_RecAlign; + base = OPC_SizeAlignment(OPM_RecSize); } else { OPV_TypSize(btyp); - offset = btyp->size - (LONGINT)__ASHR(btyp->sysflag, 8); + offset = btyp->size - (int)__ASHR(btyp->sysflag, 8); base = btyp->align; } fld = typ->link; @@ -93,7 +94,7 @@ void OPV_TypSize (OPT_Struct typ) btyp = fld->typ; OPV_TypSize(btyp); size = btyp->size; - fbase = OPC_Base(btyp); + fbase = OPC_BaseAlignment(btyp); OPC_Align(&offset, fbase); fld->adr = offset; offset += size; @@ -107,7 +108,7 @@ void OPV_TypSize (OPT_Struct typ) offset = 1; } if (OPM_RecSize == 0) { - base = OPV_NaturalAlignment(offset, OPM_RecAlign); + base = OPV_NaturalAlignment(offset, OPC_SizeAlignment(OPM_RecSize)); } OPC_Align(&offset, base); if ((typ->strobj == NIL && __MASK(typ->align, -65536) == 0)) { @@ -332,7 +333,7 @@ static INTEGER OPV_Precedence (INTEGER class, INTEGER subclass, INTEGER form, IN return _o_result; break; default: - OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence Nmop, subclass = ", (LONGINT)51); + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Nmop, subclass = ", (LONGINT)55); OPM_LogWNum(subclass, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -402,7 +403,7 @@ static INTEGER OPV_Precedence (INTEGER class, INTEGER subclass, INTEGER form, IN return _o_result; break; default: - OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence Ndop, subclass = ", (LONGINT)51); + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Ndop, subclass = ", (LONGINT)55); OPM_LogWNum(subclass, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -465,41 +466,26 @@ static void OPV_Entier (OPT_Node n, INTEGER prec) } } -static void OPV_Convert (OPT_Node n, INTEGER form, INTEGER prec) +static void OPV_SizeCast (LONGINT size) { - INTEGER from; + if (size <= 4) { + OPM_WriteString((CHAR*)"(int)", (LONGINT)6); + } else { + OPM_WriteString((CHAR*)"(SYSTEM_INT64)", (LONGINT)15); + } +} + +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INTEGER prec) +{ + INTEGER from, to; from = n->typ->form; - if (form == 9) { + to = newtype->form; + if (to == 9) { OPM_WriteString((CHAR*)"__SETOF(", (LONGINT)9); OPV_Entier(n, -1); OPM_Write(')'); - } else if (form == 6) { - if (from < 6) { - OPM_WriteString((CHAR*)"(LONGINT)", (LONGINT)10); - } - OPV_Entier(n, 9); - } else if (form == 5) { - if (from < 5) { - OPM_WriteString((CHAR*)"(int)", (LONGINT)6); - OPV_expr(n, 9); - } else { - if (__IN(2, OPM_opt)) { - OPM_WriteString((CHAR*)"__SHORT", (LONGINT)8); - if (OPV_SideEffects(n)) { - OPM_Write('F'); - } - OPM_Write('('); - OPV_Entier(n, -1); - OPM_WriteString((CHAR*)", ", (LONGINT)3); - OPM_WriteInt(OPM_MaxInt + 1); - OPM_Write(')'); - } else { - OPM_WriteString((CHAR*)"(int)", (LONGINT)6); - OPV_Entier(n, 9); - } - } - } else if (form == 4) { - if (__IN(2, OPM_opt)) { + } else if (__IN(to, 0x70)) { + if ((newtype->size < n->typ->size && __IN(2, OPM_opt))) { OPM_WriteString((CHAR*)"__SHORT", (LONGINT)8); if (OPV_SideEffects(n)) { OPM_Write('F'); @@ -507,13 +493,15 @@ static void OPV_Convert (OPT_Node n, INTEGER form, INTEGER prec) OPM_Write('('); OPV_Entier(n, -1); OPM_WriteString((CHAR*)", ", (LONGINT)3); - OPM_WriteInt(OPM_MaxSInt + 1); + OPM_WriteInt(OPM_SignedMaximum(newtype->size) + 1); OPM_Write(')'); } else { - OPM_WriteString((CHAR*)"(int)", (LONGINT)6); + if (newtype->size != n->typ->size) { + OPV_SizeCast(newtype->size); + } OPV_Entier(n, 9); } - } else if (form == 3) { + } else if (to == 3) { if (__IN(2, OPM_opt)) { OPM_WriteString((CHAR*)"__CHR", (LONGINT)6); if (OPV_SideEffects(n)) { @@ -576,7 +564,7 @@ static void OPV_design (OPT_Node n, INTEGER prec) OPT_Struct typ = NIL; INTEGER class, designPrec, comp; OPT_Node d = NIL, x = NIL; - INTEGER dims, i, _for__26; + INTEGER dims, i, _for__27; comp = n->typ->comp; obj = n->obj; class = n->class; @@ -652,15 +640,15 @@ static void OPV_design (OPT_Node n, INTEGER prec) } x = x->left; } - _for__26 = dims; + _for__27 = dims; i = 1; - while (i <= _for__26) { + while (i <= _for__27) { OPM_Write(')'); i += 1; } if (n->typ->comp == 3) { OPM_Write(')'); - while ((LONGINT)i < __ASHR(d->typ->size - 4, 2)) { + while ((int)i < __ASHR(d->typ->size - 4, 2)) { OPM_WriteString((CHAR*)" * ", (LONGINT)4); OPV_Len(d, i); i += 1; @@ -795,7 +783,7 @@ static void OPV_ActualPar (OPT_Node n, OPT_Object fp) } if ((((mode == 2 && n->class == 11)) && n->subcl == 29)) { OPV_expr(n->left, prec); - } else if ((((((form == 6 && n->class == 7)) && n->conval->intval <= OPM_MaxInt)) && n->conval->intval >= OPM_MinInt)) { + } else if ((((((form == 6 && n->class == 7)) && n->conval->intval <= OPM_SignedMaximum(OPM_IntSize))) && n->conval->intval >= OPM_SignedMinimum(OPM_IntSize))) { OPM_WriteString((CHAR*)"((LONGINT)(", (LONGINT)12); OPV_expr(n, prec); OPM_WriteString((CHAR*)"))", (LONGINT)3); @@ -914,7 +902,7 @@ static void OPV_expr (OPT_Node n, INTEGER prec) OPM_Write(')'); break; case 20: - OPV_Convert(l, form, exprPrec); + OPV_Convert(l, n->typ, exprPrec); break; case 21: if (OPV_SideEffects(l)) { @@ -943,7 +931,7 @@ static void OPV_expr (OPT_Node n, INTEGER prec) OPM_Write(')'); break; case 24: - OPM_WriteString((CHAR*)"(LONGINT)(uintptr_t)", (LONGINT)21); + OPM_WriteString((CHAR*)"(LONGINT)(SYSTEM_ADDRESS)", (LONGINT)26); if (l->class == 1) { OPC_CompleteIdent(l->obj); } else { @@ -954,20 +942,16 @@ static void OPV_expr (OPT_Node n, INTEGER prec) } break; case 29: - if ((((__IN(n->typ->form, 0x6240) && __IN(l->typ->form, 0x6240))) && n->typ->size == l->typ->size) || !__IN(l->class, 0x17)) { + if (!__IN(l->class, 0x17) || (((__IN(n->typ->form, 0x6240) && __IN(l->typ->form, 0x6240))) && n->typ->size == l->typ->size)) { OPM_Write('('); OPC_Ident(n->typ->strobj); OPM_Write(')'); if (__IN(n->typ->form, 0x6000) || __IN(l->typ->form, 0x6000)) { - OPM_WriteString((CHAR*)"(uintptr_t)", (LONGINT)12); + OPM_WriteString((CHAR*)"(SYSTEM_ADDRESS)", (LONGINT)17); } OPV_expr(l, exprPrec); } else { - if (__IN(n->typ->form, 0x6000) || __IN(l->typ->form, 0x6000)) { - OPM_WriteString((CHAR*)"__VALP(", (LONGINT)8); - } else { - OPM_WriteString((CHAR*)"__VAL(", (LONGINT)7); - } + OPM_WriteString((CHAR*)"__VAL(", (LONGINT)7); OPC_Ident(n->typ->strobj); OPM_WriteString((CHAR*)", ", (LONGINT)3); OPV_expr(l, -1); @@ -1326,7 +1310,7 @@ static void OPV_NewArr (OPT_Node d, OPT_Node x) OPM_WriteInt(base->size); OPM_WriteString((CHAR*)"))", (LONGINT)3); OPM_WriteString((CHAR*)", ", (LONGINT)3); - OPM_WriteInt(OPC_Base(base)); + OPM_WriteInt(OPC_BaseAlignment(base)); OPM_WriteString((CHAR*)", ", (LONGINT)3); OPM_WriteInt(nofdim); OPM_WriteString((CHAR*)", ", (LONGINT)3); diff --git a/bootstrap/windows-48/OPV.h b/bootstrap/windows-48/OPV.h index 0de9e6cc..04828b2f 100644 --- a/bootstrap/windows-48/OPV.h +++ b/bootstrap/windows-48/OPV.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPV__h #define OPV__h diff --git a/bootstrap/windows-48/Platform.c b/bootstrap/windows-48/Platform.c index 78bdbf70..4e8b44c8 100644 --- a/bootstrap/windows-48/Platform.c +++ b/bootstrap/windows-48/Platform.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" typedef @@ -109,11 +109,11 @@ export BOOLEAN Platform_getEnv (CHAR *var, LONGINT var__len, CHAR *val, LONGINT #define Platform_ERRORWRITEPROTECT() ERROR_WRITE_PROTECT #define Platform_ETIMEDOUT() WSAETIMEDOUT extern void Heap_InitHeap(); -#define Platform_GetTickCount() (LONGINT)(uint32_t)GetTickCount() +#define Platform_GetTickCount() (LONGINT)(SYSTEM_CARD32)GetTickCount() #define Platform_HeapInitHeap() Heap_InitHeap() -#define Platform_SetInterruptHandler(h) SystemSetInterruptHandler((uintptr_t)h) -#define Platform_SetQuitHandler(h) SystemSetQuitHandler((uintptr_t)h) -#define Platform_allocate(size) (LONGINT)(uintptr_t)((void*)HeapAlloc(GetProcessHeap(), 0, (size_t)size)) +#define Platform_SetInterruptHandler(h) SystemSetInterruptHandler((SYSTEM_ADDRESS)h) +#define Platform_SetQuitHandler(h) SystemSetQuitHandler((SYSTEM_ADDRESS)h) +#define Platform_allocate(size) (LONGINT)(SYSTEM_ADDRESS)((void*)HeapAlloc(GetProcessHeap(), 0, (size_t)size)) #define Platform_bhfiIndexHigh() (LONGINT)bhfi.nFileIndexHigh #define Platform_bhfiIndexLow() (LONGINT)bhfi.nFileIndexLow #define Platform_bhfiMtimeHigh() (LONGINT)bhfi.ftLastWriteTime.dwHighDateTime @@ -121,44 +121,44 @@ extern void Heap_InitHeap(); #define Platform_bhfiVsn() (LONGINT)bhfi.dwVolumeSerialNumber #define Platform_byHandleFileInformation() BY_HANDLE_FILE_INFORMATION bhfi #define Platform_cleanupProcess() CloseHandle(pi.hProcess); CloseHandle(pi.hThread); -#define Platform_closeHandle(h) (INTEGER)CloseHandle((HANDLE)(uintptr_t)h) +#define Platform_closeHandle(h) (INTEGER)CloseHandle((HANDLE)(SYSTEM_ADDRESS)h) #define Platform_createProcess(str, str__len) (INTEGER)CreateProcess(0, (char*)str, 0,0,0,0,0,0,&si,&pi) #define Platform_deleteFile(n, n__len) (INTEGER)DeleteFile((char*)n) #define Platform_err() (INTEGER)GetLastError() -#define Platform_errc(c) WriteFile((HANDLE)(uintptr_t)Platform_StdOut, &c, 1, 0,0) -#define Platform_errstring(s, s__len) WriteFile((HANDLE)(uintptr_t)Platform_StdOut, s, s__len-1, 0,0) +#define Platform_errc(c) WriteFile((HANDLE)(SYSTEM_ADDRESS)Platform_StdOut, &c, 1, 0,0) +#define Platform_errstring(s, s__len) WriteFile((HANDLE)(SYSTEM_ADDRESS)Platform_StdOut, s, s__len-1, 0,0) #define Platform_exit(code) ExitProcess((UINT)code) #define Platform_fileTimeToSysTime() SYSTEMTIME st; FileTimeToSystemTime(&ft, &st) -#define Platform_flushFileBuffers(h) (INTEGER)FlushFileBuffers((HANDLE)(uintptr_t)h) -#define Platform_free(address) HeapFree(GetProcessHeap(), 0, (void*)(uintptr_t)address) +#define Platform_flushFileBuffers(h) (INTEGER)FlushFileBuffers((HANDLE)(SYSTEM_ADDRESS)h) +#define Platform_free(address) HeapFree(GetProcessHeap(), 0, (void*)(SYSTEM_ADDRESS)address) #define Platform_ftToUli() ULARGE_INTEGER ul; ul.LowPart=ft.dwLowDateTime; ul.HighPart=ft.dwHighDateTime #define Platform_getCurrentDirectory(n, n__len) GetCurrentDirectory(n__len, (char*)n) #define Platform_getExitCodeProcess(exitcode) GetExitCodeProcess(pi.hProcess, (DWORD*)exitcode); -#define Platform_getFileInformationByHandle(h) (INTEGER)GetFileInformationByHandle((HANDLE)(uintptr_t)h, &bhfi) -#define Platform_getFilePos(h, r, rc) LARGE_INTEGER liz = {0}; *rc = (INTEGER)SetFilePointerEx((HANDLE)(uintptr_t)h, liz, &li, FILE_CURRENT); *r = (LONGINT)li.QuadPart -#define Platform_getFileSize(h) (INTEGER)GetFileSizeEx((HANDLE)(uintptr_t)h, &li) +#define Platform_getFileInformationByHandle(h) (INTEGER)GetFileInformationByHandle((HANDLE)(SYSTEM_ADDRESS)h, &bhfi) +#define Platform_getFilePos(h, r, rc) LARGE_INTEGER liz = {0}; *rc = (INTEGER)SetFilePointerEx((HANDLE)(SYSTEM_ADDRESS)h, liz, &li, FILE_CURRENT); *r = (LONGINT)li.QuadPart +#define Platform_getFileSize(h) (INTEGER)GetFileSizeEx((HANDLE)(SYSTEM_ADDRESS)h, &li) #define Platform_getLocalTime() SYSTEMTIME st; GetLocalTime(&st) #define Platform_getenv(name, name__len, buf, buf__len) (INTEGER)GetEnvironmentVariable((char*)name, (char*)buf, buf__len) #define Platform_getpid() (INTEGER)GetCurrentProcessId() -#define Platform_getstderrhandle() (uintptr_t)GetStdHandle(STD_ERROR_HANDLE) -#define Platform_getstdinhandle() (uintptr_t)GetStdHandle(STD_INPUT_HANDLE) -#define Platform_getstdouthandle() (uintptr_t)GetStdHandle(STD_OUTPUT_HANDLE) +#define Platform_getstderrhandle() (SYSTEM_ADDRESS)GetStdHandle(STD_ERROR_HANDLE) +#define Platform_getstdinhandle() (SYSTEM_ADDRESS)GetStdHandle(STD_INPUT_HANDLE) +#define Platform_getstdouthandle() (SYSTEM_ADDRESS)GetStdHandle(STD_OUTPUT_HANDLE) #define Platform_identityToFileTime(i) FILETIME ft; ft.dwHighDateTime = i.mtimehigh; ft.dwLowDateTime = i.mtimelow -#define Platform_invalidHandleValue() ((LONGINT)(uintptr_t)INVALID_HANDLE_VALUE) +#define Platform_invalidHandleValue() ((LONGINT)(SYSTEM_ADDRESS)INVALID_HANDLE_VALUE) #define Platform_largeInteger() LARGE_INTEGER li #define Platform_liLongint() (LONGINT)li.QuadPart #define Platform_moveFile(o, o__len, n, n__len) (INTEGER)MoveFileEx((char*)o, (char*)n, MOVEFILE_REPLACE_EXISTING) -#define Platform_opennew(n, n__len) (LONGINT)(uintptr_t)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0) -#define Platform_openro(n, n__len) (LONGINT)(uintptr_t)CreateFile((char*)n, GENERIC_READ , FILE_SHARE_READ|FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) -#define Platform_openrw(n, n__len) (LONGINT)(uintptr_t)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) +#define Platform_opennew(n, n__len) (LONGINT)(SYSTEM_ADDRESS)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0) +#define Platform_openro(n, n__len) (LONGINT)(SYSTEM_ADDRESS)CreateFile((char*)n, GENERIC_READ , FILE_SHARE_READ|FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) +#define Platform_openrw(n, n__len) (LONGINT)(SYSTEM_ADDRESS)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) #define Platform_processInfo() PROCESS_INFORMATION pi = {0}; -#define Platform_readfile(fd, p, l, n) (INTEGER)ReadFile ((HANDLE)(uintptr_t)fd, (void*)(uintptr_t)(p), (DWORD)l, (DWORD*)n, 0) +#define Platform_readfile(fd, p, l, n) (INTEGER)ReadFile ((HANDLE)(SYSTEM_ADDRESS)fd, (void*)(SYSTEM_ADDRESS)(p), (DWORD)l, (DWORD*)n, 0) #define Platform_seekcur() FILE_CURRENT #define Platform_seekend() FILE_END #define Platform_seekset() FILE_BEGIN #define Platform_setCurrentDirectory(n, n__len) (INTEGER)SetCurrentDirectory((char*)n) -#define Platform_setEndOfFile(h) (INTEGER)SetEndOfFile((HANDLE)(uintptr_t)h) -#define Platform_setFilePointerEx(h, o, r, rc) li.QuadPart=o; *rc = (INTEGER)SetFilePointerEx((HANDLE)(uintptr_t)h, li, 0, (DWORD)r) +#define Platform_setEndOfFile(h) (INTEGER)SetEndOfFile((HANDLE)(SYSTEM_ADDRESS)h) +#define Platform_setFilePointerEx(h, o, r, rc) li.QuadPart=o; *rc = (INTEGER)SetFilePointerEx((HANDLE)(SYSTEM_ADDRESS)h, li, 0, (DWORD)r) #define Platform_sleep(ms) Sleep((DWORD)ms) #define Platform_stToFt() FILETIME ft; SystemTimeToFileTime(&st, &ft) #define Platform_startupInfo() STARTUPINFO si = {0}; si.cb = sizeof(si); @@ -173,7 +173,7 @@ extern void Heap_InitHeap(); #define Platform_ulSec() (LONGINT)(ul.QuadPart / 1000000LL) #define Platform_uluSec() (LONGINT)(ul.QuadPart % 1000000LL) #define Platform_waitForProcess() (INTEGER)WaitForSingleObject(pi.hProcess, INFINITE) -#define Platform_writefile(fd, p, l) (INTEGER)WriteFile((HANDLE)(uintptr_t)fd, (void*)(uintptr_t)(p), (DWORD)l, 0,0) +#define Platform_writefile(fd, p, l) (INTEGER)WriteFile((HANDLE)(SYSTEM_ADDRESS)fd, (void*)(SYSTEM_ADDRESS)(p), (DWORD)l, 0,0) BOOLEAN Platform_TooManyFiles (INTEGER e) { @@ -241,7 +241,7 @@ void Platform_Init (INTEGER argc, LONGINT argvadr) Platform_ArgVecPtr av = NIL; Platform_MainStackFrame = argvadr; Platform_ArgCount = argc; - av = (Platform_ArgVecPtr)(uintptr_t)argvadr; + av = (Platform_ArgVecPtr)(SYSTEM_ADDRESS)argvadr; Platform_ArgVector = (*av)[0]; Platform_HaltCode = -128; Platform_HeapInitHeap(); @@ -280,7 +280,7 @@ void Platform_GetArg (INTEGER n, CHAR *val, LONGINT val__len) { Platform_ArgVec av = NIL; if (n < Platform_ArgCount) { - av = (Platform_ArgVec)(uintptr_t)Platform_ArgVector; + av = (Platform_ArgVec)(SYSTEM_ADDRESS)Platform_ArgVector; __COPY(*(*av)[__X(n, ((LONGINT)(1024)))], val, val__len); } } @@ -334,8 +334,8 @@ void Platform_SetBadInstructionHandler (Platform_SignalHandler handler) static void Platform_YMDHMStoClock (INTEGER ye, INTEGER mo, INTEGER da, INTEGER ho, INTEGER mi, INTEGER se, LONGINT *t, LONGINT *d) { - *d = (__ASHL((LONGINT)(int)__MOD(ye, 100), 9) + __ASHL((LONGINT)(mo + 1), 5)) + (LONGINT)da; - *t = (__ASHL((LONGINT)ho, 12) + __ASHL((LONGINT)mi, 6)) + (LONGINT)se; + *d = (__ASHL((int)(int)__MOD(ye, 100), 9) + __ASHL((int)(mo + 1), 5)) + (int)da; + *t = (__ASHL((int)ho, 12) + __ASHL((int)mi, 6)) + (int)se; } void Platform_GetClock (LONGINT *t, LONGINT *d) @@ -559,7 +559,7 @@ INTEGER Platform_ReadBuf (LONGINT h, SYSTEM_BYTE *b, LONGINT b__len, LONGINT *n) INTEGER _o_result; INTEGER result; *n = 0; - result = Platform_readfile(h, (LONGINT)(uintptr_t)b, b__len, &*n); + result = Platform_readfile(h, (LONGINT)(SYSTEM_ADDRESS)b, b__len, &*n); if (result == 0) { *n = 0; _o_result = Platform_err(); @@ -795,7 +795,7 @@ static void Platform_TestLittleEndian (void) { INTEGER i; i = 1; - __GET((LONGINT)(uintptr_t)&i, Platform_LittleEndian, BOOLEAN); + __GET((LONGINT)(SYSTEM_ADDRESS)&i, Platform_LittleEndian, BOOLEAN); } __TDESC(Platform_FileIdentity, 1, 0) = {__TDFLDS("FileIdentity", 20), {-4}}; diff --git a/bootstrap/windows-48/Platform.h b/bootstrap/windows-48/Platform.h index aecbb66c..673b2b0b 100644 --- a/bootstrap/windows-48/Platform.h +++ b/bootstrap/windows-48/Platform.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Platform__h #define Platform__h @@ -78,7 +78,7 @@ import INTEGER Platform_Write (LONGINT h, LONGINT p, LONGINT l); import BOOLEAN Platform_getEnv (CHAR *var, LONGINT var__len, CHAR *val, LONGINT val__len); import void *Platform__init(void); -#define Platform_SetInterruptHandler(h) SystemSetInterruptHandler((uintptr_t)h) -#define Platform_SetQuitHandler(h) SystemSetQuitHandler((uintptr_t)h) +#define Platform_SetInterruptHandler(h) SystemSetInterruptHandler((SYSTEM_ADDRESS)h) +#define Platform_SetQuitHandler(h) SystemSetQuitHandler((SYSTEM_ADDRESS)h) #endif diff --git a/bootstrap/windows-48/Reals.c b/bootstrap/windows-48/Reals.c index 0f1c3a92..2323e34d 100644 --- a/bootstrap/windows-48/Reals.c +++ b/bootstrap/windows-48/Reals.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" @@ -58,7 +58,7 @@ INTEGER Reals_Expo (REAL x) { INTEGER _o_result; INTEGER i; - __GET((LONGINT)(uintptr_t)&x + 2, i, INTEGER); + __GET((LONGINT)(SYSTEM_ADDRESS)&x + 2, i, INTEGER); _o_result = __MASK(__ASHR(i, 7), -256); return _o_result; } @@ -66,17 +66,17 @@ INTEGER Reals_Expo (REAL x) void Reals_SetExpo (REAL *x, INTEGER ex) { CHAR c; - __GET((LONGINT)(uintptr_t)x + 3, c, CHAR); - __PUT((LONGINT)(uintptr_t)x + 3, (CHAR)(__ASHL(__ASHR((int)c, 7), 7) + __MASK(__ASHR(ex, 1), -128)), CHAR); - __GET((LONGINT)(uintptr_t)x + 2, c, CHAR); - __PUT((LONGINT)(uintptr_t)x + 2, (CHAR)(__MASK((int)c, -128) + __ASHL(__MASK(ex, -2), 7)), CHAR); + __GET((LONGINT)(SYSTEM_ADDRESS)x + 3, c, CHAR); + __PUT((LONGINT)(SYSTEM_ADDRESS)x + 3, (CHAR)(__ASHL(__ASHR((int)c, 7), 7) + __MASK(__ASHR(ex, 1), -128)), CHAR); + __GET((LONGINT)(SYSTEM_ADDRESS)x + 2, c, CHAR); + __PUT((LONGINT)(SYSTEM_ADDRESS)x + 2, (CHAR)(__MASK((int)c, -128) + __ASHL(__MASK(ex, -2), 7)), CHAR); } INTEGER Reals_ExpoL (LONGREAL x) { INTEGER _o_result; INTEGER i; - __GET((LONGINT)(uintptr_t)&x + 6, i, INTEGER); + __GET((LONGINT)(SYSTEM_ADDRESS)&x + 6, i, INTEGER); _o_result = __MASK(__ASHR(i, 4), -2048); return _o_result; } @@ -89,8 +89,8 @@ void Reals_ConvertL (LONGREAL x, INTEGER n, CHAR *d, LONGINT d__len) } k = 0; if (n > 9) { - i = __ENTIER(x / (LONGREAL)(LONGREAL)1000000000); - j = __ENTIER(x - i * (LONGREAL)1000000000); + i = (int)__ENTIER(x / (LONGREAL)(LONGREAL)1000000000); + j = (int)__ENTIER(x - i * (LONGREAL)1000000000); if (j < 0) { j = 0; } @@ -100,9 +100,9 @@ void Reals_ConvertL (LONGREAL x, INTEGER n, CHAR *d, LONGINT d__len) k += 1; } } else { - i = __ENTIER(x); + i = (int)__ENTIER(x); } - while (k < (LONGINT)n) { + while (k < (int)n) { d[__X(k, d__len)] = (CHAR)(__MOD(i, 10) + 48); i = __DIV(i, 10); k += 1; @@ -134,7 +134,7 @@ static void Reals_BytesToHex (SYSTEM_BYTE *b, LONGINT b__len, SYSTEM_BYTE *d, LO CHAR by; i = 0; l = b__len; - while ((LONGINT)i < l) { + while ((int)i < l) { by = __VAL(CHAR, b[__X(i, b__len)]); d[__X(__ASHL(i, 1), d__len)] = Reals_ToHex(__ASHR((int)by, 4)); d[__X(__ASHL(i, 1) + 1, d__len)] = Reals_ToHex(__MASK((int)by, -16)); diff --git a/bootstrap/windows-48/Reals.h b/bootstrap/windows-48/Reals.h index 4a783296..7e6b534c 100644 --- a/bootstrap/windows-48/Reals.h +++ b/bootstrap/windows-48/Reals.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Reals__h #define Reals__h diff --git a/bootstrap/windows-48/SYSTEM.c b/bootstrap/windows-48/SYSTEM.c index 50e91c6d..33511a70 100644 --- a/bootstrap/windows-48/SYSTEM.c +++ b/bootstrap/windows-48/SYSTEM.c @@ -35,7 +35,7 @@ void SYSTEM_INHERIT(LONGINT *t, LONGINT *t0) void SYSTEM_ENUMP(void *adr, LONGINT n, void (*P)()) { while (n > 0) { - P((LONGINT)(uintptr_t)(*((void**)(adr)))); + P((LONGINT)(SYSTEM_ADDRESS)(*((void**)(adr)))); adr = ((void**)adr) + 1; n--; } @@ -106,7 +106,7 @@ SYSTEM_PTR SYSTEM_NEWARR(LONGINT *typ, LONGINT elemsz, int elemalgn, int nofdim, else if (typ == (LONGINT*)POINTER__typ) { /* element type is a pointer */ x = Heap_NEWBLK(size + nofelems * sizeof(LONGINT)); - p = (LONGINT*)(uintptr_t)x[-1]; + p = (LONGINT*)(SYSTEM_ADDRESS)x[-1]; p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */ while (n <= nofelems) {*p = n*sizeof(LONGINT); p++; n++;} @@ -119,7 +119,7 @@ SYSTEM_PTR SYSTEM_NEWARR(LONGINT *typ, LONGINT elemsz, int elemalgn, int nofdim, while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */ nptr = nofelems * nofptrs; /* total number of pointers */ x = Heap_NEWBLK(size + nptr * sizeof(LONGINT)); - p = (LONGINT*)(uintptr_t)x[- 1]; + p = (LONGINT*)(SYSTEM_ADDRESS)x[- 1]; p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ p -= nptr - 1; n = 0; off = dataoff; while (n < nofelems) {i = 0; @@ -155,7 +155,7 @@ typedef void (*SystemSignalHandler)(INTEGER); // = Platform_SignalHandler // (Ignore other signals) } - void SystemSetHandler(int s, uintptr_t h) { + void SystemSetHandler(int s, SYSTEM_ADDRESS h) { if (s >= 2 && s <= 4) { int needtosetsystemhandler = handler[s-2] == 0; handler[s-2] = (SystemSignalHandler)h; @@ -194,12 +194,12 @@ typedef void (*SystemSignalHandler)(INTEGER); // = Platform_SignalHandler } } - void SystemSetInterruptHandler(uintptr_t h) { + void SystemSetInterruptHandler(SYSTEM_ADDRESS h) { EnsureConsoleCtrlHandler(); SystemInterruptHandler = (SystemSignalHandler)h; } - void SystemSetQuitHandler(uintptr_t h) { + void SystemSetQuitHandler(SYSTEM_ADDRESS h) { EnsureConsoleCtrlHandler(); SystemQuitHandler = (SystemSignalHandler)h; } diff --git a/bootstrap/windows-48/SYSTEM.h b/bootstrap/windows-48/SYSTEM.h index 949951ac..6377745e 100644 --- a/bootstrap/windows-48/SYSTEM.h +++ b/bootstrap/windows-48/SYSTEM.h @@ -1,28 +1,38 @@ #ifndef SYSTEM__h #define SYSTEM__h -#ifndef _WIN32 - - // Building for a Unix/Linux based system - #include // For memcpy ... - #include // For uintptr_t ... - +#if defined(_WIN64) + typedef long long SYSTEM_INT64; + typedef unsigned long long SYSTEM_CARD64; #else - - // Building for Windows platform with either mingw under cygwin, or the MS C compiler - #ifdef _WIN64 - typedef unsigned long long size_t; - typedef unsigned long long uintptr_t; - #else - typedef unsigned int size_t; - typedef unsigned int uintptr_t; - #endif /* _WIN64 */ - - typedef unsigned int uint32_t; - void * __cdecl memcpy(void * dest, const void * source, size_t size); - + typedef long SYSTEM_INT64; + typedef unsigned long SYSTEM_CARD64; #endif +typedef int SYSTEM_INT32; +typedef unsigned int SYSTEM_CARD32; +typedef short int SYSTEM_INT16; +typedef unsigned short int SYSTEM_CARD16; +typedef signed char SYSTEM_INT8; +typedef unsigned char SYSTEM_CARD8; + +#if (__SIZEOF_POINTER__ == 8) || defined(_WIN64) || defined(__LP64__) + #if defined(_WIN64) + typedef unsigned long long size_t; + #else + typedef unsigned long size_t; + #endif +#else + typedef unsigned int size_t; +#endif + +#define SYSTEM_ADDRESS size_t +#define _SIZE_T_DECLARED // For FreeBSD +#define _SIZE_T_DEFINED_ // For OpenBSD + +void *memcpy(void *dest, const void *source, SYSTEM_ADDRESS size); + + // The compiler uses 'import' and 'export' which translate to 'extern' and // nothing respectively. @@ -70,6 +80,7 @@ typedef unsigned char U_SHORTINT; #endif typedef U_LONGINT SET; +typedef U_LONGINT U_SET; // OS Memory allocation interfaces are in PlatformXXX.Mod @@ -96,10 +107,10 @@ extern LONGINT SYSTEM_ENTIER (double x); // Signal handling in SYSTEM.c #ifndef _WIN32 - extern void SystemSetHandler(int s, uintptr_t h); + extern void SystemSetHandler(int s, SYSTEM_ADDRESS h); #else - extern void SystemSetInterruptHandler(uintptr_t h); - extern void SystemSetQuitHandler (uintptr_t h); + extern void SystemSetInterruptHandler(SYSTEM_ADDRESS h); + extern void SystemSetQuitHandler (SYSTEM_ADDRESS h); #endif @@ -122,20 +133,20 @@ static int __str_cmp(CHAR *x, CHAR *y){ #define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d; LONGINT _i=0,_t=n-1; \ while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;} -#define __DUP(x, l, t) x=(void*)memcpy((void*)(uintptr_t)Platform_OSAllocate(l*sizeof(t)),x,l*sizeof(t)) +#define __DUP(x, l, t) x=(void*)memcpy((void*)(SYSTEM_ADDRESS)Platform_OSAllocate(l*sizeof(t)),x,l*sizeof(t)) #define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) -#define __DEL(x) Platform_OSFree((LONGINT)(uintptr_t)x) +#define __DEL(x) Platform_OSFree((LONGINT)(SYSTEM_ADDRESS)x) /* SYSTEM ops */ -#define __VAL(t, x) ((t)(x)) -#define __VALP(t, x) ((t)(uintptr_t)(x)) +#define __VAL(t, x) (*(t*)&(x)) -#define __GET(a, x, t) x= *(t*)(uintptr_t)(a) -#define __PUT(a, x, t) *(t*)(uintptr_t)(a)=x + +#define __GET(a, x, t) x= *(t*)(SYSTEM_ADDRESS)(a) +#define __PUT(a, x, t) *(t*)(SYSTEM_ADDRESS)(a)=x #define __LSHL(x, n, t) ((t)((U_##t)(x)<<(n))) #define __LSHR(x, n, t) ((t)((U_##t)(x)>>(n))) @@ -150,7 +161,7 @@ static int __str_cmp(CHAR *x, CHAR *y){ #define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t)) #define __BIT(x, n) (*(U_LONGINT*)(x)>>(n)&1) -#define __MOVE(s, d, n) memcpy((char*)(uintptr_t)(d),(char*)(uintptr_t)(s),n) +#define __MOVE(s, d, n) memcpy((char*)(SYSTEM_ADDRESS)(d),(char*)(SYSTEM_ADDRESS)(s),n) #define __ASHF(x, n) SYSTEM_ASH((LONGINT)(x), (LONGINT)(n)) #define __SHORT(x, y) ((int)((U_LONGINT)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0))) #define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y))) @@ -211,7 +222,7 @@ extern void Heap_INCREF(); extern void Platform_Init(INTEGER argc, LONGINT argv); extern void Heap_FINALL(); -#define __INIT(argc, argv) static void *m; Platform_Init((INTEGER)argc, (LONGINT)(uintptr_t)&argv); +#define __INIT(argc, argv) static void *m; Platform_Init((INTEGER)argc, (LONGINT)(SYSTEM_ADDRESS)&argv); #define __REGMAIN(name, enum) m = Heap_REGMOD((CHAR*)name,enum) #define __FINI Heap_FINALL(); return 0 @@ -232,7 +243,7 @@ extern SYSTEM_PTR Heap_NEWREC (LONGINT tag); extern SYSTEM_PTR SYSTEM_NEWARR(LONGINT*, LONGINT, int, int, int, ...); #define __SYSNEW(p, len) p = Heap_NEWBLK((LONGINT)(len)) -#define __NEW(p, t) p = Heap_NEWREC((LONGINT)(uintptr_t)t##__typ) +#define __NEW(p, t) p = Heap_NEWREC((LONGINT)(SYSTEM_ADDRESS)t##__typ) #define __NEWARR SYSTEM_NEWARR @@ -263,20 +274,20 @@ extern SYSTEM_PTR SYSTEM_NEWARR(LONGINT*, LONGINT, int, int, int, ...); #define __INITYP(t, t0, level) \ t##__typ = (LONGINT*)&t##__desc.blksz; \ memcpy(t##__desc.basep, t0##__typ - __BASEOFF, level*sizeof(LONGINT)); \ - t##__desc.basep[level] = (LONGINT)(uintptr_t)t##__typ; \ - t##__desc.module = (LONGINT)(uintptr_t)m; \ + t##__desc.basep[level] = (LONGINT)(SYSTEM_ADDRESS)t##__typ; \ + t##__desc.module = (LONGINT)(SYSTEM_ADDRESS)m; \ if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ t##__desc.blksz = (t##__desc.blksz+5*sizeof(LONGINT)-1)/(4*sizeof(LONGINT))*(4*sizeof(LONGINT)); \ - Heap_REGTYP(m, (LONGINT)(uintptr_t)&t##__desc.next); \ + Heap_REGTYP(m, (LONGINT)(SYSTEM_ADDRESS)&t##__desc.next); \ SYSTEM_INHERIT(t##__typ, t0##__typ) -#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(LONGINT)(uintptr_t)typ##__typ) -#define __TYPEOF(p) ((LONGINT*)(uintptr_t)(*(((LONGINT*)(p))-1))) +#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(LONGINT)(SYSTEM_ADDRESS)typ##__typ) +#define __TYPEOF(p) ((LONGINT*)(SYSTEM_ADDRESS)(*(((LONGINT*)(p))-1))) #define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) // Oberon-2 type bound procedures support -#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(LONGINT)(uintptr_t)proc -#define __SEND(typ, num, funtyp, parlist) ((funtyp)((uintptr_t)*(typ-(__TPROC0OFF+num))))parlist +#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(LONGINT)(SYSTEM_ADDRESS)proc +#define __SEND(typ, num, funtyp, parlist) ((funtyp)((SYSTEM_ADDRESS)*(typ-(__TPROC0OFF+num))))parlist diff --git a/bootstrap/windows-48/Strings.c b/bootstrap/windows-48/Strings.c index d2713d0f..115456ea 100644 --- a/bootstrap/windows-48/Strings.c +++ b/bootstrap/windows-48/Strings.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" @@ -21,7 +21,7 @@ INTEGER Strings_Length (CHAR *s, LONGINT s__len) INTEGER i; __DUP(s, s__len, CHAR); i = 0; - while (((LONGINT)i < s__len && s[__X(i, s__len)] != 0x00)) { + while (((int)i < s__len && s[__X(i, s__len)] != 0x00)) { i += 1; } _o_result = i; @@ -36,11 +36,11 @@ void Strings_Append (CHAR *extra, LONGINT extra__len, CHAR *dest, LONGINT dest__ n1 = Strings_Length(dest, dest__len); n2 = Strings_Length(extra, extra__len); i = 0; - while ((i < n2 && (LONGINT)(i + n1) < dest__len)) { + while ((i < n2 && (int)(i + n1) < dest__len)) { dest[__X(i + n1, dest__len)] = extra[__X(i, extra__len)]; i += 1; } - if ((LONGINT)(i + n1) < dest__len) { + if ((int)(i + n1) < dest__len) { dest[__X(i + n1, dest__len)] = 0x00; } __DEL(extra); @@ -59,10 +59,10 @@ void Strings_Insert (CHAR *source, LONGINT source__len, INTEGER pos, CHAR *dest, Strings_Append(dest, dest__len, (void*)source, source__len); return; } - if ((LONGINT)(pos + n2) < dest__len) { + if ((int)(pos + n2) < dest__len) { i = n1; while (i >= pos) { - if ((LONGINT)(i + n2) < dest__len) { + if ((int)(i + n2) < dest__len) { dest[__X(i + n2, dest__len)] = dest[__X(i, dest__len)]; } i -= 1; @@ -91,7 +91,7 @@ void Strings_Delete (CHAR *s, LONGINT s__len, INTEGER pos, INTEGER n) s[__X(i - n, s__len)] = s[__X(i, s__len)]; i += 1; } - if ((LONGINT)(i - n) < s__len) { + if ((int)(i - n) < s__len) { s[__X(i - n, s__len)] = 0x00; } } else { @@ -121,7 +121,7 @@ void Strings_Extract (CHAR *source, LONGINT source__len, INTEGER pos, INTEGER n, return; } i = 0; - while (((((LONGINT)(pos + i) <= source__len && source[__X(pos + i, source__len)] != 0x00)) && i < n)) { + while (((((int)(pos + i) <= source__len && source[__X(pos + i, source__len)] != 0x00)) && i < n)) { if (i < destLen) { dest[__X(i, dest__len)] = source[__X(pos + i, source__len)]; } diff --git a/bootstrap/windows-48/Strings.h b/bootstrap/windows-48/Strings.h index 5f45d8a8..96dbb01d 100644 --- a/bootstrap/windows-48/Strings.h +++ b/bootstrap/windows-48/Strings.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Strings__h #define Strings__h diff --git a/bootstrap/windows-48/Texts.c b/bootstrap/windows-48/Texts.c index 2dab1e0f..cfe34ca7 100644 --- a/bootstrap/windows-48/Texts.c +++ b/bootstrap/windows-48/Texts.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Files.h" #include "Modules.h" @@ -787,9 +787,9 @@ void Texts_Scan (Texts_Scanner *S, LONGINT *S__typ) (*S).s[__X(i, ((LONGINT)(64)))] = 0x00; (*S).len = i; (*S).class = 1; - } else if (ch == '\"') { + } else if (ch == '"') { Texts_Read((void*)&*S, S__typ, &ch); - while ((((ch != '\"' && ch >= ' ')) && i != 63)) { + while ((((ch != '"' && ch >= ' ')) && i != 63)) { (*S).s[__X(i, ((LONGINT)(64)))] = ch; i += 1; Texts_Read((void*)&*S, S__typ, &ch); @@ -839,7 +839,7 @@ void Texts_Scan (Texts_Scanner *S, LONGINT *S__typ) k -= 16; } while (j < i) { - k = __ASHL(k, 4) + (LONGINT)((int)d[__X(j, ((LONGINT)(32)))] - 48); + k = __ASHL(k, 4) + (int)((int)d[__X(j, ((LONGINT)(32)))] - 48); j += 1; } if (neg) { @@ -929,7 +929,7 @@ void Texts_Scan (Texts_Scanner *S, LONGINT *S__typ) (*S).class = 3; k = 0; do { - k = k * 10 + (LONGINT)((int)d[__X(j, ((LONGINT)(32)))] - 48); + k = k * 10 + (int)((int)d[__X(j, ((LONGINT)(32)))] - 48); j += 1; } while (!(j == i)); if (neg) { @@ -1067,7 +1067,7 @@ void Texts_WriteInt (Texts_Writer *W, LONGINT *W__typ, LONGINT x, LONGINT n) x0 = __DIV(x0, 10); i += 1; } while (!(x0 == 0)); - while (n > (LONGINT)i) { + while (n > (int)i) { Texts_Write(&*W, W__typ, ' '); n -= 1; } @@ -1319,7 +1319,7 @@ void Texts_WriteLongReal (Texts_Writer *W, LONGINT *W__typ, LONGREAL x, INTEGER } else { Texts_Write(&*W, W__typ, ' '); } - e = (int)__ASHR((LONGINT)(e - 1023) * 77, 8); + e = (int)__ASHR((int)(e - 1023) * 77, 8); if (e >= 0) { x = x / (LONGREAL)Reals_TenL(e); } else { diff --git a/bootstrap/windows-48/Texts.h b/bootstrap/windows-48/Texts.h index 189403c9..632b644a 100644 --- a/bootstrap/windows-48/Texts.h +++ b/bootstrap/windows-48/Texts.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Texts__h #define Texts__h diff --git a/bootstrap/windows-48/Vishap.c b/bootstrap/windows-48/Vishap.c index 74d0e984..4c9e3b45 100644 --- a/bootstrap/windows-48/Vishap.c +++ b/bootstrap/windows-48/Vishap.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkamSf */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkamSf */ #include "SYSTEM.h" #include "Configuration.h" #include "Heap.h" diff --git a/bootstrap/windows-48/errors.c b/bootstrap/windows-48/errors.c index f8ddb53a..68e433df 100644 --- a/bootstrap/windows-48/errors.c +++ b/bootstrap/windows-48/errors.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" typedef @@ -25,7 +25,7 @@ export void *errors__init(void) errors_errors[6][0] = 0x00; errors_errors[7][0] = 0x00; errors_errors[8][0] = 0x00; - __MOVE("\'=\' expected", errors_errors[9], 13); + __MOVE("'=' expected", errors_errors[9], 13); errors_errors[10][0] = 0x00; errors_errors[11][0] = 0x00; __MOVE("type definition starts with incorrect symbol", errors_errors[12], 45); @@ -34,28 +34,28 @@ export void *errors__init(void) __MOVE("declaration followed by incorrect symbol", errors_errors[15], 41); __MOVE("MODULE expected", errors_errors[16], 16); errors_errors[17][0] = 0x00; - __MOVE("\'.\' missing", errors_errors[18], 12); - __MOVE("\',\' missing", errors_errors[19], 12); - __MOVE("\':\' missing", errors_errors[20], 12); + __MOVE("'.' missing", errors_errors[18], 12); + __MOVE("',' missing", errors_errors[19], 12); + __MOVE("':' missing", errors_errors[20], 12); errors_errors[21][0] = 0x00; - __MOVE("\')\' missing", errors_errors[22], 12); - __MOVE("\']\' missing", errors_errors[23], 12); - __MOVE("\'}\' missing", errors_errors[24], 12); + __MOVE("')' missing", errors_errors[22], 12); + __MOVE("']' missing", errors_errors[23], 12); + __MOVE("'}' missing", errors_errors[24], 12); __MOVE("OF missing", errors_errors[25], 11); __MOVE("THEN missing", errors_errors[26], 13); __MOVE("DO missing", errors_errors[27], 11); __MOVE("TO missing", errors_errors[28], 11); errors_errors[29][0] = 0x00; - __MOVE("\'(\' missing", errors_errors[30], 12); + __MOVE("'(' missing", errors_errors[30], 12); errors_errors[31][0] = 0x00; errors_errors[32][0] = 0x00; errors_errors[33][0] = 0x00; - __MOVE("\':=\' missing", errors_errors[34], 13); - __MOVE("\',\' or OF expected", errors_errors[35], 19); + __MOVE("':=' missing", errors_errors[34], 13); + __MOVE("',' or OF expected", errors_errors[35], 19); errors_errors[36][0] = 0x00; errors_errors[37][0] = 0x00; __MOVE("identifier expected", errors_errors[38], 20); - __MOVE("\';\' missing", errors_errors[39], 12); + __MOVE("';' missing", errors_errors[39], 12); errors_errors[40][0] = 0x00; __MOVE("END missing", errors_errors[41], 12); errors_errors[42][0] = 0x00; @@ -131,10 +131,10 @@ export void *errors__init(void) __MOVE("operand is not a variable", errors_errors[112], 26); __MOVE("incompatible assignment", errors_errors[113], 24); __MOVE("string too long to be assigned", errors_errors[114], 31); - __MOVE("parameter doesn\'t match", errors_errors[115], 24); - __MOVE("number of parameters doesn\'t match", errors_errors[116], 35); - __MOVE("result type doesn\'t match", errors_errors[117], 26); - __MOVE("export mark doesn\'t match with forward declaration", errors_errors[118], 51); + __MOVE("parameter doesn't match", errors_errors[115], 24); + __MOVE("number of parameters doesn't match", errors_errors[116], 35); + __MOVE("result type doesn't match", errors_errors[117], 26); + __MOVE("export mark doesn't match with forward declaration", errors_errors[118], 51); __MOVE("redefinition textually precedes procedure bound to base type", errors_errors[119], 61); __MOVE("type of expression following IF, WHILE, UNTIL or ASSERT is not BOOLEAN", errors_errors[120], 71); __MOVE("called object is not a procedure (or is an interrupt procedure)", errors_errors[121], 64); @@ -194,5 +194,6 @@ export void *errors__init(void) __MOVE("implicit type cast", errors_errors[301], 19); __MOVE("inappropriate symbol file ignored", errors_errors[306], 34); __MOVE("no ELSE symbol after CASE statement sequence may lead to trap", errors_errors[307], 62); + __MOVE("SYSTEM.VAL result includes memory past end of source variable", errors_errors[308], 62); __ENDMOD; } diff --git a/bootstrap/windows-48/errors.h b/bootstrap/windows-48/errors.h index 5068083b..41d399ad 100644 --- a/bootstrap/windows-48/errors.h +++ b/bootstrap/windows-48/errors.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef errors__h #define errors__h diff --git a/bootstrap/windows-48/extTools.c b/bootstrap/windows-48/extTools.c index 03bd540b..4efd107a 100644 --- a/bootstrap/windows-48/extTools.c +++ b/bootstrap/windows-48/extTools.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Configuration.h" #include "Console.h" diff --git a/bootstrap/windows-48/extTools.h b/bootstrap/windows-48/extTools.h index 695ea164..fc4f0da1 100644 --- a/bootstrap/windows-48/extTools.h +++ b/bootstrap/windows-48/extTools.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef extTools__h #define extTools__h diff --git a/bootstrap/windows-48/vt100.c b/bootstrap/windows-48/vt100.c index c499aceb..d77b0b84 100644 --- a/bootstrap/windows-48/vt100.c +++ b/bootstrap/windows-48/vt100.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #include "SYSTEM.h" #include "Console.h" #include "Strings.h" @@ -252,7 +252,7 @@ export void *vt100__init(void) __REGCMD("RCP", vt100_RCP); __REGCMD("SCP", vt100_SCP); /* BEGIN */ - __COPY("", vt100_CSI, ((LONGINT)(5))); + __COPY("\033", vt100_CSI, ((LONGINT)(5))); Strings_Append((CHAR*)"[", (LONGINT)2, (void*)vt100_CSI, ((LONGINT)(5))); __ENDMOD; } diff --git a/bootstrap/windows-48/vt100.h b/bootstrap/windows-48/vt100.h index 1aaeca77..4af04d6e 100644 --- a/bootstrap/windows-48/vt100.h +++ b/bootstrap/windows-48/vt100.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef vt100__h #define vt100__h diff --git a/bootstrap/windows-88/Configuration.c b/bootstrap/windows-88/Configuration.c index 951bea6e..47f1ffc7 100644 --- a/bootstrap/windows-88/Configuration.c +++ b/bootstrap/windows-88/Configuration.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" @@ -14,6 +14,6 @@ export void *Configuration__init(void) __DEFMOD; __REGMOD("Configuration", 0); /* BEGIN */ - __MOVE("1.95 [2016/08/24] for gcc LP64 on cygwin", Configuration_versionLong, 41); + __MOVE("1.95 [2016/08/23] for gcc LP64 on cygwin", Configuration_versionLong, 41); __ENDMOD; } diff --git a/bootstrap/windows-88/Configuration.h b/bootstrap/windows-88/Configuration.h index 15594379..ba0bbd99 100644 --- a/bootstrap/windows-88/Configuration.h +++ b/bootstrap/windows-88/Configuration.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Configuration__h #define Configuration__h diff --git a/bootstrap/windows-88/Console.c b/bootstrap/windows-88/Console.c index 0e1c708d..5a9998a9 100644 --- a/bootstrap/windows-88/Console.c +++ b/bootstrap/windows-88/Console.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "Platform.h" @@ -22,7 +22,7 @@ export void Console_String (CHAR *s, LONGINT s__len); void Console_Flush (void) { INTEGER error; - error = Platform_Write(Platform_StdOut, (LONGINT)(uintptr_t)Console_line, Console_pos); + error = Platform_Write(Platform_StdOut, (LONGINT)(SYSTEM_ADDRESS)Console_line, Console_pos); Console_pos = 0; } diff --git a/bootstrap/windows-88/Console.h b/bootstrap/windows-88/Console.h index 11152de0..4606384c 100644 --- a/bootstrap/windows-88/Console.h +++ b/bootstrap/windows-88/Console.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Console__h #define Console__h diff --git a/bootstrap/windows-88/Files.c b/bootstrap/windows-88/Files.c index b9b748e0..c46ffdd2 100644 --- a/bootstrap/windows-88/Files.c +++ b/bootstrap/windows-88/Files.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #define LARGE #include "SYSTEM.h" #include "Configuration.h" @@ -258,7 +258,7 @@ static void Files_Flush (Files_Buffer buf) if (buf->org != f->pos) { error = Platform_Seek(f->fd, buf->org, Platform_SeekSet); } - error = Platform_Write(f->fd, (LONGINT)(uintptr_t)buf->data, buf->size); + error = Platform_Write(f->fd, (LONGINT)(SYSTEM_ADDRESS)buf->data, buf->size); if (error != 0) { Files_Err((CHAR*)"error writing file", (LONGINT)19, f, error); } @@ -657,7 +657,7 @@ void Files_ReadBytes (Files_Rider *r, LONGINT *r__typ, SYSTEM_BYTE *x, LONGINT x } else { min = n; } - __MOVE((LONGINT)(uintptr_t)buf->data + offset, (LONGINT)(uintptr_t)x + xpos, min); + __MOVE((LONGINT)(SYSTEM_ADDRESS)buf->data + offset, (LONGINT)(SYSTEM_ADDRESS)x + xpos, min); offset += min; (*r).offset = offset; xpos += min; @@ -722,7 +722,7 @@ void Files_WriteBytes (Files_Rider *r, LONGINT *r__typ, SYSTEM_BYTE *x, LONGINT } else { min = n; } - __MOVE((LONGINT)(uintptr_t)x + xpos, (LONGINT)(uintptr_t)buf->data + offset, min); + __MOVE((LONGINT)(SYSTEM_ADDRESS)x + xpos, (LONGINT)(SYSTEM_ADDRESS)buf->data + offset, min); offset += min; (*r).offset = offset; if (offset > buf->size) { @@ -773,15 +773,15 @@ void Files_Rename (CHAR *old, LONGINT old__len, CHAR *new, LONGINT new__len, INT *res = 3; return; } - error = Platform_Read(fdold, (LONGINT)(uintptr_t)buf, ((LONGINT)(4096)), &n); + error = Platform_Read(fdold, (LONGINT)(SYSTEM_ADDRESS)buf, ((LONGINT)(4096)), &n); while (n > 0) { - error = Platform_Write(fdnew, (LONGINT)(uintptr_t)buf, n); + error = Platform_Write(fdnew, (LONGINT)(SYSTEM_ADDRESS)buf, n); if (error != 0) { ignore = Platform_Close(fdold); ignore = Platform_Close(fdnew); Files_Err((CHAR*)"cannot move file", (LONGINT)17, NIL, error); } - error = Platform_Read(fdold, (LONGINT)(uintptr_t)buf, ((LONGINT)(4096)), &n); + error = Platform_Read(fdold, (LONGINT)(SYSTEM_ADDRESS)buf, ((LONGINT)(4096)), &n); } ignore = Platform_Close(fdold); ignore = Platform_Close(fdnew); @@ -839,7 +839,7 @@ static void Files_FlipBytes (SYSTEM_BYTE *src, LONGINT src__len, SYSTEM_BYTE *de j += 1; } } else { - __MOVE((LONGINT)(uintptr_t)src, (LONGINT)(uintptr_t)dest, src__len); + __MOVE((LONGINT)(SYSTEM_ADDRESS)src, (LONGINT)(SYSTEM_ADDRESS)dest, src__len); } } @@ -865,8 +865,10 @@ void Files_ReadLInt (Files_Rider *R, LONGINT *R__typ, LONGINT *x) void Files_ReadSet (Files_Rider *R, LONGINT *R__typ, SET *x) { CHAR b[4]; + LONGINT l; Files_ReadBytes(&*R, R__typ, (void*)b, ((LONGINT)(4)), ((LONGINT)(4))); - *x = (SET)((((int)b[0] + __ASHL((int)b[1], 8)) + __ASHL((int)b[2], 16)) + __ASHL((int)b[3], 24)); + l = (((int)b[0] + __ASHL((int)b[1], 8)) + __ASHL((int)b[2], 16)) + __ASHL((int)b[3], 24); + *x = (SET)l; } void Files_ReadReal (Files_Rider *R, LONGINT *R__typ, REAL *x) @@ -922,11 +924,11 @@ void Files_ReadNum (Files_Rider *R, LONGINT *R__typ, LONGINT *x) n = 0; Files_Read(&*R, R__typ, (void*)&ch); while ((int)ch >= 128) { - n += __ASH((LONGINT)((int)ch - 128), s); + n += __ASH((SYSTEM_INT64)((int)ch - 128), s); s += 7; Files_Read(&*R, R__typ, (void*)&ch); } - n += __ASH((LONGINT)(__MASK((int)ch, -64) - __ASHL(__ASHR((int)ch, 6), 6)), s); + n += __ASH((SYSTEM_INT64)(__MASK((int)ch, -64) - __ASHL(__ASHR((int)ch, 6), 6)), s); *x = n; } @@ -1007,7 +1009,7 @@ static void Files_Finalize (SYSTEM_PTR o) { Files_File f = NIL; LONGINT res; - f = (Files_File)(uintptr_t)o; + f = (Files_File)(SYSTEM_ADDRESS)o; if (f->fd >= 0) { Files_CloseOSFile(f); if (f->tempFile) { diff --git a/bootstrap/windows-88/Files.h b/bootstrap/windows-88/Files.h index da7d6e44..eb946544 100644 --- a/bootstrap/windows-88/Files.h +++ b/bootstrap/windows-88/Files.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #ifndef Files__h #define Files__h diff --git a/bootstrap/windows-88/Heap.c b/bootstrap/windows-88/Heap.c index 69ba4ffb..9873a734 100644 --- a/bootstrap/windows-88/Heap.c +++ b/bootstrap/windows-88/Heap.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tskSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tskSfF */ #define LARGE #include "SYSTEM.h" @@ -102,7 +102,7 @@ export void Heap_Unlock (void); extern void *Heap__init(); extern LONGINT Platform_MainStackFrame; extern LONGINT Platform_OSAllocate(LONGINT size); -#define Heap_FetchAddress(pointer) (LONGINT)(uintptr_t)(*((void**)((uintptr_t)pointer))) +#define Heap_FetchAddress(pointer) (LONGINT)(SYSTEM_ADDRESS)(*((void**)((SYSTEM_ADDRESS)pointer))) #define Heap_HeapModuleInit() Heap__init() #define Heap_OSAllocate(size) Platform_OSAllocate(size) #define Heap_PlatformHalt(code) Platform_Halt(code) @@ -135,7 +135,7 @@ SYSTEM_PTR Heap_REGMOD (Heap_ModuleName name, Heap_EnumProc enumPtrs) __COPY(name, m->name, ((LONGINT)(20))); m->refcnt = 0; m->enumPtrs = enumPtrs; - m->next = (Heap_Module)(uintptr_t)Heap_modules; + m->next = (Heap_Module)(SYSTEM_ADDRESS)Heap_modules; Heap_modules = (SYSTEM_PTR)m; _o_result = (void*)m; return _o_result; @@ -316,7 +316,7 @@ SYSTEM_PTR Heap_NEWREC (LONGINT tag) __PUT(adr + 16, 0, LONGINT); Heap_allocated += blksz; Heap_Unlock(); - _o_result = (SYSTEM_PTR)(uintptr_t)(adr + 8); + _o_result = (SYSTEM_PTR)(SYSTEM_ADDRESS)(adr + 8); return _o_result; } @@ -327,12 +327,12 @@ SYSTEM_PTR Heap_NEWBLK (LONGINT size) SYSTEM_PTR new; Heap_Lock(); blksz = __ASHL(__ASHR(size + 63, 5), 5); - new = Heap_NEWREC((LONGINT)(uintptr_t)&blksz); - tag = ((LONGINT)(uintptr_t)new + blksz) - 24; + new = Heap_NEWREC((LONGINT)(SYSTEM_ADDRESS)&blksz); + tag = ((LONGINT)(SYSTEM_ADDRESS)new + blksz) - 24; __PUT(tag - 8, 0, LONGINT); __PUT(tag, blksz, LONGINT); __PUT(tag + 8, -8, LONGINT); - __PUT((LONGINT)(uintptr_t)new - 8, tag, LONGINT); + __PUT((LONGINT)(SYSTEM_ADDRESS)new - 8, tag, LONGINT); Heap_Unlock(); _o_result = new; return _o_result; @@ -361,7 +361,7 @@ static void Heap_Mark (LONGINT q) __GET(tag, offset, LONGINT); fld = q + offset; p = Heap_FetchAddress(fld); - __PUT(fld, (SYSTEM_PTR)(uintptr_t)n, SYSTEM_PTR); + __PUT(fld, (SYSTEM_PTR)(SYSTEM_ADDRESS)n, SYSTEM_PTR); } else { fld = q + offset; n = Heap_FetchAddress(fld); @@ -370,7 +370,7 @@ static void Heap_Mark (LONGINT q) if (!__ODD(tagbits)) { __PUT(n - 8, tagbits + 1, LONGINT); __PUT(q - 8, tag + 1, LONGINT); - __PUT(fld, (SYSTEM_PTR)(uintptr_t)p, SYSTEM_PTR); + __PUT(fld, (SYSTEM_PTR)(SYSTEM_ADDRESS)p, SYSTEM_PTR); p = q; q = n; tag = tagbits; @@ -385,7 +385,7 @@ static void Heap_Mark (LONGINT q) static void Heap_MarkP (SYSTEM_PTR p) { - Heap_Mark((LONGINT)(uintptr_t)p); + Heap_Mark((LONGINT)(SYSTEM_ADDRESS)p); } static void Heap_Scan (void) @@ -554,7 +554,7 @@ static void Heap_Finalize (void) } else { prev->next = n->next; } - (*n->finalize)((SYSTEM_PTR)(uintptr_t)n->obj); + (*n->finalize)((SYSTEM_PTR)(SYSTEM_ADDRESS)n->obj); if (prev == NIL) { n = Heap_fin; } else { @@ -573,7 +573,7 @@ void Heap_FINALL (void) while (Heap_fin != NIL) { n = Heap_fin; Heap_fin = Heap_fin->next; - (*n->finalize)((SYSTEM_PTR)(uintptr_t)n->obj); + (*n->finalize)((SYSTEM_PTR)(SYSTEM_ADDRESS)n->obj); } } @@ -590,9 +590,9 @@ static void Heap_MarkStack (LONGINT n, LONGINT *cand, LONGINT cand__len) } if (n == 0) { nofcand = 0; - sp = (LONGINT)(uintptr_t)&frame; + sp = (LONGINT)(SYSTEM_ADDRESS)&frame; stack0 = Heap_PlatformMainStackFrame(); - inc = (LONGINT)(uintptr_t)&align.p - (LONGINT)(uintptr_t)&align; + inc = (LONGINT)(SYSTEM_ADDRESS)&align.p - (LONGINT)(SYSTEM_ADDRESS)&align; if (sp > stack0) { inc = -inc; } @@ -623,7 +623,7 @@ void Heap_GC (BOOLEAN markStack) LONGINT cand[10000]; if (Heap_lockdepth == 0 || (Heap_lockdepth == 1 && !markStack)) { Heap_Lock(); - m = (Heap_Module)(uintptr_t)Heap_modules; + m = (Heap_Module)(SYSTEM_ADDRESS)Heap_modules; while (m != NIL) { if (m->enumPtrs != NIL) { (*m->enumPtrs)(Heap_MarkP); @@ -700,7 +700,7 @@ void Heap_RegisterFinalizer (SYSTEM_PTR obj, Heap_Finalizer finalize) { Heap_FinNode f; __NEW(f, Heap_FinDesc); - f->obj = (LONGINT)(uintptr_t)obj; + f->obj = (LONGINT)(SYSTEM_ADDRESS)obj; f->finalize = finalize; f->marked = 1; f->next = Heap_fin; diff --git a/bootstrap/windows-88/Heap.h b/bootstrap/windows-88/Heap.h index 40db2aca..b1ff5968 100644 --- a/bootstrap/windows-88/Heap.h +++ b/bootstrap/windows-88/Heap.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tskSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tskSfF */ #ifndef Heap__h #define Heap__h diff --git a/bootstrap/windows-88/Modules.c b/bootstrap/windows-88/Modules.c index eaf370c4..0c836ead 100644 --- a/bootstrap/windows-88/Modules.c +++ b/bootstrap/windows-88/Modules.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "Console.h" diff --git a/bootstrap/windows-88/Modules.h b/bootstrap/windows-88/Modules.h index d273cf1a..6e6ded2e 100644 --- a/bootstrap/windows-88/Modules.h +++ b/bootstrap/windows-88/Modules.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Modules__h #define Modules__h diff --git a/bootstrap/windows-88/OPB.c b/bootstrap/windows-88/OPB.c index 2fccfe61..f4bdb1a8 100644 --- a/bootstrap/windows-88/OPB.c +++ b/bootstrap/windows-88/OPB.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "OPM.h" @@ -35,7 +35,9 @@ export void OPB_In (OPT_Node *x, OPT_Node y); export void OPB_Index (OPT_Node *x, OPT_Node y); export void OPB_Inittd (OPT_Node *inittd, OPT_Node *last, OPT_Struct typ); static BOOLEAN OPB_IntToBool (LONGINT i); +static OPT_Struct OPB_IntType (LONGINT size); export void OPB_Link (OPT_Node *x, OPT_Node *last, OPT_Node y); +static LONGINT OPB_LongerSize (LONGINT i); export void OPB_MOp (SHORTINT op, OPT_Node *x); export OPT_Node OPB_NewBoolConst (BOOLEAN boolval); export OPT_Node OPB_NewIntConst (LONGINT intval); @@ -52,6 +54,8 @@ export void OPB_Return (OPT_Node *x, OPT_Object proc); export void OPB_SetElem (OPT_Node *x); static void OPB_SetIntType (OPT_Node node); export void OPB_SetRange (OPT_Node *x, OPT_Node y); +static LONGINT OPB_ShorterSize (LONGINT i); +static INTEGER OPB_SignedByteSize (LONGINT n); export void OPB_StFct (OPT_Node *par0, SHORTINT fctno, INTEGER parno); export void OPB_StPar0 (OPT_Node *par0, INTEGER fctno); export void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno); @@ -91,8 +95,8 @@ OPT_Node OPB_NewLeaf (OPT_Object obj) node = OPT_NewNode(9); break; default: - OPB_err(127); node = OPT_NewNode(0); + OPB_err(127); break; } node->obj = obj; @@ -221,21 +225,68 @@ OPT_Node OPB_EmptySet (void) return _o_result; } +static INTEGER OPB_SignedByteSize (LONGINT n) +{ + INTEGER _o_result; + INTEGER b; + if (n < 0) { + n = -(n + 1); + } + b = 1; + while ((b < 8 && __ASH(n, -(__ASHL(b, 3) - 1)) != 0)) { + b += 1; + } + _o_result = b; + return _o_result; +} + +static LONGINT OPB_ShorterSize (LONGINT i) +{ + LONGINT _o_result; + if (i >= (SYSTEM_INT64)OPM_LIntSize) { + _o_result = OPM_IntSize; + return _o_result; + } else { + _o_result = OPM_SIntSize; + return _o_result; + } + __RETCHK; +} + +static LONGINT OPB_LongerSize (LONGINT i) +{ + LONGINT _o_result; + if (i <= (SYSTEM_INT64)OPM_SIntSize) { + _o_result = OPM_IntSize; + return _o_result; + } else { + _o_result = OPM_LIntSize; + return _o_result; + } + __RETCHK; +} + +static OPT_Struct OPB_IntType (LONGINT size) +{ + OPT_Struct _o_result; + OPT_Struct result = NIL; + if (size <= OPT_sinttyp->size) { + result = OPT_sinttyp; + } else if (size <= OPT_inttyp->size) { + result = OPT_inttyp; + } else { + result = OPT_linttyp; + } + if (size > OPT_linttyp->size) { + OPB_err(203); + } + _o_result = result; + return _o_result; +} + static void OPB_SetIntType (OPT_Node node) { - LONGINT v; - v = node->conval->intval; - if ((OPM_MinSInt <= (LONGINT)v && (LONGINT)v <= OPM_MaxSInt)) { - node->typ = OPT_sinttyp; - } else if ((OPM_MinInt <= (LONGINT)v && (LONGINT)v <= OPM_MaxInt)) { - node->typ = OPT_inttyp; - } else if ((OPM_MinLInt <= v && v <= OPM_MaxLInt)) { - node->typ = OPT_linttyp; - } else { - OPB_err(203); - node->typ = OPT_sinttyp; - node->conval->intval = 1; - } + node->typ = OPB_IntType(OPB_SignedByteSize(node->conval->intval)); } OPT_Node OPB_NewIntConst (LONGINT intval) @@ -379,16 +430,16 @@ void OPB_Field (OPT_Node *x, OPT_Object y) } } -static struct TypTest__57 { +static struct TypTest__61 { OPT_Node *x; OPT_Object *obj; BOOLEAN *guard; - struct TypTest__57 *lnk; -} *TypTest__57_s; + struct TypTest__61 *lnk; +} *TypTest__61_s; -static void GTT__58 (OPT_Struct t0, OPT_Struct t1); +static void GTT__62 (OPT_Struct t0, OPT_Struct t1); -static void GTT__58 (OPT_Struct t0, OPT_Struct t1) +static void GTT__62 (OPT_Struct t0, OPT_Struct t1) { OPT_Node node = NIL; OPT_Struct t = NIL; @@ -401,54 +452,54 @@ static void GTT__58 (OPT_Struct t0, OPT_Struct t1) t1 = t1->BaseTyp; } if (t1 == t0 || t0->form == 0) { - if (*TypTest__57_s->guard) { - OPB_BindNodes(5, NIL, &*TypTest__57_s->x, NIL); - (*TypTest__57_s->x)->readonly = (*TypTest__57_s->x)->left->readonly; + if (*TypTest__61_s->guard) { + OPB_BindNodes(5, NIL, &*TypTest__61_s->x, NIL); + (*TypTest__61_s->x)->readonly = (*TypTest__61_s->x)->left->readonly; } else { node = OPT_NewNode(11); node->subcl = 16; - node->left = *TypTest__57_s->x; - node->obj = *TypTest__57_s->obj; - *TypTest__57_s->x = node; + node->left = *TypTest__61_s->x; + node->obj = *TypTest__61_s->obj; + *TypTest__61_s->x = node; } } else { OPB_err(85); } } else if (t0 != t1) { OPB_err(85); - } else if (!*TypTest__57_s->guard) { - if ((*TypTest__57_s->x)->class == 5) { + } else if (!*TypTest__61_s->guard) { + if ((*TypTest__61_s->x)->class == 5) { node = OPT_NewNode(11); node->subcl = 16; - node->left = *TypTest__57_s->x; - node->obj = *TypTest__57_s->obj; - *TypTest__57_s->x = node; + node->left = *TypTest__61_s->x; + node->obj = *TypTest__61_s->obj; + *TypTest__61_s->x = node; } else { - *TypTest__57_s->x = OPB_NewBoolConst(1); + *TypTest__61_s->x = OPB_NewBoolConst(1); } } } void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard) { - struct TypTest__57 _s; + struct TypTest__61 _s; _s.x = x; _s.obj = &obj; _s.guard = &guard; - _s.lnk = TypTest__57_s; - TypTest__57_s = &_s; + _s.lnk = TypTest__61_s; + TypTest__61_s = &_s; if (OPB_NotVar(*x)) { OPB_err(112); } else if ((*x)->typ->form == 13) { if (((*x)->typ->BaseTyp->comp != 4 && (*x)->typ != OPT_sysptrtyp)) { OPB_err(85); } else if (obj->typ->form == 13) { - GTT__58((*x)->typ->BaseTyp, obj->typ->BaseTyp); + GTT__62((*x)->typ->BaseTyp, obj->typ->BaseTyp); } else { OPB_err(86); } } else if (((((*x)->typ->comp == 4 && (*x)->class == 1)) && obj->typ->comp == 4)) { - GTT__58((*x)->typ, obj->typ); + GTT__62((*x)->typ, obj->typ); } else { OPB_err(87); } @@ -457,7 +508,7 @@ void OPB_TypTest (OPT_Node *x, OPT_Object obj, BOOLEAN guard) } else { (*x)->typ = OPT_booltyp; } - TypTest__57_s = _s.lnk; + TypTest__61_s = _s.lnk; } void OPB_In (OPT_Node *x, OPT_Node y) @@ -470,7 +521,7 @@ void OPB_In (OPT_Node *x, OPT_Node y) } else if ((__IN(f, 0x70) && y->typ->form == 9)) { if ((*x)->class == 7) { k = (*x)->conval->intval; - if (k < 0 || k > (LONGINT)OPM_MaxSet) { + if (k < 0 || k > (SYSTEM_INT64)OPM_MaxSet) { OPB_err(202); } else if (y->class == 7) { (*x)->conval->intval = OPB_BoolToInt(__IN(k, y->conval->setval)); @@ -523,13 +574,13 @@ static void OPB_CheckRealType (INTEGER f, INTEGER nr, OPT_Const x) x->intval = -1; } -static struct MOp__28 { - struct MOp__28 *lnk; -} *MOp__28_s; +static struct MOp__30 { + struct MOp__30 *lnk; +} *MOp__30_s; -static OPT_Node NewOp__29 (SHORTINT op, OPT_Struct typ, OPT_Node z); +static OPT_Node NewOp__31 (SHORTINT op, OPT_Struct typ, OPT_Node z); -static OPT_Node NewOp__29 (SHORTINT op, OPT_Struct typ, OPT_Node z) +static OPT_Node NewOp__31 (SHORTINT op, OPT_Struct typ, OPT_Node z) { OPT_Node _o_result; OPT_Node node = NIL; @@ -546,9 +597,9 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) INTEGER f; OPT_Struct typ = NIL; OPT_Node z = NIL; - struct MOp__28 _s; - _s.lnk = MOp__28_s; - MOp__28_s = &_s; + struct MOp__30 _s; + _s.lnk = MOp__30_s; + MOp__30_s = &_s; z = *x; if (z->class == 8 || z->class == 9) { OPB_err(126); @@ -562,7 +613,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) z->conval->intval = OPB_BoolToInt(!OPB_IntToBool(z->conval->intval)); z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(98); @@ -590,7 +641,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) } z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(97); @@ -611,7 +662,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) } z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(111); @@ -623,7 +674,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) z->conval->intval = (int)__CAP((CHAR)z->conval->intval); z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(111); @@ -636,7 +687,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) z->conval->intval = OPB_BoolToInt(__ODD(z->conval->intval)); z->obj = NIL; } else { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } } else { OPB_err(111); @@ -649,7 +700,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) f = 10; } if (z->class < 7 || f == 10) { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } else { OPB_err(127); } @@ -658,7 +709,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) case 25: if ((__IN(f, 0x70) && z->class == 7)) { if ((0 <= z->conval->intval && z->conval->intval <= -1)) { - z = NewOp__29(op, typ, z); + z = NewOp__31(op, typ, z); } else { OPB_err(219); } @@ -675,7 +726,7 @@ void OPB_MOp (SHORTINT op, OPT_Node *x) } } *x = z; - MOp__28_s = _s.lnk; + MOp__30_s = _s.lnk; } static void OPB_CheckPtr (OPT_Node x, OPT_Node y) @@ -866,41 +917,13 @@ static void OPB_ConstOp (INTEGER op, OPT_Node x, OPT_Node y) __GUARDEQP(yval, OPT_ConstDesc) = *xval; } break; - case 4: + case 4: case 5: case 6: if (__IN(g, 0x70)) { - x->typ = y->typ; - } else if (g == 7) { - x->typ = OPT_realtyp; - xval->realval = xval->intval; - } else if (g == 8) { - x->typ = OPT_lrltyp; - xval->realval = xval->intval; - } else { - OPB_err(100); - y->typ = x->typ; - __GUARDEQP(yval, OPT_ConstDesc) = *xval; - } - break; - case 5: - if (g == 4) { - y->typ = OPT_inttyp; - } else if (__IN(g, 0x70)) { - x->typ = y->typ; - } else if (g == 7) { - x->typ = OPT_realtyp; - xval->realval = xval->intval; - } else if (g == 8) { - x->typ = OPT_lrltyp; - xval->realval = xval->intval; - } else { - OPB_err(100); - y->typ = x->typ; - __GUARDEQP(yval, OPT_ConstDesc) = *xval; - } - break; - case 6: - if (__IN(g, 0x70)) { - y->typ = OPT_linttyp; + if (x->typ->size <= y->typ->size) { + x->typ = y->typ; + } else { + x->typ = OPB_IntType(x->typ->size); + } } else if (g == 7) { x->typ = OPT_realtyp; xval->realval = xval->intval; @@ -1197,15 +1220,15 @@ static void OPB_Convert (OPT_Node *x, OPT_Struct typ) (*x)->typ = typ; } -static struct Op__38 { +static struct Op__40 { INTEGER *f, *g; - struct Op__38 *lnk; -} *Op__38_s; + struct Op__40 *lnk; +} *Op__40_s; -static void NewOp__39 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y); -static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y); +static void NewOp__41 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y); +static BOOLEAN strings__43 (OPT_Node *x, OPT_Node *y); -static void NewOp__39 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y) +static void NewOp__41 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y) { OPT_Node node = NIL; node = OPT_NewNode(12); @@ -1216,29 +1239,29 @@ static void NewOp__39 (SHORTINT op, OPT_Struct typ, OPT_Node *x, OPT_Node y) *x = node; } -static BOOLEAN strings__41 (OPT_Node *x, OPT_Node *y) +static BOOLEAN strings__43 (OPT_Node *x, OPT_Node *y) { BOOLEAN _o_result; BOOLEAN ok, xCharArr, yCharArr; - xCharArr = (__IN((*x)->typ->comp, 0x0c) && (*x)->typ->BaseTyp->form == 3) || *Op__38_s->f == 10; - yCharArr = (__IN((*y)->typ->comp, 0x0c) && (*y)->typ->BaseTyp->form == 3) || *Op__38_s->g == 10; - if ((((xCharArr && *Op__38_s->g == 3)) && (*y)->class == 7)) { + xCharArr = (__IN((*x)->typ->comp, 0x0c) && (*x)->typ->BaseTyp->form == 3) || *Op__40_s->f == 10; + yCharArr = (__IN((*y)->typ->comp, 0x0c) && (*y)->typ->BaseTyp->form == 3) || *Op__40_s->g == 10; + if ((((xCharArr && *Op__40_s->g == 3)) && (*y)->class == 7)) { OPB_CharToString(*y); - *Op__38_s->g = 10; + *Op__40_s->g = 10; yCharArr = 1; } - if ((((yCharArr && *Op__38_s->f == 3)) && (*x)->class == 7)) { + if ((((yCharArr && *Op__40_s->f == 3)) && (*x)->class == 7)) { OPB_CharToString(*x); - *Op__38_s->f = 10; + *Op__40_s->f = 10; xCharArr = 1; } ok = (xCharArr && yCharArr); if (ok) { - if ((*Op__38_s->f == 10 && (*x)->conval->intval2 == 1)) { + if ((*Op__40_s->f == 10 && (*x)->conval->intval2 == 1)) { (*x)->typ = OPT_chartyp; (*x)->conval->intval = 0; OPB_Index(&*y, OPB_NewIntConst(((LONGINT)(0)))); - } else if ((*Op__38_s->g == 10 && (*y)->conval->intval2 == 1)) { + } else if ((*Op__40_s->g == 10 && (*y)->conval->intval2 == 1)) { (*y)->typ = OPT_chartyp; (*y)->conval->intval = 0; OPB_Index(&*x, OPB_NewIntConst(((LONGINT)(0)))); @@ -1255,11 +1278,11 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPT_Struct typ = NIL; BOOLEAN do_; LONGINT val; - struct Op__38 _s; + struct Op__40 _s; _s.f = &f; _s.g = &g; - _s.lnk = Op__38_s; - Op__38_s = &_s; + _s.lnk = Op__40_s; + Op__40_s = &_s; z = *x; if (((z->class == 8 || z->class == 9) || y->class == 8) || y->class == 9) { OPB_err(126); @@ -1277,15 +1300,8 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(100); } break; - case 4: - if (__IN(g, 0x01f0)) { - OPB_Convert(&z, y->typ); - } else { - OPB_err(100); - } - break; - case 5: - if (g == 4) { + case 4: case 5: case 6: + if ((__IN(g, 0x70) && y->typ->size < z->typ->size)) { OPB_Convert(&y, z->typ); } else if (__IN(g, 0x01f0)) { OPB_Convert(&z, y->typ); @@ -1293,15 +1309,6 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(100); } break; - case 6: - if (__IN(g, 0x70)) { - OPB_Convert(&y, z->typ); - } else if (__IN(g, 0x0180)) { - OPB_Convert(&z, y->typ); - } else { - OPB_err(100); - } - break; case 7: if (__IN(g, 0x70)) { OPB_Convert(&y, z->typ); @@ -1387,7 +1394,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) typ = OPT_undftyp; } if (do_) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 2: @@ -1406,7 +1413,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(102); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; case 3: do_ = 1; @@ -1429,7 +1436,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) typ = OPT_undftyp; } if (do_) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 4: @@ -1447,7 +1454,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(104); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; case 5: if (f == 2) { @@ -1457,7 +1464,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } else if ((y->class == 7 && OPB_IntToBool(y->conval->intval))) { } else { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } } else if (f != 0) { OPB_err(94); @@ -1480,7 +1487,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } if (do_) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 7: @@ -1489,7 +1496,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) typ = OPT_undftyp; } if ((!__IN(f, 0x70) || y->class != 7) || y->conval->intval != 0) { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } break; case 8: @@ -1500,7 +1507,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } else if ((y->class == 7 && !OPB_IntToBool(y->conval->intval))) { } else { - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); } } else if (f != 0) { OPB_err(95); @@ -1508,16 +1515,16 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } break; case 9: case 10: - if (__IN(f, 0x6bff) || strings__41(&z, &y)) { + if (__IN(f, 0x6bff) || strings__43(&z, &y)) { typ = OPT_booltyp; } else { OPB_err(107); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; case 11: case 12: case 13: case 14: - if (__IN(f, 0x01f9) || strings__41(&z, &y)) { + if (__IN(f, 0x01f9) || strings__43(&z, &y)) { typ = OPT_booltyp; } else { OPM_LogWLn(); @@ -1526,7 +1533,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) OPB_err(108); typ = OPT_undftyp; } - NewOp__39(op, typ, &z, y); + NewOp__41(op, typ, &z, y); break; default: OPM_LogWStr((CHAR*)"unhandled case in OPB.Op, op = ", (LONGINT)32); @@ -1536,7 +1543,7 @@ void OPB_Op (SHORTINT op, OPT_Node *x, OPT_Node y) } } *x = z; - Op__38_s = _s.lnk; + Op__40_s = _s.lnk; } void OPB_SetRange (OPT_Node *x, OPT_Node y) @@ -1547,13 +1554,13 @@ void OPB_SetRange (OPT_Node *x, OPT_Node y) } else if ((__IN((*x)->typ->form, 0x70) && __IN(y->typ->form, 0x70))) { if ((*x)->class == 7) { k = (*x)->conval->intval; - if (0 > k || k > (LONGINT)OPM_MaxSet) { + if (0 > k || k > (SYSTEM_INT64)OPM_MaxSet) { OPB_err(202); } } if (y->class == 7) { l = y->conval->intval; - if (0 > l || l > (LONGINT)OPM_MaxSet) { + if (0 > l || l > (SYSTEM_INT64)OPM_MaxSet) { OPB_err(202); } } @@ -1583,7 +1590,7 @@ void OPB_SetElem (OPT_Node *x) OPB_err(93); } else if ((*x)->class == 7) { k = (*x)->conval->intval; - if ((0 <= k && k <= (LONGINT)OPM_MaxSet)) { + if ((0 <= k && k <= (SYSTEM_INT64)OPM_MaxSet)) { (*x)->conval->setval = __SETOF(k); } else { OPB_err(202); @@ -1597,8 +1604,9 @@ void OPB_SetElem (OPT_Node *x) static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) { + OPT_Struct y = NIL; INTEGER f, g; - OPT_Struct y = NIL, p = NIL, q = NIL; + OPT_Struct p = NIL, q = NIL; if (OPM_Verbose) { OPM_LogWLn(); OPM_LogWStr((CHAR*)"PROCEDURE CheckAssign", (LONGINT)22); @@ -1628,31 +1636,20 @@ static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) case 0: case 10: break; case 1: - if (!__IN(g, 0x1a)) { + if (!((__IN(g, 0x7a) && y->size == 1))) { OPB_err(113); } break; - case 2: case 3: case 4: case 9: + case 2: case 3: case 9: if (g != f) { OPB_err(113); } break; - case 5: - if (!__IN(g, 0x30)) { + case 4: case 5: case 6: + if (!__IN(g, 0x70) || x->size < y->size) { OPB_err(113); } break; - case 6: - if (OPM_LIntSize == 4) { - if (!__IN(g, 0x70)) { - OPB_err(113); - } - } else { - if (!__IN(g, 0x70)) { - OPB_err(113); - } - } - break; case 7: if (!__IN(g, 0xf0)) { OPB_err(113); @@ -1833,14 +1830,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) x = OPB_NewIntConst(((LONGINT)(0))); x->typ = OPT_chartyp; break; - case 4: - x = OPB_NewIntConst(OPM_MinSInt); - break; - case 5: - x = OPB_NewIntConst(OPM_MinInt); - break; - case 6: - x = OPB_NewIntConst(OPM_MinLInt); + case 4: case 5: case 6: + x = OPB_NewIntConst(OPM_SignedMinimum(x->typ->size)); break; case 9: x = OPB_NewIntConst(((LONGINT)(0))); @@ -1870,14 +1861,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) x = OPB_NewIntConst(((LONGINT)(255))); x->typ = OPT_chartyp; break; - case 4: - x = OPB_NewIntConst(OPM_MaxSInt); - break; - case 5: - x = OPB_NewIntConst(OPM_MaxInt); - break; - case 6: - x = OPB_NewIntConst(OPM_MaxLInt); + case 4: case 5: case 6: + x = OPB_NewIntConst(OPM_SignedMaximum(x->typ->size)); break; case 9: x = OPB_NewIntConst(OPM_MaxSet); @@ -1910,10 +1895,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) case 10: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if (f == 5) { - OPB_Convert(&x, OPT_sinttyp); - } else if (f == 6) { - OPB_Convert(&x, OPT_inttyp); + } else if ((__IN(f, 0x70) && x->typ->size > (SYSTEM_INT64)OPM_SIntSize)) { + OPB_Convert(&x, OPB_IntType(OPB_ShorterSize(x->typ->size))); } else if (f == 8) { OPB_Convert(&x, OPT_realtyp); } else { @@ -1923,10 +1906,8 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) case 11: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if (f == 4) { - OPB_Convert(&x, OPT_inttyp); - } else if (f == 5) { - OPB_Convert(&x, OPT_linttyp); + } else if ((__IN(f, 0x70) && x->typ->size < (SYSTEM_INT64)OPM_LIntSize)) { + OPB_Convert(&x, OPB_IntType(OPB_LongerSize(x->typ->size))); } else if (f == 7) { OPB_Convert(&x, OPT_lrltyp); } else if (f == 3) { @@ -1974,7 +1955,7 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - if (f != 6) { + if (x->typ->size != (SYSTEM_INT64)OPM_LIntSize) { OPB_Convert(&x, OPT_linttyp); } } else { @@ -2012,9 +1993,9 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) case 24: case 25: case 28: case 31: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if ((x->class == 7 && __IN(f, 0x30))) { + } else if ((((x->class == 7 && __IN(f, 0x70))) && x->typ->size < OPT_linttyp->size)) { OPB_Convert(&x, OPT_linttyp); - } else if (!__IN(f, 0x2040)) { + } else if (!((__IN(x->typ->form, 0x2070) && x->typ->size == (SYSTEM_INT64)OPM_PointerSize))) { OPB_err(111); x->typ = OPT_linttyp; } @@ -2063,13 +2044,13 @@ void OPB_StPar0 (OPT_Node *par0, INTEGER fctno) *par0 = x; } -static struct StPar1__52 { - struct StPar1__52 *lnk; -} *StPar1__52_s; +static struct StPar1__56 { + struct StPar1__56 *lnk; +} *StPar1__56_s; -static OPT_Node NewOp__53 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right); +static OPT_Node NewOp__57 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right); -static OPT_Node NewOp__53 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right) +static OPT_Node NewOp__57 (SHORTINT class, SHORTINT subcl, OPT_Node left, OPT_Node right) { OPT_Node _o_result; OPT_Node node = NIL; @@ -2086,9 +2067,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) INTEGER f, L; OPT_Struct typ = NIL; OPT_Node p = NIL, t = NIL; - struct StPar1__52 _s; - _s.lnk = StPar1__52_s; - StPar1__52_s = &_s; + struct StPar1__56 _s; + _s.lnk = StPar1__56_s; + StPar1__56_s = &_s; p = *par0; f = x->typ->form; switch (fctno) { @@ -2104,7 +2085,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) OPB_err(111); } } - p = NewOp__53(19, fctno, p, x); + p = NewOp__57(19, fctno, p, x); p->typ = OPT_notyp; } break; @@ -2112,10 +2093,10 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - if ((x->class == 7 && (0 > x->conval->intval || x->conval->intval > (LONGINT)OPM_MaxSet))) { + if ((x->class == 7 && (0 > x->conval->intval || x->conval->intval > (SYSTEM_INT64)OPM_MaxSet))) { OPB_err(202); } - p = NewOp__53(19, fctno, p, x); + p = NewOp__57(19, fctno, p, x); } else { OPB_err(111); } @@ -2124,7 +2105,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) case 17: if (!__IN(f, 0x70) || x->class != 7) { OPB_err(69); - } else if (f == 4) { + } else if (x->typ->size == 1) { L = (int)x->conval->intval; typ = p->typ; while ((L > 0 && __IN(typ->comp, 0x0c))) { @@ -2140,7 +2121,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) p = p->left; x->conval->intval += 1; } - p = NewOp__53(12, 19, p, x); + p = NewOp__57(12, 19, p, x); p->typ = OPT_linttyp; } else { p = x; @@ -2162,7 +2143,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) t = x; x = p; p = t; - p = NewOp__53(19, 18, p, x); + p = NewOp__57(19, 18, p, x); } else { OPB_err(111); } @@ -2188,7 +2169,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) } p->obj = NIL; } else { - p = NewOp__53(12, 17, p, x); + p = NewOp__57(12, 17, p, x); p->typ = OPT_linttyp; } } else { @@ -2219,9 +2200,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) OPB_err(111); } else { if (fctno == 22) { - p = NewOp__53(12, 27, p, x); + p = NewOp__57(12, 27, p, x); } else { - p = NewOp__53(12, 28, p, x); + p = NewOp__57(12, 28, p, x); } p->typ = p->left->typ; } @@ -2238,7 +2219,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) x = p; p = t; } - p = NewOp__53(19, fctno, p, x); + p = NewOp__57(19, fctno, p, x); } else { OPB_err(111); } @@ -2248,7 +2229,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - p = NewOp__53(12, 26, p, x); + p = NewOp__57(12, 26, p, x); } else { OPB_err(111); } @@ -2258,6 +2239,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (((x->class == 8 || x->class == 9) || __IN(f, 0x1401)) || x->typ->comp == 3) { OPB_err(126); } + if (x->typ->size < p->typ->size) { + OPB_err(-308); + } t = OPT_NewNode(11); t->subcl = 29; t->left = x; @@ -2269,7 +2253,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) if (x->class == 8 || x->class == 9) { OPB_err(126); } else if (__IN(f, 0x70)) { - p = NewOp__53(19, 30, p, x); + p = NewOp__57(19, 30, p, x); } else { OPB_err(111); } @@ -2278,9 +2262,9 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) case 31: if (x->class == 8 || x->class == 9) { OPB_err(126); - } else if ((x->class == 7 && __IN(f, 0x30))) { + } else if ((((x->class == 7 && __IN(f, 0x70))) && x->typ->size < OPT_linttyp->size)) { OPB_Convert(&x, OPT_linttyp); - } else if (!__IN(f, 0x2040)) { + } else if (!((__IN(x->typ->form, 0x2070) && x->typ->size == (SYSTEM_INT64)OPM_PointerSize))) { OPB_err(111); x->typ = OPT_linttyp; } @@ -2315,7 +2299,7 @@ void OPB_StPar1 (OPT_Node *par0, OPT_Node x, SHORTINT fctno) break; } *par0 = p; - StPar1__52_s = _s.lnk; + StPar1__56_s = _s.lnk; } void OPB_StParN (OPT_Node *par0, OPT_Node x, INTEGER fctno, INTEGER n) @@ -2434,7 +2418,7 @@ static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpa ftyp = ftyp->BaseTyp; atyp = atyp->BaseTyp; if ((fvarpar && ftyp == OPT_bytetyp)) { - if (!__IN(f, 0x0c) || !__IN(atyp->form, 0x1e)) { + if (!__IN(f, 0x0c) || !((__IN(atyp->form, 0x7e) && atyp->size == 1))) { if (__IN(18, OPM_opt)) { OPB_err(-301); } @@ -2517,7 +2501,7 @@ void OPB_Param (OPT_Node ap, OPT_Object fp) OPB_err(111); } } else if ((fp->typ == OPT_sysptrtyp && ap->typ->form == 13)) { - } else if ((ap->typ != fp->typ && !((fp->typ->form == 1 && __IN(ap->typ->form, 0x18))))) { + } else if ((ap->typ != fp->typ && !((fp->typ->form == 1 && ((__IN(ap->typ->form, 0x7e) && ap->typ->size == 1)))))) { OPB_err(123); } else if ((fp->typ->form == 13 && ap->class == 5)) { OPB_err(123); diff --git a/bootstrap/windows-88/OPB.h b/bootstrap/windows-88/OPB.h index 48c946c5..af419f75 100644 --- a/bootstrap/windows-88/OPB.h +++ b/bootstrap/windows-88/OPB.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPB__h #define OPB__h diff --git a/bootstrap/windows-88/OPC.c b/bootstrap/windows-88/OPC.c index 40697da9..bb9b75e6 100644 --- a/bootstrap/windows-88/OPC.c +++ b/bootstrap/windows-88/OPC.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "Configuration.h" @@ -17,12 +17,13 @@ static CHAR OPC_BodyNameExt[13]; export void OPC_Align (LONGINT *adr, LONGINT base); export void OPC_Andent (OPT_Struct typ); static void OPC_AnsiParamList (OPT_Object obj, BOOLEAN showParamNames); -export LONGINT OPC_Base (OPT_Struct typ); +export LONGINT OPC_BaseAlignment (OPT_Struct typ); export OPT_Object OPC_BaseTProc (OPT_Object obj); export void OPC_BegBlk (void); export void OPC_BegStat (void); static void OPC_CProcDefs (OPT_Object obj, INTEGER vis); export void OPC_Case (LONGINT caseVal, INTEGER form); +static void OPC_CharacterLiteral (LONGINT c); export void OPC_Cmp (INTEGER rel); export void OPC_CompleteIdent (OPT_Object obj); export void OPC_Constant (OPT_Const con, INTEGER form); @@ -74,8 +75,10 @@ static void OPC_PutBase (OPT_Struct typ); static void OPC_PutPtrOffsets (OPT_Struct typ, LONGINT adr, LONGINT *cnt); static void OPC_RegCmds (OPT_Object obj); export void OPC_SetInclude (BOOLEAN exclude); +export LONGINT OPC_SizeAlignment (LONGINT size); static void OPC_Stars (OPT_Struct typ, BOOLEAN *openClause); static void OPC_Str1 (CHAR *s, LONGINT s__len, LONGINT x); +static void OPC_StringLiteral (CHAR *s, LONGINT s__len, LONGINT l); export void OPC_TDescDecl (OPT_Struct typ); export void OPC_TypeDefs (OPT_Object obj, INTEGER vis); export void OPC_TypeOf (OPT_Object ap); @@ -316,7 +319,7 @@ void OPC_Andent (OPT_Struct typ) static BOOLEAN OPC_Undefined (OPT_Object obj) { BOOLEAN _o_result; - _o_result = (((obj->mnolev >= 0 && obj->linkadr != (LONGINT)(3 + OPM_currFile))) && obj->linkadr != 2) || obj->name[0] == 0x00; + _o_result = obj->name[0] == 0x00 || (((obj->mnolev >= 0 && obj->linkadr != (SYSTEM_INT64)(3 + OPM_currFile))) && obj->linkadr != 2); return _o_result; } @@ -816,14 +819,15 @@ void OPC_TDescDecl (OPT_Struct typ) OPC_Andent(typ); OPC_Str1((CHAR*)", #", (LONGINT)4, typ->n + 1); OPC_Str1((CHAR*)", #) = {__TDFLDS(", (LONGINT)18, OPC_NofPtrs(typ)); - OPM_Write('\"'); + OPM_Write('"'); if (typ->strobj != NIL) { OPM_WriteStringVar((void*)typ->strobj->name, ((LONGINT)(256))); } - OPC_Str1((CHAR*)"\", #), {", (LONGINT)9, typ->size); + OPM_Write('"'); + OPC_Str1((CHAR*)", #), {", (LONGINT)8, typ->size); nofptrs = 0; OPC_PutPtrOffsets(typ, ((LONGINT)(0)), &nofptrs); - OPC_Str1((CHAR*)"#}}", (LONGINT)4, -((nofptrs + 1) * (LONGINT)OPM_LIntSize)); + OPC_Str1((CHAR*)"#}}", (LONGINT)4, -((nofptrs + 1) * (SYSTEM_INT64)OPM_LIntSize)); OPC_EndStat(); } @@ -865,70 +869,37 @@ void OPC_Align (LONGINT *adr, LONGINT base) } } -LONGINT OPC_Base (OPT_Struct typ) +LONGINT OPC_SizeAlignment (LONGINT size) { LONGINT _o_result; - switch (typ->form) { - case 1: - _o_result = 1; - return _o_result; - break; - case 3: - _o_result = OPM_CharAlign; - return _o_result; - break; - case 2: - _o_result = OPM_BoolAlign; - return _o_result; - break; - case 4: - _o_result = OPM_SIntAlign; - return _o_result; - break; - case 5: - _o_result = OPM_IntAlign; - return _o_result; - break; - case 6: - _o_result = OPM_LIntAlign; - return _o_result; - break; - case 7: - _o_result = OPM_RealAlign; - return _o_result; - break; - case 8: - _o_result = OPM_LRealAlign; - return _o_result; - break; - case 9: - _o_result = OPM_SetAlign; - return _o_result; - break; - case 13: - _o_result = OPM_PointerAlign; - return _o_result; - break; - case 14: - _o_result = OPM_ProcAlign; - return _o_result; - break; - case 15: - if (typ->comp == 4) { - _o_result = __MASK(typ->align, -65536); - return _o_result; - } else { - _o_result = OPC_Base(typ->BaseTyp); - return _o_result; - } - break; - default: - OPM_LogWStr((CHAR*)"unhandled case in OPC.Base, typ^form = ", (LONGINT)40); - OPM_LogWNum(typ->form, ((LONGINT)(0))); - OPM_LogWLn(); - break; + LONGINT alignment; + if (size < (SYSTEM_INT64)OPM_Alignment) { + alignment = 1; + while (alignment < size) { + alignment = __ASHL(alignment, 1); + } + } else { + alignment = OPM_Alignment; } - __RETCHK; + _o_result = alignment; + return _o_result; +} + +LONGINT OPC_BaseAlignment (OPT_Struct typ) +{ + LONGINT _o_result; + LONGINT alignment; + if (typ->form == 15) { + if (typ->comp == 4) { + alignment = __MASK(typ->align, -65536); + } else { + alignment = OPC_BaseAlignment(typ->BaseTyp); + } + } else { + alignment = OPC_SizeAlignment(typ->size); + } + _o_result = alignment; + return _o_result; } static void OPC_FillGap (LONGINT gap, LONGINT off, LONGINT align, LONGINT *n, LONGINT *curAlign) @@ -939,11 +910,11 @@ static void OPC_FillGap (LONGINT gap, LONGINT off, LONGINT align, LONGINT *n, LO if ((*curAlign < align && gap - (adr - off) >= align)) { gap -= (adr - off) + align; OPC_BegStat(); - if (align == (LONGINT)OPM_IntSize) { + if (align == (SYSTEM_INT64)OPM_IntSize) { OPM_WriteString((CHAR*)"INTEGER", (LONGINT)8); - } else if (align == (LONGINT)OPM_LIntSize) { + } else if (align == (SYSTEM_INT64)OPM_LIntSize) { OPM_WriteString((CHAR*)"LONGINT", (LONGINT)8); - } else if (align == (LONGINT)OPM_LRealSize) { + } else if (align == (SYSTEM_INT64)OPM_LRealSize) { OPM_WriteString((CHAR*)"LONGREAL", (LONGINT)9); } OPC_Str1((CHAR*)" _prvt#", (LONGINT)8, *n); @@ -982,7 +953,7 @@ static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, LONGINT *off, LONGINT * } } else { adr = *off; - fldAlign = OPC_Base(fld->typ); + fldAlign = OPC_BaseAlignment(fld->typ); OPC_Align(&adr, fldAlign); gap = fld->adr - adr; if (fldAlign > *curAlign) { @@ -1008,7 +979,7 @@ static void OPC_FieldList (OPT_Struct typ, BOOLEAN last, LONGINT *off, LONGINT * } } if (last) { - adr = typ->size - (LONGINT)__ASHR(typ->sysflag, 8); + adr = typ->size - (SYSTEM_INT64)__ASHR(typ->sysflag, 8); if (adr == 0) { gap = 1; } else { @@ -1171,10 +1142,10 @@ static void OPC_Include (CHAR *name, LONGINT name__len) { __DUP(name, name__len, CHAR); OPM_WriteString((CHAR*)"#include ", (LONGINT)10); - OPM_Write('\"'); + OPM_Write('"'); OPM_WriteStringVar((void*)name, name__len); OPM_WriteString((CHAR*)".h", (LONGINT)3); - OPM_Write('\"'); + OPM_Write('"'); OPM_WriteLn(); __DEL(name); } @@ -1239,8 +1210,8 @@ void OPC_GenHdr (OPT_Node n) static void OPC_GenHeaderMsg (void) { INTEGER i; - OPM_WriteString((CHAR*)"/*", (LONGINT)3); - OPM_WriteString((CHAR*)" voc ", (LONGINT)6); + OPM_WriteString((CHAR*)"/* ", (LONGINT)4); + OPM_WriteString((CHAR*)"voc", (LONGINT)4); OPM_Write(' '); OPM_WriteString(Configuration_versionLong, ((LONGINT)(41))); OPM_Write(' '); @@ -1856,26 +1827,56 @@ void OPC_Cmp (INTEGER rel) } } +static void OPC_CharacterLiteral (LONGINT c) +{ + if (c < 32 || c > 126) { + OPM_WriteString((CHAR*)"0x", (LONGINT)3); + OPM_WriteHex(c); + } else { + OPM_Write('\''); + if ((c == 92 || c == 39) || c == 63) { + OPM_Write('\\'); + } + OPM_Write((CHAR)c); + OPM_Write('\''); + } +} + +static void OPC_StringLiteral (CHAR *s, LONGINT s__len, LONGINT l) +{ + LONGINT i; + INTEGER c; + __DUP(s, s__len, CHAR); + OPM_Write('"'); + i = 0; + while (i < l) { + c = (int)s[__X(i, s__len)]; + if (c < 32 || c > 126) { + OPM_Write('\\'); + OPM_Write((CHAR)(48 + __ASHR(c, 6))); + c = __MASK(c, -64); + OPM_Write((CHAR)(48 + __ASHR(c, 3))); + c = __MASK(c, -8); + OPM_Write((CHAR)(48 + c)); + } else { + if ((c == 92 || c == 34) || c == 63) { + OPM_Write('\\'); + } + OPM_Write((CHAR)c); + } + i += 1; + } + OPM_Write('"'); + __DEL(s); +} + void OPC_Case (LONGINT caseVal, INTEGER form) { CHAR ch; OPM_WriteString((CHAR*)"case ", (LONGINT)6); switch (form) { case 3: - ch = (CHAR)caseVal; - if ((ch >= ' ' && ch <= '~')) { - OPM_Write('\''); - if (((ch == '\\' || ch == '\?') || ch == '\'') || ch == '\"') { - OPM_Write('\\'); - OPM_Write(ch); - } else { - OPM_Write(ch); - } - OPM_Write('\''); - } else { - OPM_WriteString((CHAR*)"0x", (LONGINT)3); - OPM_WriteHex(caseVal); - } + OPC_CharacterLiteral(caseVal); break; case 4: case 5: case 6: OPM_WriteInt(caseVal); @@ -1933,8 +1934,7 @@ void OPC_Len (OPT_Object obj, OPT_Struct array, LONGINT dim) void OPC_Constant (OPT_Const con, INTEGER form) { - INTEGER i, len; - CHAR ch; + INTEGER i; SET s; LONGINT hex; BOOLEAN skipLeading; @@ -1946,18 +1946,7 @@ void OPC_Constant (OPT_Const con, INTEGER form) OPM_WriteInt(con->intval); break; case 3: - ch = (CHAR)con->intval; - if ((ch >= ' ' && ch <= '~')) { - OPM_Write('\''); - if (((ch == '\\' || ch == '\?') || ch == '\'') || ch == '\"') { - OPM_Write('\\'); - } - OPM_Write(ch); - OPM_Write('\''); - } else { - OPM_WriteString((CHAR*)"0x", (LONGINT)3); - OPM_WriteHex(con->intval); - } + OPC_CharacterLiteral(con->intval); break; case 4: case 5: case 6: OPM_WriteInt(con->intval); @@ -1992,18 +1981,7 @@ void OPC_Constant (OPT_Const con, INTEGER form) } break; case 10: - OPM_Write('\"'); - len = (int)con->intval2 - 1; - i = 0; - while (i < len) { - ch = (*con->ext)[__X(i, ((LONGINT)(256)))]; - if (((ch == '\\' || ch == '\?') || ch == '\'') || ch == '\"') { - OPM_Write('\\'); - } - OPM_Write(ch); - i += 1; - } - OPM_Write('\"'); + OPC_StringLiteral(*con->ext, ((LONGINT)(256)), con->intval2 - 1); break; case 11: OPM_WriteString((CHAR*)"NIL", (LONGINT)4); @@ -2016,74 +1994,74 @@ void OPC_Constant (OPT_Const con, INTEGER form) } } -static struct InitKeywords__47 { +static struct InitKeywords__48 { SHORTINT *n; - struct InitKeywords__47 *lnk; -} *InitKeywords__47_s; + struct InitKeywords__48 *lnk; +} *InitKeywords__48_s; -static void Enter__48 (CHAR *s, LONGINT s__len); +static void Enter__49 (CHAR *s, LONGINT s__len); -static void Enter__48 (CHAR *s, LONGINT s__len) +static void Enter__49 (CHAR *s, LONGINT s__len) { INTEGER h; __DUP(s, s__len, CHAR); h = OPC_PerfectHash((void*)s, s__len); - OPC_hashtab[__X(h, ((LONGINT)(105)))] = *InitKeywords__47_s->n; - __COPY(s, OPC_keytab[__X(*InitKeywords__47_s->n, ((LONGINT)(36)))], ((LONGINT)(9))); - *InitKeywords__47_s->n += 1; + OPC_hashtab[__X(h, ((LONGINT)(105)))] = *InitKeywords__48_s->n; + __COPY(s, OPC_keytab[__X(*InitKeywords__48_s->n, ((LONGINT)(36)))], ((LONGINT)(9))); + *InitKeywords__48_s->n += 1; __DEL(s); } static void OPC_InitKeywords (void) { SHORTINT n, i; - struct InitKeywords__47 _s; + struct InitKeywords__48 _s; _s.n = &n; - _s.lnk = InitKeywords__47_s; - InitKeywords__47_s = &_s; + _s.lnk = InitKeywords__48_s; + InitKeywords__48_s = &_s; n = 0; i = 0; while (i <= 104) { OPC_hashtab[__X(i, ((LONGINT)(105)))] = -1; i += 1; } - Enter__48((CHAR*)"asm", (LONGINT)4); - Enter__48((CHAR*)"auto", (LONGINT)5); - Enter__48((CHAR*)"break", (LONGINT)6); - Enter__48((CHAR*)"case", (LONGINT)5); - Enter__48((CHAR*)"char", (LONGINT)5); - Enter__48((CHAR*)"const", (LONGINT)6); - Enter__48((CHAR*)"continue", (LONGINT)9); - Enter__48((CHAR*)"default", (LONGINT)8); - Enter__48((CHAR*)"do", (LONGINT)3); - Enter__48((CHAR*)"double", (LONGINT)7); - Enter__48((CHAR*)"else", (LONGINT)5); - Enter__48((CHAR*)"enum", (LONGINT)5); - Enter__48((CHAR*)"extern", (LONGINT)7); - Enter__48((CHAR*)"export", (LONGINT)7); - Enter__48((CHAR*)"float", (LONGINT)6); - Enter__48((CHAR*)"for", (LONGINT)4); - Enter__48((CHAR*)"fortran", (LONGINT)8); - Enter__48((CHAR*)"goto", (LONGINT)5); - Enter__48((CHAR*)"if", (LONGINT)3); - Enter__48((CHAR*)"import", (LONGINT)7); - Enter__48((CHAR*)"int", (LONGINT)4); - Enter__48((CHAR*)"long", (LONGINT)5); - Enter__48((CHAR*)"register", (LONGINT)9); - Enter__48((CHAR*)"return", (LONGINT)7); - Enter__48((CHAR*)"short", (LONGINT)6); - Enter__48((CHAR*)"signed", (LONGINT)7); - Enter__48((CHAR*)"sizeof", (LONGINT)7); - Enter__48((CHAR*)"static", (LONGINT)7); - Enter__48((CHAR*)"struct", (LONGINT)7); - Enter__48((CHAR*)"switch", (LONGINT)7); - Enter__48((CHAR*)"typedef", (LONGINT)8); - Enter__48((CHAR*)"union", (LONGINT)6); - Enter__48((CHAR*)"unsigned", (LONGINT)9); - Enter__48((CHAR*)"void", (LONGINT)5); - Enter__48((CHAR*)"volatile", (LONGINT)9); - Enter__48((CHAR*)"while", (LONGINT)6); - InitKeywords__47_s = _s.lnk; + Enter__49((CHAR*)"asm", (LONGINT)4); + Enter__49((CHAR*)"auto", (LONGINT)5); + Enter__49((CHAR*)"break", (LONGINT)6); + Enter__49((CHAR*)"case", (LONGINT)5); + Enter__49((CHAR*)"char", (LONGINT)5); + Enter__49((CHAR*)"const", (LONGINT)6); + Enter__49((CHAR*)"continue", (LONGINT)9); + Enter__49((CHAR*)"default", (LONGINT)8); + Enter__49((CHAR*)"do", (LONGINT)3); + Enter__49((CHAR*)"double", (LONGINT)7); + Enter__49((CHAR*)"else", (LONGINT)5); + Enter__49((CHAR*)"enum", (LONGINT)5); + Enter__49((CHAR*)"extern", (LONGINT)7); + Enter__49((CHAR*)"export", (LONGINT)7); + Enter__49((CHAR*)"float", (LONGINT)6); + Enter__49((CHAR*)"for", (LONGINT)4); + Enter__49((CHAR*)"fortran", (LONGINT)8); + Enter__49((CHAR*)"goto", (LONGINT)5); + Enter__49((CHAR*)"if", (LONGINT)3); + Enter__49((CHAR*)"import", (LONGINT)7); + Enter__49((CHAR*)"int", (LONGINT)4); + Enter__49((CHAR*)"long", (LONGINT)5); + Enter__49((CHAR*)"register", (LONGINT)9); + Enter__49((CHAR*)"return", (LONGINT)7); + Enter__49((CHAR*)"short", (LONGINT)6); + Enter__49((CHAR*)"signed", (LONGINT)7); + Enter__49((CHAR*)"sizeof", (LONGINT)7); + Enter__49((CHAR*)"static", (LONGINT)7); + Enter__49((CHAR*)"struct", (LONGINT)7); + Enter__49((CHAR*)"switch", (LONGINT)7); + Enter__49((CHAR*)"typedef", (LONGINT)8); + Enter__49((CHAR*)"union", (LONGINT)6); + Enter__49((CHAR*)"unsigned", (LONGINT)9); + Enter__49((CHAR*)"void", (LONGINT)5); + Enter__49((CHAR*)"volatile", (LONGINT)9); + Enter__49((CHAR*)"while", (LONGINT)6); + InitKeywords__48_s = _s.lnk; } diff --git a/bootstrap/windows-88/OPC.h b/bootstrap/windows-88/OPC.h index 58679d74..37a86252 100644 --- a/bootstrap/windows-88/OPC.h +++ b/bootstrap/windows-88/OPC.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPC__h #define OPC__h @@ -12,7 +12,7 @@ import void OPC_Align (LONGINT *adr, LONGINT base); import void OPC_Andent (OPT_Struct typ); -import LONGINT OPC_Base (OPT_Struct typ); +import LONGINT OPC_BaseAlignment (OPT_Struct typ); import OPT_Object OPC_BaseTProc (OPT_Object obj); import void OPC_BegBlk (void); import void OPC_BegStat (void); @@ -41,6 +41,7 @@ import void OPC_InitTDesc (OPT_Struct typ); import void OPC_Len (OPT_Object obj, OPT_Struct array, LONGINT dim); import LONGINT OPC_NofPtrs (OPT_Struct typ); import void OPC_SetInclude (BOOLEAN exclude); +import LONGINT OPC_SizeAlignment (LONGINT size); import void OPC_TDescDecl (OPT_Struct typ); import void OPC_TypeDefs (OPT_Object obj, INTEGER vis); import void OPC_TypeOf (OPT_Object ap); diff --git a/bootstrap/windows-88/OPM.c b/bootstrap/windows-88/OPM.c index 40d53974..50047c9e 100644 --- a/bootstrap/windows-88/OPM.c +++ b/bootstrap/windows-88/OPM.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "Configuration.h" @@ -15,8 +15,8 @@ typedef static CHAR OPM_SourceFileName[256]; -export INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_CharAlign, OPM_BoolAlign, OPM_SIntAlign, OPM_IntAlign, OPM_LIntAlign, OPM_SetAlign, OPM_RealAlign, OPM_LRealAlign, OPM_PointerAlign, OPM_ProcAlign, OPM_RecAlign, OPM_MaxSet; -export LONGINT OPM_MinSInt, OPM_MinInt, OPM_MinLInt, OPM_MaxSInt, OPM_MaxInt, OPM_MaxLInt, OPM_MaxIndex; +export INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_MaxSet; +export LONGINT OPM_MaxIndex; export LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; export BOOLEAN OPM_noerr; export LONGINT OPM_curpos, OPM_errpos, OPM_breakpc; @@ -58,7 +58,6 @@ export void OPM_LogWNum (LONGINT i, LONGINT len); export void OPM_LogWStr (CHAR *s, LONGINT s__len); static void OPM_MakeFileName (CHAR *name, LONGINT name__len, CHAR *FName, LONGINT FName__len, CHAR *ext, LONGINT ext__len); export void OPM_Mark (INTEGER n, LONGINT pos); -static INTEGER OPM_Min (INTEGER a, INTEGER b); export void OPM_NewSym (CHAR *modName, LONGINT modName__len); export void OPM_OldSym (CHAR *modName, LONGINT modName__len, BOOLEAN *done); export void OPM_OpenFiles (CHAR *moduleName, LONGINT moduleName__len); @@ -66,6 +65,8 @@ export BOOLEAN OPM_OpenPar (void); export void OPM_RegisterNewSym (void); static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt); static void OPM_ShowLine (LONGINT pos); +export LONGINT OPM_SignedMaximum (LONGINT bytecount); +export LONGINT OPM_SignedMinimum (LONGINT bytecount); export void OPM_SymRCh (CHAR *ch); export LONGINT OPM_SymRInt (void); export void OPM_SymRLReal (LONGREAL *lr); @@ -86,7 +87,7 @@ export void OPM_WriteString (CHAR *s, LONGINT s__len); export void OPM_WriteStringVar (CHAR *s, LONGINT s__len); export BOOLEAN OPM_eofSF (void); export void OPM_err (INTEGER n); -static LONGINT OPM_minus (LONGINT i); +static LONGINT OPM_minusop (LONGINT i); static LONGINT OPM_power0 (LONGINT i, LONGINT j); @@ -118,50 +119,38 @@ static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) i = 1; while (s[__X(i, s__len)] != 0x00) { switch (s[__X(i, s__len)]) { - case 'e': - *opt = *opt ^ 0x0200; - break; - case 's': - *opt = *opt ^ 0x10; - break; - case 'm': - *opt = *opt ^ 0x0400; - break; - case 'x': - *opt = *opt ^ 0x01; - break; - case 'r': - *opt = *opt ^ 0x04; - break; - case 't': - *opt = *opt ^ 0x08; - break; case 'a': *opt = *opt ^ 0x80; break; - case 'k': - *opt = *opt ^ 0x40; - break; - case 'p': - *opt = *opt ^ 0x20; - break; - case 'S': - *opt = *opt ^ 0x2000; - break; case 'c': *opt = *opt ^ 0x4000; break; - case 'M': - *opt = *opt ^ 0x8000; + case 'e': + *opt = *opt ^ 0x0200; break; case 'f': *opt = *opt ^ 0x010000; break; - case 'F': - *opt = *opt ^ 0x020000; + case 'k': + *opt = *opt ^ 0x40; break; - case 'V': - *opt = *opt ^ 0x040000; + case 'm': + *opt = *opt ^ 0x0400; + break; + case 'p': + *opt = *opt ^ 0x20; + break; + case 'r': + *opt = *opt ^ 0x04; + break; + case 's': + *opt = *opt ^ 0x10; + break; + case 't': + *opt = *opt ^ 0x08; + break; + case 'x': + *opt = *opt ^ 0x01; break; case 'B': if (s[__X(i + 1, s__len)] != 0x00) { @@ -179,6 +168,19 @@ static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) __ASSERT(OPM_IntSize == 2 || OPM_IntSize == 4, 0); __ASSERT(OPM_PointerSize == 4 || OPM_PointerSize == 8, 0); __ASSERT(OPM_Alignment == 4 || OPM_Alignment == 8, 0); + Files_SetSearchPath((CHAR*)"", (LONGINT)1); + break; + case 'F': + *opt = *opt ^ 0x020000; + break; + case 'M': + *opt = *opt ^ 0x8000; + break; + case 'S': + *opt = *opt ^ 0x2000; + break; + case 'V': + *opt = *opt ^ 0x040000; break; default: OPM_LogWStr((CHAR*)" warning: option ", (LONGINT)19); @@ -228,17 +230,17 @@ BOOLEAN OPM_OpenPar (void) OPM_LogWLn(); OPM_LogWStr((CHAR*)" x - turn off array indices check", (LONGINT)35); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" a - don\'t check ASSERTs at runtime, use this option in tested production code", (LONGINT)80); + OPM_LogWStr((CHAR*)" a - don't check ASSERTs at runtime, use this option in tested production code", (LONGINT)80); OPM_LogWLn(); OPM_LogWStr((CHAR*)" p - turn off automatic pointer initialization", (LONGINT)48); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" t - don\'t check type guards (use in rare cases such as low-level modules where every cycle counts)", (LONGINT)101); + OPM_LogWStr((CHAR*)" t - don't check type guards (use in rare cases such as low-level modules where every cycle counts)", (LONGINT)101); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" S - don\'t call external assembler/compiler, only generate C code", (LONGINT)67); + OPM_LogWStr((CHAR*)" S - don't call external assembler/compiler, only generate C code", (LONGINT)67); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" c - don\'t call linker", (LONGINT)24); + OPM_LogWStr((CHAR*)" c - don't call linker", (LONGINT)24); OPM_LogWLn(); - OPM_LogWStr((CHAR*)" f - don\'t use color output", (LONGINT)29); + OPM_LogWStr((CHAR*)" f - don't use color output", (LONGINT)29); OPM_LogWLn(); OPM_LogWStr((CHAR*)" F - force writing new symbol file in current directory", (LONGINT)57); OPM_LogWLn(); @@ -541,16 +543,17 @@ void OPM_FPrintSet (LONGINT *fp, SET set) void OPM_FPrintReal (LONGINT *fp, REAL real) { - OPM_FPrint(&*fp, __VAL(LONGINT, real)); + INTEGER i; + LONGINT l; + __GET((LONGINT)(SYSTEM_ADDRESS)&real, i, INTEGER); + l = i; + OPM_FPrint(&*fp, l); } void OPM_FPrintLReal (LONGINT *fp, LONGREAL lr) { LONGINT l, h; - __GET((LONGINT)(uintptr_t)&lr, l, LONGINT); - __GET((LONGINT)(uintptr_t)&lr + 4, h, LONGINT); - OPM_FPrint(&*fp, l); - OPM_FPrint(&*fp, h); + OPM_FPrint(&*fp, __VAL(LONGINT, lr)); } static void OPM_GetProperty (Texts_Scanner *S, LONGINT *S__typ, CHAR *name, LONGINT name__len, INTEGER *size, INTEGER *align) @@ -576,7 +579,7 @@ static void OPM_GetProperty (Texts_Scanner *S, LONGINT *S__typ, CHAR *name, LONG __DEL(name); } -static LONGINT OPM_minus (LONGINT i) +static LONGINT OPM_minusop (LONGINT i) { LONGINT _o_result; _o_result = -i; @@ -604,103 +607,62 @@ static void OPM_VerboseListSizes (void) OPM_LogWLn(); OPM_LogWStr((CHAR*)"CHAR ", (LONGINT)14); OPM_LogWNum(OPM_CharSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_CharAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"BOOLEAN ", (LONGINT)14); OPM_LogWNum(OPM_BoolSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_BoolAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"SHORTINT ", (LONGINT)14); OPM_LogWNum(OPM_SIntSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_SIntAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"INTEGER ", (LONGINT)14); OPM_LogWNum(OPM_IntSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_IntAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"LONGINT ", (LONGINT)14); OPM_LogWNum(OPM_LIntSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_LIntAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"SET ", (LONGINT)14); OPM_LogWNum(OPM_SetSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_SetAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"REAL ", (LONGINT)14); OPM_LogWNum(OPM_RealSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_RealAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"LONGREAL ", (LONGINT)14); OPM_LogWNum(OPM_LRealSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_LRealAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"PTR ", (LONGINT)14); OPM_LogWNum(OPM_PointerSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_PointerAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"PROC ", (LONGINT)14); OPM_LogWNum(OPM_ProcSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_ProcAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWStr((CHAR*)"RECORD ", (LONGINT)14); OPM_LogWNum(OPM_RecSize, ((LONGINT)(4))); - OPM_LogWNum(OPM_RecAlign, ((LONGINT)(5))); OPM_LogWLn(); OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Min shortint ", (LONGINT)14); - OPM_LogWNum(OPM_MinSInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Max shortint ", (LONGINT)14); - OPM_LogWNum(OPM_MaxSInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Min integer ", (LONGINT)14); - OPM_LogWNum(OPM_MinInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Max integer ", (LONGINT)14); - OPM_LogWNum(OPM_MaxInt, ((LONGINT)(4))); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Min longint ", (LONGINT)14); - OPM_LogWNum(OPM_MinLInt, ((LONGINT)(4))); - OPM_LogWLn(); } -static INTEGER OPM_Min (INTEGER a, INTEGER b) +LONGINT OPM_SignedMaximum (LONGINT bytecount) { - INTEGER _o_result; - if (a < b) { - _o_result = a; - return _o_result; - } else { - _o_result = b; - return _o_result; - } - __RETCHK; + LONGINT _o_result; + LONGINT result; + result = 1; + result = __LSH(result, __ASHL(bytecount, 3) - 1, LONGINT); + _o_result = result - 1; + return _o_result; +} + +LONGINT OPM_SignedMinimum (LONGINT bytecount) +{ + LONGINT _o_result; + _o_result = -OPM_SignedMaximum(bytecount) - 1; + return _o_result; } static void OPM_GetProperties (void) { - LONGINT base; OPM_ProcSize = OPM_PointerSize; OPM_LIntSize = __ASHL(OPM_IntSize, 1); OPM_SetSize = OPM_LIntSize; - OPM_CharAlign = OPM_Min(OPM_Alignment, OPM_CharSize); - OPM_BoolAlign = OPM_Min(OPM_Alignment, OPM_BoolSize); - OPM_SIntAlign = OPM_Min(OPM_Alignment, OPM_SIntSize); - OPM_RecAlign = OPM_Min(OPM_Alignment, OPM_RecSize); - OPM_RealAlign = OPM_Min(OPM_Alignment, OPM_RealSize); - OPM_LRealAlign = OPM_Min(OPM_Alignment, OPM_LRealSize); - OPM_PointerAlign = OPM_Min(OPM_Alignment, OPM_PointerSize); - OPM_ProcAlign = OPM_Min(OPM_Alignment, OPM_ProcSize); - OPM_IntAlign = OPM_Min(OPM_Alignment, OPM_IntSize); - OPM_LIntAlign = OPM_Min(OPM_Alignment, OPM_LIntSize); - OPM_SetAlign = OPM_Min(OPM_Alignment, OPM_SetSize); - base = -2; - OPM_MinSInt = __ASH(base, __ASHL(OPM_SIntSize, 3) - 2); - OPM_MaxSInt = OPM_minus(OPM_MinSInt + 1); - OPM_MinInt = __ASH(base, __ASHL(OPM_IntSize, 3) - 2); - OPM_MaxInt = OPM_minus(OPM_MinInt + 1); - OPM_MinLInt = __ASH(base, __ASHL(OPM_LIntSize, 3) - 2); - OPM_MaxLInt = OPM_minus(OPM_MinLInt + 1); if (OPM_RealSize == 4) { OPM_MaxReal = 3.40282346000000e+038; } else if (OPM_RealSize == 8) { @@ -714,7 +676,7 @@ static void OPM_GetProperties (void) OPM_MinReal = -OPM_MaxReal; OPM_MinLReal = -OPM_MaxLReal; OPM_MaxSet = __ASHL(OPM_SetSize, 3) - 1; - OPM_MaxIndex = OPM_MaxLInt; + OPM_MaxIndex = OPM_SignedMaximum(OPM_PointerSize); if (OPM_Verbose) { OPM_VerboseListSizes(); } @@ -876,7 +838,7 @@ void OPM_WriteInt (LONGINT i) { CHAR s[20]; LONGINT i1, k; - if (i == OPM_MinInt || i == OPM_MinLInt) { + if (i == OPM_SignedMinimum(OPM_IntSize) || i == OPM_SignedMinimum(OPM_LIntSize)) { OPM_Write('('); OPM_WriteInt(i + 1); OPM_WriteString((CHAR*)"-1)", (LONGINT)4); @@ -909,7 +871,7 @@ void OPM_WriteReal (LONGREAL r, CHAR suffx) CHAR s[32]; CHAR ch; INTEGER i; - if ((((r < OPM_MaxLInt && r > OPM_MinLInt)) && r == (__ENTIER(r)))) { + if ((((r < OPM_SignedMaximum(OPM_LIntSize) && r > OPM_SignedMinimum(OPM_LIntSize))) && r == (__ENTIER(r)))) { if (suffx == 'f') { OPM_WriteString((CHAR*)"(REAL)", (LONGINT)7); } else { diff --git a/bootstrap/windows-88/OPM.h b/bootstrap/windows-88/OPM.h index 2e93dfcf..1706f8f1 100644 --- a/bootstrap/windows-88/OPM.h +++ b/bootstrap/windows-88/OPM.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPM__h #define OPM__h @@ -7,8 +7,8 @@ #include "SYSTEM.h" -import INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_CharAlign, OPM_BoolAlign, OPM_SIntAlign, OPM_IntAlign, OPM_LIntAlign, OPM_SetAlign, OPM_RealAlign, OPM_LRealAlign, OPM_PointerAlign, OPM_ProcAlign, OPM_RecAlign, OPM_MaxSet; -import LONGINT OPM_MinSInt, OPM_MinInt, OPM_MinLInt, OPM_MaxSInt, OPM_MaxInt, OPM_MaxLInt, OPM_MaxIndex; +import INTEGER OPM_Alignment, OPM_ByteSize, OPM_CharSize, OPM_BoolSize, OPM_SIntSize, OPM_IntSize, OPM_LIntSize, OPM_SetSize, OPM_RealSize, OPM_LRealSize, OPM_PointerSize, OPM_ProcSize, OPM_RecSize, OPM_MaxSet; +import LONGINT OPM_MaxIndex; import LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; import BOOLEAN OPM_noerr; import LONGINT OPM_curpos, OPM_errpos, OPM_breakpc; @@ -39,6 +39,8 @@ import void OPM_OldSym (CHAR *modName, LONGINT modName__len, BOOLEAN *done); import void OPM_OpenFiles (CHAR *moduleName, LONGINT moduleName__len); import BOOLEAN OPM_OpenPar (void); import void OPM_RegisterNewSym (void); +import LONGINT OPM_SignedMaximum (LONGINT bytecount); +import LONGINT OPM_SignedMinimum (LONGINT bytecount); import void OPM_SymRCh (CHAR *ch); import LONGINT OPM_SymRInt (void); import void OPM_SymRLReal (LONGREAL *lr); diff --git a/bootstrap/windows-88/OPP.c b/bootstrap/windows-88/OPP.c index 9ce53b1f..be7c13b5 100644 --- a/bootstrap/windows-88/OPP.c +++ b/bootstrap/windows-88/OPP.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "OPB.h" @@ -439,10 +439,10 @@ static void OPP_TypeDecl (OPT_Struct *typ, OPT_Struct *banned) if (OPP_sym == 38) { OPP_qualident(&id); if (id->mode == 5) { - if (id->typ != *banned) { - *typ = id->typ; - } else { + if (id->typ == *banned) { OPP_err(58); + } else { + *typ = id->typ; } } else { OPP_err(52); @@ -1784,6 +1784,24 @@ void OPP_Module (OPT_Node *prog, SET opt) if (OPP_sym == 63) { OPS_Get(&OPP_sym); } else { + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Unexpected symbol found when MODULE expected:", (LONGINT)46); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" sym: ", (LONGINT)15); + OPM_LogWNum(OPP_sym, ((LONGINT)(1))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.name: ", (LONGINT)15); + OPM_LogWStr(OPS_name, ((LONGINT)(256))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.str: ", (LONGINT)15); + OPM_LogWStr(OPS_str, ((LONGINT)(256))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.numtyp: ", (LONGINT)15); + OPM_LogWNum(OPS_numtyp, ((LONGINT)(1))); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)" OPS.intval: ", (LONGINT)15); + OPM_LogWNum(OPS_intval, ((LONGINT)(1))); + OPM_LogWLn(); OPP_err(16); } if (OPP_sym == 38) { diff --git a/bootstrap/windows-88/OPP.h b/bootstrap/windows-88/OPP.h index 372c5f88..0b3b1b2c 100644 --- a/bootstrap/windows-88/OPP.h +++ b/bootstrap/windows-88/OPP.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPP__h #define OPP__h diff --git a/bootstrap/windows-88/OPS.c b/bootstrap/windows-88/OPS.c index 8276ecf9..cc04e014 100644 --- a/bootstrap/windows-88/OPS.c +++ b/bootstrap/windows-88/OPS.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #define LARGE #include "SYSTEM.h" #include "OPM.h" @@ -174,7 +174,7 @@ static void OPS_Number (void) OPS_numtyp = 1; if (n <= 2) { while (i < n) { - OPS_intval = __ASHL(OPS_intval, 4) + (LONGINT)Ord__7(dig[i], 1); + OPS_intval = __ASHL(OPS_intval, 4) + (SYSTEM_INT64)Ord__7(dig[i], 1); i += 1; } } else { @@ -189,7 +189,7 @@ static void OPS_Number (void) OPS_intval = -1; } while (i < n) { - OPS_intval = __ASHL(OPS_intval, 4) + (LONGINT)Ord__7(dig[i], 1); + OPS_intval = __ASHL(OPS_intval, 4) + (SYSTEM_INT64)Ord__7(dig[i], 1); i += 1; } } else { @@ -200,8 +200,8 @@ static void OPS_Number (void) while (i < n) { d = Ord__7(dig[i], 0); i += 1; - if (OPS_intval <= __DIV(9223372036854775807 - (LONGINT)d, 10)) { - OPS_intval = OPS_intval * 10 + (LONGINT)d; + if (OPS_intval <= __DIV(9223372036854775807 - (SYSTEM_INT64)d, 10)) { + OPS_intval = OPS_intval * 10 + (SYSTEM_INT64)d; } else { OPS_err(203); } @@ -326,7 +326,7 @@ void OPS_Get (SHORTINT *sym) } } switch (OPS_ch) { - case '\"': case '\'': + case '"': case '\'': OPS_Str(&s); break; case '#': diff --git a/bootstrap/windows-88/OPS.h b/bootstrap/windows-88/OPS.h index 8f1581bb..32148c49 100644 --- a/bootstrap/windows-88/OPS.h +++ b/bootstrap/windows-88/OPS.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin tspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin tspkaSfF */ #ifndef OPS__h #define OPS__h diff --git a/bootstrap/windows-88/OPT.c b/bootstrap/windows-88/OPT.c index 7f03064b..a0d41c71 100644 --- a/bootstrap/windows-88/OPT.c +++ b/bootstrap/windows-88/OPT.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "OPM.h" @@ -850,7 +850,7 @@ static void OPT_InConstant (LONGINT f, OPT_Const conval) conval->intval = 0; break; default: - OPM_LogWStr((CHAR*)"unhandled case in OPT.InConstant(), f = ", (LONGINT)41); + OPM_LogWStr((CHAR*)"unhandled case in InConstant(), f = ", (LONGINT)37); OPM_LogWNum(f, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1073,7 +1073,7 @@ static void OPT_InStruct (OPT_Struct *typ) OPT_InSign(mno, &(*typ)->BaseTyp, &(*typ)->link); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.InStruct, tag = ", (LONGINT)39); + OPM_LogWStr((CHAR*)"unhandled case at InStruct, tag = ", (LONGINT)35); OPM_LogWNum(tag, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1176,7 +1176,7 @@ static OPT_Object OPT_InObj (SHORTINT mno) } break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.InObj, tag = ", (LONGINT)36); + OPM_LogWStr((CHAR*)"unhandled case at InObj, tag = ", (LONGINT)32); OPM_LogWNum(tag, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1465,14 +1465,14 @@ static void OPT_OutStr (OPT_Struct typ) OPM_SymWInt(((LONGINT)(18))); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutStr, typ^.comp = ", (LONGINT)43); + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.comp = ", (LONGINT)39); OPM_LogWNum(typ->comp, ((LONGINT)(0))); OPM_LogWLn(); break; } break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutStr, typ^.form = ", (LONGINT)43); + OPM_LogWStr((CHAR*)"unhandled case at OutStr, typ^.form = ", (LONGINT)39); OPM_LogWNum(typ->form, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1537,7 +1537,7 @@ static void OPT_OutObj (OPT_Object obj) OPT_FPrintErr(obj, 251); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutObj, obj^.history = ", (LONGINT)46); + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj^.history = ", (LONGINT)42); OPM_LogWNum(obj->history, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1593,7 +1593,7 @@ static void OPT_OutObj (OPT_Object obj) OPT_OutName((void*)obj->name, ((LONGINT)(256))); break; default: - OPM_LogWStr((CHAR*)"unhandled case at OPT.OutObj, obj.mode = ", (LONGINT)42); + OPM_LogWStr((CHAR*)"unhandled case at OutObj, obj.mode = ", (LONGINT)38); OPM_LogWNum(obj->mode, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -1810,6 +1810,7 @@ export void *OPT__init(void) OPT_syslink = OPT_topScope->right; OPT_universe = OPT_topScope; OPT_topScope->right = NIL; + OPT_EnterTyp((CHAR*)"BOOLEAN", 2, OPM_BoolSize, &OPT_booltyp); OPT_EnterTyp((CHAR*)"CHAR", 3, OPM_CharSize, &OPT_chartyp); OPT_EnterTyp((CHAR*)"SET", 9, OPM_SetSize, &OPT_settyp); OPT_EnterTyp((CHAR*)"REAL", 7, OPM_RealSize, &OPT_realtyp); @@ -1817,7 +1818,6 @@ export void *OPT__init(void) OPT_EnterTyp((CHAR*)"LONGINT", 6, OPM_LIntSize, &OPT_linttyp); OPT_EnterTyp((CHAR*)"LONGREAL", 8, OPM_LRealSize, &OPT_lrltyp); OPT_EnterTyp((CHAR*)"SHORTINT", 4, OPM_SIntSize, &OPT_sinttyp); - OPT_EnterTyp((CHAR*)"BOOLEAN", 2, OPM_BoolSize, &OPT_booltyp); OPT_EnterBoolConst((CHAR*)"FALSE", ((LONGINT)(0))); OPT_EnterBoolConst((CHAR*)"TRUE", ((LONGINT)(1))); OPT_EnterProc((CHAR*)"HALT", 0); diff --git a/bootstrap/windows-88/OPT.h b/bootstrap/windows-88/OPT.h index 7e03d42c..ab2c4684 100644 --- a/bootstrap/windows-88/OPT.h +++ b/bootstrap/windows-88/OPT.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPT__h #define OPT__h @@ -60,8 +60,7 @@ typedef INTEGER ref, sysflag; LONGINT n, size, align, txtpos; BOOLEAN allocated, pbused, pvused; - char _prvt0[8]; - LONGINT pbfp, pvfp; + char _prvt0[24]; OPT_Struct BaseTyp; OPT_Object link, strobj; } OPT_StrDesc; diff --git a/bootstrap/windows-88/OPV.c b/bootstrap/windows-88/OPV.c index c86ba15e..ae14f629 100644 --- a/bootstrap/windows-88/OPV.c +++ b/bootstrap/windows-88/OPV.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "OPC.h" @@ -24,7 +24,7 @@ export LONGINT *OPV_ExitInfo__typ; static void OPV_ActualPar (OPT_Node n, OPT_Object fp); export void OPV_AdrAndSize (OPT_Object topScope); static void OPV_CaseStat (OPT_Node n, OPT_Object outerProc); -static void OPV_Convert (OPT_Node n, INTEGER form, INTEGER prec); +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INTEGER prec); static void OPV_DefineTDescs (OPT_Node n); static void OPV_Entier (OPT_Node n, INTEGER prec); static void OPV_GetTProcNum (OPT_Object obj); @@ -39,6 +39,7 @@ static LONGINT OPV_NaturalAlignment (LONGINT size, LONGINT max); static void OPV_NewArr (OPT_Node d, OPT_Node x); static INTEGER OPV_Precedence (INTEGER class, INTEGER subclass, INTEGER form, INTEGER comp); static BOOLEAN OPV_SideEffects (OPT_Node n); +static void OPV_SizeCast (LONGINT size); static void OPV_Stamp (OPS_Name s); static OPT_Object OPV_SuperProc (OPT_Node n); static void OPV_Traverse (OPT_Object obj, OPT_Object outerScope, BOOLEAN exported); @@ -83,10 +84,10 @@ void OPV_TypSize (OPT_Struct typ) btyp = typ->BaseTyp; if (btyp == NIL) { offset = 0; - base = OPM_RecAlign; + base = OPC_SizeAlignment(OPM_RecSize); } else { OPV_TypSize(btyp); - offset = btyp->size - (LONGINT)__ASHR(btyp->sysflag, 8); + offset = btyp->size - (SYSTEM_INT64)__ASHR(btyp->sysflag, 8); base = btyp->align; } fld = typ->link; @@ -94,7 +95,7 @@ void OPV_TypSize (OPT_Struct typ) btyp = fld->typ; OPV_TypSize(btyp); size = btyp->size; - fbase = OPC_Base(btyp); + fbase = OPC_BaseAlignment(btyp); OPC_Align(&offset, fbase); fld->adr = offset; offset += size; @@ -108,7 +109,7 @@ void OPV_TypSize (OPT_Struct typ) offset = 1; } if (OPM_RecSize == 0) { - base = OPV_NaturalAlignment(offset, OPM_RecAlign); + base = OPV_NaturalAlignment(offset, OPC_SizeAlignment(OPM_RecSize)); } OPC_Align(&offset, base); if ((typ->strobj == NIL && __MASK(typ->align, -65536) == 0)) { @@ -333,7 +334,7 @@ static INTEGER OPV_Precedence (INTEGER class, INTEGER subclass, INTEGER form, IN return _o_result; break; default: - OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence Nmop, subclass = ", (LONGINT)51); + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Nmop, subclass = ", (LONGINT)55); OPM_LogWNum(subclass, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -403,7 +404,7 @@ static INTEGER OPV_Precedence (INTEGER class, INTEGER subclass, INTEGER form, IN return _o_result; break; default: - OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence Ndop, subclass = ", (LONGINT)51); + OPM_LogWStr((CHAR*)"unhandled case in OPV.Precedence OPT.Ndop, subclass = ", (LONGINT)55); OPM_LogWNum(subclass, ((LONGINT)(0))); OPM_LogWLn(); break; @@ -466,41 +467,26 @@ static void OPV_Entier (OPT_Node n, INTEGER prec) } } -static void OPV_Convert (OPT_Node n, INTEGER form, INTEGER prec) +static void OPV_SizeCast (LONGINT size) { - INTEGER from; + if (size <= 4) { + OPM_WriteString((CHAR*)"(int)", (LONGINT)6); + } else { + OPM_WriteString((CHAR*)"(SYSTEM_INT64)", (LONGINT)15); + } +} + +static void OPV_Convert (OPT_Node n, OPT_Struct newtype, INTEGER prec) +{ + INTEGER from, to; from = n->typ->form; - if (form == 9) { + to = newtype->form; + if (to == 9) { OPM_WriteString((CHAR*)"__SETOF(", (LONGINT)9); OPV_Entier(n, -1); OPM_Write(')'); - } else if (form == 6) { - if (from < 6) { - OPM_WriteString((CHAR*)"(LONGINT)", (LONGINT)10); - } - OPV_Entier(n, 9); - } else if (form == 5) { - if (from < 5) { - OPM_WriteString((CHAR*)"(int)", (LONGINT)6); - OPV_expr(n, 9); - } else { - if (__IN(2, OPM_opt)) { - OPM_WriteString((CHAR*)"__SHORT", (LONGINT)8); - if (OPV_SideEffects(n)) { - OPM_Write('F'); - } - OPM_Write('('); - OPV_Entier(n, -1); - OPM_WriteString((CHAR*)", ", (LONGINT)3); - OPM_WriteInt(OPM_MaxInt + 1); - OPM_Write(')'); - } else { - OPM_WriteString((CHAR*)"(int)", (LONGINT)6); - OPV_Entier(n, 9); - } - } - } else if (form == 4) { - if (__IN(2, OPM_opt)) { + } else if (__IN(to, 0x70)) { + if ((newtype->size < n->typ->size && __IN(2, OPM_opt))) { OPM_WriteString((CHAR*)"__SHORT", (LONGINT)8); if (OPV_SideEffects(n)) { OPM_Write('F'); @@ -508,13 +494,15 @@ static void OPV_Convert (OPT_Node n, INTEGER form, INTEGER prec) OPM_Write('('); OPV_Entier(n, -1); OPM_WriteString((CHAR*)", ", (LONGINT)3); - OPM_WriteInt(OPM_MaxSInt + 1); + OPM_WriteInt(OPM_SignedMaximum(newtype->size) + 1); OPM_Write(')'); } else { - OPM_WriteString((CHAR*)"(int)", (LONGINT)6); + if (newtype->size != n->typ->size) { + OPV_SizeCast(newtype->size); + } OPV_Entier(n, 9); } - } else if (form == 3) { + } else if (to == 3) { if (__IN(2, OPM_opt)) { OPM_WriteString((CHAR*)"__CHR", (LONGINT)6); if (OPV_SideEffects(n)) { @@ -577,7 +565,7 @@ static void OPV_design (OPT_Node n, INTEGER prec) OPT_Struct typ = NIL; INTEGER class, designPrec, comp; OPT_Node d = NIL, x = NIL; - INTEGER dims, i, _for__26; + INTEGER dims, i, _for__27; comp = n->typ->comp; obj = n->obj; class = n->class; @@ -653,15 +641,15 @@ static void OPV_design (OPT_Node n, INTEGER prec) } x = x->left; } - _for__26 = dims; + _for__27 = dims; i = 1; - while (i <= _for__26) { + while (i <= _for__27) { OPM_Write(')'); i += 1; } if (n->typ->comp == 3) { OPM_Write(')'); - while ((LONGINT)i < __ASHR(d->typ->size - 4, 2)) { + while ((SYSTEM_INT64)i < __ASHR(d->typ->size - 4, 2)) { OPM_WriteString((CHAR*)" * ", (LONGINT)4); OPV_Len(d, i); i += 1; @@ -796,7 +784,7 @@ static void OPV_ActualPar (OPT_Node n, OPT_Object fp) } if ((((mode == 2 && n->class == 11)) && n->subcl == 29)) { OPV_expr(n->left, prec); - } else if ((((((form == 6 && n->class == 7)) && n->conval->intval <= OPM_MaxInt)) && n->conval->intval >= OPM_MinInt)) { + } else if ((((((form == 6 && n->class == 7)) && n->conval->intval <= OPM_SignedMaximum(OPM_IntSize))) && n->conval->intval >= OPM_SignedMinimum(OPM_IntSize))) { OPM_WriteString((CHAR*)"((LONGINT)(", (LONGINT)12); OPV_expr(n, prec); OPM_WriteString((CHAR*)"))", (LONGINT)3); @@ -915,7 +903,7 @@ static void OPV_expr (OPT_Node n, INTEGER prec) OPM_Write(')'); break; case 20: - OPV_Convert(l, form, exprPrec); + OPV_Convert(l, n->typ, exprPrec); break; case 21: if (OPV_SideEffects(l)) { @@ -944,7 +932,7 @@ static void OPV_expr (OPT_Node n, INTEGER prec) OPM_Write(')'); break; case 24: - OPM_WriteString((CHAR*)"(LONGINT)(uintptr_t)", (LONGINT)21); + OPM_WriteString((CHAR*)"(LONGINT)(SYSTEM_ADDRESS)", (LONGINT)26); if (l->class == 1) { OPC_CompleteIdent(l->obj); } else { @@ -955,20 +943,16 @@ static void OPV_expr (OPT_Node n, INTEGER prec) } break; case 29: - if ((((__IN(n->typ->form, 0x6240) && __IN(l->typ->form, 0x6240))) && n->typ->size == l->typ->size) || !__IN(l->class, 0x17)) { + if (!__IN(l->class, 0x17) || (((__IN(n->typ->form, 0x6240) && __IN(l->typ->form, 0x6240))) && n->typ->size == l->typ->size)) { OPM_Write('('); OPC_Ident(n->typ->strobj); OPM_Write(')'); if (__IN(n->typ->form, 0x6000) || __IN(l->typ->form, 0x6000)) { - OPM_WriteString((CHAR*)"(uintptr_t)", (LONGINT)12); + OPM_WriteString((CHAR*)"(SYSTEM_ADDRESS)", (LONGINT)17); } OPV_expr(l, exprPrec); } else { - if (__IN(n->typ->form, 0x6000) || __IN(l->typ->form, 0x6000)) { - OPM_WriteString((CHAR*)"__VALP(", (LONGINT)8); - } else { - OPM_WriteString((CHAR*)"__VAL(", (LONGINT)7); - } + OPM_WriteString((CHAR*)"__VAL(", (LONGINT)7); OPC_Ident(n->typ->strobj); OPM_WriteString((CHAR*)", ", (LONGINT)3); OPV_expr(l, -1); @@ -1327,7 +1311,7 @@ static void OPV_NewArr (OPT_Node d, OPT_Node x) OPM_WriteInt(base->size); OPM_WriteString((CHAR*)"))", (LONGINT)3); OPM_WriteString((CHAR*)", ", (LONGINT)3); - OPM_WriteInt(OPC_Base(base)); + OPM_WriteInt(OPC_BaseAlignment(base)); OPM_WriteString((CHAR*)", ", (LONGINT)3); OPM_WriteInt(nofdim); OPM_WriteString((CHAR*)", ", (LONGINT)3); diff --git a/bootstrap/windows-88/OPV.h b/bootstrap/windows-88/OPV.h index eeb89a76..4eba5b89 100644 --- a/bootstrap/windows-88/OPV.h +++ b/bootstrap/windows-88/OPV.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef OPV__h #define OPV__h diff --git a/bootstrap/windows-88/Platform.c b/bootstrap/windows-88/Platform.c index ec8fb7a9..4281164c 100644 --- a/bootstrap/windows-88/Platform.c +++ b/bootstrap/windows-88/Platform.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" @@ -110,11 +110,11 @@ export BOOLEAN Platform_getEnv (CHAR *var, LONGINT var__len, CHAR *val, LONGINT #define Platform_ERRORWRITEPROTECT() ERROR_WRITE_PROTECT #define Platform_ETIMEDOUT() WSAETIMEDOUT extern void Heap_InitHeap(); -#define Platform_GetTickCount() (LONGINT)(uint32_t)GetTickCount() +#define Platform_GetTickCount() (LONGINT)(SYSTEM_CARD32)GetTickCount() #define Platform_HeapInitHeap() Heap_InitHeap() -#define Platform_SetInterruptHandler(h) SystemSetInterruptHandler((uintptr_t)h) -#define Platform_SetQuitHandler(h) SystemSetQuitHandler((uintptr_t)h) -#define Platform_allocate(size) (LONGINT)(uintptr_t)((void*)HeapAlloc(GetProcessHeap(), 0, (size_t)size)) +#define Platform_SetInterruptHandler(h) SystemSetInterruptHandler((SYSTEM_ADDRESS)h) +#define Platform_SetQuitHandler(h) SystemSetQuitHandler((SYSTEM_ADDRESS)h) +#define Platform_allocate(size) (LONGINT)(SYSTEM_ADDRESS)((void*)HeapAlloc(GetProcessHeap(), 0, (size_t)size)) #define Platform_bhfiIndexHigh() (LONGINT)bhfi.nFileIndexHigh #define Platform_bhfiIndexLow() (LONGINT)bhfi.nFileIndexLow #define Platform_bhfiMtimeHigh() (LONGINT)bhfi.ftLastWriteTime.dwHighDateTime @@ -122,44 +122,44 @@ extern void Heap_InitHeap(); #define Platform_bhfiVsn() (LONGINT)bhfi.dwVolumeSerialNumber #define Platform_byHandleFileInformation() BY_HANDLE_FILE_INFORMATION bhfi #define Platform_cleanupProcess() CloseHandle(pi.hProcess); CloseHandle(pi.hThread); -#define Platform_closeHandle(h) (INTEGER)CloseHandle((HANDLE)(uintptr_t)h) +#define Platform_closeHandle(h) (INTEGER)CloseHandle((HANDLE)(SYSTEM_ADDRESS)h) #define Platform_createProcess(str, str__len) (INTEGER)CreateProcess(0, (char*)str, 0,0,0,0,0,0,&si,&pi) #define Platform_deleteFile(n, n__len) (INTEGER)DeleteFile((char*)n) #define Platform_err() (INTEGER)GetLastError() -#define Platform_errc(c) WriteFile((HANDLE)(uintptr_t)Platform_StdOut, &c, 1, 0,0) -#define Platform_errstring(s, s__len) WriteFile((HANDLE)(uintptr_t)Platform_StdOut, s, s__len-1, 0,0) +#define Platform_errc(c) WriteFile((HANDLE)(SYSTEM_ADDRESS)Platform_StdOut, &c, 1, 0,0) +#define Platform_errstring(s, s__len) WriteFile((HANDLE)(SYSTEM_ADDRESS)Platform_StdOut, s, s__len-1, 0,0) #define Platform_exit(code) ExitProcess((UINT)code) #define Platform_fileTimeToSysTime() SYSTEMTIME st; FileTimeToSystemTime(&ft, &st) -#define Platform_flushFileBuffers(h) (INTEGER)FlushFileBuffers((HANDLE)(uintptr_t)h) -#define Platform_free(address) HeapFree(GetProcessHeap(), 0, (void*)(uintptr_t)address) +#define Platform_flushFileBuffers(h) (INTEGER)FlushFileBuffers((HANDLE)(SYSTEM_ADDRESS)h) +#define Platform_free(address) HeapFree(GetProcessHeap(), 0, (void*)(SYSTEM_ADDRESS)address) #define Platform_ftToUli() ULARGE_INTEGER ul; ul.LowPart=ft.dwLowDateTime; ul.HighPart=ft.dwHighDateTime #define Platform_getCurrentDirectory(n, n__len) GetCurrentDirectory(n__len, (char*)n) #define Platform_getExitCodeProcess(exitcode) GetExitCodeProcess(pi.hProcess, (DWORD*)exitcode); -#define Platform_getFileInformationByHandle(h) (INTEGER)GetFileInformationByHandle((HANDLE)(uintptr_t)h, &bhfi) -#define Platform_getFilePos(h, r, rc) LARGE_INTEGER liz = {0}; *rc = (INTEGER)SetFilePointerEx((HANDLE)(uintptr_t)h, liz, &li, FILE_CURRENT); *r = (LONGINT)li.QuadPart -#define Platform_getFileSize(h) (INTEGER)GetFileSizeEx((HANDLE)(uintptr_t)h, &li) +#define Platform_getFileInformationByHandle(h) (INTEGER)GetFileInformationByHandle((HANDLE)(SYSTEM_ADDRESS)h, &bhfi) +#define Platform_getFilePos(h, r, rc) LARGE_INTEGER liz = {0}; *rc = (INTEGER)SetFilePointerEx((HANDLE)(SYSTEM_ADDRESS)h, liz, &li, FILE_CURRENT); *r = (LONGINT)li.QuadPart +#define Platform_getFileSize(h) (INTEGER)GetFileSizeEx((HANDLE)(SYSTEM_ADDRESS)h, &li) #define Platform_getLocalTime() SYSTEMTIME st; GetLocalTime(&st) #define Platform_getenv(name, name__len, buf, buf__len) (INTEGER)GetEnvironmentVariable((char*)name, (char*)buf, buf__len) #define Platform_getpid() (INTEGER)GetCurrentProcessId() -#define Platform_getstderrhandle() (uintptr_t)GetStdHandle(STD_ERROR_HANDLE) -#define Platform_getstdinhandle() (uintptr_t)GetStdHandle(STD_INPUT_HANDLE) -#define Platform_getstdouthandle() (uintptr_t)GetStdHandle(STD_OUTPUT_HANDLE) +#define Platform_getstderrhandle() (SYSTEM_ADDRESS)GetStdHandle(STD_ERROR_HANDLE) +#define Platform_getstdinhandle() (SYSTEM_ADDRESS)GetStdHandle(STD_INPUT_HANDLE) +#define Platform_getstdouthandle() (SYSTEM_ADDRESS)GetStdHandle(STD_OUTPUT_HANDLE) #define Platform_identityToFileTime(i) FILETIME ft; ft.dwHighDateTime = i.mtimehigh; ft.dwLowDateTime = i.mtimelow -#define Platform_invalidHandleValue() ((LONGINT)(uintptr_t)INVALID_HANDLE_VALUE) +#define Platform_invalidHandleValue() ((LONGINT)(SYSTEM_ADDRESS)INVALID_HANDLE_VALUE) #define Platform_largeInteger() LARGE_INTEGER li #define Platform_liLongint() (LONGINT)li.QuadPart #define Platform_moveFile(o, o__len, n, n__len) (INTEGER)MoveFileEx((char*)o, (char*)n, MOVEFILE_REPLACE_EXISTING) -#define Platform_opennew(n, n__len) (LONGINT)(uintptr_t)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0) -#define Platform_openro(n, n__len) (LONGINT)(uintptr_t)CreateFile((char*)n, GENERIC_READ , FILE_SHARE_READ|FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) -#define Platform_openrw(n, n__len) (LONGINT)(uintptr_t)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) +#define Platform_opennew(n, n__len) (LONGINT)(SYSTEM_ADDRESS)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0) +#define Platform_openro(n, n__len) (LONGINT)(SYSTEM_ADDRESS)CreateFile((char*)n, GENERIC_READ , FILE_SHARE_READ|FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) +#define Platform_openrw(n, n__len) (LONGINT)(SYSTEM_ADDRESS)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) #define Platform_processInfo() PROCESS_INFORMATION pi = {0}; -#define Platform_readfile(fd, p, l, n) (INTEGER)ReadFile ((HANDLE)(uintptr_t)fd, (void*)(uintptr_t)(p), (DWORD)l, (DWORD*)n, 0) +#define Platform_readfile(fd, p, l, n) (INTEGER)ReadFile ((HANDLE)(SYSTEM_ADDRESS)fd, (void*)(SYSTEM_ADDRESS)(p), (DWORD)l, (DWORD*)n, 0) #define Platform_seekcur() FILE_CURRENT #define Platform_seekend() FILE_END #define Platform_seekset() FILE_BEGIN #define Platform_setCurrentDirectory(n, n__len) (INTEGER)SetCurrentDirectory((char*)n) -#define Platform_setEndOfFile(h) (INTEGER)SetEndOfFile((HANDLE)(uintptr_t)h) -#define Platform_setFilePointerEx(h, o, r, rc) li.QuadPart=o; *rc = (INTEGER)SetFilePointerEx((HANDLE)(uintptr_t)h, li, 0, (DWORD)r) +#define Platform_setEndOfFile(h) (INTEGER)SetEndOfFile((HANDLE)(SYSTEM_ADDRESS)h) +#define Platform_setFilePointerEx(h, o, r, rc) li.QuadPart=o; *rc = (INTEGER)SetFilePointerEx((HANDLE)(SYSTEM_ADDRESS)h, li, 0, (DWORD)r) #define Platform_sleep(ms) Sleep((DWORD)ms) #define Platform_stToFt() FILETIME ft; SystemTimeToFileTime(&st, &ft) #define Platform_startupInfo() STARTUPINFO si = {0}; si.cb = sizeof(si); @@ -174,7 +174,7 @@ extern void Heap_InitHeap(); #define Platform_ulSec() (LONGINT)(ul.QuadPart / 1000000LL) #define Platform_uluSec() (LONGINT)(ul.QuadPart % 1000000LL) #define Platform_waitForProcess() (INTEGER)WaitForSingleObject(pi.hProcess, INFINITE) -#define Platform_writefile(fd, p, l) (INTEGER)WriteFile((HANDLE)(uintptr_t)fd, (void*)(uintptr_t)(p), (DWORD)l, 0,0) +#define Platform_writefile(fd, p, l) (INTEGER)WriteFile((HANDLE)(SYSTEM_ADDRESS)fd, (void*)(SYSTEM_ADDRESS)(p), (DWORD)l, 0,0) BOOLEAN Platform_TooManyFiles (INTEGER e) { @@ -242,7 +242,7 @@ void Platform_Init (INTEGER argc, LONGINT argvadr) Platform_ArgVecPtr av = NIL; Platform_MainStackFrame = argvadr; Platform_ArgCount = argc; - av = (Platform_ArgVecPtr)(uintptr_t)argvadr; + av = (Platform_ArgVecPtr)(SYSTEM_ADDRESS)argvadr; Platform_ArgVector = (*av)[0]; Platform_HaltCode = -128; Platform_HeapInitHeap(); @@ -281,7 +281,7 @@ void Platform_GetArg (INTEGER n, CHAR *val, LONGINT val__len) { Platform_ArgVec av = NIL; if (n < Platform_ArgCount) { - av = (Platform_ArgVec)(uintptr_t)Platform_ArgVector; + av = (Platform_ArgVec)(SYSTEM_ADDRESS)Platform_ArgVector; __COPY(*(*av)[__X(n, ((LONGINT)(1024)))], val, val__len); } } @@ -335,8 +335,8 @@ void Platform_SetBadInstructionHandler (Platform_SignalHandler handler) static void Platform_YMDHMStoClock (INTEGER ye, INTEGER mo, INTEGER da, INTEGER ho, INTEGER mi, INTEGER se, LONGINT *t, LONGINT *d) { - *d = (__ASHL((LONGINT)(int)__MOD(ye, 100), 9) + __ASHL((LONGINT)(mo + 1), 5)) + (LONGINT)da; - *t = (__ASHL((LONGINT)ho, 12) + __ASHL((LONGINT)mi, 6)) + (LONGINT)se; + *d = (__ASHL((SYSTEM_INT64)(int)__MOD(ye, 100), 9) + __ASHL((SYSTEM_INT64)(mo + 1), 5)) + (SYSTEM_INT64)da; + *t = (__ASHL((SYSTEM_INT64)ho, 12) + __ASHL((SYSTEM_INT64)mi, 6)) + (SYSTEM_INT64)se; } void Platform_GetClock (LONGINT *t, LONGINT *d) @@ -560,7 +560,7 @@ INTEGER Platform_ReadBuf (LONGINT h, SYSTEM_BYTE *b, LONGINT b__len, LONGINT *n) INTEGER _o_result; INTEGER result; *n = 0; - result = Platform_readfile(h, (LONGINT)(uintptr_t)b, b__len, &*n); + result = Platform_readfile(h, (LONGINT)(SYSTEM_ADDRESS)b, b__len, &*n); if (result == 0) { *n = 0; _o_result = Platform_err(); @@ -796,7 +796,7 @@ static void Platform_TestLittleEndian (void) { INTEGER i; i = 1; - __GET((LONGINT)(uintptr_t)&i, Platform_LittleEndian, BOOLEAN); + __GET((LONGINT)(SYSTEM_ADDRESS)&i, Platform_LittleEndian, BOOLEAN); } __TDESC(Platform_FileIdentity, 1, 0) = {__TDFLDS("FileIdentity", 40), {-8}}; diff --git a/bootstrap/windows-88/Platform.h b/bootstrap/windows-88/Platform.h index 179bd3c3..374b6842 100644 --- a/bootstrap/windows-88/Platform.h +++ b/bootstrap/windows-88/Platform.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Platform__h #define Platform__h @@ -79,7 +79,7 @@ import INTEGER Platform_Write (LONGINT h, LONGINT p, LONGINT l); import BOOLEAN Platform_getEnv (CHAR *var, LONGINT var__len, CHAR *val, LONGINT val__len); import void *Platform__init(void); -#define Platform_SetInterruptHandler(h) SystemSetInterruptHandler((uintptr_t)h) -#define Platform_SetQuitHandler(h) SystemSetQuitHandler((uintptr_t)h) +#define Platform_SetInterruptHandler(h) SystemSetInterruptHandler((SYSTEM_ADDRESS)h) +#define Platform_SetQuitHandler(h) SystemSetQuitHandler((SYSTEM_ADDRESS)h) #endif diff --git a/bootstrap/windows-88/Reals.c b/bootstrap/windows-88/Reals.c index 0fb9a236..8b61d8cd 100644 --- a/bootstrap/windows-88/Reals.c +++ b/bootstrap/windows-88/Reals.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" @@ -59,7 +59,7 @@ INTEGER Reals_Expo (REAL x) { INTEGER _o_result; INTEGER i; - __GET((LONGINT)(uintptr_t)&x + 2, i, INTEGER); + __GET((LONGINT)(SYSTEM_ADDRESS)&x + 2, i, INTEGER); _o_result = __MASK(__ASHR(i, 7), -256); return _o_result; } @@ -67,17 +67,17 @@ INTEGER Reals_Expo (REAL x) void Reals_SetExpo (REAL *x, INTEGER ex) { CHAR c; - __GET((LONGINT)(uintptr_t)x + 3, c, CHAR); - __PUT((LONGINT)(uintptr_t)x + 3, (CHAR)(__ASHL(__ASHR((int)c, 7), 7) + __MASK(__ASHR(ex, 1), -128)), CHAR); - __GET((LONGINT)(uintptr_t)x + 2, c, CHAR); - __PUT((LONGINT)(uintptr_t)x + 2, (CHAR)(__MASK((int)c, -128) + __ASHL(__MASK(ex, -2), 7)), CHAR); + __GET((LONGINT)(SYSTEM_ADDRESS)x + 3, c, CHAR); + __PUT((LONGINT)(SYSTEM_ADDRESS)x + 3, (CHAR)(__ASHL(__ASHR((int)c, 7), 7) + __MASK(__ASHR(ex, 1), -128)), CHAR); + __GET((LONGINT)(SYSTEM_ADDRESS)x + 2, c, CHAR); + __PUT((LONGINT)(SYSTEM_ADDRESS)x + 2, (CHAR)(__MASK((int)c, -128) + __ASHL(__MASK(ex, -2), 7)), CHAR); } INTEGER Reals_ExpoL (LONGREAL x) { INTEGER _o_result; INTEGER i; - __GET((LONGINT)(uintptr_t)&x + 6, i, INTEGER); + __GET((LONGINT)(SYSTEM_ADDRESS)&x + 6, i, INTEGER); _o_result = __MASK(__ASHR(i, 4), -2048); return _o_result; } @@ -90,7 +90,7 @@ void Reals_ConvertL (LONGREAL x, INTEGER n, CHAR *d, LONGINT d__len) } k = 0; i = __ENTIER(x); - while (k < (LONGINT)n) { + while (k < (SYSTEM_INT64)n) { d[__X(k, d__len)] = (CHAR)(__MOD(i, 10) + 48); i = __DIV(i, 10); k += 1; @@ -122,7 +122,7 @@ static void Reals_BytesToHex (SYSTEM_BYTE *b, LONGINT b__len, SYSTEM_BYTE *d, LO CHAR by; i = 0; l = b__len; - while ((LONGINT)i < l) { + while ((SYSTEM_INT64)i < l) { by = __VAL(CHAR, b[__X(i, b__len)]); d[__X(__ASHL(i, 1), d__len)] = Reals_ToHex(__ASHR((int)by, 4)); d[__X(__ASHL(i, 1) + 1, d__len)] = Reals_ToHex(__MASK((int)by, -16)); diff --git a/bootstrap/windows-88/Reals.h b/bootstrap/windows-88/Reals.h index db522698..ff21c192 100644 --- a/bootstrap/windows-88/Reals.h +++ b/bootstrap/windows-88/Reals.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Reals__h #define Reals__h diff --git a/bootstrap/windows-88/SYSTEM.c b/bootstrap/windows-88/SYSTEM.c index 50e91c6d..33511a70 100644 --- a/bootstrap/windows-88/SYSTEM.c +++ b/bootstrap/windows-88/SYSTEM.c @@ -35,7 +35,7 @@ void SYSTEM_INHERIT(LONGINT *t, LONGINT *t0) void SYSTEM_ENUMP(void *adr, LONGINT n, void (*P)()) { while (n > 0) { - P((LONGINT)(uintptr_t)(*((void**)(adr)))); + P((LONGINT)(SYSTEM_ADDRESS)(*((void**)(adr)))); adr = ((void**)adr) + 1; n--; } @@ -106,7 +106,7 @@ SYSTEM_PTR SYSTEM_NEWARR(LONGINT *typ, LONGINT elemsz, int elemalgn, int nofdim, else if (typ == (LONGINT*)POINTER__typ) { /* element type is a pointer */ x = Heap_NEWBLK(size + nofelems * sizeof(LONGINT)); - p = (LONGINT*)(uintptr_t)x[-1]; + p = (LONGINT*)(SYSTEM_ADDRESS)x[-1]; p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */ while (n <= nofelems) {*p = n*sizeof(LONGINT); p++; n++;} @@ -119,7 +119,7 @@ SYSTEM_PTR SYSTEM_NEWARR(LONGINT *typ, LONGINT elemsz, int elemalgn, int nofdim, while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */ nptr = nofelems * nofptrs; /* total number of pointers */ x = Heap_NEWBLK(size + nptr * sizeof(LONGINT)); - p = (LONGINT*)(uintptr_t)x[- 1]; + p = (LONGINT*)(SYSTEM_ADDRESS)x[- 1]; p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ p -= nptr - 1; n = 0; off = dataoff; while (n < nofelems) {i = 0; @@ -155,7 +155,7 @@ typedef void (*SystemSignalHandler)(INTEGER); // = Platform_SignalHandler // (Ignore other signals) } - void SystemSetHandler(int s, uintptr_t h) { + void SystemSetHandler(int s, SYSTEM_ADDRESS h) { if (s >= 2 && s <= 4) { int needtosetsystemhandler = handler[s-2] == 0; handler[s-2] = (SystemSignalHandler)h; @@ -194,12 +194,12 @@ typedef void (*SystemSignalHandler)(INTEGER); // = Platform_SignalHandler } } - void SystemSetInterruptHandler(uintptr_t h) { + void SystemSetInterruptHandler(SYSTEM_ADDRESS h) { EnsureConsoleCtrlHandler(); SystemInterruptHandler = (SystemSignalHandler)h; } - void SystemSetQuitHandler(uintptr_t h) { + void SystemSetQuitHandler(SYSTEM_ADDRESS h) { EnsureConsoleCtrlHandler(); SystemQuitHandler = (SystemSignalHandler)h; } diff --git a/bootstrap/windows-88/SYSTEM.h b/bootstrap/windows-88/SYSTEM.h index 949951ac..6377745e 100644 --- a/bootstrap/windows-88/SYSTEM.h +++ b/bootstrap/windows-88/SYSTEM.h @@ -1,28 +1,38 @@ #ifndef SYSTEM__h #define SYSTEM__h -#ifndef _WIN32 - - // Building for a Unix/Linux based system - #include // For memcpy ... - #include // For uintptr_t ... - +#if defined(_WIN64) + typedef long long SYSTEM_INT64; + typedef unsigned long long SYSTEM_CARD64; #else - - // Building for Windows platform with either mingw under cygwin, or the MS C compiler - #ifdef _WIN64 - typedef unsigned long long size_t; - typedef unsigned long long uintptr_t; - #else - typedef unsigned int size_t; - typedef unsigned int uintptr_t; - #endif /* _WIN64 */ - - typedef unsigned int uint32_t; - void * __cdecl memcpy(void * dest, const void * source, size_t size); - + typedef long SYSTEM_INT64; + typedef unsigned long SYSTEM_CARD64; #endif +typedef int SYSTEM_INT32; +typedef unsigned int SYSTEM_CARD32; +typedef short int SYSTEM_INT16; +typedef unsigned short int SYSTEM_CARD16; +typedef signed char SYSTEM_INT8; +typedef unsigned char SYSTEM_CARD8; + +#if (__SIZEOF_POINTER__ == 8) || defined(_WIN64) || defined(__LP64__) + #if defined(_WIN64) + typedef unsigned long long size_t; + #else + typedef unsigned long size_t; + #endif +#else + typedef unsigned int size_t; +#endif + +#define SYSTEM_ADDRESS size_t +#define _SIZE_T_DECLARED // For FreeBSD +#define _SIZE_T_DEFINED_ // For OpenBSD + +void *memcpy(void *dest, const void *source, SYSTEM_ADDRESS size); + + // The compiler uses 'import' and 'export' which translate to 'extern' and // nothing respectively. @@ -70,6 +80,7 @@ typedef unsigned char U_SHORTINT; #endif typedef U_LONGINT SET; +typedef U_LONGINT U_SET; // OS Memory allocation interfaces are in PlatformXXX.Mod @@ -96,10 +107,10 @@ extern LONGINT SYSTEM_ENTIER (double x); // Signal handling in SYSTEM.c #ifndef _WIN32 - extern void SystemSetHandler(int s, uintptr_t h); + extern void SystemSetHandler(int s, SYSTEM_ADDRESS h); #else - extern void SystemSetInterruptHandler(uintptr_t h); - extern void SystemSetQuitHandler (uintptr_t h); + extern void SystemSetInterruptHandler(SYSTEM_ADDRESS h); + extern void SystemSetQuitHandler (SYSTEM_ADDRESS h); #endif @@ -122,20 +133,20 @@ static int __str_cmp(CHAR *x, CHAR *y){ #define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d; LONGINT _i=0,_t=n-1; \ while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;} -#define __DUP(x, l, t) x=(void*)memcpy((void*)(uintptr_t)Platform_OSAllocate(l*sizeof(t)),x,l*sizeof(t)) +#define __DUP(x, l, t) x=(void*)memcpy((void*)(SYSTEM_ADDRESS)Platform_OSAllocate(l*sizeof(t)),x,l*sizeof(t)) #define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) -#define __DEL(x) Platform_OSFree((LONGINT)(uintptr_t)x) +#define __DEL(x) Platform_OSFree((LONGINT)(SYSTEM_ADDRESS)x) /* SYSTEM ops */ -#define __VAL(t, x) ((t)(x)) -#define __VALP(t, x) ((t)(uintptr_t)(x)) +#define __VAL(t, x) (*(t*)&(x)) -#define __GET(a, x, t) x= *(t*)(uintptr_t)(a) -#define __PUT(a, x, t) *(t*)(uintptr_t)(a)=x + +#define __GET(a, x, t) x= *(t*)(SYSTEM_ADDRESS)(a) +#define __PUT(a, x, t) *(t*)(SYSTEM_ADDRESS)(a)=x #define __LSHL(x, n, t) ((t)((U_##t)(x)<<(n))) #define __LSHR(x, n, t) ((t)((U_##t)(x)>>(n))) @@ -150,7 +161,7 @@ static int __str_cmp(CHAR *x, CHAR *y){ #define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t)) #define __BIT(x, n) (*(U_LONGINT*)(x)>>(n)&1) -#define __MOVE(s, d, n) memcpy((char*)(uintptr_t)(d),(char*)(uintptr_t)(s),n) +#define __MOVE(s, d, n) memcpy((char*)(SYSTEM_ADDRESS)(d),(char*)(SYSTEM_ADDRESS)(s),n) #define __ASHF(x, n) SYSTEM_ASH((LONGINT)(x), (LONGINT)(n)) #define __SHORT(x, y) ((int)((U_LONGINT)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0))) #define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y))) @@ -211,7 +222,7 @@ extern void Heap_INCREF(); extern void Platform_Init(INTEGER argc, LONGINT argv); extern void Heap_FINALL(); -#define __INIT(argc, argv) static void *m; Platform_Init((INTEGER)argc, (LONGINT)(uintptr_t)&argv); +#define __INIT(argc, argv) static void *m; Platform_Init((INTEGER)argc, (LONGINT)(SYSTEM_ADDRESS)&argv); #define __REGMAIN(name, enum) m = Heap_REGMOD((CHAR*)name,enum) #define __FINI Heap_FINALL(); return 0 @@ -232,7 +243,7 @@ extern SYSTEM_PTR Heap_NEWREC (LONGINT tag); extern SYSTEM_PTR SYSTEM_NEWARR(LONGINT*, LONGINT, int, int, int, ...); #define __SYSNEW(p, len) p = Heap_NEWBLK((LONGINT)(len)) -#define __NEW(p, t) p = Heap_NEWREC((LONGINT)(uintptr_t)t##__typ) +#define __NEW(p, t) p = Heap_NEWREC((LONGINT)(SYSTEM_ADDRESS)t##__typ) #define __NEWARR SYSTEM_NEWARR @@ -263,20 +274,20 @@ extern SYSTEM_PTR SYSTEM_NEWARR(LONGINT*, LONGINT, int, int, int, ...); #define __INITYP(t, t0, level) \ t##__typ = (LONGINT*)&t##__desc.blksz; \ memcpy(t##__desc.basep, t0##__typ - __BASEOFF, level*sizeof(LONGINT)); \ - t##__desc.basep[level] = (LONGINT)(uintptr_t)t##__typ; \ - t##__desc.module = (LONGINT)(uintptr_t)m; \ + t##__desc.basep[level] = (LONGINT)(SYSTEM_ADDRESS)t##__typ; \ + t##__desc.module = (LONGINT)(SYSTEM_ADDRESS)m; \ if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ t##__desc.blksz = (t##__desc.blksz+5*sizeof(LONGINT)-1)/(4*sizeof(LONGINT))*(4*sizeof(LONGINT)); \ - Heap_REGTYP(m, (LONGINT)(uintptr_t)&t##__desc.next); \ + Heap_REGTYP(m, (LONGINT)(SYSTEM_ADDRESS)&t##__desc.next); \ SYSTEM_INHERIT(t##__typ, t0##__typ) -#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(LONGINT)(uintptr_t)typ##__typ) -#define __TYPEOF(p) ((LONGINT*)(uintptr_t)(*(((LONGINT*)(p))-1))) +#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(LONGINT)(SYSTEM_ADDRESS)typ##__typ) +#define __TYPEOF(p) ((LONGINT*)(SYSTEM_ADDRESS)(*(((LONGINT*)(p))-1))) #define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) // Oberon-2 type bound procedures support -#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(LONGINT)(uintptr_t)proc -#define __SEND(typ, num, funtyp, parlist) ((funtyp)((uintptr_t)*(typ-(__TPROC0OFF+num))))parlist +#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(LONGINT)(SYSTEM_ADDRESS)proc +#define __SEND(typ, num, funtyp, parlist) ((funtyp)((SYSTEM_ADDRESS)*(typ-(__TPROC0OFF+num))))parlist diff --git a/bootstrap/windows-88/Strings.c b/bootstrap/windows-88/Strings.c index 962b86a0..20a14540 100644 --- a/bootstrap/windows-88/Strings.c +++ b/bootstrap/windows-88/Strings.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" @@ -22,7 +22,7 @@ INTEGER Strings_Length (CHAR *s, LONGINT s__len) INTEGER i; __DUP(s, s__len, CHAR); i = 0; - while (((LONGINT)i < s__len && s[__X(i, s__len)] != 0x00)) { + while (((SYSTEM_INT64)i < s__len && s[__X(i, s__len)] != 0x00)) { i += 1; } _o_result = i; @@ -37,11 +37,11 @@ void Strings_Append (CHAR *extra, LONGINT extra__len, CHAR *dest, LONGINT dest__ n1 = Strings_Length(dest, dest__len); n2 = Strings_Length(extra, extra__len); i = 0; - while ((i < n2 && (LONGINT)(i + n1) < dest__len)) { + while ((i < n2 && (SYSTEM_INT64)(i + n1) < dest__len)) { dest[__X(i + n1, dest__len)] = extra[__X(i, extra__len)]; i += 1; } - if ((LONGINT)(i + n1) < dest__len) { + if ((SYSTEM_INT64)(i + n1) < dest__len) { dest[__X(i + n1, dest__len)] = 0x00; } __DEL(extra); @@ -60,10 +60,10 @@ void Strings_Insert (CHAR *source, LONGINT source__len, INTEGER pos, CHAR *dest, Strings_Append(dest, dest__len, (void*)source, source__len); return; } - if ((LONGINT)(pos + n2) < dest__len) { + if ((SYSTEM_INT64)(pos + n2) < dest__len) { i = n1; while (i >= pos) { - if ((LONGINT)(i + n2) < dest__len) { + if ((SYSTEM_INT64)(i + n2) < dest__len) { dest[__X(i + n2, dest__len)] = dest[__X(i, dest__len)]; } i -= 1; @@ -92,7 +92,7 @@ void Strings_Delete (CHAR *s, LONGINT s__len, INTEGER pos, INTEGER n) s[__X(i - n, s__len)] = s[__X(i, s__len)]; i += 1; } - if ((LONGINT)(i - n) < s__len) { + if ((SYSTEM_INT64)(i - n) < s__len) { s[__X(i - n, s__len)] = 0x00; } } else { @@ -122,7 +122,7 @@ void Strings_Extract (CHAR *source, LONGINT source__len, INTEGER pos, INTEGER n, return; } i = 0; - while (((((LONGINT)(pos + i) <= source__len && source[__X(pos + i, source__len)] != 0x00)) && i < n)) { + while (((((SYSTEM_INT64)(pos + i) <= source__len && source[__X(pos + i, source__len)] != 0x00)) && i < n)) { if (i < destLen) { dest[__X(i, dest__len)] = source[__X(pos + i, source__len)]; } diff --git a/bootstrap/windows-88/Strings.h b/bootstrap/windows-88/Strings.h index 549337ee..d64d3478 100644 --- a/bootstrap/windows-88/Strings.h +++ b/bootstrap/windows-88/Strings.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Strings__h #define Strings__h diff --git a/bootstrap/windows-88/Texts.c b/bootstrap/windows-88/Texts.c index fe673ac8..a1fb81c0 100644 --- a/bootstrap/windows-88/Texts.c +++ b/bootstrap/windows-88/Texts.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "Files.h" @@ -788,9 +788,9 @@ void Texts_Scan (Texts_Scanner *S, LONGINT *S__typ) (*S).s[__X(i, ((LONGINT)(64)))] = 0x00; (*S).len = i; (*S).class = 1; - } else if (ch == '\"') { + } else if (ch == '"') { Texts_Read((void*)&*S, S__typ, &ch); - while ((((ch != '\"' && ch >= ' ')) && i != 63)) { + while ((((ch != '"' && ch >= ' ')) && i != 63)) { (*S).s[__X(i, ((LONGINT)(64)))] = ch; i += 1; Texts_Read((void*)&*S, S__typ, &ch); @@ -840,7 +840,7 @@ void Texts_Scan (Texts_Scanner *S, LONGINT *S__typ) k -= 16; } while (j < i) { - k = __ASHL(k, 4) + (LONGINT)((int)d[__X(j, ((LONGINT)(32)))] - 48); + k = __ASHL(k, 4) + (SYSTEM_INT64)((int)d[__X(j, ((LONGINT)(32)))] - 48); j += 1; } if (neg) { @@ -930,7 +930,7 @@ void Texts_Scan (Texts_Scanner *S, LONGINT *S__typ) (*S).class = 3; k = 0; do { - k = k * 10 + (LONGINT)((int)d[__X(j, ((LONGINT)(32)))] - 48); + k = k * 10 + (SYSTEM_INT64)((int)d[__X(j, ((LONGINT)(32)))] - 48); j += 1; } while (!(j == i)); if (neg) { @@ -1068,7 +1068,7 @@ void Texts_WriteInt (Texts_Writer *W, LONGINT *W__typ, LONGINT x, LONGINT n) x0 = __DIV(x0, 10); i += 1; } while (!(x0 == 0)); - while (n > (LONGINT)i) { + while (n > (SYSTEM_INT64)i) { Texts_Write(&*W, W__typ, ' '); n -= 1; } @@ -1320,7 +1320,7 @@ void Texts_WriteLongReal (Texts_Writer *W, LONGINT *W__typ, LONGREAL x, INTEGER } else { Texts_Write(&*W, W__typ, ' '); } - e = (int)__ASHR((LONGINT)(e - 1023) * 77, 8); + e = (int)__ASHR((SYSTEM_INT64)(e - 1023) * 77, 8); if (e >= 0) { x = x / (LONGREAL)Reals_TenL(e); } else { diff --git a/bootstrap/windows-88/Texts.h b/bootstrap/windows-88/Texts.h index dcee9f40..bca5665d 100644 --- a/bootstrap/windows-88/Texts.h +++ b/bootstrap/windows-88/Texts.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef Texts__h #define Texts__h diff --git a/bootstrap/windows-88/Vishap.c b/bootstrap/windows-88/Vishap.c index ccb3e59e..6eda4f2c 100644 --- a/bootstrap/windows-88/Vishap.c +++ b/bootstrap/windows-88/Vishap.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkamSf */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkamSf */ #define LARGE #include "SYSTEM.h" #include "Configuration.h" diff --git a/bootstrap/windows-88/errors.c b/bootstrap/windows-88/errors.c index 9b9ec275..48246ffa 100644 --- a/bootstrap/windows-88/errors.c +++ b/bootstrap/windows-88/errors.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" @@ -26,7 +26,7 @@ export void *errors__init(void) errors_errors[6][0] = 0x00; errors_errors[7][0] = 0x00; errors_errors[8][0] = 0x00; - __MOVE("\'=\' expected", errors_errors[9], 13); + __MOVE("'=' expected", errors_errors[9], 13); errors_errors[10][0] = 0x00; errors_errors[11][0] = 0x00; __MOVE("type definition starts with incorrect symbol", errors_errors[12], 45); @@ -35,28 +35,28 @@ export void *errors__init(void) __MOVE("declaration followed by incorrect symbol", errors_errors[15], 41); __MOVE("MODULE expected", errors_errors[16], 16); errors_errors[17][0] = 0x00; - __MOVE("\'.\' missing", errors_errors[18], 12); - __MOVE("\',\' missing", errors_errors[19], 12); - __MOVE("\':\' missing", errors_errors[20], 12); + __MOVE("'.' missing", errors_errors[18], 12); + __MOVE("',' missing", errors_errors[19], 12); + __MOVE("':' missing", errors_errors[20], 12); errors_errors[21][0] = 0x00; - __MOVE("\')\' missing", errors_errors[22], 12); - __MOVE("\']\' missing", errors_errors[23], 12); - __MOVE("\'}\' missing", errors_errors[24], 12); + __MOVE("')' missing", errors_errors[22], 12); + __MOVE("']' missing", errors_errors[23], 12); + __MOVE("'}' missing", errors_errors[24], 12); __MOVE("OF missing", errors_errors[25], 11); __MOVE("THEN missing", errors_errors[26], 13); __MOVE("DO missing", errors_errors[27], 11); __MOVE("TO missing", errors_errors[28], 11); errors_errors[29][0] = 0x00; - __MOVE("\'(\' missing", errors_errors[30], 12); + __MOVE("'(' missing", errors_errors[30], 12); errors_errors[31][0] = 0x00; errors_errors[32][0] = 0x00; errors_errors[33][0] = 0x00; - __MOVE("\':=\' missing", errors_errors[34], 13); - __MOVE("\',\' or OF expected", errors_errors[35], 19); + __MOVE("':=' missing", errors_errors[34], 13); + __MOVE("',' or OF expected", errors_errors[35], 19); errors_errors[36][0] = 0x00; errors_errors[37][0] = 0x00; __MOVE("identifier expected", errors_errors[38], 20); - __MOVE("\';\' missing", errors_errors[39], 12); + __MOVE("';' missing", errors_errors[39], 12); errors_errors[40][0] = 0x00; __MOVE("END missing", errors_errors[41], 12); errors_errors[42][0] = 0x00; @@ -132,10 +132,10 @@ export void *errors__init(void) __MOVE("operand is not a variable", errors_errors[112], 26); __MOVE("incompatible assignment", errors_errors[113], 24); __MOVE("string too long to be assigned", errors_errors[114], 31); - __MOVE("parameter doesn\'t match", errors_errors[115], 24); - __MOVE("number of parameters doesn\'t match", errors_errors[116], 35); - __MOVE("result type doesn\'t match", errors_errors[117], 26); - __MOVE("export mark doesn\'t match with forward declaration", errors_errors[118], 51); + __MOVE("parameter doesn't match", errors_errors[115], 24); + __MOVE("number of parameters doesn't match", errors_errors[116], 35); + __MOVE("result type doesn't match", errors_errors[117], 26); + __MOVE("export mark doesn't match with forward declaration", errors_errors[118], 51); __MOVE("redefinition textually precedes procedure bound to base type", errors_errors[119], 61); __MOVE("type of expression following IF, WHILE, UNTIL or ASSERT is not BOOLEAN", errors_errors[120], 71); __MOVE("called object is not a procedure (or is an interrupt procedure)", errors_errors[121], 64); @@ -195,5 +195,6 @@ export void *errors__init(void) __MOVE("implicit type cast", errors_errors[301], 19); __MOVE("inappropriate symbol file ignored", errors_errors[306], 34); __MOVE("no ELSE symbol after CASE statement sequence may lead to trap", errors_errors[307], 62); + __MOVE("SYSTEM.VAL result includes memory past end of source variable", errors_errors[308], 62); __ENDMOD; } diff --git a/bootstrap/windows-88/errors.h b/bootstrap/windows-88/errors.h index fdf34cf1..9081238a 100644 --- a/bootstrap/windows-88/errors.h +++ b/bootstrap/windows-88/errors.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef errors__h #define errors__h diff --git a/bootstrap/windows-88/extTools.c b/bootstrap/windows-88/extTools.c index 521538ae..4005b0a6 100644 --- a/bootstrap/windows-88/extTools.c +++ b/bootstrap/windows-88/extTools.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "Configuration.h" diff --git a/bootstrap/windows-88/extTools.h b/bootstrap/windows-88/extTools.h index de353aeb..6ac1ab91 100644 --- a/bootstrap/windows-88/extTools.h +++ b/bootstrap/windows-88/extTools.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef extTools__h #define extTools__h diff --git a/bootstrap/windows-88/vt100.c b/bootstrap/windows-88/vt100.c index 1b8568fe..a9110e8a 100644 --- a/bootstrap/windows-88/vt100.c +++ b/bootstrap/windows-88/vt100.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #define LARGE #include "SYSTEM.h" #include "Console.h" @@ -253,7 +253,7 @@ export void *vt100__init(void) __REGCMD("RCP", vt100_RCP); __REGCMD("SCP", vt100_SCP); /* BEGIN */ - __COPY("", vt100_CSI, ((LONGINT)(5))); + __COPY("\033", vt100_CSI, ((LONGINT)(5))); Strings_Append((CHAR*)"[", (LONGINT)2, (void*)vt100_CSI, ((LONGINT)(5))); __ENDMOD; } diff --git a/bootstrap/windows-88/vt100.h b/bootstrap/windows-88/vt100.h index 2d276238..801bc8f9 100644 --- a/bootstrap/windows-88/vt100.h +++ b/bootstrap/windows-88/vt100.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/08/24] for gcc LP64 on cygwin xtspkaSfF */ +/* voc 1.95 [2016/08/23] for gcc LP64 on cygwin xtspkaSfF */ #ifndef vt100__h #define vt100__h diff --git a/makefile b/makefile index 811ecefc..eee8238a 100644 --- a/makefile +++ b/makefile @@ -106,6 +106,7 @@ configuration: FORCE @./a.o @rm a.o @echo BRANCH=$$(git rev-parse --abbrev-ref HEAD)>>Configuration.Make + @echo Branch: $$(git rev-parse --abbrev-ref HEAD). @@ -133,6 +134,7 @@ clean: configuration # full: Full build of compiler and libarary. full: configuration @make -f src/tools/make/vishap.make -s installable + @-make -f src/tools/make/vishap.make -s uninstall @make -f src/tools/make/vishap.make -s clean # Make bootstrap compiler from source suitable for current data model @printf "\n\n--- Compiler build started ---\n\n" @@ -164,6 +166,10 @@ compiler: configuration +# Report changes to compiler source relative to bootstrap compiler +sourcechanges: + @make -f src/tools/make/vishap.make -s sourcechanges + # browsercmd: build the 'showdef' command browsercmd: configuration @@ -176,6 +182,27 @@ browsercmd: configuration library: configuration @make -f src/tools/make/vishap.make -s library +# Individual library components +v4: configuration + @make -f src/tools/make/vishap.make -s v4 + +ooc2: configuration + @make -f src/tools/make/vishap.make -s ooc2 + +ooc: configuration + @make -f src/tools/make/vishap.make -s ooc + +ulm: configuration + @make -f src/tools/make/vishap.make -s ulm + +pow32: configuration + @make -f src/tools/make/vishap.make -s pow32 + +misc: configuration + @make -f src/tools/make/vishap.make -s misc + +s3: configuration + @make -f src/tools/make/vishap.make -s s3 @@ -228,6 +255,8 @@ revertbootstrap: # --- multi-machine multi-platform build management --- +# NOTE: No longer used. Obsoleted by postpush.pl and buildall.pl. + # coordinator: Start the test machine coordinator diff --git a/src/compiler/OPB.Mod b/src/compiler/OPB.Mod index a06b1cfc..6da12c5e 100644 --- a/src/compiler/OPB.Mod +++ b/src/compiler/OPB.Mod @@ -3,93 +3,36 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) IMPORT OPT, OPS, OPM, SYSTEM; + CONST - (* symbol values or ops *) - times = 1; slash = 2; div = 3; mod = 4; - and = 5; plus = 6; minus = 7; or = 8; eql = 9; - neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; - in = 15; is = 16; ash = 17; msk = 18; len = 19; - conv = 20; abs = 21; cap = 22; odd = 23; not = 33; - (*SYSTEM*) - adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; - - (* object modes *) - Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; - SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; - - (* Structure forms *) - Undef = 0; Byte = 1; Bool = 2; Char = 3; - SInt = 4; Int = 5; LInt = 6; - Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Comp = 15; -(* Int8 = 7; Int16 = 8; Int32 = 9; Int64 = 10; - Real = 11; LReal = 12; Set = 13; String = 14; NilTyp = 15; NoTyp = 16; - Pointer = 17; ProcTyp = 18; - Comp = 19; - *) - (*Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18; - Comp = (*15*)19;*) - - intSet = {SInt..LInt(*, Int8..Int64*)}; realSet = {Real, LReal}; - - (* composite structure forms *) - Basic = 1; Array = 2; DynArr = 3; Record = 4; - - (* nodes classes *) - Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; - Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; - Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; - Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; - Nreturn = 26; Nwith = 27; Ntrap = 28; - - (*function number*) - assign = 0; - haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4; - entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9; - shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14; - inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32; - - (*SYSTEM function number*) - adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23; - getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; - bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31; - - (* module visibility of objects *) - internal = 0; external = 1; externalR = 2; - - (* procedure flags (conval^.setval) *) - hasBody = 1; isRedef = 2; slNeeded = 3; - AssertTrap = 0; (* default trap number *) + VAR typSize*: PROCEDURE(typ: OPT.Struct); - exp: INTEGER; (*side effect of log*) - maxExp: LONGINT; (* max n in ASH(1, n) on this machine *) + exp: INTEGER; (*side effect of log*) + maxExp: LONGINT; (* max n in ASH(1, n) on this machine *) + PROCEDURE err(n: INTEGER); BEGIN OPM.err(n) END err; + PROCEDURE NewLeaf*(obj: OPT.Object): OPT.Node; VAR node: OPT.Node; BEGIN CASE obj^.mode OF - Var: - node := OPT.NewNode(Nvar); node^.readonly := (obj^.vis = externalR) & (obj^.mnolev < 0) - | VarPar: - node := OPT.NewNode(Nvarpar) - | Con: - node := OPT.NewNode(Nconst); node^.conval := OPT.NewConst(); - node^.conval^ := obj^.conval^ (* string is not copied, only its ref *) - | Typ: - node := OPT.NewNode(Ntype) - | LProc..IProc: - node := OPT.NewNode(Nproc) - ELSE err(127); node := OPT.NewNode(Nvar) + | OPT.Var: node := OPT.NewNode(OPT.Nvar); + node^.readonly := (obj^.vis = OPT.externalR) & (obj^.mnolev < 0) + | OPT.VarPar: node := OPT.NewNode(OPT.Nvarpar) + | OPT.Con: node := OPT.NewNode(OPT.Nconst); + node^.conval := OPT.NewConst(); + node^.conval^ := obj^.conval^ (* string is not copied, only its ref *) + | OPT.Typ: node := OPT.NewNode(OPT.Ntype) + | OPT.LProc + ..OPT.IProc: node := OPT.NewNode(OPT.Nproc) + ELSE node := OPT.NewNode(OPT.Nvar); err(127) END ; node^.obj := obj; node^.typ := obj^.typ; RETURN node @@ -122,7 +65,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE NewBoolConst*(boolval: BOOLEAN): OPT.Node; VAR x: OPT.Node; BEGIN - x := OPT.NewNode(Nconst); x^.typ := OPT.booltyp; + x := OPT.NewNode(OPT.Nconst); x^.typ := OPT.booltyp; x^.conval := OPT.NewConst(); x^.conval^.intval := BoolToInt(boolval); RETURN x END NewBoolConst; @@ -130,7 +73,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) VAR if, pred: OPT.Node; BEGIN if := x^.left; - WHILE if^.left^.class = Nconst DO + WHILE if^.left^.class = OPT.Nconst DO IF IntToBool(if^.left^.conval^.intval) THEN x := if^.right; RETURN ELSIF if^.link = NIL THEN x := x^.right; RETURN ELSE if := if^.link; x^.left := if @@ -138,7 +81,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) END ; pred := if; if := if^.link; WHILE if # NIL DO - IF if^.left^.class = Nconst THEN + IF if^.left^.class = OPT.Nconst THEN IF IntToBool(if^.left^.conval^.intval) THEN pred^.link := NIL; x^.right := if^.right; RETURN ELSE if := if^.link; pred^.link := if @@ -151,41 +94,65 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE Nil*(): OPT.Node; VAR x: OPT.Node; BEGIN - x := OPT.NewNode(Nconst); x^.typ := OPT.niltyp; + x := OPT.NewNode(OPT.Nconst); x^.typ := OPT.niltyp; x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.nilval; RETURN x END Nil; PROCEDURE EmptySet*(): OPT.Node; VAR x: OPT.Node; BEGIN - x := OPT.NewNode(Nconst); x^.typ := OPT.settyp; + x := OPT.NewNode(OPT.Nconst); x^.typ := OPT.settyp; x^.conval := OPT.NewConst(); x^.conval^.setval := {}; RETURN x END EmptySet; + + (* Integer size support *) + + PROCEDURE SignedByteSize(n: LONGINT): INTEGER; + (* Returns number of bytes required to represent signed value n *) + VAR b: INTEGER; + BEGIN + IF n < 0 THEN n := -(n+1) END; (* Positive value in the range 0 - 7F.. *) + b := 1; WHILE (b < 8) & (ASH(n, -(8*b-1)) # 0) DO INC(b) END; + RETURN b + END SignedByteSize; + + PROCEDURE ShorterSize(i: LONGINT): LONGINT; + BEGIN IF i >= OPM.LIntSize THEN RETURN OPM.IntSize ELSE RETURN OPM.SIntSize END + END ShorterSize; + + PROCEDURE LongerSize(i: LONGINT): LONGINT; + BEGIN IF i <= OPM.SIntSize THEN RETURN OPM.IntSize ELSE RETURN OPM.LIntSize END + END LongerSize; + + PROCEDURE IntType(size: LONGINT): OPT.Struct; + (* Selects smallest standard integer type for given size in bytes *) + VAR result: OPT.Struct; + BEGIN + IF size <= OPT.sinttyp.size THEN result := OPT.sinttyp + ELSIF size <= OPT.inttyp.size THEN result := OPT.inttyp + ELSE + result := OPT.linttyp + END; + IF size > OPT.linttyp.size THEN err(203) END; (* Number too large *) + RETURN result + END IntType; + PROCEDURE SetIntType(node: OPT.Node); - VAR v: LONGINT(*SYSTEM.INT64*); - BEGIN v := node^.conval^.intval; - IF (OPM.MinSInt <= SYSTEM.VAL(LONGINT, v)) & (SYSTEM.VAL(LONGINT, v) <= OPM.MaxSInt) THEN node^.typ := OPT.sinttyp - ELSIF (OPM.MinInt <= SYSTEM.VAL(LONGINT, v)) & (SYSTEM.VAL(LONGINT, v) <= OPM.MaxInt) THEN node^.typ := OPT.inttyp - ELSIF (OPM.MinLInt <= v) & (v <= OPM.MaxLInt) (*bootstrap or cross*) THEN - node^.typ := OPT.linttyp - (*ELSIF (OPM.MinInt64) <= v) & (v <= OPM.MaxInt64) THEN - node^.typ := OPT.int64typ*) - ELSE err(203); node^.typ := OPT.sinttyp; node^.conval^.intval := 1 - END + BEGIN node.typ := IntType(SignedByteSize(node.conval.intval)) END SetIntType; PROCEDURE NewIntConst*(intval: LONGINT): OPT.Node; VAR x: OPT.Node; BEGIN - x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst(); + x := OPT.NewNode(OPT.Nconst); x^.conval := OPT.NewConst(); x^.conval^.intval := intval; SetIntType(x); RETURN x END NewIntConst; PROCEDURE NewRealConst*(realval: LONGREAL; typ: OPT.Struct): OPT.Node; VAR x: OPT.Node; BEGIN - x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst(); + x := OPT.NewNode(OPT.Nconst); x^.conval := OPT.NewConst(); x^.conval^.realval := realval; x^.typ := typ; x^.conval^.intval := OPM.ConstNotAlloc; RETURN x END NewRealConst; @@ -193,7 +160,7 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE NewString*(VAR str: OPS.String; len: LONGINT): OPT.Node; VAR x: OPT.Node; BEGIN - x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst(); x^.typ := OPT.stringtyp; + x := OPT.NewNode(OPT.Nconst); x^.conval := OPT.NewConst(); x^.typ := OPT.stringtyp; x^.conval^.intval := OPM.ConstNotAlloc; x^.conval^.intval2 := len; x^.conval^.ext := OPT.NewExt(); x^.conval^.ext^ := str; RETURN x @@ -215,21 +182,21 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) END BindNodes; PROCEDURE NotVar(x: OPT.Node): BOOLEAN; - BEGIN RETURN (x^.class >= Nconst) & ((x^.class # Nmop) OR (x^.subcl # val) OR (x^.left^.class >= Nconst)) + BEGIN RETURN (x^.class >= OPT.Nconst) & ((x^.class # OPT.Nmop) OR (x^.subcl # OPT.val) OR (x^.left^.class >= OPT.Nconst)) END NotVar; PROCEDURE DeRef*(VAR x: OPT.Node); VAR strobj, bstrobj: OPT.Object; typ, btyp: OPT.Struct; BEGIN typ := x^.typ; - IF x^.class >= Nconst THEN err(78) - ELSIF typ^.form = Pointer THEN + IF x^.class >= OPT.Nconst THEN err(78) + ELSIF typ^.form = OPT.Pointer THEN IF typ = OPT.sysptrtyp THEN err(57) END ; btyp := typ^.BaseTyp; strobj := typ^.strobj; bstrobj := btyp^.strobj; IF (strobj # NIL) & (strobj^.name # "") & (bstrobj # NIL) & (bstrobj^.name # "") THEN btyp^.pbused := TRUE END ; - BindNodes(Nderef, btyp, x, NIL) + BindNodes(OPT.Nderef, btyp, x, NIL) ELSE err(84) END END DeRef; @@ -238,23 +205,23 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) VAR f: INTEGER; typ: OPT.Struct; BEGIN f := y^.typ^.form; - IF x^.class >= Nconst THEN err(79) - ELSIF ~(f IN intSet) OR (y^.class IN {Nproc, Ntype}) THEN err(80); y^.typ := OPT.inttyp END ; - IF x^.typ^.comp = Array THEN typ := x^.typ^.BaseTyp; - IF (y^.class = Nconst) & ((y^.conval^.intval < 0) OR (y^.conval^.intval >= x^.typ^.n)) THEN err(81) END - ELSIF x^.typ^.comp = DynArr THEN typ := x^.typ^.BaseTyp; - IF (y^.class = Nconst) & (y^.conval^.intval < 0) THEN err(81) END + IF x^.class >= OPT.Nconst THEN err(79) + ELSIF ~(f IN OPT.intSet) OR (y^.class IN {OPT.Nproc, OPT.Ntype}) THEN err(80); y^.typ := OPT.inttyp END ; + IF x^.typ^.comp = OPT.Array THEN typ := x^.typ^.BaseTyp; + IF (y^.class = OPT.Nconst) & ((y^.conval^.intval < 0) OR (y^.conval^.intval >= x^.typ^.n)) THEN err(81) END + ELSIF x^.typ^.comp = OPT.DynArr THEN typ := x^.typ^.BaseTyp; + IF (y^.class = OPT.Nconst) & (y^.conval^.intval < 0) THEN err(81) END ELSE err(82); typ := OPT.undftyp END ; - BindNodes(Nindex, typ, x, y); x^.readonly := x^.left^.readonly + BindNodes(OPT.Nindex, typ, x, y); x^.readonly := x^.left^.readonly END Index; PROCEDURE Field*(VAR x: OPT.Node; y: OPT.Object); - BEGIN (*x^.typ^.comp = Record*) - IF x^.class >= Nconst THEN err(77) END ; - IF (y # NIL) & (y^.mode IN {Fld, TProc}) THEN - BindNodes(Nfield, y^.typ, x, NIL); x^.obj := y; - x^.readonly := x^.left^.readonly OR ((y^.vis = externalR) & (y^.mnolev < 0)) + BEGIN (*x^.typ^.comp = OPT.Record*) + IF x^.class >= OPT.Nconst THEN err(77) END ; + IF (y # NIL) & (y^.mode IN {OPT.Fld, OPT.TProc}) THEN + BindNodes(OPT.Nfield, y^.typ, x, NIL); x^.obj := y; + x^.readonly := x^.left^.readonly OR ((y^.vis = OPT.externalR) & (y^.mnolev < 0)) ELSE err(83); x^.typ := OPT.undftyp END END Field; @@ -267,17 +234,17 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) WHILE (t # NIL) & (t # t1) & (t # OPT.undftyp) DO t := t^.BaseTyp END ; IF t # t1 THEN WHILE (t1 # NIL) & (t1 # t0) & (t1 # OPT.undftyp) DO t1 := t1^.BaseTyp END ; - IF (t1 = t0) OR (t0.form = Undef (*SYSTEM.PTR*)) THEN - IF guard THEN BindNodes(Nguard, NIL, x, NIL); x^.readonly := x^.left^.readonly - ELSE node := OPT.NewNode(Nmop); node^.subcl := is; node^.left := x; + IF (t1 = t0) OR (t0.form = OPT.Undef (*SYSTEM.PTR*)) THEN + IF guard THEN BindNodes(OPT.Nguard, NIL, x, NIL); x^.readonly := x^.left^.readonly + ELSE node := OPT.NewNode(OPT.Nmop); node^.subcl := OPS.is; node^.left := x; node^.obj := obj; x := node END ELSE err(85) END ELSIF t0 # t1 THEN err(85) (* prevent down guard *) ELSIF ~guard THEN - IF x^.class = Nguard THEN (* cannot skip guard *) - node := OPT.NewNode(Nmop); node^.subcl := is; node^.left := x; + IF x^.class = OPT.Nguard THEN (* cannot skip guard *) + node := OPT.NewNode(OPT.Nmop); node^.subcl := OPS.is; node^.left := x; node^.obj := obj; x := node ELSE x := NewBoolConst(TRUE) END @@ -286,12 +253,12 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) BEGIN IF NotVar(x) THEN err(112) - ELSIF x^.typ^.form = Pointer THEN - IF (x^.typ^.BaseTyp^.comp # Record) & (x^.typ # OPT.sysptrtyp) THEN err(85) - ELSIF obj^.typ^.form = Pointer THEN GTT(x^.typ^.BaseTyp, obj^.typ^.BaseTyp) + ELSIF x^.typ^.form = OPT.Pointer THEN + IF (x^.typ^.BaseTyp^.comp # OPT.Record) & (x^.typ # OPT.sysptrtyp) THEN err(85) + ELSIF obj^.typ^.form = OPT.Pointer THEN GTT(x^.typ^.BaseTyp, obj^.typ^.BaseTyp) ELSE err(86) END - ELSIF (x^.typ^.comp = Record) & (x^.class = Nvarpar) & (obj^.typ^.comp = Record) THEN + ELSIF (x^.typ^.comp = OPT.Record) & (x^.class = OPT.Nvarpar) & (obj^.typ^.comp = OPT.Record) THEN GTT(x^.typ, obj^.typ) ELSE err(87) END ; @@ -301,15 +268,15 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE In*(VAR x: OPT.Node; y: OPT.Node); VAR f: INTEGER; k: LONGINT; BEGIN f := x^.typ^.form; - IF (x^.class = Ntype) OR (x^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126) - ELSIF (f IN intSet) & (y^.typ^.form = Set) THEN - IF x^.class = Nconst THEN + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) OR (y^.class = OPT.Ntype) OR (y^.class = OPT.Nproc) THEN err(126) + ELSIF (f IN OPT.intSet) & (y^.typ^.form = OPT.Set) THEN + IF x^.class = OPT.Nconst THEN k := x^.conval^.intval; IF (k < 0) OR (k > OPM.MaxSet) THEN err(202) - ELSIF y^.class = Nconst THEN x^.conval^.intval := BoolToInt(k IN y^.conval^.setval); x^.obj := NIL - ELSE BindNodes(Ndop, OPT.booltyp, x, y); x^.subcl := in + ELSIF y^.class = OPT.Nconst THEN x^.conval^.intval := BoolToInt(k IN y^.conval^.setval); x^.obj := NIL + ELSE BindNodes(OPT.Ndop, OPT.booltyp, x, y); x^.subcl := OPS.in END - ELSE BindNodes(Ndop, OPT.booltyp, x, y); x^.subcl := in + ELSE BindNodes(OPT.Ndop, OPT.booltyp, x, y); x^.subcl := OPS.in END ELSE err(92) END ; @@ -327,13 +294,13 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE CheckRealType(f, nr: INTEGER; x: OPT.Const); VAR min, max, r: LONGREAL; BEGIN - IF f = Real THEN min := OPM.MinReal; max := OPM.MaxReal + IF f = OPT.Real THEN min := OPM.MinReal; max := OPM.MaxReal ELSE min := OPM.MinLReal; max := OPM.MaxLReal END ; r := ABS(x^.realval); IF (r > max) OR (r < min) THEN err(nr); x^.realval := 1.0 - ELSIF f = Real THEN x^.realval := SHORT(x^.realval) (* single precision only *) + ELSIF f = OPT.Real THEN x^.realval := SHORT(x^.realval) (* single precision only *) END ; x^.intval := OPM.ConstNotAlloc END CheckRealType; @@ -344,86 +311,77 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE NewOp(op: SHORTINT; typ: OPT.Struct; z: OPT.Node): OPT.Node; VAR node: OPT.Node; BEGIN - node := OPT.NewNode(Nmop); node^.subcl := op; node^.typ := typ; + node := OPT.NewNode(OPT.Nmop); node^.subcl := op; node^.typ := typ; node^.left := z; RETURN node END NewOp; BEGIN z := x; - IF (z^.class = Ntype) OR (z^.class = Nproc) THEN err(126) + IF (z^.class = OPT.Ntype) OR (z^.class = OPT.Nproc) THEN err(126) ELSE typ := z^.typ; f := typ^.form; CASE op OF - not: - IF f = Bool THEN - IF z^.class = Nconst THEN - z^.conval^.intval := BoolToInt(~IntToBool(z^.conval^.intval)); z^.obj := NIL - ELSE z := NewOp(op, typ, z) - END - ELSE err(98) - END - | plus: - IF ~(f IN intSet + realSet) THEN err(96) END - | minus: - IF f IN intSet + realSet +{Set}THEN - IF z^.class = Nconst THEN - IF f IN intSet THEN - IF z^.conval^.intval = MIN(LONGINT) THEN err(203) - ELSE z^.conval^.intval := -z^.conval^.intval; SetIntType(z) - END - ELSIF f IN realSet THEN z^.conval^.realval := -z^.conval^.realval - ELSE z^.conval^.setval := -z^.conval^.setval - END ; - z^.obj := NIL - ELSE z := NewOp(op, typ, z) - END - ELSE err(97) - END - | abs: - IF f IN intSet + realSet THEN - IF z^.class = Nconst THEN - IF f IN intSet THEN - IF z^.conval^.intval = MIN(LONGINT) THEN err(203) - ELSE z^.conval^.intval := ABS(z^.conval^.intval); SetIntType(z) - END - ELSE z^.conval^.realval := ABS(z^.conval^.realval) - END ; - z^.obj := NIL - ELSE z := NewOp(op, typ, z) - END - ELSE err(111) - END - | cap: - IF f = Char THEN - IF z^.class = Nconst THEN - z^.conval^.intval := ORD(CAP(CHR(z^.conval^.intval))); z^.obj := NIL - ELSE z := NewOp(op, typ, z) - END - ELSE err(111); z^.typ := OPT.chartyp - END - | odd: - IF f IN intSet THEN - IF z^.class = Nconst THEN - z^.conval^.intval := BoolToInt(ODD(z^.conval^.intval)); z^.obj := NIL - ELSE z := NewOp(op, typ, z) - END - ELSE err(111) - END ; - z^.typ := OPT.booltyp - | adr: (*SYSTEM.ADR*) - IF (z^.class = Nconst) & (f = Char) & (z^.conval^.intval >= 20H) THEN - CharToString(z); f := String - END; - IF (z^.class < Nconst) OR (f = String) THEN z := NewOp(op, typ, z) - ELSE err(127) - END ; - z^.typ := OPT.linttyp - | cc: (*SYSTEM.CC*) - IF (f IN intSet) & (z^.class = Nconst) THEN - IF (0 <= z^.conval^.intval) & (z^.conval^.intval <= OPM.MaxCC) THEN z := NewOp(op, typ, z) ELSE err(219) END - ELSE err(69) - END ; - z^.typ := OPT.booltyp - ELSE - OPM.LogWStr("unhandled case in OPB.MOp, op = "); OPM.LogWNum(op, 0); OPM.LogWLn; + |OPS.not: IF f = OPT.Bool THEN + IF z^.class = OPT.Nconst THEN + z^.conval^.intval := BoolToInt(~IntToBool(z^.conval^.intval)); z^.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(98) + END + |OPS.plus: IF ~(f IN OPT.intSet + OPT.realSet) THEN err(96) END + |OPS.minus: IF f IN OPT.intSet + OPT.realSet +{OPT.Set}THEN + IF z^.class = OPT.Nconst THEN + IF f IN OPT.intSet THEN + IF z^.conval^.intval = MIN(LONGINT) THEN err(203) + ELSE z^.conval^.intval := -z^.conval^.intval; SetIntType(z) + END + ELSIF f IN OPT.realSet THEN z^.conval^.realval := -z^.conval^.realval + ELSE z^.conval^.setval := -z^.conval^.setval + END ; + z^.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(97) + END + |OPT.abs: IF f IN OPT.intSet + OPT.realSet THEN + IF z^.class = OPT.Nconst THEN + IF f IN OPT.intSet THEN + IF z^.conval^.intval = MIN(LONGINT) THEN err(203) + ELSE z^.conval^.intval := ABS(z^.conval^.intval); SetIntType(z) + END + ELSE z^.conval^.realval := ABS(z^.conval^.realval) + END ; + z^.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(111) + END + |OPT.cap: IF f = OPT.Char THEN + IF z^.class = OPT.Nconst THEN + z^.conval^.intval := ORD(CAP(CHR(z^.conval^.intval))); z^.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(111); z^.typ := OPT.chartyp + END + |OPT.odd: IF f IN OPT.intSet THEN + IF z^.class = OPT.Nconst THEN + z^.conval^.intval := BoolToInt(ODD(z^.conval^.intval)); z^.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(111) + END ; + z^.typ := OPT.booltyp + |OPT.adr: IF (z^.class = OPT.Nconst) & (f = OPT.Char) & (z^.conval^.intval >= 20H) THEN (*SYSTEM.ADR*) + CharToString(z); f := OPT.String + END; + IF (z^.class < OPT.Nconst) OR (f = OPT.String) THEN z := NewOp(op, typ, z) + ELSE err(127) + END ; + z^.typ := OPT.linttyp + |OPT.cc: IF (f IN OPT.intSet) & (z^.class = OPT.Nconst) THEN (*SYSTEM.CC*) + IF (0 <= z^.conval^.intval) & (z^.conval^.intval <= OPM.MaxCC) THEN z := NewOp(op, typ, z) ELSE err(219) END + ELSE err(69) + END ; + z^.typ := OPT.booltyp + ELSE OPM.LogWStr("unhandled case in OPB.MOp, op = "); OPM.LogWNum(op, 0); OPM.LogWLn; END END ; x := z @@ -432,15 +390,15 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE CheckPtr(x, y: OPT.Node); VAR g: INTEGER; p, q, t: OPT.Struct; BEGIN g := y^.typ^.form; - IF g = Pointer THEN + IF g = OPT.Pointer THEN p := x^.typ^.BaseTyp; q := y^.typ^.BaseTyp; - IF (p^.comp = Record) & (q^.comp = Record) THEN + IF (p^.comp = OPT.Record) & (q^.comp = OPT.Record) THEN IF p^.extlev < q^.extlev THEN t := p; p := q; q := t END ; WHILE (p # q) & (p # NIL) & (p # OPT.undftyp) DO p := p^.BaseTyp END ; IF p = NIL THEN err(100) END ELSE err(100) END - ELSIF g # NilTyp THEN err(100) + ELSIF g # OPT.NilTyp THEN err(100) END END CheckPtr; @@ -450,11 +408,11 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) WHILE fp # NIL DO IF ap # NIL THEN ft := fp^.typ; at := ap^.typ; - WHILE (ft^.comp = DynArr) & (at^.comp = DynArr) DO + WHILE (ft^.comp = OPT.DynArr) & (at^.comp = OPT.DynArr) DO ft := ft^.BaseTyp; at := at^.BaseTyp END ; IF ft # at THEN - IF (ft^.form = ProcTyp) & (at^.form = ProcTyp) THEN + IF (ft^.form = OPT.ProcTyp) & (at^.form = OPT.ProcTyp) THEN IF ft^.BaseTyp = at^.BaseTyp THEN CheckParameters(ft^.link, at^.link, FALSE) ELSE err(117) END @@ -472,9 +430,9 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE CheckProc(x: OPT.Struct; y: OPT.Object); (* proc var x := proc y, check compatibility *) BEGIN - IF y^.mode IN {XProc, IProc, LProc} THEN - IF y^.mode = LProc THEN - IF y^.mnolev = 0 THEN y^.mode := XProc + IF y^.mode IN {OPT.XProc, OPT.IProc, OPT.LProc} THEN + IF y^.mode = OPT.LProc THEN + IF y^.mnolev = 0 THEN y^.mode := OPT.XProc ELSE err(73) END END ; @@ -493,210 +451,176 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) VAR res: INTEGER; BEGIN CASE f OF - Undef: - res := eql - | Byte, Char..LInt(*,Int8..Int64*): - IF xval^.intval < yval^.intval THEN res := lss - ELSIF xval^.intval > yval^.intval THEN res := gtr - ELSE res := eql - END - | Real, LReal: - IF xval^.realval < yval^.realval THEN res := lss - ELSIF xval^.realval > yval^.realval THEN res := gtr - ELSE res := eql - END - | Bool: - IF xval^.intval # yval^.intval THEN res := neq - ELSE res := eql - END - | Set: - IF xval^.setval # yval^.setval THEN res := neq - ELSE res := eql - END - | String: - IF xval^.ext^ < yval^.ext^ THEN res := lss - ELSIF xval^.ext^ > yval^.ext^ THEN res := gtr - ELSE res := eql - END - | NilTyp, Pointer, ProcTyp: - IF xval^.intval # yval^.intval THEN res := neq - ELSE res := eql - END - ELSE - OPM.LogWStr("unhandled case in OPB.ConstCmp, f = "); OPM.LogWNum(f, 0); OPM.LogWLn; + |OPT.Undef: res := OPS.eql + |OPT.Byte, + OPT.Char + ..OPT.LInt: IF xval^.intval < yval^.intval THEN res := OPS.lss + ELSIF xval^.intval > yval^.intval THEN res := OPS.gtr + ELSE res := OPS.eql + END + |OPT.Real, + OPT.LReal: IF xval^.realval < yval^.realval THEN res := OPS.lss + ELSIF xval^.realval > yval^.realval THEN res := OPS.gtr + ELSE res := OPS.eql + END + |OPT.Bool: IF xval^.intval # yval^.intval THEN res := OPS.neq + ELSE res := OPS.eql + END + |OPT.Set: IF xval^.setval # yval^.setval THEN res := OPS.neq + ELSE res := OPS.eql + END + |OPT.String: IF xval^.ext^ < yval^.ext^ THEN res := OPS.lss + ELSIF xval^.ext^ > yval^.ext^ THEN res := OPS.gtr + ELSE res := OPS.eql + END + |OPT.NilTyp, + OPT.Pointer, + OPT.ProcTyp: IF xval^.intval # yval^.intval THEN res := OPS.neq + ELSE res := OPS.eql + END + ELSE OPM.LogWStr("unhandled case in OPB.ConstCmp, f = "); OPM.LogWNum(f, 0); OPM.LogWLn; END ; x^.typ := OPT.booltyp; RETURN res END ConstCmp; BEGIN + (* f, x, xval are for left side; g, y, yval for right side. *) f := x^.typ^.form; g := y^.typ^.form; xval := x^.conval; yval := y^.conval; IF f # g THEN CASE f OF - Char: - IF g = String THEN CharToString(x) - ELSE err(100); y^.typ := x^.typ; yval^ := xval^ - END ; - | SInt(*, Int8*): - IF g IN intSet THEN x^.typ := y^.typ - ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval - ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval - ELSE err(100); y^.typ := x^.typ; yval^ := xval^ - END - | Int(*, Int16, Int32, Int64*): - IF g = SInt THEN y^.typ := OPT.inttyp - ELSIF g IN intSet THEN x^.typ := y^.typ - ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval - ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval - ELSE err(100); y^.typ := x^.typ; yval^ := xval^ - END - | LInt: - IF g IN intSet THEN y^.typ := OPT.linttyp - ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval - ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval - ELSE err(100); y^.typ := x^.typ; yval^ := xval^ - END - | Real: - IF g IN intSet THEN y^.typ := x^.typ; yval^.realval := yval^.intval - ELSIF g = LReal THEN x^.typ := OPT.lrltyp - ELSE err(100); y^.typ := x^.typ; yval^ := xval^ - END - | LReal: - IF g IN intSet THEN y^.typ := x^.typ; yval^.realval := yval^.intval - ELSIF g = Real THEN y^.typ := OPT.lrltyp - ELSE err(100); y^.typ := x^.typ; yval^ := xval^ - END - | String: - IF g = Char THEN CharToString(y); g := String - ELSE err(100); y^.typ := x^.typ; yval^ := xval^ - END ; - | NilTyp: - IF ~(g IN {Pointer, ProcTyp}) THEN err(100) END - | Pointer: - CheckPtr(x, y) - | ProcTyp: - IF g # NilTyp THEN err(100) END + |OPT.Char: IF g = OPT.String THEN CharToString(x) + ELSE err(100); y^.typ := x^.typ; yval^ := xval^ + END ; + |OPT.SInt, + OPT.Int, + OPT.LInt: IF g IN OPT.intSet THEN + IF x.typ.size <= y.typ.size THEN x.typ := y.typ ELSE x.typ := IntType(x.typ.size) END + ELSIF g = OPT.Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval + ELSIF g = OPT.LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval + ELSE err(100); y^.typ := x^.typ; yval^ := xval^ + END + |OPT.Real: IF g IN OPT.intSet THEN y^.typ := x^.typ; yval^.realval := yval^.intval + ELSIF g = OPT.LReal THEN x^.typ := OPT.lrltyp + ELSE err(100); y^.typ := x^.typ; yval^ := xval^ + END + |OPT.LReal: IF g IN OPT.intSet THEN y^.typ := x^.typ; yval^.realval := yval^.intval + ELSIF g = OPT.Real THEN y^.typ := OPT.lrltyp + ELSE err(100); y^.typ := x^.typ; yval^ := xval^ + END + |OPT.String: IF g = OPT.Char THEN CharToString(y); g := OPT.String + ELSE err(100); y^.typ := x^.typ; yval^ := xval^ + END ; + |OPT.NilTyp: IF ~(g IN {OPT.Pointer, OPT.ProcTyp}) THEN err(100) END + |OPT.Pointer: CheckPtr(x, y) + |OPT.ProcTyp: IF g # OPT.NilTyp THEN err(100) END ELSE err(100); y^.typ := x^.typ; yval^ := xval^ END ; f := x^.typ^.form END ; (* {x^.typ = y^.typ} *) CASE op OF - times: - IF f IN intSet THEN xv := xval^.intval; yv := yval^.intval; - IF (xv = 0) OR (yv = 0) OR (* division with negative numbers is not defined *) - (xv > 0) & (yv > 0) & (yv <= MAX(LONGINT) DIV xv) OR - (xv > 0) & (yv < 0) & (yv >= MIN(LONGINT) DIV xv) OR - (xv < 0) & (yv > 0) & (xv >= MIN(LONGINT) DIV yv) OR - (xv < 0) & (yv < 0) & (xv # MIN(LONGINT)) & (yv # MIN(LONGINT)) & (-xv <= MAX(LONGINT) DIV (-yv)) THEN - xval^.intval := xv * yv; SetIntType(x) - ELSE err(204) - END - ELSIF f IN realSet THEN - temp := ABS(yval^.realval) <= 1.0; - IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) / ABS(yval^.realval)) THEN - xval^.realval := xval^.realval * yval^.realval; CheckRealType(f, 204, xval) - ELSE err(204) - END - ELSIF f = Set THEN - xval^.setval := xval^.setval * yval^.setval - ELSIF f # Undef THEN err(101) - END - | slash: - IF f IN intSet THEN - IF yval^.intval # 0 THEN - xval^.realval := xval^.intval / yval^.intval; CheckRealType(Real, 205, xval) - ELSE err(205); xval^.realval := 1.0 - END ; - x^.typ := OPT.realtyp - ELSIF f IN realSet THEN - temp := ABS(yval^.realval) >= 1.0; - IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) * ABS(yval^.realval)) THEN - xval^.realval := xval^.realval / yval^.realval; CheckRealType(f, 205, xval) - ELSE err(205) - END - ELSIF f = Set THEN - xval^.setval := xval^.setval / yval^.setval - ELSIF f # Undef THEN err(102) - END - | div: - IF f IN intSet THEN - IF yval^.intval # 0 THEN - xval^.intval := xval^.intval DIV yval^.intval; SetIntType(x) - ELSE err(205) - END - ELSIF f # Undef THEN err(103) - END - | mod: - IF f IN intSet THEN - IF yval^.intval # 0 THEN - xval^.intval := xval^.intval MOD yval^.intval; SetIntType(x) - ELSE err(205) - END - ELSIF f # Undef THEN err(104) - END - | and: - IF f = Bool THEN - xval^.intval := BoolToInt(IntToBool(xval^.intval) & IntToBool(yval^.intval)) - ELSE err(94) - END - | plus: - IF f IN intSet THEN - temp := (yval^.intval >= 0) & (xval^.intval <= MAX(LONGINT) - yval^.intval); - IF temp OR (yval^.intval < 0) & (xval^.intval >= MIN(LONGINT) - yval^.intval) THEN - INC(xval^.intval, yval^.intval); SetIntType(x) - ELSE err(206) - END - ELSIF f IN realSet THEN - temp := (yval^.realval >= 0.0) & (xval^.realval <= MAX(LONGREAL) - yval^.realval); - IF temp OR (yval^.realval < 0.0) & (xval^.realval >= -MAX(LONGREAL) - yval^.realval) THEN - xval^.realval := xval^.realval + yval^.realval; CheckRealType(f, 206, xval) - ELSE err(206) - END - ELSIF f = Set THEN - xval^.setval := xval^.setval + yval^.setval - ELSIF f # Undef THEN err(105) - END - | minus: - IF f IN intSet THEN - IF (yval^.intval >= 0) & (xval^.intval >= MIN(LONGINT) + yval^.intval) OR - (yval^.intval < 0) & (xval^.intval <= MAX(LONGINT) + yval^.intval) THEN - DEC(xval^.intval, yval^.intval); SetIntType(x) - ELSE err(207) - END - ELSIF f IN realSet THEN - temp := (yval^.realval >= 0.0) & (xval^.realval >= -MAX(LONGREAL) + yval^.realval); - IF temp OR (yval^.realval < 0.0) & (xval^.realval <= MAX(LONGREAL) + yval^.realval) THEN - xval^.realval := xval^.realval - yval^.realval; CheckRealType(f, 207, xval) - ELSE err(207) - END - ELSIF f = Set THEN - xval^.setval := xval^.setval - yval^.setval - ELSIF f # Undef THEN err(106) - END - | or: - IF f = Bool THEN - xval^.intval := BoolToInt(IntToBool(xval^.intval) OR IntToBool(yval^.intval)) - ELSE err(95) - END - | eql: - xval^.intval := BoolToInt(ConstCmp() = eql) - | neq: - xval^.intval := BoolToInt(ConstCmp() # eql) - | lss: - IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108) - ELSE xval^.intval := BoolToInt(ConstCmp() = lss) - END - | leq: - IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108) - ELSE xval^.intval := BoolToInt(ConstCmp() # gtr) - END - | gtr: - IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108) - ELSE xval^.intval := BoolToInt(ConstCmp() = gtr) - END - | geq: - IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108) - ELSE xval^.intval := BoolToInt(ConstCmp() # lss) - END + |OPS.times: IF f IN OPT.intSet THEN xv := xval^.intval; yv := yval^.intval; + IF (xv = 0) OR (yv = 0) OR (* division with negative numbers is not defined *) + (xv > 0) & (yv > 0) & (yv <= MAX(LONGINT) DIV xv) OR + (xv > 0) & (yv < 0) & (yv >= MIN(LONGINT) DIV xv) OR + (xv < 0) & (yv > 0) & (xv >= MIN(LONGINT) DIV yv) OR + (xv < 0) & (yv < 0) & (xv # MIN(LONGINT)) & (yv # MIN(LONGINT)) & (-xv <= MAX(LONGINT) DIV (-yv)) THEN + xval^.intval := xv * yv; SetIntType(x) + ELSE err(204) + END + ELSIF f IN OPT.realSet THEN + temp := ABS(yval^.realval) <= 1.0; + IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) / ABS(yval^.realval)) THEN + xval^.realval := xval^.realval * yval^.realval; CheckRealType(f, 204, xval) + ELSE err(204) + END + ELSIF f = OPT.Set THEN + xval^.setval := xval^.setval * yval^.setval + ELSIF f # OPT.Undef THEN err(101) + END + |OPS.slash: IF f IN OPT.intSet THEN + IF yval^.intval # 0 THEN + xval^.realval := xval^.intval / yval^.intval; CheckRealType(OPT.Real, 205, xval) + ELSE err(205); xval^.realval := 1.0 + END ; + x^.typ := OPT.realtyp + ELSIF f IN OPT.realSet THEN + temp := ABS(yval^.realval) >= 1.0; + IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) * ABS(yval^.realval)) THEN + xval^.realval := xval^.realval / yval^.realval; CheckRealType(f, 205, xval) + ELSE err(205) + END + ELSIF f = OPT.Set THEN + xval^.setval := xval^.setval / yval^.setval + ELSIF f # OPT.Undef THEN err(102) + END + |OPS.div: IF f IN OPT.intSet THEN + IF yval^.intval # 0 THEN + xval^.intval := xval^.intval DIV yval^.intval; SetIntType(x) + ELSE err(205) + END + ELSIF f # OPT.Undef THEN err(103) + END + |OPS.mod: IF f IN OPT.intSet THEN + IF yval^.intval # 0 THEN + xval^.intval := xval^.intval MOD yval^.intval; SetIntType(x) + ELSE err(205) + END + ELSIF f # OPT.Undef THEN err(104) + END + |OPS.and: IF f = OPT.Bool THEN + xval^.intval := BoolToInt(IntToBool(xval^.intval) & IntToBool(yval^.intval)) + ELSE err(94) + END + |OPS.plus: IF f IN OPT.intSet THEN + temp := (yval^.intval >= 0) & (xval^.intval <= MAX(LONGINT) - yval^.intval); + IF temp OR (yval^.intval < 0) & (xval^.intval >= MIN(LONGINT) - yval^.intval) THEN + INC(xval^.intval, yval^.intval); SetIntType(x) + ELSE err(206) + END + ELSIF f IN OPT.realSet THEN + temp := (yval^.realval >= 0.0) & (xval^.realval <= MAX(LONGREAL) - yval^.realval); + IF temp OR (yval^.realval < 0.0) & (xval^.realval >= -MAX(LONGREAL) - yval^.realval) THEN + xval^.realval := xval^.realval + yval^.realval; CheckRealType(f, 206, xval) + ELSE err(206) + END + ELSIF f = OPT.Set THEN + xval^.setval := xval^.setval + yval^.setval + ELSIF f # OPT.Undef THEN err(105) + END + |OPS.minus: IF f IN OPT.intSet THEN + IF (yval^.intval >= 0) & (xval^.intval >= MIN(LONGINT) + yval^.intval) OR + (yval^.intval < 0) & (xval^.intval <= MAX(LONGINT) + yval^.intval) THEN + DEC(xval^.intval, yval^.intval); SetIntType(x) + ELSE err(207) + END + ELSIF f IN OPT.realSet THEN + temp := (yval^.realval >= 0.0) & (xval^.realval >= -MAX(LONGREAL) + yval^.realval); + IF temp OR (yval^.realval < 0.0) & (xval^.realval <= MAX(LONGREAL) + yval^.realval) THEN + xval^.realval := xval^.realval - yval^.realval; CheckRealType(f, 207, xval) + ELSE err(207) + END + ELSIF f = OPT.Set THEN + xval^.setval := xval^.setval - yval^.setval + ELSIF f # OPT.Undef THEN err(106) + END + |OPS.or: IF f = OPT.Bool THEN + xval^.intval := BoolToInt(IntToBool(xval^.intval) OR IntToBool(yval^.intval)) + ELSE err(95) + END + |OPS.eql: xval^.intval := BoolToInt(ConstCmp() = OPS.eql) + |OPS.neq: xval^.intval := BoolToInt(ConstCmp() # OPS.eql) + |OPS.lss: IF f IN {OPT.Bool, OPT.Set, OPT.NilTyp, OPT.Pointer} THEN err(108) + ELSE xval^.intval := BoolToInt(ConstCmp() = OPS.lss) + END + |OPS.leq: IF f IN {OPT.Bool, OPT.Set, OPT.NilTyp, OPT.Pointer} THEN err(108) + ELSE xval^.intval := BoolToInt(ConstCmp() # OPS.gtr) + END + |OPS.gtr: IF f IN {OPT.Bool, OPT.Set, OPT.NilTyp, OPT.Pointer} THEN err(108) + ELSE xval^.intval := BoolToInt(ConstCmp() = OPS.gtr) + END + |OPS.geq: IF f IN {OPT.Bool, OPT.Set, OPT.NilTyp, OPT.Pointer} THEN err(108) + ELSE xval^.intval := BoolToInt(ConstCmp() # OPS.lss) + END ELSE OPM.LogWStr("unhandled case in OPB.ConstOp, op = "); OPM.LogWNum(op, 0); OPM.LogWLn; END @@ -705,30 +629,30 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE Convert(VAR x: OPT.Node; typ: OPT.Struct); VAR node: OPT.Node; f, g: INTEGER; k: LONGINT; r: LONGREAL; BEGIN f := x^.typ^.form; g := typ^.form; - IF x^.class = Nconst THEN - IF f IN intSet THEN - IF g IN intSet THEN + IF x^.class = OPT.Nconst THEN + IF f IN OPT.intSet THEN + IF g IN OPT.intSet THEN IF f > g THEN SetIntType(x); IF x^.typ^.form > g THEN err(203); x^.conval^.intval := 1 END END - ELSIF g IN realSet THEN x^.conval^.realval := x^.conval^.intval; x^.conval^.intval := OPM.ConstNotAlloc - ELSE (*g = Char*) k := x^.conval^.intval; + ELSIF g IN OPT.realSet THEN x^.conval^.realval := x^.conval^.intval; x^.conval^.intval := OPM.ConstNotAlloc + ELSE (*g = OPT.Char*) k := x^.conval^.intval; IF (0 > k) OR (k > 0FFH) THEN err(220) END END - ELSIF f IN realSet THEN - IF g IN realSet THEN CheckRealType(g, 203, x^.conval) - ELSE (*g = LInt*) + ELSIF f IN OPT.realSet THEN + IF g IN OPT.realSet THEN CheckRealType(g, 203, x^.conval) + ELSE (*g = OPT.LInt*) r := x^.conval^.realval; IF (r < MIN(LONGINT)) OR (r > MAX(LONGINT)) THEN err(203); r := 1 END ; x^.conval^.intval := ENTIER(r); SetIntType(x) END - ELSE (* (f IN {Char, Byte}) & (g IN {Byte} + intSet) OR (f = Undef) *) + ELSE (* (f IN {OPT.Char, OPT.Byte}) & (g IN {OPT.Byte} + OPT.intSet) OR (f = OPT.Undef) *) END ; x^.obj := NIL - ELSIF (x^.class = Nmop) & (x^.subcl = conv) & ((x^.left^.typ^.form < f) OR (f > g)) THEN + ELSIF (x^.class = OPT.Nmop) & (x^.subcl = OPT.conv) & ((x^.left^.typ^.form < f) OR (f > g)) THEN (* don't create new node *) IF x^.left^.typ = typ THEN (* and suppress existing node *) x := x^.left END - ELSE node := OPT.NewNode(Nmop); node^.subcl := conv; node^.left := x; x := node + ELSE node := OPT.NewNode(OPT.Nmop); node^.subcl := OPT.conv; node^.left := x; x := node END ; x^.typ := typ END Convert; @@ -739,23 +663,23 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE NewOp(op: SHORTINT; typ: OPT.Struct; VAR x: OPT.Node; y: OPT.Node); VAR node: OPT.Node; BEGIN - node := OPT.NewNode(Ndop); node^.subcl := op; node^.typ := typ; + node := OPT.NewNode(OPT.Ndop); node^.subcl := op; node^.typ := typ; node^.left := x; node^.right := y; x := node END NewOp; PROCEDURE strings(VAR x, y: OPT.Node): BOOLEAN; VAR ok, xCharArr, yCharArr: BOOLEAN; BEGIN - xCharArr := ((x^.typ^.comp IN {Array, DynArr}) & (x^.typ^.BaseTyp^.form=Char)) OR (f=String); - yCharArr := (((y^.typ^.comp IN {Array, DynArr}) & (y^.typ^.BaseTyp^.form=Char)) OR (g=String)); - IF xCharArr & (g = Char) & (y^.class = Nconst) THEN CharToString(y); g := String; yCharArr := TRUE END ; - IF yCharArr & (f = Char) & (x^.class = Nconst) THEN CharToString(x); f := String; xCharArr := TRUE END ; + xCharArr := ((x^.typ^.comp IN {OPT.Array, OPT.DynArr}) & (x^.typ^.BaseTyp^.form=OPT.Char)) OR (f=OPT.String); + yCharArr := (((y^.typ^.comp IN {OPT.Array, OPT.DynArr}) & (y^.typ^.BaseTyp^.form=OPT.Char)) OR (g=OPT.String)); + IF xCharArr & (g = OPT.Char) & (y^.class = OPT.Nconst) THEN CharToString(y); g := OPT.String; yCharArr := TRUE END ; + IF yCharArr & (f = OPT.Char) & (x^.class = OPT.Nconst) THEN CharToString(x); f := OPT.String; xCharArr := TRUE END ; ok := xCharArr & yCharArr; IF ok THEN (* replace ""-string compare with 0X-char compare, if possible *) - IF (f=String) & (x^.conval^.intval2 = 1) THEN (* y is array of char *) + IF (f=OPT.String) & (x^.conval^.intval2 = 1) THEN (* y is array of char *) x^.typ := OPT.chartyp; x^.conval^.intval := 0; Index(y, NewIntConst(0)) - ELSIF (g=String) & (y^.conval^.intval2 = 1) THEN (* x is array of char *) + ELSIF (g=OPT.String) & (y^.conval^.intval2 = 1) THEN (* x is array of char *) y^.typ := OPT.chartyp; y^.conval^.intval := 0; Index(x, NewIntConst(0)) END @@ -765,153 +689,131 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) BEGIN z := x; - IF (z^.class = Ntype) OR (z^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126) - ELSIF (z^.class = Nconst) & (y^.class = Nconst) THEN ConstOp(op, z, y); z^.obj := NIL + IF (z^.class = OPT.Ntype) OR (z^.class = OPT.Nproc) OR (y^.class = OPT.Ntype) OR (y^.class = OPT.Nproc) THEN err(126) + ELSIF (z^.class = OPT.Nconst) & (y^.class = OPT.Nconst) THEN ConstOp(op, z, y); z^.obj := NIL ELSE IF z^.typ # y^.typ THEN g := y^.typ^.form; CASE z^.typ^.form OF - Char: - IF z^.class = Nconst THEN CharToString(z) ELSE err(100) END - | SInt(*, Int8*): - IF g IN intSet + realSet THEN Convert(z, y^.typ) - ELSE err(100) - END - | Int: - IF g = SInt THEN Convert(y, z^.typ) - ELSIF g IN intSet + realSet THEN Convert(z, y^.typ) - ELSE err(100) - END - | LInt(*, Int16, Int32, Int64*): - IF g IN intSet THEN Convert(y, z^.typ) - ELSIF g IN realSet THEN Convert(z, y^.typ) - ELSE err(100) - END - | Real: - IF g IN intSet THEN Convert(y, z^.typ) - ELSIF g IN realSet THEN Convert(z, y^.typ) - ELSE err(100) - END - | LReal: - IF g IN intSet + realSet THEN Convert(y, z^.typ) - ELSIF g IN realSet THEN Convert(y, z^.typ) - ELSE err(100) - END - | NilTyp: - IF ~(g IN {Pointer, ProcTyp}) THEN err(100) END - | Pointer: - CheckPtr(z, y) - | ProcTyp: - IF g # NilTyp THEN err(100) END - | String: - | Comp: - IF z^.typ^.comp = Record THEN err(100) END + |OPT.Char: IF z^.class = OPT.Nconst THEN CharToString(z) ELSE err(100) END + |OPT.SInt, + OPT.Int, + OPT.LInt: IF (g IN OPT.intSet) & (y.typ.size < z.typ.size) THEN Convert(y, z.typ) + ELSIF g IN OPT.intSet + OPT.realSet THEN Convert(z, y.typ) + ELSE err(100) + END + |OPT.Real: IF g IN OPT.intSet THEN Convert(y, z^.typ) + ELSIF g IN OPT.realSet THEN Convert(z, y^.typ) + ELSE err(100) + END + |OPT.LReal: IF g IN OPT.intSet + OPT.realSet THEN Convert(y, z^.typ) + ELSIF g IN OPT.realSet THEN Convert(y, z^.typ) (* DCWB: Surely this line does nothing. *) + ELSE err(100) + END + |OPT.NilTyp: IF ~(g IN {OPT.Pointer, OPT.ProcTyp}) THEN err(100) END + |OPT.Pointer: CheckPtr(z, y) + |OPT.ProcTyp: IF g # OPT.NilTyp THEN err(100) END + |OPT.String: + |OPT.Comp: IF z^.typ^.comp = OPT.Record THEN err(100) END ELSE err(100) END END ; (* {z^.typ = y^.typ} *) typ := z^.typ; f := typ^.form; g := y^.typ^.form; CASE op OF - times: - do := TRUE; - IF f IN intSet THEN - IF z^.class = Nconst THEN val := z^.conval^.intval; - IF val = 1 THEN do := FALSE; z := y - ELSIF val = 0 THEN do := FALSE - ELSIF log(val) = 1 THEN - t := y; y := z; z := t; - op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL - END - ELSIF y^.class = Nconst THEN val := y^.conval^.intval; - IF val = 1 THEN do := FALSE - ELSIF val = 0 THEN do := FALSE; z := y - ELSIF log(val) = 1 THEN - op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL - END - END - ELSIF ~(f IN {Undef, Real..Set}) THEN err(105); typ := OPT.undftyp - END ; - IF do THEN NewOp(op, typ, z, y) END - | slash: - IF f IN intSet THEN - IF (y^.class = Nconst) & (y^.conval^.intval = 0) THEN err(205) END ; - Convert(z, OPT.realtyp); Convert(y, OPT.realtyp); - typ := OPT.realtyp - ELSIF f IN realSet THEN - IF (y^.class = Nconst) & (y^.conval^.realval = 0.0) THEN err(205) END - ELSIF (f # Set) & (f # Undef) THEN err(102); typ := OPT.undftyp - END ; - NewOp(op, typ, z, y) - | div: - do := TRUE; - IF f IN intSet THEN - IF y^.class = Nconst THEN val := y^.conval^.intval; - IF val = 0 THEN err(205) - ELSIF val = 1 THEN do := FALSE - ELSIF log(val) = 1 THEN - op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := -exp; y^.obj := NIL - END - END - ELSIF f # Undef THEN err(103); typ := OPT.undftyp - END ; - IF do THEN NewOp(op, typ, z, y) END - | mod: - IF f IN intSet THEN - IF y^.class = Nconst THEN - IF y^.conval^.intval = 0 THEN err(205) - ELSIF log(y^.conval^.intval) = 1 THEN - op := msk; y^.conval^.intval := ASH(-1, exp); y^.obj := NIL - END - END - ELSIF f # Undef THEN err(104); typ := OPT.undftyp - END ; - NewOp(op, typ, z, y) - | and: - IF f = Bool THEN - IF z^.class = Nconst THEN - IF IntToBool(z^.conval^.intval) THEN z := y END - ELSIF (y^.class = Nconst) & IntToBool(y^.conval^.intval) THEN (* optimize z & TRUE -> z *) - (* ELSIF (y^.class = Nconst) & ~IntToBool(y^.conval^.intval) THEN - don't optimize z & FALSE -> FALSE: side effects possible *) - ELSE NewOp(op, typ, z, y) - END - ELSIF f # Undef THEN err(94); z^.typ := OPT.undftyp - END - | plus: - IF ~(f IN {Undef, SInt..Set(*, Int8..Int64*)}) THEN err(105); typ := OPT.undftyp END ; - do := TRUE; - IF f IN intSet THEN - IF (z^.class = Nconst) & (z^.conval^.intval = 0) THEN do := FALSE; z := y END ; - IF (y^.class = Nconst) & (y^.conval^.intval = 0) THEN do := FALSE END - END ; - IF do THEN NewOp(op, typ, z, y) END - | minus: - IF ~(f IN {Undef, SInt..Set(*, Int8..Int64*)}) THEN err(106); typ := OPT.undftyp END ; - IF ~(f IN intSet) OR (y^.class # Nconst) OR (y^.conval^.intval # 0) THEN NewOp(op, typ, z, y) END - | or: - IF f = Bool THEN - IF z^.class = Nconst THEN - IF ~IntToBool(z^.conval^.intval) THEN z := y END - ELSIF (y^.class = Nconst) & ~IntToBool(y^.conval^.intval) THEN (* optimize z OR FALSE -> z *) - (* ELSIF (y^.class = Nconst) & IntToBool(y^.conval^.intval) THEN - don't optimize z OR TRUE -> TRUE: side effects possible *) - ELSE NewOp(op, typ, z, y) - END - ELSIF f # Undef THEN err(95); z^.typ := OPT.undftyp - END - | eql, neq: - IF (f IN {Undef..Set, NilTyp, Pointer, ProcTyp(*, Int8..Int64*)}) OR strings(z, y) THEN typ := OPT.booltyp - ELSE err(107); typ := OPT.undftyp - END ; - NewOp(op, typ, z, y) - | lss, leq, gtr, geq: - IF (f IN {Undef, Char..LReal(*, Int8..Int64*)}) OR strings(z, y) THEN typ := OPT.booltyp - ELSE - OPM.LogWLn; OPM.LogWStr("ELSE in Op()"); OPM.LogWLn; - err(108); typ := OPT.undftyp - END ; - NewOp(op, typ, z, y) - ELSE - OPM.LogWStr("unhandled case in OPB.Op, op = "); OPM.LogWNum(op, 0); OPM.LogWLn; + |OPS.times: do := TRUE; + IF f IN OPT.intSet THEN + IF z^.class = OPT.Nconst THEN val := z^.conval^.intval; + IF val = 1 THEN do := FALSE; z := y + ELSIF val = 0 THEN do := FALSE + ELSIF log(val) = 1 THEN + t := y; y := z; z := t; + op := OPT.ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL + END + ELSIF y^.class = OPT.Nconst THEN val := y^.conval^.intval; + IF val = 1 THEN do := FALSE + ELSIF val = 0 THEN do := FALSE; z := y + ELSIF log(val) = 1 THEN + op := OPT.ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL + END + END + ELSIF ~(f IN {OPT.Undef, OPT.Real..OPT.Set}) THEN err(105); typ := OPT.undftyp + END ; + IF do THEN NewOp(op, typ, z, y) END + |OPS.slash: IF f IN OPT.intSet THEN + IF (y^.class = OPT.Nconst) & (y^.conval^.intval = 0) THEN err(205) END ; + Convert(z, OPT.realtyp); Convert(y, OPT.realtyp); + typ := OPT.realtyp + ELSIF f IN OPT.realSet THEN + IF (y^.class = OPT.Nconst) & (y^.conval^.realval = 0.0) THEN err(205) END + ELSIF (f # OPT.Set) & (f # OPT.Undef) THEN err(102); typ := OPT.undftyp + END ; + NewOp(op, typ, z, y) + |OPS.div: do := TRUE; + IF f IN OPT.intSet THEN + IF y^.class = OPT.Nconst THEN val := y^.conval^.intval; + IF val = 0 THEN err(205) + ELSIF val = 1 THEN do := FALSE + ELSIF log(val) = 1 THEN + op := OPT.ash; y^.typ := OPT.sinttyp; y^.conval^.intval := -exp; y^.obj := NIL + END + END + ELSIF f # OPT.Undef THEN err(103); typ := OPT.undftyp + END ; + IF do THEN NewOp(op, typ, z, y) END + |OPS.mod: IF f IN OPT.intSet THEN + IF y^.class = OPT.Nconst THEN + IF y^.conval^.intval = 0 THEN err(205) + ELSIF log(y^.conval^.intval) = 1 THEN + op := OPT.msk; y^.conval^.intval := ASH(-1, exp); y^.obj := NIL + END + END + ELSIF f # OPT.Undef THEN err(104); typ := OPT.undftyp + END ; + NewOp(op, typ, z, y) + |OPS.and: IF f = OPT.Bool THEN + IF z^.class = OPT.Nconst THEN + IF IntToBool(z^.conval^.intval) THEN z := y END + ELSIF (y^.class = OPT.Nconst) & IntToBool(y^.conval^.intval) THEN (* optimize z & TRUE -> z *) + (*ELSIF (y^.class = OPT.Nconst) & ~IntToBool(y^.conval^.intval) THEN + don't optimize z & FALSE -> FALSE: side effects possible *) + ELSE NewOp(op, typ, z, y) + END + ELSIF f # OPT.Undef THEN err(94); z^.typ := OPT.undftyp + END + |OPS.plus: IF ~(f IN {OPT.Undef, OPT.SInt..OPT.Set}) THEN err(105); typ := OPT.undftyp END ; + do := TRUE; + IF f IN OPT.intSet THEN + IF (z^.class = OPT.Nconst) & (z^.conval^.intval = 0) THEN do := FALSE; z := y END ; + IF (y^.class = OPT.Nconst) & (y^.conval^.intval = 0) THEN do := FALSE END + END ; + IF do THEN NewOp(op, typ, z, y) END + |OPS.minus: IF ~(f IN {OPT.Undef, OPT.SInt..OPT.Set}) THEN err(106); typ := OPT.undftyp END ; + IF ~(f IN OPT.intSet) OR (y^.class # OPT.Nconst) OR (y^.conval^.intval # 0) THEN NewOp(op, typ, z, y) END + |OPS.or: IF f = OPT.Bool THEN + IF z^.class = OPT.Nconst THEN + IF ~IntToBool(z^.conval^.intval) THEN z := y END + ELSIF (y^.class = OPT.Nconst) & ~IntToBool(y^.conval^.intval) THEN (* optimize z OR FALSE -> z *) + (*ELSIF (y^.class = OPT.Nconst) & IntToBool(y^.conval^.intval) THEN + don't optimize z OR TRUE -> TRUE: side effects possible *) + ELSE NewOp(op, typ, z, y) + END + ELSIF f # OPT.Undef THEN err(95); z^.typ := OPT.undftyp + END + |OPS.eql, + OPS.neq: IF (f IN {OPT.Undef..OPT.Set, OPT.NilTyp, OPT.Pointer, OPT.ProcTyp}) OR strings(z, y) THEN typ := OPT.booltyp + ELSE err(107); typ := OPT.undftyp + END ; + NewOp(op, typ, z, y) + |OPS.lss, + OPS.leq, + OPS.gtr, + OPS.geq: IF (f IN {OPT.Undef, OPT.Char..OPT.LReal}) OR strings(z, y) THEN typ := OPT.booltyp + ELSE + OPM.LogWLn; OPM.LogWStr("ELSE in Op()"); OPM.LogWLn; + err(108); typ := OPT.undftyp + END ; + NewOp(op, typ, z, y) + ELSE OPM.LogWStr("unhandled case in OPB.Op, op = "); OPM.LogWNum(op, 0); OPM.LogWLn; END END ; x := z @@ -920,23 +822,23 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE SetRange*(VAR x: OPT.Node; y: OPT.Node); VAR k, l: LONGINT; BEGIN - IF (x^.class = Ntype) OR (x^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126) - ELSIF (x^.typ^.form IN intSet) & (y^.typ^.form IN intSet) THEN - IF x^.class = Nconst THEN + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) OR (y^.class = OPT.Ntype) OR (y^.class = OPT.Nproc) THEN err(126) + ELSIF (x^.typ^.form IN OPT.intSet) & (y^.typ^.form IN OPT.intSet) THEN + IF x^.class = OPT.Nconst THEN k := x^.conval^.intval; IF (0 > k) OR (k > OPM.MaxSet) THEN err(202) END END ; - IF y^.class = Nconst THEN + IF y^.class = OPT.Nconst THEN l := y^.conval^.intval; IF (0 > l) OR (l > OPM.MaxSet) THEN err(202) END END ; - IF (x^.class = Nconst) & (y^.class = Nconst) THEN + IF (x^.class = OPT.Nconst) & (y^.class = OPT.Nconst) THEN IF k <= l THEN x^.conval^.setval := {k..l} ELSE err(201); x^.conval^.setval := {l..k} END ; x^.obj := NIL - ELSE BindNodes(Nupto, OPT.settyp, x, y) + ELSE BindNodes(OPT.Nupto, OPT.settyp, x, y) END ELSE err(93) END ; @@ -946,9 +848,9 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) PROCEDURE SetElem*(VAR x: OPT.Node); VAR k: LONGINT; BEGIN - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF ~(x^.typ^.form IN intSet) THEN err(93) - ELSIF x^.class = Nconst THEN + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF ~(x^.typ^.form IN OPT.intSet) THEN err(93) + ELSIF x^.class = OPT.Nconst THEN k := x^.conval^.intval; IF (0 <= k) & (k <= OPM.MaxSet) THEN x^.conval^.setval := {k} ELSE err(202) @@ -960,7 +862,11 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) END SetElem; PROCEDURE CheckAssign(x: OPT.Struct; ynode: OPT.Node); (* x := y *) - VAR f, g: INTEGER; y, p, q: OPT.Struct; + VAR (* x is designator (target) type *) + y: OPT.Struct; (* expression (source) type *) + f: INTEGER; (* designator (target) form *) + g: INTEGER; (* expression (source) form *) + p, q: OPT.Struct; BEGIN IF OPM.Verbose THEN OPM.LogWLn; OPM.LogWStr("PROCEDURE CheckAssign"); OPM.LogWLn; @@ -972,108 +878,76 @@ MODULE OPB; (* RC 6.3.89 / 21.2.94 *) (* object model 17.1.93 *) OPM.LogWStr("g = "); OPM.LogWNum(g, 0); OPM.LogWLn; OPM.LogWStr("ynode.typ.syze = "); OPM.LogWNum(ynode.typ.size, 0); OPM.LogWLn; END; - IF (ynode^.class = Ntype) OR (ynode^.class = Nproc) & (f # ProcTyp) THEN err(126) END ; + IF (ynode^.class = OPT.Ntype) OR (ynode^.class = OPT.Nproc) & (f # OPT.ProcTyp) THEN err(126) END ; CASE f OF - Undef, String: - (* | Int8: - IF (ynode.typ.size > OPM.Int8Size) THEN - IF OPM.Verbose THEN OPM.LogWStr("f of int8"); OPM.LogWLn END; - err(113) - END - | Int16: - IF (ynode.typ.size > OPM.Int16Size) THEN - IF OPM.Verbose THEN OPM.LogWStr("f of int16"); OPM.LogWLn END; - err(113) - END - | Int32: - IF (ynode.typ.size > OPM.Int32Size) THEN - IF OPM.Verbose THEN OPM.LogWStr("f of int32"); OPM.LogWLn END; - err(113) - END - | Int64: - IF ynode.typ.size > OPM.Int64Size THEN - IF OPM.Verbose THEN OPM.LogWStr("f of int64"); OPM.LogWLn END; - err(113) - END*) - | Byte: - IF ~(g IN {Byte, Char, SInt}) THEN err(113) END - | Bool, Char, SInt, Set: - IF g # f THEN err(113) END - | Int: - IF ~(g IN {SInt, Int}) THEN err(113) END - | LInt: - IF OPM.LIntSize = 4 THEN - IF ~(g IN {SInt, Int, LInt(*, Int8, Int16, Int32*)}) THEN err(113) END - ELSE (* assume OPM.LIntSize = 8 *) - IF ~(g IN {SInt, Int, LInt(*, Int8, Int16, Int32, Int64*)}) THEN err(113) END - END; - | Real: - IF ~(g IN {SInt..Real}) THEN err(113) END - | LReal: - IF ~(g IN {SInt..LReal}) THEN err(113) END - | Pointer: - IF (x = y) OR (g = NilTyp) OR (x = OPT.sysptrtyp) & (g = Pointer) THEN (* ok *) - ELSIF g = Pointer THEN - p := x^.BaseTyp; q := y^.BaseTyp; - IF (p^.comp = Record) & (q^.comp = Record) THEN - WHILE (q # p) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ; - IF q = NIL THEN err(113) END - ELSE err(113) - END - ELSE err(113) - END - | ProcTyp: - IF ynode^.class = Nproc THEN CheckProc(x, ynode^.obj) - ELSIF (x = y) OR (g = NilTyp) THEN (* ok *) - ELSE err(113) - END - | NoTyp, NilTyp: - err(113) - | Comp: - x^.pvused := TRUE; (* idfp of y guarantees assignment compatibility with x *) - IF x^.comp = Array THEN - IF (ynode^.class = Nconst) & (g = Char) THEN CharToString(ynode); y := ynode^.typ; g := String END ; - IF x = y THEN (* ok *) - ELSIF x^.BaseTyp = OPT.chartyp THEN (* Assign to (static) ARRAY OF CHAR *) - IF g = String THEN (*check length of string*) - IF ynode^.conval^.intval2 > x^.n THEN err(114) END - ELSIF (y.comp IN {DynArr, Array}) & (y.BaseTyp = OPT.chartyp) THEN - (* Assignment from ARRAY OF CHAR is good.*) - ELSE err(113) - END - ELSE err(113) - END - ELSIF (x.comp = DynArr) & (x^.BaseTyp = OPT.chartyp) THEN (* Assign to dynamic ARRAY OF CHAR*) - IF (y.comp IN {DynArr, Array}) & (y.BaseTyp = OPT.chartyp) THEN - (* Assignment from ARRAY OF CHAR is good.*) - ELSE err(113) - END - ELSIF x^.comp = Record THEN - IF x = y THEN (* ok *) - ELSIF y^.comp = Record THEN - q := y^.BaseTyp; - WHILE (q # NIL) & (q # x) & (q # OPT.undftyp) DO q := q^.BaseTyp END ; - IF q = NIL THEN err(113) END - ELSE err(113) - END - ELSE err(113) - END - ELSE (* In case of not estimated f it would crash -- noch *) - OPM.LogWStr("unhandled case in OPB.CheckAssign, f = "); OPM.LogWNum(f, 0); OPM.LogWLn; + OPT.Undef, + OPT.String: + | OPT.Byte: IF ~((g IN ({OPT.Byte, OPT.Char} + OPT.intSet)) & (y.size = 1)) THEN err(113) END + | OPT.Bool, + OPT.Char, + OPT.Set: IF g # f THEN err(113) END + | OPT.SInt, + OPT.Int, + OPT.LInt: IF ~(g IN OPT.intSet) OR (x.size < y.size) THEN err(113) END + | OPT.Real: IF ~(g IN {OPT.SInt..OPT.Real}) THEN err(113) END + | OPT.LReal: IF ~(g IN {OPT.SInt..OPT.LReal}) THEN err(113) END + | OPT.Pointer: IF (x = y) OR (g = OPT.NilTyp) OR (x = OPT.sysptrtyp) & (g = OPT.Pointer) THEN (* ok *) + ELSIF g = OPT.Pointer THEN + p := x^.BaseTyp; q := y^.BaseTyp; + IF (p^.comp = OPT.Record) & (q^.comp = OPT.Record) THEN + WHILE (q # p) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ; + IF q = NIL THEN err(113) END + ELSE err(113) + END + ELSE err(113) + END + | OPT.ProcTyp: IF ynode^.class = OPT.Nproc THEN CheckProc(x, ynode^.obj) + ELSIF (x = y) OR (g = OPT.NilTyp) THEN (* ok *) + ELSE err(113) + END + | OPT.NoTyp, + OPT.NilTyp: err(113) + | OPT.Comp: x^.pvused := TRUE; (* idfp of y guarantees assignment compatibility with x *) + IF x^.comp = OPT.Array THEN + IF (ynode^.class = OPT.Nconst) & (g = OPT.Char) THEN CharToString(ynode); y := ynode^.typ; g := OPT.String END ; + IF x = y THEN (* ok *) + ELSIF x^.BaseTyp = OPT.chartyp THEN (* Assign to (static) ARRAY OF CHAR *) + IF g = OPT.String THEN (*check length of string*) + IF ynode^.conval^.intval2 > x^.n THEN err(114) END + ELSIF (y.comp IN {OPT.DynArr, OPT.Array}) & (y.BaseTyp = OPT.chartyp) THEN + (* Assignment from ARRAY OF CHAR is good.*) + ELSE err(113) + END + ELSE err(113) + END + ELSIF (x.comp = OPT.DynArr) & (x^.BaseTyp = OPT.chartyp) THEN (* Assign to dynamic ARRAY OF CHAR*) + IF (y.comp IN {OPT.DynArr, OPT.Array}) & (y.BaseTyp = OPT.chartyp) THEN + (* Assignment from ARRAY OF CHAR is good.*) + ELSE err(113) + END + ELSIF x^.comp = OPT.Record THEN + IF x = y THEN (* ok *) + ELSIF y^.comp = OPT.Record THEN + q := y^.BaseTyp; + WHILE (q # NIL) & (q # x) & (q # OPT.undftyp) DO q := q^.BaseTyp END ; + IF q = NIL THEN err(113) END + ELSE err(113) + END + ELSE err(113) + END + ELSE OPM.LogWStr("unhandled case in OPB.CheckAssign, f = "); OPM.LogWNum(f, 0); OPM.LogWLn; END ; - IF (ynode^.class = Nconst) & (g < f) & (g IN {SInt..Real}) & (f IN {Int..LReal}) THEN + IF (ynode^.class = OPT.Nconst) & (g < f) & (g IN {OPT.SInt..OPT.Real}) & (f IN {OPT.Int..OPT.LReal}) THEN Convert(ynode, x) END END CheckAssign; PROCEDURE CheckLeaf(x: OPT.Node; dynArrToo: BOOLEAN); BEGIN -(* -avoid unnecessary intermediate variables in voc - - IF (x^.class = Nmop) & (x^.subcl = val) THEN x := x^.left END ; - IF x^.class = Nguard THEN x := x^.left END ; (* skip last (and unique) guard *) - IF (x^.class = Nvar) & (dynArrToo OR (x^.typ^.comp # DynArr)) THEN x^.obj^.leaf := FALSE END +(* avoid unnecessary intermediate variables in voc + IF (x^.class = OPT.Nmop) & (x^.subcl = val) THEN x := x^.left END ; + IF x^.class = OPT.Nguard THEN x := x^.left END ; (* skip last (and unique) guard *) + IF (x^.class = OPT.Nvar) & (dynArrToo OR (x^.typ^.comp # OPT.DynArr)) THEN x^.obj^.leaf := FALSE END *) END CheckLeaf; @@ -1081,177 +955,168 @@ avoid unnecessary intermediate variables in voc VAR f: INTEGER; typ: OPT.Struct; x: OPT.Node; BEGIN x := par0; f := x^.typ^.form; CASE fctno OF - haltfn: (*HALT*) - IF (f IN intSet) & (x^.class = Nconst) THEN - IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN - BindNodes(Ntrap, OPT.notyp, x, x) - ELSE err(218) - END - ELSE err(69) - END ; - x^.typ := OPT.notyp - | newfn: (*NEW*) - typ := OPT.notyp; - IF NotVar(x) THEN err(112) - ELSIF f = Pointer THEN - IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ; - IF x^.readonly THEN err(76) END ; - f := x^.typ^.BaseTyp^.comp; - IF f IN {Record, DynArr, Array} THEN - IF f = DynArr THEN typ := x^.typ^.BaseTyp END ; - BindNodes(Nassign, OPT.notyp, x, NIL); x^.subcl := newfn - ELSE err(111) - END - ELSE err(111) - END ; - x^.typ := typ - | absfn: (*ABS*) - MOp(abs, x) - | capfn: (*CAP*) - MOp(cap, x) - | ordfn: (*ORD*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f = Char THEN Convert(x, OPT.inttyp) - ELSE err(111) - END ; - x^.typ := OPT.inttyp - | entierfn: (*ENTIER*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN realSet THEN Convert(x, OPT.linttyp) - ELSE err(111) - END ; - x^.typ := OPT.linttyp - | oddfn: (*ODD*) - MOp(odd, x) - | minfn: (*MIN*) - IF x^.class = Ntype THEN - CASE f OF - Bool: x := NewBoolConst(FALSE) - | Char: x := NewIntConst(0); x^.typ := OPT.chartyp - | SInt: x := NewIntConst(OPM.MinSInt) - | Int: x := NewIntConst(OPM.MinInt) - | LInt: x := NewIntConst(OPM.MinLInt) - (* | Int8: x := NewIntConst(OPM.MinInt8) - | Int16: x := NewIntConst(OPM.MinInt16) - | Int32: x := NewIntConst(OPM.MinInt32) - | Int64: err(111)(*x := NewIntConst(OPM.MinInt64)*) (* int64 constants not implemented yet *)*) - | Set: x := NewIntConst(0); x^.typ := OPT.inttyp - | Real: x := NewRealConst(OPM.MinReal, OPT.realtyp) - | LReal: x := NewRealConst(OPM.MinLReal, OPT.lrltyp) - ELSE err(111) - END - ELSE err(110) - END - | maxfn: (*MAX*) - IF x^.class = Ntype THEN - CASE f OF - Bool: x := NewBoolConst(TRUE) - | Char: x := NewIntConst(0FFH); x^.typ := OPT.chartyp - | SInt: x := NewIntConst(OPM.MaxSInt) - | Int: x := NewIntConst(OPM.MaxInt) - | LInt: x := NewIntConst(OPM.MaxLInt) - (* | Int8: x := NewIntConst(OPM.MaxInt8) - | Int16: x := NewIntConst(OPM.MaxInt16) - | Int32: x := NewIntConst(OPM.MaxInt32) - | Int64: err(111); (*x := NewIntConst(OPM.MaxInt64)*) (* int64 contstants not implemented yet *)*) - | Set: x := NewIntConst(OPM.MaxSet); x^.typ := OPT.inttyp - | Real: x := NewRealConst(OPM.MaxReal, OPT.realtyp) - | LReal: x := NewRealConst(OPM.MaxLReal, OPT.lrltyp) - ELSE err(111) - END - ELSE err(110) - END - | chrfn: (*CHR*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN {Undef, SInt..LInt(*, Int8..Int64*)} THEN Convert(x, OPT.chartyp) - ELSE err(111); x^.typ := OPT.chartyp - END - | shortfn: (*SHORT*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f = Int THEN Convert(x, OPT.sinttyp) - ELSIF f = LInt THEN Convert(x, OPT.inttyp) - (*ELSIF f = Int64 THEN Convert(x, OPT.int32typ) - ELSIF f = Int32 THEN Convert(x, OPT.int16typ) - ELSIF f = Int16 THEN Convert(x, OPT.int8typ)*) - ELSIF f = LReal THEN Convert(x, OPT.realtyp) - ELSE err(111) - END - | longfn: (*LONG*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f = SInt THEN Convert(x, OPT.inttyp) - ELSIF f = Int THEN Convert(x, OPT.linttyp) - (*ELSIF f = Int8 THEN Convert(x, OPT.int16typ) - ELSIF f = Int16 THEN Convert(x, OPT.int32typ) - ELSIF f = Int32 THEN Convert(x, OPT.int64typ)*) - ELSIF f = Real THEN Convert(x, OPT.lrltyp) - ELSIF f = Char THEN Convert(x, OPT.linttyp) - ELSE err(111) - END - | incfn, decfn: (*INC, DEC*) - IF NotVar(x) THEN err(112) - ELSIF ~(f IN intSet) THEN err(111) - ELSIF x^.readonly THEN err(76) - END - | inclfn, exclfn: (*INCL, EXCL*) - IF NotVar(x) THEN err(112) - ELSIF x^.typ # OPT.settyp THEN err(111); x^.typ := OPT.settyp - ELSIF x^.readonly THEN err(76) - END - | lenfn: (*LEN*) - IF ~(x^.typ^.comp IN {DynArr, Array}) THEN err(131) END - | copyfn: (*COPY*) - IF (x^.class = Nconst) & (f = Char) THEN CharToString(x); f := String END ; - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF (~(x^.typ^.comp IN {DynArr, Array}) OR (x^.typ^.BaseTyp^.form # Char)) - & (f # String) THEN err(111) - END - | ashfn: (*ASH*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - IF f # LInt THEN Convert(x, OPT.linttyp) END - ELSE err(111); x^.typ := OPT.linttyp - END - | adrfn: (*SYSTEM.ADR*) - CheckLeaf(x, FALSE); MOp(adr, x) - | sizefn: (*SIZE*) - IF x^.class # Ntype THEN err(110); x := NewIntConst(1) - ELSIF (f IN {Byte..Set(*, Int8..Int64*), Pointer, ProcTyp}) OR (x^.typ^.comp IN {Array, Record}) THEN - typSize(x^.typ); x^.typ^.pvused := TRUE; x := NewIntConst(x^.typ^.size) - ELSE err(111); x := NewIntConst(1) - END - | ccfn: (*SYSTEM.CC*) - MOp(cc, x) - | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF ~(f IN intSet + {Byte, Char, Set(*, Int8, Int16, Int32, Int64*)}) THEN err(111) - END - | getfn, putfn, bitfn, movefn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.BIT, SYSTEM.MOVE*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF (x^.class = Nconst) & (f IN {SInt, Int}) THEN Convert(x, OPT.linttyp) - ELSIF ~(f IN {LInt, Pointer}) THEN err(111); x^.typ := OPT.linttyp - END - | getrfn, putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*) - IF (f IN intSet) & (x^.class = Nconst) THEN - IF (x^.conval^.intval < OPM.MinRegNr) OR (x^.conval^.intval > OPM.MaxRegNr) THEN err(220) END - ELSE err(69) - END - | valfn: (*SYSTEM.VAL*) - IF x^.class # Ntype THEN err(110) - ELSIF (f IN {Undef, String, NoTyp}) OR (x^.typ^.comp = DynArr) THEN err(111) - END - | sysnewfn: (*SYSTEM.NEW*) - IF NotVar(x) THEN err(112) - ELSIF f = Pointer THEN - IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END - ELSE err(111) - END - | assertfn: (*ASSERT*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); x := NewBoolConst(FALSE) - ELSIF f # Bool THEN err(120); x := NewBoolConst(FALSE) - ELSE MOp(not, x) - END - ELSE - OPM.LogWStr("unhandled case in OPB.StPar0, fctno = "); OPM.LogWNum(fctno, 0); OPM.LogWLn; + |OPT.haltfn: (*HALT*) + IF (f IN OPT.intSet) & (x^.class = OPT.Nconst) THEN + IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN + BindNodes(OPT.Ntrap, OPT.notyp, x, x) + ELSE err(218) + END + ELSE err(69) + END ; + x^.typ := OPT.notyp + |OPT.newfn: (*NEW*) + typ := OPT.notyp; + IF NotVar(x) THEN err(112) + ELSIF f = OPT.Pointer THEN + IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ; + IF x^.readonly THEN err(76) END ; + f := x^.typ^.BaseTyp^.comp; + IF f IN {OPT.Record, OPT.DynArr, OPT.Array} THEN + IF f = OPT.DynArr THEN typ := x^.typ^.BaseTyp END ; + BindNodes(OPT.Nassign, OPT.notyp, x, NIL); x^.subcl := OPT.newfn + ELSE err(111) + END + ELSE err(111) + END ; + x^.typ := typ + |OPT.absfn: (*ABS*) + MOp(OPT.abs, x) + |OPT.capfn: (*CAP*) + MOp(OPT.cap, x) + |OPT.ordfn: (*ORD*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f = OPT.Char THEN Convert(x, OPT.inttyp) + ELSE err(111) + END ; + x^.typ := OPT.inttyp + |OPT.entierfn: (*ENTIER*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f IN OPT.realSet THEN Convert(x, OPT.linttyp) + ELSE err(111) + END ; + x^.typ := OPT.linttyp + |OPT.oddfn: (*ODD*) + MOp(OPT.odd, x) + |OPT.minfn: (*MIN*) + IF x^.class = OPT.Ntype THEN + CASE f OF + OPT.Bool: x := NewBoolConst(FALSE) + | OPT.Char: x := NewIntConst(0); x^.typ := OPT.chartyp + | OPT.SInt, + OPT.Int, + OPT.LInt: x := NewIntConst(OPM.SignedMinimum(x.typ.size)) + | OPT.Set: x := NewIntConst(0); x^.typ := OPT.inttyp + | OPT.Real: x := NewRealConst(OPM.MinReal, OPT.realtyp) + | OPT.LReal: x := NewRealConst(OPM.MinLReal, OPT.lrltyp) + ELSE err(111) + END + ELSE err(110) + END + |OPT.maxfn: (*MAX*) + IF x^.class = OPT.Ntype THEN + CASE f OF + OPT.Bool: x := NewBoolConst(TRUE) + | OPT.Char: x := NewIntConst(0FFH); x^.typ := OPT.chartyp + | OPT.SInt, + OPT.Int, + OPT.LInt: x := NewIntConst(OPM.SignedMaximum(x.typ.size)) + | OPT.Set: x := NewIntConst(OPM.MaxSet); x^.typ := OPT.inttyp + | OPT.Real: x := NewRealConst(OPM.MaxReal, OPT.realtyp) + | OPT.LReal: x := NewRealConst(OPM.MaxLReal, OPT.lrltyp) + ELSE err(111) + END + ELSE err(110) + END + |OPT.chrfn: (*CHR*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f IN {OPT.Undef} + OPT.intSet THEN Convert(x, OPT.chartyp) + ELSE err(111); x^.typ := OPT.chartyp + END + |OPT.shortfn: (*SHORT*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF (f IN OPT.intSet) & (x.typ.size > OPM.SIntSize) THEN Convert(x, IntType(ShorterSize(x.typ.size))) + ELSIF f = OPT.LReal THEN Convert(x, OPT.realtyp) + ELSE err(111) + END + |OPT.longfn: (*LONG*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF (f IN OPT.intSet) & (x.typ.size < OPM.LIntSize) THEN Convert(x, IntType(LongerSize(x.typ.size))) + ELSIF f = OPT.Real THEN Convert(x, OPT.lrltyp) + ELSIF f = OPT.Char THEN Convert(x, OPT.linttyp) + ELSE err(111) + END + |OPT.incfn, + OPT.decfn: (*INC, DEC*) + IF NotVar(x) THEN err(112) + ELSIF ~(f IN OPT.intSet) THEN err(111) + ELSIF x^.readonly THEN err(76) + END + |OPT.inclfn, + OPT.exclfn: (*INCL, EXCL*) + IF NotVar(x) THEN err(112) + ELSIF x^.typ # OPT.settyp THEN err(111); x^.typ := OPT.settyp + ELSIF x^.readonly THEN err(76) + END + |OPT.lenfn: (*LEN*) + IF ~(x^.typ^.comp IN {OPT.DynArr, OPT.Array}) THEN err(131) END + |OPT.copyfn: (*COPY*) + IF (x^.class = OPT.Nconst) & (f = OPT.Char) THEN CharToString(x); f := OPT.String END ; + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF (~(x^.typ^.comp IN {OPT.DynArr, OPT.Array}) OR (x^.typ^.BaseTyp^.form # OPT.Char)) + & (f # OPT.String) THEN err(111) + END + |OPT.ashfn: (*ASH*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f IN OPT.intSet THEN + IF x.typ.size # OPM.LIntSize THEN Convert(x, OPT.linttyp) END + ELSE err(111); x^.typ := OPT.linttyp + END + |OPT.adrfn: (*SYSTEM.ADR*) + CheckLeaf(x, FALSE); MOp(OPT.adr, x) + |OPT.sizefn: (*SIZE*) + IF x^.class # OPT.Ntype THEN err(110); x := NewIntConst(1) + ELSIF (f IN {OPT.Byte..OPT.Set, OPT.Pointer, OPT.ProcTyp}) + OR (x^.typ^.comp IN {OPT.Array, OPT.Record}) THEN + typSize(x^.typ); x^.typ^.pvused := TRUE; x := NewIntConst(x^.typ^.size) + ELSE err(111); x := NewIntConst(1) + END + |OPT.ccfn: (*SYSTEM.CC*) + MOp(OPT.cc, x) + |OPT.lshfn, + OPT.rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF ~(f IN OPT.intSet + {OPT.Byte, OPT.Char, OPT.Set}) THEN err(111) + END + |OPT.getfn, + OPT.putfn, + OPT.bitfn, + OPT.movefn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.BIT, SYSTEM.MOVE*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF (x^.class = OPT.Nconst) & (f IN OPT.intSet) & (x.typ.size < OPT.linttyp.size) THEN Convert(x, OPT.linttyp) + ELSIF ~((x.typ.form IN {OPT.Pointer} + OPT.intSet) & (x.typ.size = OPM.PointerSize)) THEN err(111); x^.typ := OPT.linttyp + END + |OPT.getrfn, + OPT.putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*) + IF (f IN OPT.intSet) & (x^.class = OPT.Nconst) THEN + IF (x^.conval^.intval < OPM.MinRegNr) OR (x^.conval^.intval > OPM.MaxRegNr) THEN err(220) END + ELSE err(69) + END + |OPT.valfn: (*SYSTEM.VAL*) + IF x^.class # OPT.Ntype THEN err(110) + ELSIF (f IN {OPT.Undef, OPT.String, OPT.NoTyp}) OR (x^.typ^.comp = OPT.DynArr) THEN err(111) + END + |OPT.sysnewfn: (*SYSTEM.NEW*) + IF NotVar(x) THEN err(112) + ELSIF f = OPT.Pointer THEN + IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END + ELSE err(111) + END + |OPT.assertfn: (*ASSERT*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126); x := NewBoolConst(FALSE) + ELSIF f # OPT.Bool THEN err(120); x := NewBoolConst(FALSE) + ELSE MOp(OPS.not, x) + END + ELSE OPM.LogWStr("unhandled case in OPB.StPar0, fctno = "); OPM.LogWNum(fctno, 0); OPM.LogWLn; END ; par0 := x END StPar0; @@ -1268,141 +1133,152 @@ avoid unnecessary intermediate variables in voc BEGIN p := par0; f := x^.typ^.form; CASE fctno OF - incfn, decfn: (*INC DEC*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); p^.typ := OPT.notyp - ELSE - IF x^.typ # p^.typ THEN - IF (x^.class = Nconst) & (f IN intSet) THEN Convert(x, p^.typ) - ELSE err(111) - END - END ; - p := NewOp(Nassign, fctno, p, x); - p^.typ := OPT.notyp - END - | inclfn, exclfn: (*INCL, EXCL*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - IF (x^.class = Nconst) & ((0 > x^.conval^.intval) OR (x^.conval^.intval > OPM.MaxSet)) THEN err(202) - END ; - p := NewOp(Nassign, fctno, p, x) - ELSE err(111) - END ; - p^.typ := OPT.notyp - | lenfn: (*LEN*) - IF ~(f IN intSet) OR (x^.class # Nconst) THEN err(69) - ELSIF f = SInt THEN - L := SHORT(x^.conval^.intval); typ := p^.typ; - WHILE (L > 0) & (typ^.comp IN {DynArr, Array}) DO typ := typ^.BaseTyp; DEC(L) END ; - IF (L # 0) OR ~(typ^.comp IN {DynArr, Array}) THEN err(132) - ELSE x^.obj := NIL; - IF typ^.comp = DynArr THEN - WHILE p^.class = Nindex DO p := p^.left; INC(x^.conval^.intval) END ; (* possible side effect ignored *) - p := NewOp(Ndop, len, p, x); p^.typ := OPT.linttyp - ELSE p := x; p^.conval^.intval := typ^.n; SetIntType(p) - END - END - ELSE err(132) - END - | copyfn: (*COPY*) - IF NotVar(x) THEN err(112) - ELSIF (x^.typ^.comp IN {Array, DynArr}) & (x^.typ^.BaseTyp^.form = Char) THEN - IF x^.readonly THEN err(76) END ; - t := x; x := p; p := t; p := NewOp(Nassign, copyfn, p, x) - ELSE err(111) - END ; - p^.typ := OPT.notyp - | ashfn: (*ASH*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - IF (p^.class = Nconst) & (x^.class = Nconst) THEN - IF (-maxExp > x^.conval^.intval) OR (x^.conval^.intval > maxExp) THEN err(208); p^.conval^.intval := 1 - ELSIF x^.conval^.intval >= 0 THEN - IF ABS(p^.conval^.intval) <= MAX(LONGINT) DIV ASH(1, x^.conval^.intval) THEN - p^.conval^.intval := p^.conval^.intval * ASH(1, x^.conval^.intval) - ELSE err(208); p^.conval^.intval := 1 - END - ELSE p^.conval^.intval := ASH(p^.conval^.intval, x^.conval^.intval) - END ; - p^.obj := NIL - ELSE p := NewOp(Ndop, ash, p, x); p^.typ := OPT.linttyp - END - ELSE err(111) - END - | newfn: (*NEW(p, x...)*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF p^.typ^.comp = DynArr THEN - IF f IN intSet THEN - IF (x^.class = Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END - ELSE err(111) - END ; - p^.right := x; p^.typ := p^.typ^.BaseTyp - ELSE err(64) - END - | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF ~(f IN intSet) THEN err(111) - ELSE - IF fctno = lshfn THEN p := NewOp(Ndop, lsh, p, x) ELSE p := NewOp(Ndop, rot, p, x) END ; - p^.typ := p^.left^.typ - END - | getfn, putfn, getrfn, putrfn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.GETREG, SYSTEM.PUTREG*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN {Undef..Set, Pointer, ProcTyp} THEN - IF (fctno = getfn) OR (fctno = getrfn) THEN - IF NotVar(x) THEN err(112) END ; - t := x; x := p; p := t - END ; - p := NewOp(Nassign, fctno, p, x) - ELSE err(111) - END ; - p^.typ := OPT.notyp - | bitfn: (*SYSTEM.BIT*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - p := NewOp(Ndop, bit, p, x) - ELSE err(111) - END ; - p^.typ := OPT.booltyp - | valfn: (*SYSTEM.VAL*) (* type is changed without considering the byte ordering on the target machine *) - IF (x^.class = Ntype) OR (x^.class = Nproc) OR - (f IN {Undef, String, NoTyp}) OR (x^.typ^.comp = DynArr) THEN err(126) - END ; - t := OPT.NewNode(Nmop); t^.subcl := val; t^.left := x; x := t; -(* - IF (x^.class >= Nconst) OR ((f IN realSet) # (p^.typ^.form IN realSet)) THEN - t := OPT.NewNode(Nmop); t^.subcl := val; t^.left := x; x := t - ELSE x^.readonly := FALSE - END ; -*) - x^.typ := p^.typ; p := x - | sysnewfn: (*SYSTEM.NEW*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - p := NewOp(Nassign, sysnewfn, p, x) - ELSE err(111) - END ; - p^.typ := OPT.notyp - | movefn: (*SYSTEM.MOVE*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF (x^.class = Nconst) & (f IN {SInt, Int}) THEN Convert(x, OPT.linttyp) - ELSIF ~(f IN {LInt, Pointer}) THEN err(111); x^.typ := OPT.linttyp - END ; - p^.link := x - | assertfn: (*ASSERT*) - IF (f IN intSet) & (x^.class = Nconst) THEN - IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN - BindNodes(Ntrap, OPT.notyp, x, x); - x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.errpos; - Construct(Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos; - Construct(Nifelse, p, NIL); OptIf(p); - IF p = NIL THEN (* ASSERT(TRUE) *) - ELSIF p^.class = Ntrap THEN err(99) - ELSE p^.subcl := assertfn - END - ELSE err(218) - END - ELSE err(69) - END + |OPT.incfn, + OPT.decfn: (*INC DEC*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126); p^.typ := OPT.notyp + ELSE + IF x^.typ # p^.typ THEN + IF (x^.class = OPT.Nconst) & (f IN OPT.intSet) THEN Convert(x, p^.typ) + ELSE err(111) + END + END ; + p := NewOp(OPT.Nassign, fctno, p, x); + p^.typ := OPT.notyp + END + |OPT.inclfn, + OPT.exclfn: (*INCL, EXCL*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f IN OPT.intSet THEN + IF (x^.class = OPT.Nconst) & ((0 > x^.conval^.intval) OR (x^.conval^.intval > OPM.MaxSet)) THEN err(202) + END ; + p := NewOp(OPT.Nassign, fctno, p, x) + ELSE err(111) + END ; + p^.typ := OPT.notyp + |OPT.lenfn: (*LEN*) + IF ~(f IN OPT.intSet) OR (x^.class # OPT.Nconst) THEN err(69) + ELSIF x.typ.size = 1 THEN (* Hard limit of 127 dimensions *) + L := SHORT(x^.conval^.intval); typ := p^.typ; + WHILE (L > 0) & (typ^.comp IN {OPT.DynArr, OPT.Array}) DO typ := typ^.BaseTyp; DEC(L) END ; + IF (L # 0) OR ~(typ^.comp IN {OPT.DynArr, OPT.Array}) THEN err(132) + ELSE x^.obj := NIL; + IF typ^.comp = OPT.DynArr THEN + WHILE p^.class = OPT.Nindex DO p := p^.left; INC(x^.conval^.intval) END ; (* possible side effect ignored *) + p := NewOp(OPT.Ndop, OPT.len, p, x); p^.typ := OPT.linttyp + ELSE p := x; p^.conval^.intval := typ^.n; SetIntType(p) + END + END + ELSE err(132) + END + |OPT.copyfn: (*COPY*) + IF NotVar(x) THEN err(112) + ELSIF (x^.typ^.comp IN {OPT.Array, OPT.DynArr}) & (x^.typ^.BaseTyp^.form = OPT.Char) THEN + IF x^.readonly THEN err(76) END ; + t := x; x := p; p := t; p := NewOp(OPT.Nassign, OPT.copyfn, p, x) + ELSE err(111) + END ; + p^.typ := OPT.notyp + |OPT.ashfn: (*ASH*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f IN OPT.intSet THEN + IF (p^.class = OPT.Nconst) & (x^.class = OPT.Nconst) THEN + IF (-maxExp > x^.conval^.intval) OR (x^.conval^.intval > maxExp) THEN err(208); p^.conval^.intval := 1 + ELSIF x^.conval^.intval >= 0 THEN + IF ABS(p^.conval^.intval) <= MAX(LONGINT) DIV ASH(1, x^.conval^.intval) THEN + p^.conval^.intval := p^.conval^.intval * ASH(1, x^.conval^.intval) + ELSE err(208); p^.conval^.intval := 1 + END + ELSE p^.conval^.intval := ASH(p^.conval^.intval, x^.conval^.intval) + END ; + p^.obj := NIL + ELSE p := NewOp(OPT.Ndop, OPT.ash, p, x); p^.typ := OPT.linttyp + END + ELSE err(111) + END + |OPT.newfn: (*NEW(p, x...)*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF p^.typ^.comp = OPT.DynArr THEN + IF f IN OPT.intSet THEN + IF (x^.class = OPT.Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END + ELSE err(111) + END ; + p^.right := x; p^.typ := p^.typ^.BaseTyp + ELSE err(64) + END + |OPT.lshfn, + OPT.rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF ~(f IN OPT.intSet) THEN err(111) + ELSE + IF fctno = OPT.lshfn THEN p := NewOp(OPT.Ndop, OPT.lsh, p, x) ELSE p := NewOp(OPT.Ndop, OPT.rot, p, x) END ; + p^.typ := p^.left^.typ + END + |OPT.getfn, + OPT.putfn, + OPT.getrfn, + OPT.putrfn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.GETREG, SYSTEM.PUTREG*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f IN {OPT.Undef..OPT.Set, OPT.Pointer, OPT.ProcTyp} THEN + IF (fctno = OPT.getfn) OR (fctno = OPT.getrfn) THEN + IF NotVar(x) THEN err(112) END ; + t := x; x := p; p := t + END ; + p := NewOp(OPT.Nassign, fctno, p, x) + ELSE err(111) + END ; + p^.typ := OPT.notyp + |OPT.bitfn: (*SYSTEM.BIT*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f IN OPT.intSet THEN + p := NewOp(OPT.Ndop, OPT.bit, p, x) + ELSE err(111) + END ; + p^.typ := OPT.booltyp + |OPT.valfn: (*SYSTEM.VAL*) (* type is changed without considering the byte ordering on the target machine *) + IF (x^.class = OPT.Ntype) + OR (x^.class = OPT.Nproc) + OR (f IN {OPT.Undef, OPT.String, OPT.NoTyp}) + OR (x^.typ^.comp = OPT.DynArr) THEN + err(126) + END; + (* Warn if the result type includes memory past the end of the source variable *) + IF x.typ.size < p.typ.size THEN err(-308) END; + t := OPT.NewNode(OPT.Nmop); t^.subcl := OPT.val; t^.left := x; x := t; + (* + IF (x^.class >= OPT.Nconst) OR ((f IN OPT.realSet) # (p^.typ^.form IN OPT.realSet)) THEN + t := OPT.NewNode(OPT.Nmop); t^.subcl := val; t^.left := x; x := t + ELSE x^.readonly := FALSE + END ; + *) + x^.typ := p^.typ; p := x + |OPT.sysnewfn: (*SYSTEM.NEW*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f IN OPT.intSet THEN + p := NewOp(OPT.Nassign, OPT.sysnewfn, p, x) + ELSE err(111) + END ; + p^.typ := OPT.notyp + |OPT.movefn: (*SYSTEM.MOVE*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF (x^.class = OPT.Nconst) & (f IN OPT.intSet) & (x.typ.size < OPT.linttyp.size) THEN Convert(x, OPT.linttyp) + ELSIF ~((x.typ.form IN {OPT.Pointer} + OPT.intSet) & (x.typ.size = OPM.PointerSize)) THEN err(111); x^.typ := OPT.linttyp + END; + p^.link := x + |OPT.assertfn: (*ASSERT*) + IF (f IN OPT.intSet) & (x^.class = OPT.Nconst) THEN + IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN + BindNodes(OPT.Ntrap, OPT.notyp, x, x); + x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.errpos; + Construct(OPT.Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos; + Construct(OPT.Nifelse, p, NIL); OptIf(p); + IF p = NIL THEN (* ASSERT(TRUE) *) + ELSIF p^.class = OPT.Ntrap THEN err(99) + ELSE p^.subcl := OPT.assertfn + END + ELSE err(218) + END + ELSE err(69) + END ELSE err(64) END ; par0 := p @@ -1411,19 +1287,19 @@ avoid unnecessary intermediate variables in voc PROCEDURE StParN*(VAR par0: OPT.Node; x: OPT.Node; fctno, n: INTEGER); (* x: n+1-th param of standard proc *) VAR node: OPT.Node; f: INTEGER; p: OPT.Node; BEGIN p := par0; f := x^.typ^.form; - IF fctno = newfn THEN (*NEW(p, ..., x...*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF p^.typ^.comp # DynArr THEN err(64) - ELSIF f IN intSet THEN - IF (x^.class = Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END ; + IF fctno = OPT.newfn THEN (*NEW(p, ..., x...*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF p^.typ^.comp # OPT.DynArr THEN err(64) + ELSIF f IN OPT.intSet THEN + IF (x^.class = OPT.Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END ; node := p^.right; WHILE node^.link # NIL DO node := node^.link END; node^.link := x; p^.typ := p^.typ^.BaseTyp ELSE err(111) END - ELSIF (fctno = movefn) & (n = 2) THEN (*SYSTEM.MOVE*) - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF f IN intSet THEN - node := OPT.NewNode(Nassign); node^.subcl := movefn; node^.right := p; + ELSIF (fctno = OPT.movefn) & (n = 2) THEN (*SYSTEM.MOVE*) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF f IN OPT.intSet THEN + node := OPT.NewNode(OPT.Nassign); node^.subcl := OPT.movefn; node^.right := p; node^.left := p^.link; p^.link := x; p := node ELSE err(111) END ; @@ -1436,41 +1312,41 @@ avoid unnecessary intermediate variables in voc PROCEDURE StFct*(VAR par0: OPT.Node; fctno: SHORTINT; parno: INTEGER); VAR dim: INTEGER; x, p: OPT.Node; BEGIN p := par0; - IF fctno <= ashfn THEN - IF (fctno = newfn) & (p^.typ # OPT.notyp) THEN - IF p^.typ^.comp = DynArr THEN err(65) END ; + IF fctno <= OPT.ashfn THEN + IF (fctno = OPT.newfn) & (p^.typ # OPT.notyp) THEN + IF p^.typ^.comp = OPT.DynArr THEN err(65) END ; p^.typ := OPT.notyp - ELSIF fctno <= sizefn THEN (* 1 param *) + ELSIF fctno <= OPT.sizefn THEN (* 1 param *) IF parno < 1 THEN err(65) END ELSE (* more than 1 param *) - IF ((fctno = incfn) OR (fctno = decfn)) & (parno = 1) THEN (*INC, DEC*) - BindNodes(Nassign, OPT.notyp, p, NewIntConst(1)); p^.subcl := fctno; p^.right^.typ := p^.left^.typ - ELSIF (fctno = lenfn) & (parno = 1) THEN (*LEN*) - IF p^.typ^.comp = DynArr THEN dim := 0; - WHILE p^.class = Nindex DO p := p^.left; INC(dim) END ; (* possible side effect ignored *) - BindNodes(Ndop, OPT.linttyp, p, NewIntConst(dim)); p^.subcl := len + IF ((fctno = OPT.incfn) OR (fctno = OPT.decfn)) & (parno = 1) THEN (*INC, DEC*) + BindNodes(OPT.Nassign, OPT.notyp, p, NewIntConst(1)); p^.subcl := fctno; p^.right^.typ := p^.left^.typ + ELSIF (fctno = OPT.lenfn) & (parno = 1) THEN (*LEN*) + IF p^.typ^.comp = OPT.DynArr THEN dim := 0; + WHILE p^.class = OPT.Nindex DO p := p^.left; INC(dim) END ; (* possible side effect ignored *) + BindNodes(OPT.Ndop, OPT.linttyp, p, NewIntConst(dim)); p^.subcl := OPT.len ELSE p := NewIntConst(p^.typ^.n) END ELSIF parno < 2 THEN err(65) END END - ELSIF fctno = assertfn THEN + ELSIF fctno = OPT.assertfn THEN IF parno = 1 THEN x := NIL; - BindNodes(Ntrap, OPT.notyp, x, NewIntConst(AssertTrap)); + BindNodes(OPT.Ntrap, OPT.notyp, x, NewIntConst(AssertTrap)); x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.errpos; - Construct(Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos; - Construct(Nifelse, p, NIL); OptIf(p); + Construct(OPT.Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos; + Construct(OPT.Nifelse, p, NIL); OptIf(p); IF p = NIL THEN (* ASSERT(TRUE) *) - ELSIF p^.class = Ntrap THEN err(99) - ELSE p^.subcl := assertfn + ELSIF p^.class = OPT.Ntrap THEN err(99) + ELSE p^.subcl := OPT.assertfn END ELSIF parno < 1 THEN err(65) END ELSE (*SYSTEM*) IF (parno < 1) OR - (fctno > ccfn) & (parno < 2) OR - (fctno = movefn) & (parno < 3) THEN err(65) + (fctno > OPT.ccfn) & (parno < 2) OR + (fctno = OPT.movefn) & (parno < 3) THEN err(65) END END ; par0 := p @@ -1478,18 +1354,18 @@ avoid unnecessary intermediate variables in voc PROCEDURE DynArrParCheck(ftyp, atyp: OPT.Struct; fvarpar: BOOLEAN); VAR f: INTEGER; - BEGIN (* ftyp^.comp = DynArr *) + BEGIN (* ftyp^.comp = OPT.DynArr *) f := atyp^.comp; ftyp := ftyp^.BaseTyp; atyp := atyp^.BaseTyp; IF fvarpar & (ftyp = OPT.bytetyp) THEN (* ok, but ... *) - IF ~(f IN {Array, DynArr}) OR ~(atyp^.form IN {Byte..SInt(*, Int8..Int64*)}) THEN + IF ~(f IN {OPT.Array, OPT.DynArr}) OR ~((atyp.form IN {OPT.Byte..OPT.Char} + OPT.intSet) & (atyp.size = 1)) THEN IF OPM.verbose IN OPM.opt THEN err(-301) END END - ELSIF f IN {Array, DynArr} THEN - IF ftyp^.comp = DynArr THEN DynArrParCheck(ftyp, atyp, fvarpar) + ELSIF f IN {OPT.Array, OPT.DynArr} THEN + IF ftyp^.comp = OPT.DynArr THEN DynArrParCheck(ftyp, atyp, fvarpar) ELSIF ftyp # atyp THEN - IF ~fvarpar & (ftyp.form = Pointer) & (atyp.form = Pointer) THEN + IF ~fvarpar & (ftyp.form = OPT.Pointer) & (atyp.form = OPT.Pointer) THEN ftyp := ftyp^.BaseTyp; atyp := atyp^.BaseTyp; - IF (ftyp^.comp = Record) & (atyp^.comp = Record) THEN + IF (ftyp^.comp = OPT.Record) & (atyp^.comp = OPT.Record) THEN WHILE (ftyp # atyp) & (atyp # NIL) & (atyp # OPT.undftyp) DO atyp := atyp^.BaseTyp END ; IF atyp = NIL THEN err(113) END ELSE err(66) @@ -1503,17 +1379,17 @@ avoid unnecessary intermediate variables in voc PROCEDURE CheckReceiver(VAR x: OPT.Node; fp: OPT.Object); BEGIN - IF fp^.typ^.form = Pointer THEN - IF x^.class = Nderef THEN x := x^.left (*undo DeRef*) ELSE (*x^.typ^.comp = Record*) err(71) END + IF fp^.typ^.form = OPT.Pointer THEN + IF x^.class = OPT.Nderef THEN x := x^.left (*undo DeRef*) ELSE (*x^.typ^.comp = OPT.Record*) err(71) END END END CheckReceiver; PROCEDURE PrepCall*(VAR x: OPT.Node; VAR fpar: OPT.Object); BEGIN - IF (x^.obj # NIL) & (x^.obj^.mode IN {LProc, XProc, TProc, CProc}) THEN + IF (x^.obj # NIL) & (x^.obj^.mode IN {OPT.LProc, OPT.XProc, OPT.TProc, OPT.CProc}) THEN fpar := x^.obj^.link; - IF x^.obj^.mode = TProc THEN CheckReceiver(x^.left, fpar); fpar := fpar^.link END - ELSIF (x^.class # Ntype) & (x^.typ # NIL) & (x^.typ^.form = ProcTyp) THEN + IF x^.obj^.mode = OPT.TProc THEN CheckReceiver(x^.left, fpar); fpar := fpar^.link END + ELSIF (x^.class # OPT.Ntype) & (x^.typ # NIL) & (x^.typ^.form = OPT.ProcTyp) THEN fpar := x^.typ^.link ELSE err(121); fpar := NIL; x^.typ := OPT.undftyp END @@ -1522,25 +1398,25 @@ avoid unnecessary intermediate variables in voc PROCEDURE Param*(ap: OPT.Node; fp: OPT.Object); VAR q: OPT.Struct; BEGIN - IF fp.typ.form # Undef THEN - IF fp^.mode = VarPar THEN + IF fp.typ.form # OPT.Undef THEN + IF fp^.mode = OPT.VarPar THEN IF NotVar(ap) THEN err(122) ELSE CheckLeaf(ap, FALSE) END ; IF ap^.readonly THEN err(76) END ; - IF fp^.typ^.comp = DynArr THEN DynArrParCheck(fp^.typ, ap^.typ, TRUE) - ELSIF (fp^.typ^.comp = Record) & (ap^.typ^.comp = Record) THEN + IF fp^.typ^.comp = OPT.DynArr THEN DynArrParCheck(fp^.typ, ap^.typ, TRUE) + ELSIF (fp^.typ^.comp = OPT.Record) & (ap^.typ^.comp = OPT.Record) THEN q := ap^.typ; WHILE (q # fp^.typ) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ; IF q = NIL THEN err(111) END - ELSIF (fp^.typ = OPT.sysptrtyp) & (ap^.typ^.form = Pointer) THEN (* ok *) - ELSIF (ap^.typ # fp^.typ) & ~((fp^.typ^.form = Byte) & (ap^.typ^.form IN {Char, SInt})) THEN err(123) - ELSIF (fp^.typ^.form = Pointer) & (ap^.class = Nguard) THEN err(123) + ELSIF (fp^.typ = OPT.sysptrtyp) & (ap^.typ^.form = OPT.Pointer) THEN (* ok *) + ELSIF (ap^.typ # fp^.typ) & ~((fp^.typ^.form = OPT.Byte) & ((ap.typ.form IN {OPT.Byte..OPT.Char} + OPT.intSet) & (ap.typ.size = 1))) THEN err(123) + ELSIF (fp^.typ^.form = OPT.Pointer) & (ap^.class = OPT.Nguard) THEN err(123) END - ELSIF fp^.typ^.comp = DynArr THEN - IF (ap^.class = Nconst) & (ap^.typ^.form = Char) THEN CharToString(ap) END ; - IF (ap^.typ^.form = String) & (fp^.typ^.BaseTyp^.form = Char) THEN (* ok *) - ELSIF ap^.class >= Nconst THEN err(59) + ELSIF fp^.typ^.comp = OPT.DynArr THEN + IF (ap^.class = OPT.Nconst) & (ap^.typ^.form = OPT.Char) THEN CharToString(ap) END ; + IF (ap^.typ^.form = OPT.String) & (fp^.typ^.BaseTyp^.form = OPT.Char) THEN (* ok *) + ELSIF ap^.class >= OPT.Nconst THEN err(59) ELSE DynArrParCheck(fp^.typ, ap^.typ, FALSE) END ELSE CheckAssign(fp^.typ, ap) @@ -1553,7 +1429,7 @@ avoid unnecessary intermediate variables in voc BEGIN scope := OPT.topScope; WHILE dlev > 0 DO DEC(dlev); - INCL(scope^.link^.conval^.setval, slNeeded); + INCL(scope^.link^.conval^.setval, OPT.slNeeded); scope := scope^.left END END StaticLink; @@ -1561,21 +1437,21 @@ avoid unnecessary intermediate variables in voc PROCEDURE Call*(VAR x: OPT.Node; apar: OPT.Node; fp: OPT.Object); VAR typ: OPT.Struct; p: OPT.Node; lev: SHORTINT; BEGIN - IF x^.class = Nproc THEN typ := x^.typ; + IF x^.class = OPT.Nproc THEN typ := x^.typ; lev := x^.obj^.mnolev; IF lev > 0 THEN StaticLink(OPT.topScope^.mnolev-lev) END ; - IF x^.obj^.mode = IProc THEN err(121) END - ELSIF (x^.class = Nfield) & (x^.obj^.mode = TProc) THEN typ := x^.typ; - x^.class := Nproc; p := x^.left; x^.left := NIL; p^.link := apar; apar := p; fp := x^.obj^.link + IF x^.obj^.mode = OPT.IProc THEN err(121) END + ELSIF (x^.class = OPT.Nfield) & (x^.obj^.mode = OPT.TProc) THEN typ := x^.typ; + x^.class := OPT.Nproc; p := x^.left; x^.left := NIL; p^.link := apar; apar := p; fp := x^.obj^.link ELSE typ := x^.typ^.BaseTyp END ; - BindNodes(Ncall, typ, x, apar); x^.obj := fp + BindNodes(OPT.Ncall, typ, x, apar); x^.obj := fp END Call; PROCEDURE Enter*(VAR procdec: OPT.Node; stat: OPT.Node; proc: OPT.Object); VAR x: OPT.Node; BEGIN - x := OPT.NewNode(Nenter); x^.typ := OPT.notyp; x^.obj := proc; + x := OPT.NewNode(OPT.Nenter); x^.typ := OPT.notyp; x^.obj := proc; x^.left := procdec; x^.right := stat; procdec := x END Enter; @@ -1589,42 +1465,42 @@ avoid unnecessary intermediate variables in voc ELSIF proc^.typ # OPT.notyp THEN err(124) END END ; - node := OPT.NewNode(Nreturn); node^.typ := OPT.notyp; node^.obj := proc; node^.left := x; x := node + node := OPT.NewNode(OPT.Nreturn); node^.typ := OPT.notyp; node^.obj := proc; node^.left := x; x := node END Return; PROCEDURE Assign*(VAR x: OPT.Node; y: OPT.Node); VAR z: OPT.Node; subcl: SHORTINT; BEGIN - IF x^.class >= Nconst THEN err(56) END ; + IF x^.class >= OPT.Nconst THEN err(56) END ; CheckAssign(x^.typ, y); IF x^.readonly THEN err(76) END ; - IF x^.typ^.comp = Record THEN - IF x^.class = Nguard THEN z := x^.left ELSE z := x END ; - IF (z^.class = Nderef) & (z^.left^.class = Nguard) THEN + IF x^.typ^.comp = OPT.Record THEN + IF x^.class = OPT.Nguard THEN z := x^.left ELSE z := x END ; + IF (z^.class = OPT.Nderef) & (z^.left^.class = OPT.Nguard) THEN z^.left := z^.left^.left (* skip guard before dereferencing *) END ; - IF (x^.typ^.strobj # NIL) & ((z^.class = Nderef) OR (z^.class = Nvarpar)) THEN - BindNodes(Neguard, x^.typ, z, NIL); x := z + IF (x^.typ^.strobj # NIL) & ((z^.class = OPT.Nderef) OR (z^.class = OPT.Nvarpar)) THEN + BindNodes(OPT.Neguard, x^.typ, z, NIL); x := z END - ELSIF (x^.typ^.comp = Array) & (x^.typ^.BaseTyp = OPT.chartyp) & - (y^.typ^.form = String) & (y^.conval^.intval2 = 1) THEN (* replace array := "" with array[0] := 0X *) + ELSIF (x^.typ^.comp = OPT.Array) & (x^.typ^.BaseTyp = OPT.chartyp) & + (y^.typ^.form = OPT.String) & (y^.conval^.intval2 = 1) THEN (* replace array := "" with array[0] := 0X *) y^.typ := OPT.chartyp; y^.conval^.intval := 0; Index(x, NewIntConst(0)) END ; - IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp = OPT.chartyp) - & (y.typ.comp IN {Array, DynArr}) & (y.typ.BaseTyp = OPT.chartyp) THEN - subcl := copyfn + IF (x.typ.comp IN {OPT.Array, OPT.DynArr}) & (x.typ.BaseTyp = OPT.chartyp) + & (y.typ.comp IN {OPT.Array, OPT.DynArr}) & (y.typ.BaseTyp = OPT.chartyp) THEN + subcl := OPT.copyfn ELSE - subcl := assign + subcl := OPT.assign END; - BindNodes(Nassign, OPT.notyp, x, y); + BindNodes(OPT.Nassign, OPT.notyp, x, y); x^.subcl := subcl; END Assign; PROCEDURE Inittd*(VAR inittd, last: OPT.Node; typ: OPT.Struct); VAR node: OPT.Node; BEGIN - node := OPT.NewNode(Ninittd); node^.typ := typ; + node := OPT.NewNode(OPT.Ninittd); node^.typ := typ; node^.conval := OPT.NewConst(); node^.conval^.intval := typ^.txtpos; IF inittd = NIL THEN inittd := node ELSE last^.link := node END ; last := node diff --git a/src/compiler/OPC.Mod b/src/compiler/OPC.Mod index 718ba572..1076a289 100644 --- a/src/compiler/OPC.Mod +++ b/src/compiler/OPC.Mod @@ -1,1408 +1,1352 @@ -MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *) +MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *) (* C source code generator version - 30.4.2000 jt, synchronized with BlackBox version, in particular - various promotion rules changed (long) => (LONGINT), xxxL avoided + 30.4.2000 jt, synchronized with BlackBox version, in particular + various promotion rules changed (long) => (LONGINT), xxxL avoided *) - IMPORT OPT, OPM, Configuration; - - CONST demoVersion = FALSE; - - CONST - (* structure forms *) - Byte = 1; Bool = 2; Char = 3; - SInt = 4; Int = 5; LInt = 6; - Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Comp = 15; -(* - Int8 = 7; Int16 = 8; Int32 = 9; Int64 = 10; - Real = 11; LReal = 12; Set = 13; String = 14; NilTyp = 15; NoTyp = 16; - Pointer = 17; ProcTyp = 18; - Comp = 19; -*) - (*Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18; - Comp = (*15*)19;*) - - (* composite structure forms *) - Array = 2; DynArr = 3; Record = 4; - - (* object history *) - removed = 4; - - (* object modes *) - Var = 1; VarPar = 2; Fld = 4; Typ = 5; LProc = 6; XProc = 7; - CProc = 9; Mod = 11; TProc = 13; - - (* symbol values and ops *) - eql = 9; neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; - - (* nodes classes *) - Ninittd = 14; - - (* module visibility of objects *) - internal = 0; external = 1; - - UndefinedType = 0; (* named type not yet defined *) - ProcessingType = 1; (* pointer type is being processed *) - PredefinedType = 2; (* for all predefined types *) - DefinedInHdr = 3+OPM.HeaderFile; (* named type has been defined in header file *) - DefinedInBdy = 3+OPM.BodyFile; (* named type has been defined in body file *) - - - HeaderMsg = " voc "; - BasicIncludeFile = "SYSTEM"; - Static = "static "; - Export = "export "; (* particularily introduced for VC++ declspec() *) - Extern = "import "; (* particularily introduced for VC++ declspec() *) - Struct = "struct "; - LocalScope = "_s"; (* name of a local intermediate scope (variable name) *) - GlobalScope = "_s"; (* pointer to current scope extension *) - LinkName = "lnk"; (* pointer to previous scope field *) - FlagExt = "__h"; - LenExt = "__len"; - DynTypExt = "__typ"; - TagExt = "__typ"; - - OpenParen = "("; - CloseParen = ")"; - OpenBrace = "{"; - CloseBrace = "}"; - OpenBracket = "["; - CloseBracket = "]"; - Underscore = "_"; - Quotes = 22X; - SingleQuote = 27X; - Tab = 9X; - Colon = ": "; - Semicolon = ";"; - Comma = ", "; - Becomes = " = "; - Star = "*"; - Blank = " "; - Dot = "."; - - DupFunc = "__DUP("; (* duplication of dynamic arrays *) - DupArrFunc = "__DUPARR("; (* duplication of fixed size arrays *) - DelFunc = "__DEL("; (* removal of dynamic arrays *) - - NilConst = "NIL"; - - VoidType = "void"; - CaseStat = "case "; - - VAR - indentLevel: INTEGER; - ptrinit, mainprog, ansi: BOOLEAN; - hashtab: ARRAY 105 OF SHORTINT; - keytab: ARRAY 36, 9 OF CHAR; - GlbPtrs: BOOLEAN; - BodyNameExt: ARRAY 13 OF CHAR; - - PROCEDURE Init*; - BEGIN - indentLevel := 0; - ptrinit := OPM.ptrinit IN OPM.opt; - (*mainprog := OPM.mainprog IN OPM.opt;*) - mainprog := OPM.mainProg OR OPM.mainLinkStat; - ansi := OPM.ansi IN OPM.opt; - IF ansi THEN BodyNameExt := "__init(void)" ELSE BodyNameExt := "__init()" END - END Init; - - PROCEDURE Indent* (count: INTEGER); - BEGIN INC(indentLevel, count) - END Indent; - - PROCEDURE BegStat*; - VAR i: INTEGER; - BEGIN i := indentLevel; - WHILE i > 0 DO OPM.Write(Tab); DEC (i) END - END BegStat; - - PROCEDURE EndStat*; - BEGIN OPM.Write(Semicolon); OPM.WriteLn - END EndStat; - - PROCEDURE BegBlk*; - BEGIN OPM.Write(OpenBrace); OPM.WriteLn; INC(indentLevel) - END BegBlk; - - PROCEDURE EndBlk*; - BEGIN DEC(indentLevel); BegStat; OPM.Write(CloseBrace); OPM.WriteLn - END EndBlk; - - PROCEDURE EndBlk0*; - BEGIN DEC(indentLevel); BegStat; OPM.Write(CloseBrace) - END EndBlk0; - - PROCEDURE Str1(s: ARRAY OF CHAR; x: LONGINT); - VAR ch: CHAR; i: INTEGER; - BEGIN ch := s[0]; i := 0; - WHILE ch # 0X DO - IF ch = "#" THEN OPM.WriteInt(x) - ELSE OPM.Write(ch); - END ; - INC(i); ch := s[i] - END - END Str1; - - PROCEDURE Length(VAR s: ARRAY OF CHAR): INTEGER; - VAR i: INTEGER; - BEGIN i := 0; - WHILE s[i] # 0X DO INC(i) END ; - RETURN i - END Length; - - PROCEDURE PerfectHash (VAR s: ARRAY OF CHAR): INTEGER; - VAR i, h: INTEGER; - BEGIN i := 0; h := 0; - WHILE (s[i] # 0X) & (i < 5) DO h := 3*h + ORD(s[i]); INC(i) END; - RETURN h MOD 105 - END PerfectHash; - - PROCEDURE Ident* (obj: OPT.Object); - VAR mode, level, h: INTEGER; - BEGIN - mode := obj^.mode; level := obj^.mnolev; - IF (mode IN {Var, Typ, LProc}) & (level > 0) OR (mode IN {Fld, VarPar}) THEN - OPM.WriteStringVar(obj^.name); - h := PerfectHash(obj^.name); - IF hashtab[h] >= 0 THEN - IF keytab[hashtab[h]] = obj^.name THEN OPM.Write(Underscore) END - END - ELSE - IF (mode # Typ) OR (obj^.linkadr # PredefinedType) THEN - IF mode = TProc THEN Ident(obj^.link^.typ^.strobj) - ELSIF level < 0 THEN (* use unaliased module name *) - OPM.WriteStringVar(OPT.GlbMod[-level].name); - IF OPM.currFile = OPM.HeaderFile THEN OPT.GlbMod[-level].vis := 1 (*include in header file*) END ; - ELSE OPM.WriteStringVar(OPM.modName) - END ; - OPM.Write(Underscore) - ELSIF (obj = OPT.sysptrtyp^.strobj) OR (obj = OPT.bytetyp^.strobj) (*OR (obj = OPT.int8typ^.strobj) OR (obj = OPT.int16typ^.strobj) OR (obj = OPT.int32typ^.strobj) OR (obj = OPT.int64typ^.strobj)*) THEN - OPM.WriteString("SYSTEM_") - - END ; - OPM.WriteStringVar(obj^.name) - END - END Ident; - - PROCEDURE Stars (typ: OPT.Struct; VAR openClause: BOOLEAN); - VAR pointers: INTEGER; - BEGIN - openClause := FALSE; - IF ((typ^.strobj = NIL) OR (typ^.strobj^.name = "")) & (typ^.comp # Record) THEN - IF typ^.comp IN {Array, DynArr} THEN - Stars (typ^.BaseTyp, openClause); - openClause := (typ^.comp = Array) - ELSIF typ^.form = ProcTyp THEN - OPM.Write(OpenParen); OPM.Write(Star) - ELSE - pointers := 0; - (*WHILE (typ^.strobj = NIL) & (typ^.form = Pointer) DO INC (pointers); typ := typ^.BaseTyp END ; - IF (typ^.comp # DynArr) & (pointers # 0) THEN Stars (typ, openClause) END ;*) - WHILE ((typ^.strobj = NIL) OR (typ^.strobj^.name = "")) & (typ^.form = Pointer) DO - INC (pointers); typ := typ^.BaseTyp - END ; - IF pointers > 0 THEN - IF typ^.comp # DynArr THEN Stars (typ, openClause) END ; - IF openClause THEN OPM.Write(OpenParen); openClause := FALSE END ; - WHILE pointers > 0 DO OPM.Write(Star); DEC (pointers) END - END - END - END - END Stars; - - PROCEDURE ^AnsiParamList (obj: OPT.Object; showParamNames: BOOLEAN); - - PROCEDURE DeclareObj(dcl: OPT.Object; scopeDef: BOOLEAN); - VAR - typ: OPT.Struct; - varPar, openClause: BOOLEAN; form, comp: INTEGER; - BEGIN - typ := dcl^.typ; - varPar := ((dcl^.mode = VarPar) & (typ^.comp # Array)) OR (typ^.comp = DynArr) OR scopeDef; - Stars(typ, openClause); - IF varPar THEN - IF openClause THEN OPM.Write(OpenParen) END ; - OPM.Write(Star) - END ; - IF dcl.name # "" THEN Ident(dcl) END ; - IF varPar & openClause THEN OPM.Write(CloseParen) END ; - openClause := FALSE; - LOOP - form := typ^.form; - comp := typ^.comp; - IF ((typ^.strobj # NIL) & (typ^.strobj^.name # "")) OR (form = NoTyp) OR (comp = Record) THEN EXIT - ELSIF (form = Pointer) & (typ^.BaseTyp^.comp # DynArr) THEN - openClause := TRUE - ELSIF (form = ProcTyp) OR (comp IN {Array, DynArr}) THEN - IF openClause THEN OPM.Write(CloseParen); openClause := FALSE END ; - IF form = ProcTyp THEN - IF ansi THEN OPM.Write(")"); AnsiParamList(typ^.link, FALSE) - ELSE OPM.WriteString(")()") - END ; - EXIT - ELSIF comp = Array THEN - OPM.Write(OpenBracket); OPM.WriteInt(typ^.n); OPM.Write(CloseBracket) - END - ELSE - EXIT - END ; - typ := typ^.BaseTyp - END - END DeclareObj; - - PROCEDURE Andent*(typ: OPT.Struct); (* ident of possibly anonymous record type *) - BEGIN - IF (typ^.strobj = NIL) OR (typ^.align >= 10000H) THEN - OPM.WriteStringVar(OPM.modName); Str1("__#", typ^.align DIV 10000H) - ELSE Ident(typ^.strobj) - END - END Andent; - - PROCEDURE Undefined(obj: OPT.Object): BOOLEAN; - BEGIN - (* imported anonymous types have obj^.name = ""; used e.g. for repeating inherited fields *) - RETURN (obj^.mnolev >= 0) & (obj^.linkadr # 3+OPM.currFile ) & (obj^.linkadr # PredefinedType) OR (obj^.name = "") - END Undefined; - - PROCEDURE ^FieldList (typ: OPT.Struct; last: BOOLEAN; VAR off, n, curAlign: LONGINT); - - PROCEDURE DeclareBase(dcl: OPT.Object); (* declare the specifier of object dcl*) - VAR typ, prev: OPT.Struct; obj: OPT.Object; nofdims: INTEGER; off, n, dummy: LONGINT; - BEGIN - typ := dcl^.typ; prev := typ; - WHILE ((typ^.strobj = NIL) OR (typ^.comp = DynArr) OR Undefined(typ^.strobj)) & (typ^.comp # Record) & (typ^.form # NoTyp) - & ~((typ^.form = Pointer) & (typ^.BaseTyp^.comp = DynArr)) DO - prev := typ; typ := typ^.BaseTyp - END ; - obj := typ^.strobj; - IF typ^.form = NoTyp THEN (* proper procedure *) - OPM.WriteString(VoidType) - ELSIF (obj # NIL) & ~Undefined(obj) THEN (* named type, already declared *) - Ident(obj) - ELSIF typ^.comp = Record THEN - OPM.WriteString(Struct); Andent(typ); - IF (prev.form # Pointer) & ((obj # NIL) OR (dcl.name = "")) THEN - (* named record type not yet declared OR anonymous record with empty name *) - IF (typ^.BaseTyp # NIL) & (typ^.BaseTyp^.strobj.vis # internal) THEN - OPM.WriteString(" { /* "); Ident(typ^.BaseTyp^.strobj); OPM.WriteString(" */"); OPM.WriteLn; Indent(1) - ELSE OPM.Write(Blank); BegBlk - END ; - FieldList(typ, TRUE, off, n, dummy); - EndBlk0 - END - ELSIF (typ^.form = Pointer) & (typ^.BaseTyp^.comp = DynArr) THEN - typ := typ^.BaseTyp^.BaseTyp; nofdims := 1; - WHILE typ^.comp = DynArr DO INC(nofdims); typ := typ^.BaseTyp END ; - OPM.WriteString(Struct); BegBlk; - BegStat; Str1("LONGINT len[#]", nofdims); EndStat; - BegStat; NEW(obj); NEW(obj.typ); (* aux. object for easy declaration *) - obj.typ.form := Comp; obj.typ.comp := Array; obj.typ.n := 1; obj.typ.BaseTyp := typ; obj.mode := Fld; obj.name := "data"; - obj.linkadr := UndefinedType; DeclareBase(obj); OPM.Write(Blank); DeclareObj(obj, FALSE); - EndStat; EndBlk0 - END - END DeclareBase; - - PROCEDURE NofPtrs* (typ: OPT.Struct): LONGINT; - VAR fld: OPT.Object; btyp: OPT.Struct; n: LONGINT; - BEGIN - IF (typ^.form = Pointer) & (typ^.sysflag = 0) THEN RETURN 1 - ELSIF (typ^.comp = Record) & (typ^.sysflag MOD 100H = 0) THEN - btyp := typ^.BaseTyp; - IF btyp # NIL THEN n := NofPtrs(btyp) ELSE n := 0 END ; - fld := typ^.link; - WHILE (fld # NIL) & (fld^.mode = Fld) DO - IF fld^.name # OPM.HdPtrName THEN n := n + NofPtrs(fld^.typ) - ELSE INC(n) - END ; - fld := fld^.link - END ; - RETURN n - ELSIF typ^.comp = Array THEN - btyp := typ^.BaseTyp; n := typ^.n; - WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; - RETURN NofPtrs(btyp) * n - ELSE RETURN 0 - END - END NofPtrs; - - PROCEDURE PutPtrOffsets (typ: OPT.Struct; adr: LONGINT; VAR cnt: LONGINT); - VAR fld: OPT.Object; btyp: OPT.Struct; n, i: LONGINT; - BEGIN - IF (typ^.form = Pointer) & (typ^.sysflag = 0) THEN - OPM.WriteInt(adr); OPM.WriteString(", "); INC(cnt); - IF cnt MOD 16 = 0 THEN OPM.WriteLn; OPM.Write(Tab) END - ELSIF (typ^.comp = Record) & (typ^.sysflag MOD 100H = 0) THEN - btyp := typ^.BaseTyp; - IF btyp # NIL THEN PutPtrOffsets(btyp, adr, cnt) END ; - fld := typ^.link; - WHILE (fld # NIL) & (fld^.mode = Fld) DO - IF fld^.name # OPM.HdPtrName THEN PutPtrOffsets(fld^.typ, adr + fld^.adr, cnt) - ELSE - OPM.WriteInt(adr + fld^.adr); OPM.WriteString(", "); INC(cnt); - IF cnt MOD 16 = 0 THEN OPM.WriteLn; OPM.Write(Tab) END - END ; - fld := fld^.link - END - ELSIF typ^.comp = Array THEN - btyp := typ^.BaseTyp; n := typ^.n; - WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; - IF NofPtrs(btyp) > 0 THEN i := 0; - WHILE i < n DO PutPtrOffsets(btyp, adr + i * btyp^.size, cnt); INC(i) END - END - END - END PutPtrOffsets; - - PROCEDURE InitTProcs(typ, obj: OPT.Object); - BEGIN - IF obj # NIL THEN - InitTProcs(typ, obj^.left); - IF obj^.mode = TProc THEN - BegStat; - OPM.WriteString("__INITBP("); - Ident(typ); OPM.WriteString(Comma); Ident(obj); - Str1(", #)", obj^.adr DIV 10000H); - EndStat - END ; - InitTProcs(typ, obj^.right) - END - END InitTProcs; - - PROCEDURE PutBase(typ: OPT.Struct); - BEGIN - IF typ # NIL THEN - PutBase(typ^.BaseTyp); - Ident(typ^.strobj); OPM.WriteString(DynTypExt); OPM.WriteString(", ") - END - END PutBase; - - PROCEDURE LenList(par: OPT.Object; ansiDefine, showParamName: BOOLEAN); - VAR typ: OPT.Struct; dim: INTEGER; - BEGIN - IF showParamName THEN Ident(par); OPM.WriteString(LenExt) END ; - dim := 1; typ := par^.typ^.BaseTyp; - WHILE typ^.comp = DynArr DO - IF ansiDefine THEN OPM.WriteString(", LONGINT ") ELSE OPM.WriteString(Comma) END ; - IF showParamName THEN Ident(par); OPM.WriteString(LenExt); OPM.WriteInt(dim) END ; - typ := typ^.BaseTyp; INC(dim) - END - END LenList; - - PROCEDURE DeclareParams(par: OPT.Object; macro: BOOLEAN); - BEGIN - OPM.Write(OpenParen); - WHILE par # NIL DO - IF macro THEN OPM.WriteStringVar(par.name) - ELSE - IF (par^.mode = Var) & (par^.typ^.form = Real) THEN OPM.Write("_") END ; - Ident(par) - END ; - IF par^.typ^.comp = DynArr THEN - OPM.WriteString(Comma); LenList(par, FALSE, TRUE); - ELSIF (par^.mode = VarPar) & (par^.typ^.comp = Record) THEN - OPM.WriteString(Comma); OPM.WriteStringVar(par.name); OPM.WriteString(TagExt) - END ; - par := par^.link; - IF par # NIL THEN OPM.WriteString(Comma) END - END ; - OPM.Write(CloseParen) - END DeclareParams; - - PROCEDURE ^DefineType(str: OPT.Struct); - PROCEDURE ^ProcHeader(proc: OPT.Object; define: BOOLEAN); - - PROCEDURE DefineTProcTypes(obj: OPT.Object); (* define all types that are used in a TProc definition *) - VAR par: OPT.Object; - BEGIN - IF obj^.typ # OPT.notyp THEN DefineType(obj^.typ) END ; - IF ansi THEN par := obj^.link; - WHILE par # NIL DO DefineType(par^.typ); par := par^.link END - END - END DefineTProcTypes; - - PROCEDURE DeclareTProcs(obj: OPT.Object; VAR empty: BOOLEAN); - BEGIN - IF obj # NIL THEN - DeclareTProcs(obj^.left, empty); - IF obj^.mode = TProc THEN - IF obj^.typ # OPT.notyp THEN DefineType(obj^.typ) END ; - IF OPM.currFile = OPM.HeaderFile THEN - IF obj^.vis = external THEN - DefineTProcTypes(obj); - OPM.WriteString(Extern); empty := FALSE; - ProcHeader(obj, FALSE) - END - ELSE empty := FALSE; - DefineTProcTypes(obj); - IF obj^.vis = internal THEN OPM.WriteString(Static) - ELSE OPM.WriteString(Export) - END ; - ProcHeader(obj, FALSE) - END - END ; - DeclareTProcs(obj^.right, empty) - END - END DeclareTProcs; - - PROCEDURE BaseTProc*(obj: OPT.Object): OPT.Object; - VAR typ, base: OPT.Struct; mno: LONGINT; - BEGIN typ := obj^.link^.typ; (* receiver type *) - IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ; - base := typ^.BaseTyp; mno := obj^.adr DIV 10000H; - WHILE (base # NIL) & (mno < base^.n) DO typ := base; base := typ^.BaseTyp END ; - OPT.FindField(obj^.name, typ, obj); - RETURN obj - END BaseTProc; - - PROCEDURE DefineTProcMacros(obj: OPT.Object; VAR empty: BOOLEAN); - BEGIN - IF obj # NIL THEN - DefineTProcMacros(obj^.left, empty); - IF (obj^.mode = TProc) & (obj = BaseTProc(obj)) & ((OPM.currFile # OPM.HeaderFile) OR (obj^.vis = external)) THEN - OPM.WriteString("#define __"); - Ident(obj); - DeclareParams(obj^.link, TRUE); - OPM.WriteString(" __SEND("); - IF obj^.link^.typ^.form = Pointer THEN - OPM.WriteString("__TYPEOF("); Ident(obj^.link); OPM.Write(")") - ELSE Ident(obj^.link); OPM.WriteString(TagExt) - END ; - Str1(", #, ", obj^.adr DIV 10000H); - IF obj^.typ = OPT.notyp THEN OPM.WriteString(VoidType) ELSE Ident(obj^.typ^.strobj) END ; - OPM.WriteString("(*)"); - IF ansi THEN - AnsiParamList(obj^.link, FALSE); - ELSE - OPM.WriteString("()"); - END ; - OPM.WriteString(", "); - DeclareParams(obj^.link, TRUE); - OPM.Write(")"); OPM.WriteLn - END ; - DefineTProcMacros(obj^.right, empty) - END - END DefineTProcMacros; - - PROCEDURE DefineType(str: OPT.Struct); (* define a type object *) - VAR obj, field, par: OPT.Object; empty: BOOLEAN; - BEGIN - IF (OPM.currFile = OPM.BodyFile) OR (str^.ref < OPM.MaxStruct (*for hidden exports*) ) THEN - obj := str^.strobj; - IF (obj = NIL) OR Undefined(obj) THEN - IF obj # NIL THEN (* check for cycles *) - IF obj^.linkadr = ProcessingType THEN - IF str^.form # Pointer THEN OPM.Mark(244, str^.txtpos); obj^.linkadr := PredefinedType END - ELSE obj^.linkadr := ProcessingType - END - END ; - IF str^.comp = Record THEN - (* the following exports the base type of an exported type even if the former is non-exported *) - IF str^.BaseTyp # NIL THEN DefineType(str^.BaseTyp) END ; - field := str^.link; - WHILE (field # NIL) & (field^.mode = Fld) DO - IF (field^.vis # internal) OR (OPM.currFile = OPM.BodyFile) THEN DefineType(field^.typ) END ; - field := field^.link - END - ELSIF str^.form = Pointer THEN - IF str^.BaseTyp^.comp # Record THEN DefineType(str^.BaseTyp) END - ELSIF str^.comp IN {Array, DynArr} THEN - DefineType(str^.BaseTyp) - ELSIF str^.form = ProcTyp THEN - IF str^.BaseTyp # OPT.notyp THEN DefineType(str^.BaseTyp) END ; - field := str^.link; - WHILE field # NIL DO DefineType(field^.typ); field := field^.link END - END - END ; - IF (obj # NIL) & Undefined(obj) THEN - OPM.WriteString("typedef"); OPM.WriteLn; OPM.Write(Tab); Indent(1); - obj^.linkadr := ProcessingType; - DeclareBase(obj); OPM.Write(Blank); - obj^.typ^.strobj := NIL; (* SG: trick to make DeclareObj declare the type *) - DeclareObj(obj, FALSE); - obj^.typ^.strobj := obj; (* SG: revert trick *) - obj^.linkadr := 3+OPM.currFile; - EndStat; Indent(-1); OPM.WriteLn; - IF obj^.typ^.comp = Record THEN empty := TRUE; - DeclareTProcs(str^.link, empty); DefineTProcMacros(str^.link, empty); - IF ~empty THEN OPM.WriteLn END - END - END - END - END DefineType; - - PROCEDURE Prefixed(x: OPT.ConstExt; y: ARRAY OF CHAR): BOOLEAN; - VAR i: INTEGER; r: BOOLEAN; - BEGIN i := 0; - WHILE x[i+1] = y[i] DO INC(i) END ; - r := y[i] = 0X; - RETURN r; - END Prefixed; - - PROCEDURE CProcDefs(obj: OPT.Object; vis: INTEGER); - VAR i: INTEGER; ext: OPT.ConstExt; - BEGIN - IF obj # NIL THEN - CProcDefs(obj^.left, vis); - (* bug: obj.history cannot be used to cover unexported and deleted CProcs; use special flag obj.adr = 1 *) - IF (obj^.mode = CProc) & (obj^.vis >= vis) & (obj^.adr = 1) THEN - ext := obj.conval.ext; i := 1; - IF (ext[1] # "#") & ~(Prefixed(ext, "extern ") OR Prefixed(ext, Extern)) THEN - OPM.WriteString("#define "); Ident(obj); - DeclareParams(obj^.link, TRUE); - OPM.Write(Tab); - END ; - FOR i := i TO ORD(obj.conval.ext[0]) DO OPM.Write(obj.conval.ext[i]) END; - OPM.WriteLn - END ; - CProcDefs(obj^.right, vis) - END - END CProcDefs; - - PROCEDURE TypeDefs* (obj: OPT.Object; vis(*replaced by test on currFile in DefineType*): INTEGER); - BEGIN - IF obj # NIL THEN - TypeDefs(obj^.left, vis); - (* test typ.txtpos to skip types that have been unexported; obj.history # removed is not enough!*) - IF (obj^.mode = Typ) & (obj^.typ^.txtpos > 0) THEN DefineType(obj^.typ) END ; - TypeDefs(obj^.right, vis) - END - END TypeDefs; - - PROCEDURE DefAnonRecs(n: OPT.Node); - VAR o: OPT.Object; typ: OPT.Struct; - BEGIN - WHILE (n # NIL) & (n^.class = Ninittd) DO - typ := n^.typ; - IF (typ^.strobj = NIL) & ((OPM.currFile = OPM.BodyFile) OR (typ.ref < OPM.MaxStruct)) THEN - DefineType(typ); (* declare base and field types, if any *) - NEW(o); o.typ := typ; o.name := ""; DeclareBase(o); EndStat; OPM.WriteLn - (* simply defines a named struct, but not a type; - o.name = "" signals field list expansion for DeclareBase in this very special case *) - END ; - n := n^.link - END - END DefAnonRecs; - - PROCEDURE TDescDecl* (typ: OPT.Struct); - VAR nofptrs: LONGINT; - o: OPT.Object; - BEGIN - BegStat; OPM.WriteString("__TDESC("); - Andent(typ); - Str1(", #", typ^.n + 1); Str1(", #) = {__TDFLDS(", NofPtrs(typ)); - OPM.Write('"'); - IF typ^.strobj # NIL THEN OPM.WriteStringVar(typ^.strobj^.name) END ; - Str1('", #), {', typ^.size); - nofptrs := 0; PutPtrOffsets(typ, 0, nofptrs); Str1("#}}", -(nofptrs + 1) * OPM.LIntSize); - EndStat - END TDescDecl; - - PROCEDURE InitTDesc*(typ: OPT.Struct); - BEGIN - BegStat; OPM.WriteString("__INITYP("); - Andent(typ); OPM.WriteString(", "); - IF typ^.BaseTyp # NIL THEN Andent(typ^.BaseTyp) ELSE Andent(typ) END ; - Str1(", #)", typ^.extlev); - EndStat; - IF typ^.strobj # NIL THEN InitTProcs(typ^.strobj, typ^.link) END - END InitTDesc; - - PROCEDURE Align*(VAR adr: LONGINT; base: LONGINT); - BEGIN - CASE base OF - | 2: INC(adr, adr MOD 2) - | 4: INC(adr, (-adr) MOD 4) - | 8: INC(adr, (-adr) MOD 8) - |16: INC(adr, (-adr) MOD 16) - ELSE (*1*) - (*OPM.LogWStr("unhandled case at OPC.Align, base = "); OPM.LogWNum(base, 0); OPM.LogWLn;*) - END - END Align; - - PROCEDURE Base*(typ: OPT.Struct): LONGINT; - BEGIN - CASE typ^.form OF - | Byte: RETURN 1 - | Char: RETURN OPM.CharAlign - | Bool: RETURN OPM.BoolAlign - | SInt: RETURN OPM.SIntAlign - | Int: RETURN OPM.IntAlign - | LInt: RETURN OPM.LIntAlign - (* | Int8: RETURN OPM.Int8Align - | Int16: RETURN OPM.Int16Align - | Int32: RETURN OPM.Int32Align - | Int64: RETURN OPM.Int64Align*) - | Real: RETURN OPM.RealAlign - | LReal: RETURN OPM.LRealAlign - | Set: RETURN OPM.SetAlign - | Pointer: RETURN OPM.PointerAlign - | ProcTyp: RETURN OPM.ProcAlign - | Comp: - IF typ^.comp = Record THEN RETURN typ^.align MOD 10000H - ELSE RETURN Base(typ^.BaseTyp) - END - ELSE OPM.LogWStr("unhandled case in OPC.Base, typ^form = "); OPM.LogWNum(typ^.form, 0); OPM.LogWLn; - END - END Base; - - PROCEDURE FillGap(gap, off, align: LONGINT; VAR n, curAlign: LONGINT); - VAR adr: LONGINT; - BEGIN - adr := off; Align(adr, align); - IF (curAlign < align) & (gap - (adr - off) >= align) THEN (* preserve alignment of the enclosing struct! *) - DEC(gap, (adr - off) + align); - BegStat; - IF align = OPM.IntSize THEN OPM.WriteString("INTEGER") - ELSIF align = OPM.LIntSize THEN OPM.WriteString("LONGINT") - ELSIF align = OPM.LRealSize THEN OPM.WriteString("LONGREAL") - END ; - Str1(" _prvt#", n); INC(n); EndStat; - curAlign := align - END ; - IF gap > 0 THEN BegStat; Str1("char _prvt#", n); INC(n); Str1("[#]", gap); EndStat END - END FillGap; - - PROCEDURE FieldList (typ: OPT.Struct; last: BOOLEAN; VAR off, n, curAlign: LONGINT); - VAR fld: OPT.Object; base: OPT.Struct; gap, adr, align, fldAlign: LONGINT; - BEGIN - fld := typ.link; align := typ^.align MOD 10000H; - IF typ.BaseTyp # NIL THEN FieldList(typ.BaseTyp, FALSE, off, n, curAlign) - ELSE off := 0; n := 0; curAlign := 1 - END ; - WHILE (fld # NIL) & (fld.mode = Fld) DO - IF (OPM.currFile = OPM.HeaderFile) & (fld.vis = internal) OR - (OPM.currFile = OPM.BodyFile) & (fld.vis = internal) & (typ^.mno # 0) THEN - fld := fld.link; - WHILE (fld # NIL) & (fld.mode = Fld) & (fld.vis = internal) DO fld := fld.link END ; - ELSE - (* mimic OPV.TypSize to detect gaps caused by private fields *) - adr := off; fldAlign := Base(fld^.typ); Align(adr, fldAlign); - gap := fld.adr - adr; - IF fldAlign > curAlign THEN curAlign := fldAlign END ; - IF gap > 0 THEN FillGap(gap, off, align, n, curAlign) END ; - BegStat; DeclareBase(fld); OPM.Write(Blank); DeclareObj(fld, FALSE); - off := fld.adr + fld.typ.size; base := fld.typ; fld := fld.link; - WHILE (fld # NIL) & (fld.mode = Fld) & (fld.typ = base) & (fld.adr = off) -(* ?? *) & ((OPM.currFile = OPM.BodyFile) OR (fld.vis # internal) OR (fld.typ.strobj = NIL)) DO - OPM.WriteString(", "); DeclareObj(fld, FALSE); off := fld.adr + fld.typ.size; fld := fld.link - END ; - EndStat - END - END ; - IF last THEN - adr := typ.size - typ^.sysflag DIV 100H; - IF adr = 0 THEN gap := 1 (* avoid empty struct *) ELSE gap := adr - off END ; - IF gap > 0 THEN FillGap(gap, off, align, n, curAlign) END - END - END FieldList; - - PROCEDURE IdentList (obj: OPT.Object; vis: INTEGER); - (* generate var and param lists; vis: 0 all global vars, local var, 1 exported(R) var, 2 par list, 3 scope var *) - VAR base: OPT.Struct; first: BOOLEAN; lastvis: INTEGER; - BEGIN - base := NIL; first := TRUE; - WHILE (obj # NIL) & (obj^.mode # TProc) DO - IF (vis IN {0, 2}) OR ((vis = 1) & (obj^.vis # 0)) OR ((vis = 3) & ~obj^.leaf) THEN - IF (obj^.typ # base) OR (obj^.vis # lastvis) THEN (* new variable base type definition required *) - IF ~first THEN EndStat END ; - first := FALSE; - base := obj^.typ; lastvis := obj^.vis; - BegStat; - IF (vis = 1) & (obj^.vis # internal) THEN OPM.WriteString(Extern) - ELSIF (obj^.mnolev = 0) & (vis = 0) THEN - IF obj^.vis = internal THEN OPM.WriteString(Static) - ELSE OPM.WriteString(Export) - END - END ; - IF (vis = 2) & (obj^.mode = Var) & (base^.form = Real) THEN OPM.WriteString("double") - ELSE DeclareBase(obj) - END - ELSE OPM.Write(","); - END ; - OPM.Write(Blank); - IF (vis = 2) & (obj^.mode = Var) & (base^.form = Real) THEN OPM.Write("_") END ; - DeclareObj(obj, vis = 3); - IF obj^.typ^.comp = DynArr THEN (* declare len parameter(s) *) - EndStat; BegStat; - base := OPT.linttyp; - OPM.WriteString("LONGINT "); LenList(obj, FALSE, TRUE) - ELSIF (obj^.mode = VarPar) & (obj^.typ^.comp = Record) THEN - EndStat; BegStat; - OPM.WriteString("LONGINT *"); Ident(obj); OPM.WriteString(TagExt); - base := NIL - ELSIF ptrinit & (vis = 0) & (obj^.mnolev > 0) & (obj^.typ^.form = Pointer) THEN - OPM.WriteString(" = NIL") - END - END ; - obj := obj^.link - END ; - IF ~first THEN EndStat END - END IdentList; - - PROCEDURE AnsiParamList (obj: OPT.Object; showParamNames: BOOLEAN); - VAR name: ARRAY 32 OF CHAR; - BEGIN - OPM.Write("("); - IF (obj = NIL) OR (obj^.mode = TProc) THEN OPM.WriteString("void") - ELSE - LOOP - DeclareBase(obj); - IF showParamNames THEN - OPM.Write(Blank); DeclareObj(obj, FALSE) - ELSE - COPY(obj^.name, name); obj^.name := ""; DeclareObj(obj, FALSE); COPY(name, obj^.name) - END ; - IF obj^.typ^.comp = DynArr THEN - OPM.WriteString(", LONGINT "); - LenList(obj, TRUE, showParamNames) - ELSIF (obj^.mode = VarPar) & (obj^.typ^.comp = Record) THEN - OPM.WriteString(", LONGINT *"); - IF showParamNames THEN Ident(obj); OPM.WriteString(TagExt) END - END ; - IF (obj^.link = NIL) OR (obj^.link.mode = TProc) THEN EXIT END ; - OPM.WriteString(", "); - obj := obj^.link - END - END ; - OPM.Write(")") - END AnsiParamList; - - PROCEDURE ProcHeader(proc: OPT.Object; define: BOOLEAN); - BEGIN - IF proc^.typ = OPT.notyp THEN OPM.WriteString(VoidType) ELSE Ident(proc^.typ^.strobj) END ; - OPM.Write(Blank); Ident(proc); OPM.Write(Blank); - IF ansi THEN - AnsiParamList(proc^.link, TRUE); - IF ~define THEN OPM.Write(";") END ; - OPM.WriteLn; - ELSIF define THEN - DeclareParams(proc^.link, FALSE); - OPM.WriteLn; - Indent(1); IdentList(proc^.link, 2(* map REAL to double *)); Indent(-1) - ELSE OPM.WriteString("();"); OPM.WriteLn - END - END ProcHeader; - - PROCEDURE ProcPredefs (obj: OPT.Object; vis: SHORTINT); (* forward declaration of procedures *) - BEGIN - IF obj # NIL THEN - ProcPredefs(obj^.left, vis); - IF (obj^.mode IN {LProc, XProc}) & (obj^.vis >= vis) & ((obj^.history # removed) OR (obj^.mode = LProc)) THEN - (* previous XProc may be deleted or become LProc after interface change*) - IF vis = external THEN OPM.WriteString(Extern) - ELSIF obj^.vis = internal THEN OPM.WriteString(Static) - ELSE OPM.WriteString(Export) - END ; - ProcHeader(obj, FALSE); - END ; - ProcPredefs(obj^.right, vis); - END; - END ProcPredefs; - - PROCEDURE Include(name: ARRAY OF CHAR); - BEGIN - OPM.WriteString("#include "); OPM.Write(Quotes); OPM.WriteStringVar(name); - OPM.WriteString(".h"); OPM.Write(Quotes); OPM.WriteLn - END Include; - - PROCEDURE IncludeImports(obj: OPT.Object; vis: INTEGER); - BEGIN - IF obj # NIL THEN - IncludeImports(obj^.left, vis); - IF (obj^.mode = Mod) & (obj^.mnolev # 0) & (OPT.GlbMod[-obj^.mnolev].vis >= vis) THEN (* @self and SYSTEM have mnolev = 0 *) - Include(OPT.GlbMod[-obj^.mnolev].name) (* use unaliased module name *) - END; - IncludeImports(obj^.right, vis); - END; - END IncludeImports; - - PROCEDURE GenDynTypes (n: OPT.Node; vis: INTEGER); - VAR typ: OPT.Struct; - BEGIN - WHILE (n # NIL) & (n^.class = Ninittd) DO - typ := n^.typ; - IF (vis = internal) OR (typ^.ref < OPM.MaxStruct (*type needed in symbol file*)) THEN - BegStat; - IF vis = external THEN OPM.WriteString(Extern) - ELSIF (typ^.strobj # NIL) & (typ^.strobj^.mnolev > 0) THEN OPM.WriteString(Static) - ELSE OPM.WriteString(Export) - END ; - OPM.WriteString("LONGINT *"); Andent(typ); OPM.WriteString(DynTypExt); - EndStat - END ; - n := n^.link - END - END GenDynTypes; - - PROCEDURE GenHdr*(n: OPT.Node); - BEGIN - (* includes are delayed until it is known which ones are needed in the header *) - OPM.currFile := OPM.HeaderFile; - DefAnonRecs(n); - TypeDefs(OPT.topScope^.right, 1); OPM.WriteLn; - IdentList(OPT.topScope^.scope, 1); OPM.WriteLn; - GenDynTypes(n, external); OPM.WriteLn; - ProcPredefs(OPT.topScope^.right, 1); - OPM.WriteString(Extern); OPM.WriteString("void *"); - OPM.WriteStringVar(OPM.modName); OPM.WriteString(BodyNameExt); - EndStat; OPM.WriteLn; - CProcDefs(OPT.topScope^.right, 1); OPM.WriteLn; - OPM.WriteString("#endif"); OPM.WriteLn - END GenHdr; - - PROCEDURE GenHeaderMsg; - VAR i: INTEGER; - BEGIN - OPM.WriteString("/*"); OPM.WriteString(HeaderMsg); - OPM.Write(" "); OPM.WriteString(Configuration.versionLong); OPM.Write (" "); (* noch *) - FOR i := 0 TO MAX(SET) DO - IF i IN OPM.glbopt THEN - CASE i OF (* c.f. ScanOptions in OPM *) - | OPM.inxchk: OPM.Write("x") - | OPM.ranchk: OPM.Write("r") - | OPM.typchk: OPM.Write("t") - | OPM.newsf: OPM.Write("s") - | OPM.ptrinit: OPM.Write("p") - | OPM.ansi: OPM.Write("k") - | OPM.assert: OPM.Write("a") - | OPM.extsf: OPM.Write("e") - | OPM.mainprog: OPM.Write("m") - | OPM.dontasm: OPM.Write("S") - | OPM.dontlink: OPM.Write("c") - | OPM.mainlinkstat: OPM.Write("M") - | OPM.notcoloroutput: OPM.Write("f") - | OPM.forcenewsym: OPM.Write("F") - | OPM.verbose: OPM.Write("v") - ELSE - (* this else is necessary cause - if someone defined a new option in OPM module - and forgot to add it here then - if option is passed this will - generate __CASECHK and cause Halt, - noch *) - OPM.LogWStr ("( more options defined in OPM than checked in OPC.GenHeaderMsg, if you are a compiler developer, add them to OPC.GenHeaderMsg"); OPM.LogWLn; - END - END - END; - OPM.WriteString(" */"); OPM.WriteLn - END GenHeaderMsg; - - PROCEDURE GenHdrIncludes*; - BEGIN - OPM.currFile := OPM.HeaderInclude; - GenHeaderMsg; - OPM.WriteLn; - OPM.WriteString("#ifndef "); OPM.WriteStringVar(OPM.modName); OPM.WriteString(FlagExt); OPM.WriteLn; - OPM.WriteString("#define "); OPM.WriteStringVar(OPM.modName); OPM.WriteString(FlagExt); OPM.WriteLn; - OPM.WriteLn; - IF OPM.LIntSize = 8 THEN OPM.WriteString("#define LARGE"); OPM.WriteLn END; - Include(BasicIncludeFile); - IncludeImports(OPT.topScope^.right, 1); OPM.WriteLn - END GenHdrIncludes; - - PROCEDURE GenBdy*(n: OPT.Node); - BEGIN - OPM.currFile := OPM.BodyFile; - GenHeaderMsg; - IF OPM.LIntSize = 8 THEN OPM.WriteString("#define LARGE"); OPM.WriteLn END; - Include(BasicIncludeFile); - IncludeImports(OPT.topScope^.right, 0); OPM.WriteLn; - DefAnonRecs(n); - TypeDefs(OPT.topScope^.right, 0); OPM.WriteLn; - IdentList(OPT.topScope^.scope, 0); OPM.WriteLn; - GenDynTypes(n, internal); OPM.WriteLn; - ProcPredefs(OPT.topScope^.right, 0); OPM.WriteLn; - CProcDefs(OPT.topScope^.right, 0); OPM.WriteLn - END GenBdy; - - PROCEDURE RegCmds(obj: OPT.Object); - BEGIN - IF obj # NIL THEN - RegCmds(obj^.left); - IF (obj^.mode = XProc) & (obj^.history # removed) THEN - IF (obj^.vis # 0) & (obj^.link = NIL) & (obj^.typ = OPT.notyp) THEN (*command*) - BegStat; OPM.WriteString('__REGCMD("'); - OPM.WriteStringVar(obj.name); OPM.WriteString('", '); Ident(obj); OPM.Write(")"); EndStat - END - END ; - RegCmds(obj^.right) - END - END RegCmds; - - PROCEDURE InitImports(obj: OPT.Object); - BEGIN - IF obj # NIL THEN - InitImports(obj^.left); - IF (obj^.mode = Mod) & (obj^.mnolev # 0) THEN - BegStat; OPM.WriteString("__MODULE_IMPORT("); - OPM.WriteStringVar(OPT.GlbMod[-obj^.mnolev].name); - OPM.Write(CloseParen); EndStat - END ; - InitImports(obj^.right) - END - END InitImports; - - PROCEDURE GenEnumPtrs* (var: OPT.Object); - VAR typ: OPT.Struct; n: LONGINT; - BEGIN GlbPtrs := FALSE; - WHILE var # NIL DO - typ := var^.typ; - IF NofPtrs(typ) > 0 THEN - IF ~GlbPtrs THEN GlbPtrs := TRUE; - OPM.WriteString(Static); - IF ansi THEN - OPM.WriteString("void EnumPtrs(void (*P)(void*))") - ELSE - OPM.WriteString("void EnumPtrs(P)"); OPM.WriteLn; - OPM.Write(Tab); OPM.WriteString("void (*P)();"); - END ; - OPM.WriteLn; - BegBlk - END ; - BegStat; - IF typ^.form = Pointer THEN - OPM.WriteString("P("); Ident(var); OPM.Write(")"); - ELSIF typ^.comp = Record THEN - OPM.WriteString("__ENUMR(&"); Ident(var); OPM.WriteString(", "); - Andent(typ); OPM.WriteString(DynTypExt); Str1(", #", typ^.size); OPM.WriteString(", 1, P)") - ELSIF typ^.comp = Array THEN - n := typ^.n; typ := typ^.BaseTyp; - WHILE typ^.comp = Array DO n := n * typ^.n; typ := typ^.BaseTyp END ; - IF typ^.form = Pointer THEN - OPM.WriteString("__ENUMP("); Ident(var); Str1(", #, P)", n) - ELSIF typ^.comp = Record THEN - OPM.WriteString("__ENUMR("); Ident(var); OPM.WriteString(", "); - Andent(typ); OPM.WriteString(DynTypExt); Str1(", #", typ^.size); Str1(", #, P)", n) - END - END ; - EndStat - END ; - var := var^.link - END ; - IF GlbPtrs THEN - EndBlk; OPM.WriteLn - END - END GenEnumPtrs; - - PROCEDURE EnterBody*; - BEGIN - OPM.WriteLn; OPM.WriteString(Export); - IF mainprog THEN - IF ansi THEN - OPM.WriteString("int main(int argc, char **argv)"); OPM.WriteLn; - ELSE - OPM.WriteString("main(argc, argv)"); OPM.WriteLn; - OPM.Write(Tab); OPM.WriteString("int argc; char **argv;"); OPM.WriteLn - END - ELSE - OPM.WriteString("void *"); - OPM.WriteString(OPM.modName); OPM.WriteString(BodyNameExt); OPM.WriteLn; - END ; - BegBlk; BegStat; - IF mainprog THEN OPM.WriteString("__INIT(argc, argv)") ELSE OPM.WriteString("__DEFMOD") END ; - EndStat; - IF mainprog & demoVersion THEN BegStat; - OPM.WriteString('/*don`t do it!*/ printf("DEMO VERSION: DO NOT USE THIS PROGRAM FOR ANY COMMERCIAL PURPOSE\n")'); - EndStat - END ; - InitImports(OPT.topScope^.right); - BegStat; - IF mainprog THEN OPM.WriteString('__REGMAIN("') ELSE OPM.WriteString('__REGMOD("') END ; - OPM.WriteString(OPM.modName); - IF GlbPtrs THEN OPM.WriteString('", EnumPtrs)') ELSE OPM.WriteString('", 0)') END ; - EndStat; - IF OPM.modName # "SYSTEM" THEN RegCmds(OPT.topScope) END - END EnterBody; - - PROCEDURE ExitBody*; - BEGIN - BegStat; - IF mainprog THEN OPM.WriteString("__FINI;") ELSE OPM.WriteString("__ENDMOD;") END ; - OPM.WriteLn; EndBlk - END ExitBody; - - PROCEDURE DefineInter* (proc: OPT.Object); (* define intermediate scope record and variable *) - VAR scope: OPT.Object; - BEGIN - scope := proc^.scope; - OPM.WriteString(Static); OPM.WriteString(Struct); OPM.WriteStringVar(scope^.name); OPM.Write(Blank); - BegBlk; - IdentList(proc^.link, 3); (* parameters *) - IdentList(scope^.scope, 3); (* local variables *) - BegStat; (* scope link field declaration *) - OPM.WriteString(Struct); OPM.WriteStringVar (scope^.name); - OPM.Write(Blank); OPM.Write(Star); OPM.WriteString(LinkName); EndStat; - EndBlk0; OPM.Write(Blank); - OPM.Write(Star); OPM.WriteStringVar (scope^.name); OPM.WriteString(GlobalScope); EndStat; OPM.WriteLn; - ProcPredefs (scope^.right, 0); - OPM.WriteLn; - END DefineInter; - - PROCEDURE EnterProc* (proc: OPT.Object); - VAR var, scope: OPT.Object; typ: OPT.Struct; dim: INTEGER; - BEGIN - IF proc^.vis # external THEN OPM.WriteString(Static) END ; - ProcHeader(proc, TRUE); - BegBlk; - - (* If there will be a result, provide a result variable. *) - IF proc^.typ # OPT.notyp THEN - BegStat; + IMPORT OPT, OPM, Configuration, SYSTEM; + + + CONST demoVersion = FALSE; + + + CONST + UndefinedType = 0; (* named type not yet defined *) + ProcessingType = 1; (* pointer type is being processed *) + PredefinedType = 2; (* for all predefined types *) + + DefinedInHdr = 3+OPM.HeaderFile; (* named type has been defined in header file *) + DefinedInBdy = 3+OPM.BodyFile; (* named type has been defined in body file *) + + BasicIncludeFile = "SYSTEM"; + + Export = "export "; (* particularily introduced for VC++ declspec() *) + Extern = "import "; (* particularily introduced for VC++ declspec() *) + LocalScope = "_s"; (* name of a local intermediate scope (variable name) *) + GlobalScope = "_s"; (* pointer to current scope extension *) + LinkName = "lnk"; (* pointer to previous scope field *) + FlagExt = "__h"; + LenExt = "__len"; + DynTypExt = "__typ"; + TagExt = "__typ"; + Tab = 9X; + + (* The following are defined as hex to avoid confusing editor syntax highlighting *) + Backslash = 5CX; + DoubleQuote = 22X; + + + VAR + indentLevel: INTEGER; + ptrinit, mainprog, ansi: BOOLEAN; + hashtab: ARRAY 105 OF SHORTINT; + keytab: ARRAY 36, 9 OF CHAR; + GlbPtrs: BOOLEAN; + BodyNameExt: ARRAY 13 OF CHAR; + + + PROCEDURE Init*; + BEGIN + indentLevel := 0; + ptrinit := OPM.ptrinit IN OPM.opt; + (*mainprog := OPM.mainprog IN OPM.opt;*) + mainprog := OPM.mainProg OR OPM.mainLinkStat; + ansi := OPM.ansi IN OPM.opt; + IF ansi THEN BodyNameExt := "__init(void)" ELSE BodyNameExt := "__init()" END + END Init; + + PROCEDURE Indent* (count: INTEGER); + BEGIN INC(indentLevel, count) + END Indent; + + PROCEDURE BegStat*; + VAR i: INTEGER; + BEGIN i := indentLevel; + WHILE i > 0 DO OPM.Write(Tab); DEC (i) END + END BegStat; + + PROCEDURE EndStat*; + BEGIN OPM.Write(';'); OPM.WriteLn + END EndStat; + + PROCEDURE BegBlk*; + BEGIN OPM.Write('{'); OPM.WriteLn; INC(indentLevel) + END BegBlk; + + PROCEDURE EndBlk*; + BEGIN DEC(indentLevel); BegStat; OPM.Write('}'); OPM.WriteLn + END EndBlk; + + PROCEDURE EndBlk0*; + BEGIN DEC(indentLevel); BegStat; OPM.Write('}') + END EndBlk0; + + PROCEDURE Str1(s: ARRAY OF CHAR; x: LONGINT); + VAR ch: CHAR; i: INTEGER; + BEGIN ch := s[0]; i := 0; + WHILE ch # 0X DO + IF ch = "#" THEN OPM.WriteInt(x) + ELSE OPM.Write(ch); + END ; + INC(i); ch := s[i] + END + END Str1; + + PROCEDURE Length(VAR s: ARRAY OF CHAR): INTEGER; + VAR i: INTEGER; + BEGIN i := 0; + WHILE s[i] # 0X DO INC(i) END ; + RETURN i + END Length; + + PROCEDURE PerfectHash (VAR s: ARRAY OF CHAR): INTEGER; + VAR i, h: INTEGER; + BEGIN i := 0; h := 0; + WHILE (s[i] # 0X) & (i < 5) DO h := 3*h + ORD(s[i]); INC(i) END; + RETURN h MOD 105 + END PerfectHash; + + PROCEDURE Ident* (obj: OPT.Object); + VAR mode, level, h: INTEGER; + BEGIN + mode := obj^.mode; level := obj^.mnolev; + IF (mode IN {OPT.Var, OPT.Typ, OPT.LProc}) & (level > 0) OR (mode IN {OPT.Fld, OPT.VarPar}) THEN + OPM.WriteStringVar(obj^.name); + h := PerfectHash(obj^.name); + IF hashtab[h] >= 0 THEN + IF keytab[hashtab[h]] = obj^.name THEN OPM.Write('_') END + END + ELSE + IF (mode # OPT.Typ) OR (obj^.linkadr # PredefinedType) THEN + IF mode = OPT.TProc THEN Ident(obj^.link^.typ^.strobj) + ELSIF level < 0 THEN (* use unaliased module name *) + OPM.WriteStringVar(OPT.GlbMod[-level].name); + IF OPM.currFile = OPM.HeaderFile THEN OPT.GlbMod[-level].vis := 1 (*include in header file*) END ; + ELSE OPM.WriteStringVar(OPM.modName) + END ; + OPM.Write('_') + ELSIF (obj = OPT.sysptrtyp^.strobj) + OR (obj = OPT.bytetyp^.strobj) THEN + OPM.WriteString("SYSTEM_") + END; + OPM.WriteStringVar(obj^.name); + END + END Ident; + + PROCEDURE Stars (typ: OPT.Struct; VAR openClause: BOOLEAN); + VAR pointers: INTEGER; + BEGIN + openClause := FALSE; + IF ((typ^.strobj = NIL) OR (typ^.strobj^.name = "")) & (typ^.comp # OPT.Record) THEN + IF typ^.comp IN {OPT.Array, OPT.DynArr} THEN + Stars (typ^.BaseTyp, openClause); + openClause := (typ^.comp = OPT.Array) + ELSIF typ^.form = OPT.ProcTyp THEN + OPM.Write('('); OPM.Write('*') + ELSE + pointers := 0; + (*WHILE (typ^.strobj = NIL) & (typ^.form = OPT.Pointer) DO INC (pointers); typ := typ^.BaseTyp END ; + IF (typ^.comp # OPT.DynArr) & (pointers # 0) THEN Stars (typ, openClause) END ;*) + WHILE ((typ^.strobj = NIL) OR (typ^.strobj^.name = "")) & (typ^.form = OPT.Pointer) DO + INC (pointers); typ := typ^.BaseTyp + END ; + IF pointers > 0 THEN + IF typ^.comp # OPT.DynArr THEN Stars (typ, openClause) END ; + IF openClause THEN OPM.Write('('); openClause := FALSE END ; + WHILE pointers > 0 DO OPM.Write('*'); DEC (pointers) END + END + END + END + END Stars; + + PROCEDURE ^AnsiParamList (obj: OPT.Object; showParamNames: BOOLEAN); + + PROCEDURE DeclareObj(dcl: OPT.Object; scopeDef: BOOLEAN); + VAR + typ: OPT.Struct; + varPar, openClause: BOOLEAN; form, comp: INTEGER; + BEGIN + typ := dcl^.typ; + varPar := ((dcl^.mode = OPT.VarPar) & (typ^.comp # OPT.Array)) OR (typ^.comp = OPT.DynArr) OR scopeDef; + Stars(typ, openClause); + IF varPar THEN + IF openClause THEN OPM.Write('(') END ; + OPM.Write('*') + END ; + IF dcl.name # "" THEN Ident(dcl) END ; + IF varPar & openClause THEN OPM.Write(')') END ; + openClause := FALSE; + LOOP + form := typ^.form; + comp := typ^.comp; + IF ((typ^.strobj # NIL) & (typ^.strobj^.name # "")) OR (form = OPT.NoTyp) OR (comp = OPT.Record) THEN EXIT + ELSIF (form = OPT.Pointer) & (typ^.BaseTyp^.comp # OPT.DynArr) THEN + openClause := TRUE + ELSIF (form = OPT.ProcTyp) OR (comp IN {OPT.Array, OPT.DynArr}) THEN + IF openClause THEN OPM.Write(')'); openClause := FALSE END ; + IF form = OPT.ProcTyp THEN + IF ansi THEN OPM.Write(")"); AnsiParamList(typ^.link, FALSE) + ELSE OPM.WriteString(")()") + END ; + EXIT + ELSIF comp = OPT.Array THEN + OPM.Write('['); OPM.WriteInt(typ^.n); OPM.Write(']') + END + ELSE + EXIT + END ; + typ := typ^.BaseTyp + END + END DeclareObj; + + PROCEDURE Andent*(typ: OPT.Struct); (* ident of possibly anonymous record type *) + BEGIN + IF (typ^.strobj = NIL) OR (typ^.align >= 10000H) THEN + OPM.WriteStringVar(OPM.modName); Str1("__#", typ^.align DIV 10000H) + ELSE Ident(typ^.strobj) + END + END Andent; + + PROCEDURE Undefined(obj: OPT.Object): BOOLEAN; + BEGIN + (* imported anonymous types have obj^.name = ""; + used e.g. for repeating inherited fields *) + RETURN (obj^.name = "") + OR (obj^.mnolev >= 0) + & (obj^.linkadr # 3+OPM.currFile ) + & (obj^.linkadr # PredefinedType) + END Undefined; + + PROCEDURE ^FieldList (typ: OPT.Struct; last: BOOLEAN; VAR off, n, curAlign: LONGINT); + + PROCEDURE DeclareBase(dcl: OPT.Object); (* declare the specifier of object dcl*) + VAR typ, prev: OPT.Struct; obj: OPT.Object; nofdims: INTEGER; off, n, dummy: LONGINT; + BEGIN + typ := dcl^.typ; prev := typ; + WHILE ((typ^.strobj = NIL) OR (typ^.comp = OPT.DynArr) OR Undefined(typ^.strobj)) + & (typ^.comp # OPT.Record) + & (typ^.form # OPT.NoTyp) + & ~((typ^.form = OPT.Pointer) & (typ^.BaseTyp^.comp = OPT.DynArr)) DO + prev := typ; typ := typ^.BaseTyp; + END ; + obj := typ^.strobj; + IF typ^.form = OPT.NoTyp THEN (* proper procedure *) + OPM.WriteString('void') + ELSIF (obj # NIL) & ~Undefined(obj) THEN (* named type, already declared *) + Ident(obj) + ELSIF typ^.comp = OPT.Record THEN + OPM.WriteString('struct '); Andent(typ); + IF (prev.form # OPT.Pointer) & ((obj # NIL) OR (dcl.name = "")) THEN + (* named record type not yet declared OR anonymous record with empty name *) + IF (typ^.BaseTyp # NIL) & (typ^.BaseTyp^.strobj.vis # OPT.internal) THEN + OPM.WriteString(" { /* "); Ident(typ^.BaseTyp^.strobj); OPM.WriteString(" */"); OPM.WriteLn; Indent(1) + ELSE OPM.Write(' '); BegBlk + END ; + FieldList(typ, TRUE, off, n, dummy); + EndBlk0 + END + ELSIF (typ^.form = OPT.Pointer) & (typ^.BaseTyp^.comp = OPT.DynArr) THEN + typ := typ^.BaseTyp^.BaseTyp; nofdims := 1; + WHILE typ^.comp = OPT.DynArr DO INC(nofdims); typ := typ^.BaseTyp END ; + OPM.WriteString('struct '); BegBlk; + BegStat; Str1("LONGINT len[#]", nofdims); EndStat; + BegStat; NEW(obj); NEW(obj.typ); (* aux. object for easy declaration *) + obj.typ.form := OPT.Comp; obj.typ.comp := OPT.Array; obj.typ.n := 1; obj.typ.BaseTyp := typ; obj.mode := OPT.Fld; obj.name := "data"; + obj.linkadr := UndefinedType; DeclareBase(obj); OPM.Write(' '); DeclareObj(obj, FALSE); + EndStat; EndBlk0 + END + END DeclareBase; + + PROCEDURE NofPtrs* (typ: OPT.Struct): LONGINT; + VAR fld: OPT.Object; btyp: OPT.Struct; n: LONGINT; + BEGIN + IF (typ^.form = OPT.Pointer) & (typ^.sysflag = 0) THEN RETURN 1 + ELSIF (typ^.comp = OPT.Record) & (typ^.sysflag MOD 100H = 0) THEN + btyp := typ^.BaseTyp; + IF btyp # NIL THEN n := NofPtrs(btyp) ELSE n := 0 END ; + fld := typ^.link; + WHILE (fld # NIL) & (fld^.mode = OPT.Fld) DO + IF fld^.name # OPM.HdPtrName THEN n := n + NofPtrs(fld^.typ) + ELSE INC(n) + END ; + fld := fld^.link + END ; + RETURN n + ELSIF typ^.comp = OPT.Array THEN + btyp := typ^.BaseTyp; n := typ^.n; + WHILE btyp^.comp = OPT.Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; + RETURN NofPtrs(btyp) * n + ELSE RETURN 0 + END + END NofPtrs; + + PROCEDURE PutPtrOffsets (typ: OPT.Struct; adr: LONGINT; VAR cnt: LONGINT); + VAR fld: OPT.Object; btyp: OPT.Struct; n, i: LONGINT; + BEGIN + IF (typ^.form = OPT.Pointer) & (typ^.sysflag = 0) THEN + OPM.WriteInt(adr); OPM.WriteString(", "); INC(cnt); + IF cnt MOD 16 = 0 THEN OPM.WriteLn; OPM.Write(Tab) END + ELSIF (typ^.comp = OPT.Record) & (typ^.sysflag MOD 100H = 0) THEN + btyp := typ^.BaseTyp; + IF btyp # NIL THEN PutPtrOffsets(btyp, adr, cnt) END ; + fld := typ^.link; + WHILE (fld # NIL) & (fld^.mode = OPT.Fld) DO + IF fld^.name # OPM.HdPtrName THEN PutPtrOffsets(fld^.typ, adr + fld^.adr, cnt) + ELSE + OPM.WriteInt(adr + fld^.adr); OPM.WriteString(", "); INC(cnt); + IF cnt MOD 16 = 0 THEN OPM.WriteLn; OPM.Write(Tab) END + END ; + fld := fld^.link + END + ELSIF typ^.comp = OPT.Array THEN + btyp := typ^.BaseTyp; n := typ^.n; + WHILE btyp^.comp = OPT.Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; + IF NofPtrs(btyp) > 0 THEN i := 0; + WHILE i < n DO PutPtrOffsets(btyp, adr + i * btyp^.size, cnt); INC(i) END + END + END + END PutPtrOffsets; + + PROCEDURE InitTProcs(typ, obj: OPT.Object); + BEGIN + IF obj # NIL THEN + InitTProcs(typ, obj^.left); + IF obj^.mode = OPT.TProc THEN + BegStat; + OPM.WriteString("__INITBP("); + Ident(typ); OPM.WriteString(', '); Ident(obj); + Str1(", #)", obj^.adr DIV 10000H); + EndStat + END ; + InitTProcs(typ, obj^.right) + END + END InitTProcs; + + PROCEDURE PutBase(typ: OPT.Struct); + BEGIN + IF typ # NIL THEN + PutBase(typ^.BaseTyp); + Ident(typ^.strobj); OPM.WriteString(DynTypExt); OPM.WriteString(", ") + END + END PutBase; + + PROCEDURE LenList(par: OPT.Object; ansiDefine, showParamName: BOOLEAN); + VAR typ: OPT.Struct; dim: INTEGER; + BEGIN + IF showParamName THEN Ident(par); OPM.WriteString(LenExt) END ; + dim := 1; typ := par^.typ^.BaseTyp; + WHILE typ^.comp = OPT.DynArr DO + IF ansiDefine THEN OPM.WriteString(", LONGINT ") ELSE OPM.WriteString(', ') END ; + IF showParamName THEN Ident(par); OPM.WriteString(LenExt); OPM.WriteInt(dim) END ; + typ := typ^.BaseTyp; INC(dim) + END + END LenList; + + PROCEDURE DeclareParams(par: OPT.Object; macro: BOOLEAN); + BEGIN + OPM.Write('('); + WHILE par # NIL DO + IF macro THEN OPM.WriteStringVar(par.name) + ELSE + IF (par^.mode = OPT.Var) & (par^.typ^.form = OPT.Real) THEN OPM.Write("_") END ; + Ident(par) + END ; + IF par^.typ^.comp = OPT.DynArr THEN + OPM.WriteString(', '); LenList(par, FALSE, TRUE); + ELSIF (par^.mode = OPT.VarPar) & (par^.typ^.comp = OPT.Record) THEN + OPM.WriteString(', '); OPM.WriteStringVar(par.name); OPM.WriteString(TagExt) + END ; + par := par^.link; + IF par # NIL THEN OPM.WriteString(', ') END + END ; + OPM.Write(')') + END DeclareParams; + + PROCEDURE ^DefineType(str: OPT.Struct); + PROCEDURE ^ProcHeader(proc: OPT.Object; define: BOOLEAN); + + PROCEDURE DefineTProcTypes(obj: OPT.Object); (* define all types that are used in a OPT.TProc definition *) + VAR par: OPT.Object; + BEGIN + IF obj^.typ # OPT.notyp THEN DefineType(obj^.typ) END ; + IF ansi THEN par := obj^.link; + WHILE par # NIL DO DefineType(par^.typ); par := par^.link END + END + END DefineTProcTypes; + + PROCEDURE DeclareTProcs(obj: OPT.Object; VAR empty: BOOLEAN); + BEGIN + IF obj # NIL THEN + DeclareTProcs(obj^.left, empty); + IF obj^.mode = OPT.TProc THEN + IF obj^.typ # OPT.notyp THEN DefineType(obj^.typ) END ; + IF OPM.currFile = OPM.HeaderFile THEN + IF obj^.vis = OPT.external THEN + DefineTProcTypes(obj); + OPM.WriteString(Extern); empty := FALSE; + ProcHeader(obj, FALSE) + END + ELSE empty := FALSE; + DefineTProcTypes(obj); + IF obj^.vis = OPT.internal THEN OPM.WriteString('static ') + ELSE OPM.WriteString(Export) + END ; + ProcHeader(obj, FALSE) + END + END ; + DeclareTProcs(obj^.right, empty) + END + END DeclareTProcs; + + PROCEDURE BaseTProc*(obj: OPT.Object): OPT.Object; + VAR typ, base: OPT.Struct; mno: LONGINT; + BEGIN typ := obj^.link^.typ; (* receiver type *) + IF typ^.form = OPT.Pointer THEN typ := typ^.BaseTyp END ; + base := typ^.BaseTyp; mno := obj^.adr DIV 10000H; + WHILE (base # NIL) & (mno < base^.n) DO typ := base; base := typ^.BaseTyp END ; + OPT.FindField(obj^.name, typ, obj); + RETURN obj + END BaseTProc; + + PROCEDURE DefineTProcMacros(obj: OPT.Object; VAR empty: BOOLEAN); + BEGIN + IF obj # NIL THEN + DefineTProcMacros(obj^.left, empty); + IF (obj^.mode = OPT.TProc) & (obj = BaseTProc(obj)) & ((OPM.currFile # OPM.HeaderFile) OR (obj^.vis = OPT.external)) THEN + OPM.WriteString("#define __"); + Ident(obj); + DeclareParams(obj^.link, TRUE); + OPM.WriteString(" __SEND("); + IF obj^.link^.typ^.form = OPT.Pointer THEN + OPM.WriteString("__TYPEOF("); Ident(obj^.link); OPM.Write(")") + ELSE Ident(obj^.link); OPM.WriteString(TagExt) + END ; + Str1(", #, ", obj^.adr DIV 10000H); + IF obj^.typ = OPT.notyp THEN OPM.WriteString('void') ELSE Ident(obj^.typ^.strobj) END ; + OPM.WriteString("(*)"); + IF ansi THEN + AnsiParamList(obj^.link, FALSE); + ELSE + OPM.WriteString("()"); + END ; + OPM.WriteString(", "); + DeclareParams(obj^.link, TRUE); + OPM.Write(")"); OPM.WriteLn + END ; + DefineTProcMacros(obj^.right, empty) + END + END DefineTProcMacros; + + PROCEDURE DefineType(str: OPT.Struct); (* define a type object *) + VAR obj, field, par: OPT.Object; empty: BOOLEAN; + BEGIN + IF (OPM.currFile = OPM.BodyFile) OR (str^.ref < OPM.MaxStruct (*for hidden exports*) ) THEN + obj := str^.strobj; + IF (obj = NIL) OR Undefined(obj) THEN + IF obj # NIL THEN (* check for cycles *) + IF obj^.linkadr = ProcessingType THEN + IF str^.form # OPT.Pointer THEN OPM.Mark(244, str^.txtpos); obj^.linkadr := PredefinedType END + ELSE obj^.linkadr := ProcessingType + END + END ; + IF str^.comp = OPT.Record THEN + (* the following exports the base type of an exported type even if the former is non-exported *) + IF str^.BaseTyp # NIL THEN DefineType(str^.BaseTyp) END ; + field := str^.link; + WHILE (field # NIL) & (field^.mode = OPT.Fld) DO + IF (field^.vis # OPT.internal) OR (OPM.currFile = OPM.BodyFile) THEN DefineType(field^.typ) END ; + field := field^.link + END + ELSIF str^.form = OPT.Pointer THEN + IF str^.BaseTyp^.comp # OPT.Record THEN DefineType(str^.BaseTyp) END + ELSIF str^.comp IN {OPT.Array, OPT.DynArr} THEN + DefineType(str^.BaseTyp) + ELSIF str^.form = OPT.ProcTyp THEN + IF str^.BaseTyp # OPT.notyp THEN DefineType(str^.BaseTyp) END ; + field := str^.link; + WHILE field # NIL DO DefineType(field^.typ); field := field^.link END + END + END ; + IF (obj # NIL) & Undefined(obj) THEN + OPM.WriteString("typedef"); OPM.WriteLn; OPM.Write(Tab); Indent(1); + obj^.linkadr := ProcessingType; + DeclareBase(obj); OPM.Write(' '); + obj^.typ^.strobj := NIL; (* SG: trick to make DeclareObj declare the type *) + DeclareObj(obj, FALSE); + obj^.typ^.strobj := obj; (* SG: revert trick *) + obj^.linkadr := 3+OPM.currFile; + EndStat; Indent(-1); OPM.WriteLn; + IF obj^.typ^.comp = OPT.Record THEN empty := TRUE; + DeclareTProcs(str^.link, empty); DefineTProcMacros(str^.link, empty); + IF ~empty THEN OPM.WriteLn END + END + END + END + END DefineType; + + PROCEDURE Prefixed(x: OPT.ConstExt; y: ARRAY OF CHAR): BOOLEAN; + VAR i: INTEGER; r: BOOLEAN; + BEGIN i := 0; + WHILE x[i+1] = y[i] DO INC(i) END ; + r := y[i] = 0X; + RETURN r; + END Prefixed; + + PROCEDURE CProcDefs(obj: OPT.Object; vis: INTEGER); + VAR i: INTEGER; ext: OPT.ConstExt; + BEGIN + IF obj # NIL THEN + CProcDefs(obj^.left, vis); + (* bug: obj.history cannot be used to cover unexported and deleted CProcs; use special flag obj.adr = 1 *) + IF (obj^.mode = OPT.CProc) & (obj^.vis >= vis) & (obj^.adr = 1) THEN + ext := obj.conval.ext; i := 1; + IF (ext[1] # "#") & ~(Prefixed(ext, "extern ") OR Prefixed(ext, Extern)) THEN + OPM.WriteString("#define "); Ident(obj); + DeclareParams(obj^.link, TRUE); + OPM.Write(Tab); + END ; + FOR i := i TO ORD(obj.conval.ext[0]) DO OPM.Write(obj.conval.ext[i]) END; + OPM.WriteLn + END ; + CProcDefs(obj^.right, vis) + END + END CProcDefs; + + PROCEDURE TypeDefs* (obj: OPT.Object; vis(*replaced by test on currFile in DefineType*): INTEGER); + BEGIN + IF obj # NIL THEN + TypeDefs(obj^.left, vis); + (* test typ.txtpos to skip types that have been unexported; obj.history # removed is not enough!*) + IF (obj^.mode = OPT.Typ) & (obj^.typ^.txtpos > 0) THEN DefineType(obj^.typ) END ; + TypeDefs(obj^.right, vis) + END + END TypeDefs; + + PROCEDURE DefAnonRecs(n: OPT.Node); + VAR o: OPT.Object; typ: OPT.Struct; + BEGIN + WHILE (n # NIL) & (n^.class = OPT.Ninittd) DO + typ := n^.typ; + IF (typ^.strobj = NIL) & ((OPM.currFile = OPM.BodyFile) OR (typ.ref < OPM.MaxStruct)) THEN + DefineType(typ); (* declare base and field types, if any *) + NEW(o); o.typ := typ; o.name := ""; DeclareBase(o); EndStat; OPM.WriteLn + (* simply defines a named struct, but not a type; + o.name = "" signals field list expansion for DeclareBase in this very special case *) + END ; + n := n^.link + END + END DefAnonRecs; + + PROCEDURE TDescDecl* (typ: OPT.Struct); + VAR nofptrs: LONGINT; + o: OPT.Object; + BEGIN + BegStat; OPM.WriteString("__TDESC("); + Andent(typ); + Str1(", #", typ^.n + 1); Str1(", #) = {__TDFLDS(", NofPtrs(typ)); + OPM.Write(DoubleQuote); + IF typ^.strobj # NIL THEN OPM.WriteStringVar(typ^.strobj^.name) END ; + OPM.Write(DoubleQuote); + Str1(', #), {', typ^.size); + nofptrs := 0; PutPtrOffsets(typ, 0, nofptrs); Str1("#}}", -(nofptrs + 1) * OPM.LIntSize); + EndStat + END TDescDecl; + + PROCEDURE InitTDesc*(typ: OPT.Struct); + BEGIN + BegStat; OPM.WriteString("__INITYP("); + Andent(typ); OPM.WriteString(", "); + IF typ^.BaseTyp # NIL THEN Andent(typ^.BaseTyp) ELSE Andent(typ) END ; + Str1(", #)", typ^.extlev); + EndStat; + IF typ^.strobj # NIL THEN InitTProcs(typ^.strobj, typ^.link) END + END InitTDesc; + + PROCEDURE Align*(VAR adr: LONGINT; base: LONGINT); + BEGIN + CASE base OF + | 2: INC(adr, adr MOD 2) + | 4: INC(adr, (-adr) MOD 4) + | 8: INC(adr, (-adr) MOD 8) + | 16: INC(adr, (-adr) MOD 16) + ELSE (*1*) (*OPM.LogWStr("unhandled case at OPC.Align, base = "); OPM.LogWNum(base, 0); OPM.LogWLn;*) + END + END Align; + + PROCEDURE SizeAlignment*(size: LONGINT): LONGINT; + VAR alignment: LONGINT; + BEGIN + IF size < OPM.Alignment THEN + (* Round up to next power of 2 *) + alignment := 1; WHILE alignment < size DO alignment := alignment * 2 END; + ELSE + alignment := OPM.Alignment + END; + RETURN alignment + END SizeAlignment; + + PROCEDURE BaseAlignment*(typ: OPT.Struct): LONGINT; + VAR alignment: LONGINT; + BEGIN + IF typ.form = OPT.Comp THEN + IF typ.comp = OPT.Record THEN + alignment := typ.align MOD 10000H + ELSE + alignment := BaseAlignment(typ.BaseTyp) + END + ELSE + alignment := SizeAlignment(typ.size) + END; + RETURN alignment + END BaseAlignment; + + + PROCEDURE FillGap(gap, off, align: LONGINT; VAR n, curAlign: LONGINT); + VAR adr: LONGINT; + BEGIN + adr := off; Align(adr, align); + IF (curAlign < align) & (gap - (adr - off) >= align) THEN (* preserve alignment of the enclosing struct! *) + DEC(gap, (adr - off) + align); + BegStat; + IF align = OPM.IntSize THEN OPM.WriteString("INTEGER") + ELSIF align = OPM.LIntSize THEN OPM.WriteString("LONGINT") + ELSIF align = OPM.LRealSize THEN OPM.WriteString("LONGREAL") + END ; + Str1(" _prvt#", n); INC(n); EndStat; + curAlign := align + END ; + IF gap > 0 THEN BegStat; Str1("char _prvt#", n); INC(n); Str1("[#]", gap); EndStat END + END FillGap; + + PROCEDURE FieldList (typ: OPT.Struct; last: BOOLEAN; VAR off, n, curAlign: LONGINT); + VAR fld: OPT.Object; base: OPT.Struct; gap, adr, align, fldAlign: LONGINT; + BEGIN + fld := typ.link; align := typ^.align MOD 10000H; + IF typ.BaseTyp # NIL THEN FieldList(typ.BaseTyp, FALSE, off, n, curAlign) + ELSE off := 0; n := 0; curAlign := 1 + END ; + WHILE (fld # NIL) & (fld.mode = OPT.Fld) DO + IF (OPM.currFile = OPM.HeaderFile) & (fld.vis = OPT.internal) OR + (OPM.currFile = OPM.BodyFile) & (fld.vis = OPT.internal) & (typ^.mno # 0) THEN + fld := fld.link; + WHILE (fld # NIL) & (fld.mode = OPT.Fld) & (fld.vis = OPT.internal) DO fld := fld.link END ; + ELSE + (* mimic OPV.TypSize to detect gaps caused by private fields *) + adr := off; fldAlign := BaseAlignment(fld^.typ); Align(adr, fldAlign); + gap := fld.adr - adr; + IF fldAlign > curAlign THEN curAlign := fldAlign END ; + IF gap > 0 THEN FillGap(gap, off, align, n, curAlign) END ; + BegStat; DeclareBase(fld); OPM.Write(' '); DeclareObj(fld, FALSE); + off := fld.adr + fld.typ.size; base := fld.typ; fld := fld.link; + WHILE (fld # NIL) & (fld.mode = OPT.Fld) & (fld.typ = base) & (fld.adr = off) +(* ?? *) & ((OPM.currFile = OPM.BodyFile) OR (fld.vis # OPT.internal) OR (fld.typ.strobj = NIL)) DO + OPM.WriteString(", "); DeclareObj(fld, FALSE); off := fld.adr + fld.typ.size; fld := fld.link + END ; + EndStat + END + END ; + IF last THEN + adr := typ.size - typ^.sysflag DIV 100H; + IF adr = 0 THEN gap := 1 (* avoid empty struct *) ELSE gap := adr - off END ; + IF gap > 0 THEN FillGap(gap, off, align, n, curAlign) END + END + END FieldList; + + PROCEDURE IdentList (obj: OPT.Object; vis: INTEGER); + (* generate var and param lists; vis: 0 all global vars, local var, 1 exported(R) var, 2 par list, 3 scope var *) + VAR base: OPT.Struct; first: BOOLEAN; lastvis: INTEGER; + BEGIN + base := NIL; first := TRUE; + WHILE (obj # NIL) & (obj^.mode # OPT.TProc) DO + IF (vis IN {0, 2}) OR ((vis = 1) & (obj^.vis # 0)) OR ((vis = 3) & ~obj^.leaf) THEN + IF (obj^.typ # base) OR (obj^.vis # lastvis) THEN (* new variable base type definition required *) + IF ~first THEN EndStat END ; + first := FALSE; + base := obj^.typ; lastvis := obj^.vis; + BegStat; + IF (vis = 1) & (obj^.vis # OPT.internal) THEN OPM.WriteString(Extern) + ELSIF (obj^.mnolev = 0) & (vis = 0) THEN + IF obj^.vis = OPT.internal THEN OPM.WriteString('static ') + ELSE OPM.WriteString(Export) + END + END ; + IF (vis = 2) & (obj^.mode = OPT.Var) & (base^.form = OPT.Real) THEN OPM.WriteString("double") + ELSE DeclareBase(obj) + END + ELSE OPM.Write(","); + END ; + OPM.Write(' '); + IF (vis = 2) & (obj^.mode = OPT.Var) & (base^.form = OPT.Real) THEN OPM.Write("_") END ; + DeclareObj(obj, vis = 3); + IF obj^.typ^.comp = OPT.DynArr THEN (* declare len parameter(s) *) + EndStat; BegStat; + base := OPT.linttyp; + OPM.WriteString("LONGINT "); LenList(obj, FALSE, TRUE) + ELSIF (obj^.mode = OPT.VarPar) & (obj^.typ^.comp = OPT.Record) THEN + EndStat; BegStat; + OPM.WriteString("LONGINT *"); Ident(obj); OPM.WriteString(TagExt); + base := NIL + ELSIF ptrinit & (vis = 0) & (obj^.mnolev > 0) & (obj^.typ^.form = OPT.Pointer) THEN + OPM.WriteString(" = NIL") + END + END ; + obj := obj^.link + END ; + IF ~first THEN EndStat END + END IdentList; + + PROCEDURE AnsiParamList (obj: OPT.Object; showParamNames: BOOLEAN); + VAR name: ARRAY 32 OF CHAR; + BEGIN + OPM.Write("("); + IF (obj = NIL) OR (obj^.mode = OPT.TProc) THEN OPM.WriteString("void") + ELSE + LOOP + DeclareBase(obj); + IF showParamNames THEN + OPM.Write(' '); DeclareObj(obj, FALSE) + ELSE + COPY(obj^.name, name); obj^.name := ""; DeclareObj(obj, FALSE); COPY(name, obj^.name) + END ; + IF obj^.typ^.comp = OPT.DynArr THEN + OPM.WriteString(", LONGINT "); + LenList(obj, TRUE, showParamNames) + ELSIF (obj^.mode = OPT.VarPar) & (obj^.typ^.comp = OPT.Record) THEN + OPM.WriteString(", LONGINT *"); + IF showParamNames THEN Ident(obj); OPM.WriteString(TagExt) END + END ; + IF (obj^.link = NIL) OR (obj^.link.mode = OPT.TProc) THEN EXIT END ; + OPM.WriteString(", "); + obj := obj^.link + END + END ; + OPM.Write(")") + END AnsiParamList; + + PROCEDURE ProcHeader(proc: OPT.Object; define: BOOLEAN); + BEGIN + IF proc^.typ = OPT.notyp THEN OPM.WriteString('void') ELSE Ident(proc^.typ^.strobj) END ; + OPM.Write(' '); Ident(proc); OPM.Write(' '); + IF ansi THEN + AnsiParamList(proc^.link, TRUE); + IF ~define THEN OPM.Write(";") END ; + OPM.WriteLn; + ELSIF define THEN + DeclareParams(proc^.link, FALSE); + OPM.WriteLn; + Indent(1); IdentList(proc^.link, 2(* map REAL to double *)); Indent(-1) + ELSE OPM.WriteString("();"); OPM.WriteLn + END + END ProcHeader; + + PROCEDURE ProcPredefs (obj: OPT.Object; vis: SHORTINT); (* forward declaration of procedures *) + BEGIN + IF obj # NIL THEN + ProcPredefs(obj^.left, vis); + IF (obj^.mode IN {OPT.LProc, OPT.XProc}) & (obj^.vis >= vis) & ((obj^.history # OPT.removed) OR (obj^.mode = OPT.LProc)) THEN + (* previous OPT.XProc may be deleted or become OPT.LProc after interface change*) + IF vis = OPT.external THEN OPM.WriteString(Extern) + ELSIF obj^.vis = OPT.internal THEN OPM.WriteString('static ') + ELSE OPM.WriteString(Export) + END ; + ProcHeader(obj, FALSE); + END ; + ProcPredefs(obj^.right, vis); + END; + END ProcPredefs; + + PROCEDURE Include(name: ARRAY OF CHAR); + BEGIN + OPM.WriteString("#include "); OPM.Write(DoubleQuote); OPM.WriteStringVar(name); + OPM.WriteString(".h"); OPM.Write(DoubleQuote); OPM.WriteLn + END Include; + + PROCEDURE IncludeImports(obj: OPT.Object; vis: INTEGER); + BEGIN + IF obj # NIL THEN + IncludeImports(obj^.left, vis); + IF (obj^.mode = OPT.Mod) & (obj^.mnolev # 0) & (OPT.GlbMod[-obj^.mnolev].vis >= vis) THEN (* @self and SYSTEM have mnolev = 0 *) + Include(OPT.GlbMod[-obj^.mnolev].name) (* use unaliased module name *) + END; + IncludeImports(obj^.right, vis); + END; + END IncludeImports; + + PROCEDURE GenDynTypes (n: OPT.Node; vis: INTEGER); + VAR typ: OPT.Struct; + BEGIN + WHILE (n # NIL) & (n^.class = OPT.Ninittd) DO + typ := n^.typ; + IF (vis = OPT.internal) OR (typ^.ref < OPM.MaxStruct (*type needed in symbol file*)) THEN + BegStat; + IF vis = OPT.external THEN OPM.WriteString(Extern) + ELSIF (typ^.strobj # NIL) & (typ^.strobj^.mnolev > 0) THEN OPM.WriteString('static ') + ELSE OPM.WriteString(Export) + END ; + OPM.WriteString("LONGINT *"); Andent(typ); OPM.WriteString(DynTypExt); + EndStat + END ; + n := n^.link + END + END GenDynTypes; + + PROCEDURE GenHdr*(n: OPT.Node); + BEGIN + (* includes are delayed until it is known which ones are needed in the header *) + OPM.currFile := OPM.HeaderFile; + DefAnonRecs(n); + TypeDefs(OPT.topScope^.right, 1); OPM.WriteLn; + IdentList(OPT.topScope^.scope, 1); OPM.WriteLn; + GenDynTypes(n, OPT.external); OPM.WriteLn; + ProcPredefs(OPT.topScope^.right, 1); + OPM.WriteString(Extern); OPM.WriteString("void *"); + OPM.WriteStringVar(OPM.modName); OPM.WriteString(BodyNameExt); + EndStat; OPM.WriteLn; + CProcDefs(OPT.topScope^.right, 1); OPM.WriteLn; + OPM.WriteString("#endif"); OPM.WriteLn + END GenHdr; + + PROCEDURE GenHeaderMsg; + VAR i: INTEGER; + BEGIN + OPM.WriteString("/* "); OPM.WriteString(Configuration.name); + OPM.Write(" "); OPM.WriteString(Configuration.versionLong); OPM.Write (" "); (* noch *) + FOR i := 0 TO MAX(SET) DO + IF i IN OPM.glbopt THEN + CASE i OF (* c.f. ScanOptions in OPM *) + | OPM.inxchk: OPM.Write("x") + | OPM.ranchk: OPM.Write("r") + | OPM.typchk: OPM.Write("t") + | OPM.newsf: OPM.Write("s") + | OPM.ptrinit: OPM.Write("p") + | OPM.ansi: OPM.Write("k") + | OPM.assert: OPM.Write("a") + | OPM.extsf: OPM.Write("e") + | OPM.mainprog: OPM.Write("m") + | OPM.dontasm: OPM.Write("S") + | OPM.dontlink: OPM.Write("c") + | OPM.mainlinkstat: OPM.Write("M") + | OPM.notcoloroutput: OPM.Write("f") + | OPM.forcenewsym: OPM.Write("F") + | OPM.verbose: OPM.Write("v") + ELSE OPM.LogWStr ("( more options defined in OPM than checked in OPC.GenHeaderMsg, if you are a compiler developer, add them to OPC.GenHeaderMsg"); OPM.LogWLn; + END + END + END; + OPM.WriteString(" */"); OPM.WriteLn + END GenHeaderMsg; + + PROCEDURE GenHdrIncludes*; + BEGIN + OPM.currFile := OPM.HeaderInclude; + GenHeaderMsg; + OPM.WriteLn; + OPM.WriteString("#ifndef "); OPM.WriteStringVar(OPM.modName); OPM.WriteString(FlagExt); OPM.WriteLn; + OPM.WriteString("#define "); OPM.WriteStringVar(OPM.modName); OPM.WriteString(FlagExt); OPM.WriteLn; + OPM.WriteLn; + IF OPM.LIntSize = 8 THEN OPM.WriteString("#define LARGE"); OPM.WriteLn END; + Include(BasicIncludeFile); + IncludeImports(OPT.topScope^.right, 1); OPM.WriteLn + END GenHdrIncludes; + + PROCEDURE GenBdy*(n: OPT.Node); + BEGIN + OPM.currFile := OPM.BodyFile; + GenHeaderMsg; + IF OPM.LIntSize = 8 THEN OPM.WriteString("#define LARGE"); OPM.WriteLn END; + Include(BasicIncludeFile); + IncludeImports(OPT.topScope^.right, 0); OPM.WriteLn; + DefAnonRecs(n); + TypeDefs(OPT.topScope^.right, 0); OPM.WriteLn; + IdentList(OPT.topScope^.scope, 0); OPM.WriteLn; + GenDynTypes(n, OPT.internal); OPM.WriteLn; + ProcPredefs(OPT.topScope^.right, 0); OPM.WriteLn; + CProcDefs(OPT.topScope^.right, 0); OPM.WriteLn + END GenBdy; + + PROCEDURE RegCmds(obj: OPT.Object); + BEGIN + IF obj # NIL THEN + RegCmds(obj^.left); + IF (obj^.mode = OPT.XProc) & (obj^.history # OPT.removed) THEN + IF (obj^.vis # 0) & (obj^.link = NIL) & (obj^.typ = OPT.notyp) THEN (*command*) + BegStat; OPM.WriteString('__REGCMD("'); + OPM.WriteStringVar(obj.name); OPM.WriteString('", '); Ident(obj); OPM.Write(")"); EndStat + END + END ; + RegCmds(obj^.right) + END + END RegCmds; + + PROCEDURE InitImports(obj: OPT.Object); + BEGIN + IF obj # NIL THEN + InitImports(obj^.left); + IF (obj^.mode = OPT.Mod) & (obj^.mnolev # 0) THEN + BegStat; OPM.WriteString("__MODULE_IMPORT("); + OPM.WriteStringVar(OPT.GlbMod[-obj^.mnolev].name); + OPM.Write(')'); EndStat + END ; + InitImports(obj^.right) + END + END InitImports; + + PROCEDURE GenEnumPtrs* (var: OPT.Object); + VAR typ: OPT.Struct; n: LONGINT; + BEGIN GlbPtrs := FALSE; + WHILE var # NIL DO + typ := var^.typ; + IF NofPtrs(typ) > 0 THEN + IF ~GlbPtrs THEN GlbPtrs := TRUE; + OPM.WriteString('static '); + IF ansi THEN + OPM.WriteString("void EnumPtrs(void (*P)(void*))") + ELSE + OPM.WriteString("void EnumPtrs(P)"); OPM.WriteLn; + OPM.Write(Tab); OPM.WriteString("void (*P)();"); + END ; + OPM.WriteLn; + BegBlk + END ; + BegStat; + IF typ^.form = OPT.Pointer THEN + OPM.WriteString("P("); Ident(var); OPM.Write(")"); + ELSIF typ^.comp = OPT.Record THEN + OPM.WriteString("__ENUMR(&"); Ident(var); OPM.WriteString(", "); + Andent(typ); OPM.WriteString(DynTypExt); Str1(", #", typ^.size); OPM.WriteString(", 1, P)") + ELSIF typ^.comp = OPT.Array THEN + n := typ^.n; typ := typ^.BaseTyp; + WHILE typ^.comp = OPT.Array DO n := n * typ^.n; typ := typ^.BaseTyp END ; + IF typ^.form = OPT.Pointer THEN + OPM.WriteString("__ENUMP("); Ident(var); Str1(", #, P)", n) + ELSIF typ^.comp = OPT.Record THEN + OPM.WriteString("__ENUMR("); Ident(var); OPM.WriteString(", "); + Andent(typ); OPM.WriteString(DynTypExt); Str1(", #", typ^.size); Str1(", #, P)", n) + END + END ; + EndStat + END ; + var := var^.link + END ; + IF GlbPtrs THEN + EndBlk; OPM.WriteLn + END + END GenEnumPtrs; + + PROCEDURE EnterBody*; + BEGIN + OPM.WriteLn; OPM.WriteString(Export); + IF mainprog THEN + IF ansi THEN + OPM.WriteString("int main(int argc, char **argv)"); OPM.WriteLn; + ELSE + OPM.WriteString("main(argc, argv)"); OPM.WriteLn; + OPM.Write(Tab); OPM.WriteString("int argc; char **argv;"); OPM.WriteLn + END + ELSE + OPM.WriteString("void *"); + OPM.WriteString(OPM.modName); OPM.WriteString(BodyNameExt); OPM.WriteLn; + END ; + BegBlk; BegStat; + IF mainprog THEN OPM.WriteString("__INIT(argc, argv)") ELSE OPM.WriteString("__DEFMOD") END ; + EndStat; + IF mainprog & demoVersion THEN BegStat; + OPM.WriteString('/*don`t do it!*/ printf("DEMO VERSION: DO NOT USE THIS PROGRAM FOR ANY COMMERCIAL PURPOSE\n")'); + EndStat + END ; + InitImports(OPT.topScope^.right); + BegStat; + IF mainprog THEN OPM.WriteString('__REGMAIN("') ELSE OPM.WriteString('__REGMOD("') END ; + OPM.WriteString(OPM.modName); + IF GlbPtrs THEN OPM.WriteString('", EnumPtrs)') ELSE OPM.WriteString('", 0)') END ; + EndStat; + IF OPM.modName # "SYSTEM" THEN RegCmds(OPT.topScope) END + END EnterBody; + + PROCEDURE ExitBody*; + BEGIN + BegStat; + IF mainprog THEN OPM.WriteString("__FINI;") ELSE OPM.WriteString("__ENDMOD;") END ; + OPM.WriteLn; EndBlk + END ExitBody; + + PROCEDURE DefineInter* (proc: OPT.Object); (* define intermediate scope record and variable *) + VAR scope: OPT.Object; + BEGIN + scope := proc^.scope; + OPM.WriteString('static '); OPM.WriteString('struct '); OPM.WriteStringVar(scope^.name); OPM.Write(' '); + BegBlk; + IdentList(proc^.link, 3); (* parameters *) + IdentList(scope^.scope, 3); (* local variables *) + BegStat; (* scope link field declaration *) + OPM.WriteString('struct '); OPM.WriteStringVar (scope^.name); + OPM.Write(' '); OPM.Write('*'); OPM.WriteString(LinkName); EndStat; + EndBlk0; OPM.Write(' '); + OPM.Write('*'); OPM.WriteStringVar (scope^.name); OPM.WriteString(GlobalScope); EndStat; OPM.WriteLn; + ProcPredefs (scope^.right, 0); + OPM.WriteLn; + END DefineInter; + + PROCEDURE EnterProc* (proc: OPT.Object); + VAR var, scope: OPT.Object; typ: OPT.Struct; dim: INTEGER; + BEGIN + IF proc^.vis # OPT.external THEN OPM.WriteString('static ') END ; + ProcHeader(proc, TRUE); + BegBlk; + + (* If there will be a result, provide a result variable. *) + IF proc^.typ # OPT.notyp THEN + BegStat; Ident(proc^.typ^.strobj); OPM.WriteString(" _o_result;"); OPM.WriteLn; END; - scope := proc^.scope; - IdentList(scope^.scope, 0); - IF ~scope^.leaf THEN (* declare intermediate procedure scope record variable*) - BegStat; OPM.WriteString(Struct); OPM.WriteStringVar (scope^.name); - OPM.Write(Blank); OPM.WriteString(LocalScope); EndStat - END ; - var := proc^.link; - WHILE var # NIL DO (* declare copy of fixed size value array parameters *) - IF (var^.typ^.comp = Array) & (var^.mode = Var) THEN - BegStat; - IF var^.typ^.strobj = NIL THEN OPM.Mark(200, var^.typ^.txtpos) ELSE Ident(var^.typ^.strobj) END ; - OPM.Write(Blank); Ident(var); OPM.WriteString("__copy"); - EndStat - END ; - var := var^.link - END ; - IF ~ansi THEN - var := proc^.link; - WHILE var # NIL DO (* "unpromote" value real parameters *) - IF (var^.typ^.form = Real) & (var^.mode = Var) THEN - BegStat; - Ident(var^.typ^.strobj); OPM.Write(Blank); Ident(var); OPM.WriteString(" = _"); Ident(var); - EndStat - END ; - var := var^.link - END - END ; - var := proc^.link; - WHILE var # NIL DO (* copy value array parameters *) - IF (var^.typ^.comp IN {Array, DynArr}) & (var^.mode = Var) & (var^.typ^.sysflag = 0) THEN - BegStat; - IF var^.typ^.comp = Array THEN - OPM.WriteString(DupArrFunc); - Ident(var); OPM.WriteString(Comma); - IF var^.typ^.strobj = NIL THEN OPM.Mark(200, var^.typ^.txtpos) ELSE Ident(var^.typ^.strobj) END - ELSE - OPM.WriteString(DupFunc); - Ident(var); OPM.WriteString(Comma); Ident(var); OPM.WriteString(LenExt); - typ := var^.typ^.BaseTyp; dim := 1; - WHILE typ^.comp = DynArr DO - OPM.WriteString(" * "); Ident(var); OPM.WriteString(LenExt); OPM.WriteInt(dim); - typ := typ^.BaseTyp; INC(dim) - END ; - OPM.WriteString(Comma); - IF (typ^.strobj = NIL) THEN OPM.Mark(200, typ^.txtpos) - ELSE Ident(typ^.strobj) - END - END ; - OPM.Write(CloseParen); EndStat - END ; - var := var^.link - END ; - IF ~scope^.leaf THEN - var := proc^.link; (* copy addresses of parameters into local scope record *) - WHILE var # NIL DO - IF ~var^.leaf THEN (* only if used by a nested procedure *) - BegStat; - OPM.WriteString(LocalScope); OPM.Write(Dot); Ident(var); - OPM.WriteString(Becomes); - IF var^.typ^.comp IN {Array, DynArr} THEN OPM.WriteString("(void*)") - (* K&R and ANSI differ in the type: array or element type*) - ELSIF var^.mode # VarPar THEN OPM.Write("&") - END ; - Ident(var); - IF var^.typ^.comp = DynArr THEN - typ := var^.typ; dim := 0; - REPEAT (* copy len(s) *) - OPM.WriteString("; "); - OPM.WriteString(LocalScope); OPM.Write(Dot); Ident(var); OPM.WriteString(LenExt); - IF dim # 0 THEN OPM.WriteInt(dim) END ; - OPM.WriteString(Becomes); Ident(var); OPM.WriteString(LenExt); - IF dim # 0 THEN OPM.WriteInt(dim) END ; - typ := typ^.BaseTyp - UNTIL typ^.comp # DynArr; - ELSIF (var^.mode = VarPar) & (var^.typ^.comp = Record) THEN - OPM.WriteString("; "); - OPM.WriteString(LocalScope); OPM.Write(Dot); Ident(var); OPM.WriteString(TagExt); - OPM.WriteString(Becomes); Ident(var); OPM.WriteString(TagExt) - END ; - EndStat - END; - var := var^.link; - END; - var := scope^.scope; (* copy addresses of local variables into scope record *) - WHILE var # NIL DO - IF ~var^.leaf THEN (* only if used by a nested procedure *) - BegStat; - OPM.WriteString(LocalScope); OPM.Write(Dot); Ident(var); OPM.WriteString(Becomes); - IF var^.typ^.comp # Array THEN OPM.Write("&") - ELSE OPM.WriteString("(void*)") (* K&R and ANSI differ in the type: array or element type*) - END ; - Ident(var); EndStat - END ; - var := var^.link - END; - (* now link new scope *) - BegStat; OPM.WriteString(LocalScope); OPM.Write(Dot); OPM.WriteString(LinkName); - OPM.WriteString(Becomes); OPM.WriteStringVar(scope^.name); OPM.WriteString(GlobalScope); EndStat; - BegStat; OPM.WriteStringVar(scope^.name); OPM.WriteString(GlobalScope); OPM.WriteString(Becomes); - OPM.Write("&"); OPM.WriteString(LocalScope); EndStat - END - END EnterProc; + scope := proc^.scope; + IdentList(scope^.scope, 0); + IF ~scope^.leaf THEN (* declare intermediate procedure scope record variable*) + BegStat; OPM.WriteString('struct '); OPM.WriteStringVar (scope^.name); + OPM.Write(' '); OPM.WriteString(LocalScope); EndStat + END ; + var := proc^.link; + WHILE var # NIL DO (* declare copy of fixed size value array parameters *) + IF (var^.typ^.comp = OPT.Array) & (var^.mode = OPT.Var) THEN + BegStat; + IF var^.typ^.strobj = NIL THEN OPM.Mark(200, var^.typ^.txtpos) ELSE Ident(var^.typ^.strobj) END ; + OPM.Write(' '); Ident(var); OPM.WriteString("__copy"); + EndStat + END ; + var := var^.link + END ; + IF ~ansi THEN + var := proc^.link; + WHILE var # NIL DO (* "unpromote" value real parameters *) + IF (var^.typ^.form = OPT.Real) & (var^.mode = OPT.Var) THEN + BegStat; + Ident(var^.typ^.strobj); OPM.Write(' '); Ident(var); OPM.WriteString(" = _"); Ident(var); + EndStat + END ; + var := var^.link + END + END ; + var := proc^.link; + WHILE var # NIL DO (* copy value array parameters *) + IF (var^.typ^.comp IN {OPT.Array, OPT.DynArr}) & (var^.mode = OPT.Var) & (var^.typ^.sysflag = 0) THEN + BegStat; + IF var^.typ^.comp = OPT.Array THEN + OPM.WriteString("__DUPARR("); + Ident(var); OPM.WriteString(', '); + IF var^.typ^.strobj = NIL THEN OPM.Mark(200, var^.typ^.txtpos) ELSE Ident(var^.typ^.strobj) END + ELSE + OPM.WriteString('__DUP('); + Ident(var); OPM.WriteString(', '); Ident(var); OPM.WriteString(LenExt); + typ := var^.typ^.BaseTyp; dim := 1; + WHILE typ^.comp = OPT.DynArr DO + OPM.WriteString(" * "); Ident(var); OPM.WriteString(LenExt); OPM.WriteInt(dim); + typ := typ^.BaseTyp; INC(dim) + END ; + OPM.WriteString(', '); + IF (typ^.strobj = NIL) THEN OPM.Mark(200, typ^.txtpos) + ELSE Ident(typ^.strobj) + END + END ; + OPM.Write(')'); EndStat + END ; + var := var^.link + END ; + IF ~scope^.leaf THEN + var := proc^.link; (* copy addresses of parameters into local scope record *) + WHILE var # NIL DO + IF ~var^.leaf THEN (* only if used by a nested procedure *) + BegStat; + OPM.WriteString(LocalScope); OPM.Write('.'); Ident(var); + OPM.WriteString(' = '); + IF var^.typ^.comp IN {OPT.Array, OPT.DynArr} THEN OPM.WriteString("(void*)") + (* K&R and ANSI differ in the type: array or element type*) + ELSIF var^.mode # OPT.VarPar THEN OPM.Write("&") + END ; + Ident(var); + IF var^.typ^.comp = OPT.DynArr THEN + typ := var^.typ; dim := 0; + REPEAT (* copy len(s) *) + OPM.WriteString("; "); + OPM.WriteString(LocalScope); OPM.Write('.'); Ident(var); OPM.WriteString(LenExt); + IF dim # 0 THEN OPM.WriteInt(dim) END ; + OPM.WriteString(' = '); Ident(var); OPM.WriteString(LenExt); + IF dim # 0 THEN OPM.WriteInt(dim) END ; + typ := typ^.BaseTyp + UNTIL typ^.comp # OPT.DynArr; + ELSIF (var^.mode = OPT.VarPar) & (var^.typ^.comp = OPT.Record) THEN + OPM.WriteString("; "); + OPM.WriteString(LocalScope); OPM.Write('.'); Ident(var); OPM.WriteString(TagExt); + OPM.WriteString(' = '); Ident(var); OPM.WriteString(TagExt) + END ; + EndStat + END; + var := var^.link; + END; + var := scope^.scope; (* copy addresses of local variables into scope record *) + WHILE var # NIL DO + IF ~var^.leaf THEN (* only if used by a nested procedure *) + BegStat; + OPM.WriteString(LocalScope); OPM.Write('.'); Ident(var); OPM.WriteString(' = '); + IF var^.typ^.comp # OPT.Array THEN OPM.Write("&") + ELSE OPM.WriteString("(void*)") (* K&R and ANSI differ in the type: array or element type*) + END ; + Ident(var); EndStat + END ; + var := var^.link + END; + (* now link new scope *) + BegStat; OPM.WriteString(LocalScope); OPM.Write('.'); OPM.WriteString(LinkName); + OPM.WriteString(' = '); OPM.WriteStringVar(scope^.name); OPM.WriteString(GlobalScope); EndStat; + BegStat; OPM.WriteStringVar(scope^.name); OPM.WriteString(GlobalScope); OPM.WriteString(' = '); + OPM.Write("&"); OPM.WriteString(LocalScope); EndStat + END + END EnterProc; - PROCEDURE ExitProc*(proc: OPT.Object; eoBlock, implicitRet: BOOLEAN); - VAR var: OPT.Object; indent: BOOLEAN; - BEGIN - indent := eoBlock; - IF implicitRet & (proc^.typ # OPT.notyp) THEN - OPM.Write(Tab); OPM.WriteString("__RETCHK;"); OPM.WriteLn - ELSIF ~eoBlock OR implicitRet THEN - IF ~proc^.scope^.leaf THEN - (* link scope pointer of nested proc back to previous scope *) - IF indent THEN BegStat ELSE indent := TRUE END ; - OPM.WriteStringVar(proc^.scope^.name); OPM.WriteString(GlobalScope); - OPM.WriteString(Becomes); OPM.WriteString(LocalScope); OPM.Write(Dot); OPM.WriteString(LinkName); - EndStat - END; - (* delete array value parameters *) - var := proc^.link; - WHILE var # NIL DO - IF (var^.typ^.comp = DynArr) & (var^.mode = Var) & (var^.typ^.sysflag = 0) THEN - IF indent THEN BegStat ELSE indent := TRUE END ; - OPM.WriteString(DelFunc); Ident(var); OPM.Write(CloseParen); EndStat - END ; - var := var^.link - END - END ; - IF eoBlock THEN EndBlk; OPM.WriteLn - ELSIF indent THEN BegStat - END - END ExitProc; + PROCEDURE ExitProc*(proc: OPT.Object; eoBlock, implicitRet: BOOLEAN); + VAR var: OPT.Object; indent: BOOLEAN; + BEGIN + indent := eoBlock; + IF implicitRet & (proc^.typ # OPT.notyp) THEN + OPM.Write(Tab); OPM.WriteString("__RETCHK;"); OPM.WriteLn + ELSIF ~eoBlock OR implicitRet THEN + IF ~proc^.scope^.leaf THEN + (* link scope pointer of nested proc back to previous scope *) + IF indent THEN BegStat ELSE indent := TRUE END ; + OPM.WriteStringVar(proc^.scope^.name); OPM.WriteString(GlobalScope); + OPM.WriteString(' = '); OPM.WriteString(LocalScope); OPM.Write('.'); OPM.WriteString(LinkName); + EndStat + END; + (* delete array value parameters *) + var := proc^.link; + WHILE var # NIL DO + IF (var^.typ^.comp = OPT.DynArr) & (var^.mode = OPT.Var) & (var^.typ^.sysflag = 0) THEN + IF indent THEN BegStat ELSE indent := TRUE END ; + OPM.WriteString('__DEL('); Ident(var); OPM.Write(')'); EndStat + END ; + var := var^.link + END + END ; + IF eoBlock THEN EndBlk; OPM.WriteLn + ELSIF indent THEN BegStat + END + END ExitProc; - PROCEDURE CompleteIdent*(obj: OPT.Object); - VAR comp, level: INTEGER; - BEGIN - (* obj^.mode IN {Var, VarPar} *) - level := obj^.mnolev; - IF obj^.adr = 1 THEN (* WITH-variable *) - IF obj^.typ^.comp = Record THEN Ident(obj); OPM.WriteString("__") - ELSE (* cast with guard pointer type *) - OPM.WriteString("(("); Ident(obj^.typ^.strobj); OPM.Write(")"); Ident(obj); OPM.Write(")") - END - ELSIF (level # OPM.level) & (level > 0) THEN (* intermediate var *) - comp := obj^.typ^.comp; - IF (obj^.mode # VarPar) & (comp # DynArr) THEN OPM.Write(Star); END; - OPM.WriteStringVar(obj^.scope^.name); OPM.WriteString(GlobalScope); - OPM.WriteString("->"); Ident(obj) - ELSE - Ident(obj) - END - END CompleteIdent; + PROCEDURE CompleteIdent*(obj: OPT.Object); + VAR comp, level: INTEGER; + BEGIN + (* obj^.mode IN {OPT.Var, OPT.VarPar} *) + level := obj^.mnolev; + IF obj^.adr = 1 THEN (* WITH-variable *) + IF obj^.typ^.comp = OPT.Record THEN Ident(obj); OPM.WriteString("__") + ELSE (* cast with guard pointer type *) + OPM.WriteString("(("); Ident(obj^.typ^.strobj); OPM.Write(")"); Ident(obj); OPM.Write(")") + END + ELSIF (level # OPM.level) & (level > 0) THEN (* intermediate var *) + comp := obj^.typ^.comp; + IF (obj^.mode # OPT.VarPar) & (comp # OPT.DynArr) THEN OPM.Write('*'); END; + OPM.WriteStringVar(obj^.scope^.name); OPM.WriteString(GlobalScope); + OPM.WriteString("->"); Ident(obj) + ELSE + Ident(obj) + END + END CompleteIdent; - PROCEDURE TypeOf*(ap: OPT.Object); - VAR i: INTEGER; - BEGIN - ASSERT(ap.typ.comp = Record); - IF ap.mode = VarPar THEN - IF ap.mnolev # OPM.level THEN (*intermediate level var-par record; possible WITH-guarded*) - OPM.WriteStringVar(ap^.scope^.name); OPM.WriteString("_s->"); Ident(ap) - ELSE (*local var-par record*) - Ident(ap) - END ; - OPM.WriteString(TagExt) - ELSIF ap^.typ^.strobj # NIL THEN - Ident(ap^.typ^.strobj); OPM.WriteString(DynTypExt) - ELSE Andent(ap.typ) (*anonymous ap type, p^ *) - END - END TypeOf; + PROCEDURE TypeOf*(ap: OPT.Object); + VAR i: INTEGER; + BEGIN + ASSERT(ap.typ.comp = OPT.Record); + IF ap.mode = OPT.VarPar THEN + IF ap.mnolev # OPM.level THEN (*intermediate level var-par record; possible WITH-guarded*) + OPM.WriteStringVar(ap^.scope^.name); OPM.WriteString("_s->"); Ident(ap) + ELSE (*local var-par record*) + Ident(ap) + END ; + OPM.WriteString(TagExt) + ELSIF ap^.typ^.strobj # NIL THEN + Ident(ap^.typ^.strobj); OPM.WriteString(DynTypExt) + ELSE Andent(ap.typ) (*anonymous ap type, p^ *) + END + END TypeOf; - PROCEDURE Cmp*(rel: INTEGER); - BEGIN - CASE rel OF - eql : - OPM.WriteString(" == "); - | neq : - OPM.WriteString(" != "); - | lss : - OPM.WriteString(" < "); - | leq : - OPM.WriteString(" <= "); - | gtr : - OPM.WriteString(" > "); - | geq : - OPM.WriteString(" >= "); - ELSE - OPM.LogWStr("unhandled case in OPC.Cmp, rel = "); OPM.LogWNum(rel, 0); OPM.LogWLn; - END; - END Cmp; + PROCEDURE Cmp*(rel: INTEGER); + BEGIN + CASE rel OF + | OPT.eql: OPM.WriteString(" == ") + | OPT.neq: OPM.WriteString(" != ") + | OPT.lss: OPM.WriteString(" < ") + | OPT.leq: OPM.WriteString(" <= ") + | OPT.gtr: OPM.WriteString(" > ") + | OPT.geq: OPM.WriteString(" >= ") + ELSE OPM.LogWStr("unhandled case in OPC.Cmp, rel = "); OPM.LogWNum(rel, 0); OPM.LogWLn; + END; + END Cmp; - PROCEDURE Case*(caseVal: LONGINT; form: INTEGER); - VAR - ch: CHAR; - BEGIN - OPM.WriteString(CaseStat); - CASE form OF - | Char : - ch := CHR (caseVal); - IF (ch >= " ") & (ch <= "~") THEN - OPM.Write(SingleQuote); - IF (ch = "\") OR (ch = "?") OR (ch = SingleQuote) OR (ch = Quotes) THEN OPM.Write("\"); OPM.Write(ch); - ELSE OPM.Write(ch); - END; - OPM.Write(SingleQuote); - ELSE - OPM.WriteString("0x"); OPM.WriteHex (caseVal); - END; - | SInt, Int, LInt : - OPM.WriteInt (caseVal); - ELSE - OPM.LogWStr("unhandled case in OPC.Case, form = "); OPM.LogWNum(form, 0); OPM.LogWLn; - END; - OPM.WriteString(Colon); - END Case; + PROCEDURE CharacterLiteral(c: LONGINT); + BEGIN + IF (c < 32) OR (c > 126) THEN + OPM.WriteString("0x"); OPM.WriteHex(c) + ELSE + OPM.Write("'"); + IF (c = ORD(Backslash)) OR (c = ORD("'")) OR (c = ORD("?")) THEN + OPM.Write(Backslash) + END; + OPM.Write(CHR(c)); + OPM.Write("'") + END + END CharacterLiteral; - PROCEDURE SetInclude* (exclude: BOOLEAN); - BEGIN - IF exclude THEN OPM.WriteString(" &= ~"); ELSE OPM.WriteString(" |= "); END; - END SetInclude; + PROCEDURE StringLiteral(s: ARRAY OF CHAR; l: LONGINT); + VAR i: LONGINT; c: INTEGER; + BEGIN + OPM.Write(DoubleQuote); + i := 0; WHILE i < l DO + c := ORD(s[i]); + IF (c < 32) OR (c > 126) THEN + (* Encode binary character value using exactly 3 octal digits. + Use octal in preference to hex as only the octal escape + syntax ensures a subsequent character will not be absorbed + into this literal. *) + OPM.Write(Backslash); + OPM.Write(CHR(ORD("0") + c DIV 64)); c := c MOD 64; + OPM.Write(CHR(ORD("0") + c DIV 8)); c := c MOD 8; + OPM.Write(CHR(ORD("0") + c)) + ELSE + IF (c = ORD(Backslash)) OR (c = ORD(DoubleQuote)) OR (c = ORD("?")) THEN + OPM.Write(Backslash) + END; + OPM.Write(CHR(c)); + END; + INC(i); + END; + OPM.Write(DoubleQuote) + END StringLiteral; - PROCEDURE Increment* (decrement: BOOLEAN); - BEGIN - IF decrement THEN OPM.WriteString(" -= "); ELSE OPM.WriteString(" += "); END; - END Increment; + PROCEDURE Case*(caseVal: LONGINT; form: INTEGER); + VAR + ch: CHAR; + BEGIN + OPM.WriteString('case '); + CASE form OF + | OPT.Char: CharacterLiteral(caseVal) + | OPT.SInt, + OPT.Int, + OPT.LInt: OPM.WriteInt(caseVal); + ELSE OPM.LogWStr("unhandled case in OPC.Case, form = "); OPM.LogWNum(form, 0); OPM.LogWLn; + END; + OPM.WriteString(': '); + END Case; - PROCEDURE Halt* (n: LONGINT); - BEGIN - Str1("__HALT(#)", n) - END Halt; + PROCEDURE SetInclude* (exclude: BOOLEAN); + BEGIN + IF exclude THEN OPM.WriteString(" &= ~"); ELSE OPM.WriteString(" |= "); END; + END SetInclude; - PROCEDURE Len* (obj: OPT.Object; array: OPT.Struct; dim: LONGINT); - BEGIN - IF array^.comp = DynArr THEN - CompleteIdent(obj); OPM.WriteString(LenExt); - IF dim # 0 THEN OPM.WriteInt(dim) END - ELSE (* array *) - WHILE dim > 0 DO array := array^.BaseTyp; DEC(dim) END ; - OPM.WriteString("((LONGINT)("); OPM.WriteInt(array^.n); OPM.WriteString("))"); - END - END Len; + PROCEDURE Increment* (decrement: BOOLEAN); + BEGIN + IF decrement THEN OPM.WriteString(" -= "); ELSE OPM.WriteString(" += "); END; + END Increment; - PROCEDURE Constant* (con: OPT.Const; form: INTEGER); - VAR i, len: INTEGER; ch: CHAR; s: SET; - hex: LONGINT; skipLeading: BOOLEAN; - BEGIN - CASE form OF - Byte: - OPM.WriteInt(con^.intval) - | Bool: - OPM.WriteInt(con^.intval) - | Char: - ch := CHR(con^.intval); - IF (ch >= " ") & (ch <= "~") THEN - OPM.Write(SingleQuote); - IF (ch = "\") OR (ch = "?") OR (ch = SingleQuote) OR (ch = Quotes) THEN OPM.Write("\") END ; - OPM.Write(ch); - OPM.Write(SingleQuote) - ELSE - OPM.WriteString("0x"); OPM.WriteHex(con^.intval) - END - | SInt, Int, LInt: - OPM.WriteInt(con^.intval) -(* | Int8, Int16, Int32, Int64: - OPM.WriteInt(con^.intval)*) - | Real: - OPM.WriteReal(con^.realval, "f") - | LReal: - OPM.WriteReal(con^.realval, 0X) - | Set: - OPM.WriteString("0x"); - skipLeading := TRUE; - s := con^.setval; i := MAX(SET) + 1; - REPEAT - hex := 0; - REPEAT - DEC(i); hex := 2 * hex; - IF i IN s THEN INC(hex) END - UNTIL i MOD 8 = 0; - IF (hex # 0) OR ~skipLeading THEN - OPM.WriteHex(hex); - skipLeading := FALSE - END - UNTIL i = 0; - IF skipLeading THEN OPM.Write("0") END - | String: - OPM.Write(Quotes); - len := SHORT(con^.intval2) - 1; i := 0; - WHILE i < len DO ch := con^.ext^[i]; - IF (ch = "\") OR (ch = "?") OR (ch = SingleQuote) OR (ch = Quotes) THEN OPM.Write("\") END ; - OPM.Write(ch); INC(i) - END ; - OPM.Write(Quotes) - | NilTyp: - OPM.WriteString(NilConst); - ELSE - OPM.LogWStr("unhandled case in OPC.Constant, form = "); OPM.LogWNum(form, 0); OPM.LogWLn; - END; - END Constant; + PROCEDURE Halt* (n: LONGINT); + BEGIN + Str1("__HALT(#)", n) + END Halt; + + PROCEDURE Len* (obj: OPT.Object; array: OPT.Struct; dim: LONGINT); + BEGIN + IF array^.comp = OPT.DynArr THEN + CompleteIdent(obj); OPM.WriteString(LenExt); + IF dim # 0 THEN OPM.WriteInt(dim) END + ELSE (* array *) + WHILE dim > 0 DO array := array^.BaseTyp; DEC(dim) END ; + OPM.WriteString("((LONGINT)("); OPM.WriteInt(array^.n); OPM.WriteString("))"); + END + END Len; + + PROCEDURE Constant* (con: OPT.Const; form: INTEGER); + VAR i: INTEGER; s: SET; + hex: LONGINT; skipLeading: BOOLEAN; + BEGIN + CASE form OF + | OPT.Byte: OPM.WriteInt(con^.intval) + | OPT.Bool: OPM.WriteInt(con^.intval) + | OPT.Char: CharacterLiteral(con.intval) + | OPT.SInt, + OPT.Int, + OPT.LInt: OPM.WriteInt(con^.intval) + | OPT.Real: OPM.WriteReal(con^.realval, "f") + | OPT.LReal: OPM.WriteReal(con^.realval, 0X) + | OPT.Set: OPM.WriteString("0x"); + skipLeading := TRUE; + s := con^.setval; i := MAX(SET) + 1; + REPEAT + hex := 0; + REPEAT + DEC(i); hex := 2 * hex; + IF i IN s THEN INC(hex) END + UNTIL i MOD 8 = 0; + IF (hex # 0) OR ~skipLeading THEN + OPM.WriteHex(hex); + skipLeading := FALSE + END + UNTIL i = 0; + IF skipLeading THEN OPM.Write("0") END + | OPT.String: StringLiteral(con.ext^, con.intval2-1) + | OPT.NilTyp: OPM.WriteString('NIL'); + ELSE OPM.LogWStr("unhandled case in OPC.Constant, form = "); OPM.LogWNum(form, 0); OPM.LogWLn; + END; + END Constant; - PROCEDURE InitKeywords; - VAR n, i: SHORTINT; + PROCEDURE InitKeywords; + VAR n, i: SHORTINT; - PROCEDURE Enter(s: ARRAY OF CHAR); - VAR h: INTEGER; - BEGIN h := PerfectHash(s); hashtab[h] := n; COPY(s, keytab[n]); INC(n) - END Enter; + PROCEDURE Enter(s: ARRAY OF CHAR); + VAR h: INTEGER; + BEGIN h := PerfectHash(s); hashtab[h] := n; COPY(s, keytab[n]); INC(n) + END Enter; - BEGIN n := 0; - FOR i := 0 TO 104 DO hashtab[i] := -1 END ; - Enter("asm"); - Enter("auto"); - Enter("break"); - Enter("case"); - Enter("char"); - Enter("const"); - Enter("continue"); - Enter("default"); - Enter("do"); - Enter("double"); - Enter("else"); - Enter("enum"); - Enter("extern"); - Enter("export"); (* pseudo keyword used by voc *) - Enter("float"); - Enter("for"); - Enter("fortran"); - Enter("goto"); - Enter("if"); - Enter("import"); (* pseudo keyword used by voc *) - Enter("int"); - Enter("long"); - Enter("register"); - Enter("return"); - Enter("short"); - Enter("signed"); - Enter("sizeof"); - Enter("static"); - Enter("struct"); - Enter("switch"); - Enter("typedef"); - Enter("union"); - Enter("unsigned"); - Enter("void"); - Enter("volatile"); - Enter("while"); + BEGIN n := 0; + FOR i := 0 TO 104 DO hashtab[i] := -1 END ; + Enter("asm"); + Enter("auto"); + Enter("break"); + Enter("case"); + Enter("char"); + Enter("const"); + Enter("continue"); + Enter("default"); + Enter("do"); + Enter("double"); + Enter("else"); + Enter("enum"); + Enter("extern"); + Enter("export"); (* pseudo keyword used by voc *) + Enter("float"); + Enter("for"); + Enter("fortran"); + Enter("goto"); + Enter("if"); + Enter("import"); (* pseudo keyword used by voc *) + Enter("int"); + Enter("long"); + Enter("register"); + Enter("return"); + Enter("short"); + Enter("signed"); + Enter("sizeof"); + Enter("static"); + Enter("struct"); + Enter("switch"); + Enter("typedef"); + Enter("union"); + Enter("unsigned"); + Enter("void"); + Enter("volatile"); + Enter("while"); (* what about common predefined names from cpp as e.g. Operating System: ibm, gcos, os, tss and unix @@ -1415,7 +1359,7 @@ MODULE OPC; (* copyright (c) J. Templ 12.7.95 / 3.7.96 *) The lint(1V) command: lint *) - END InitKeywords; + END InitKeywords; BEGIN InitKeywords END OPC. diff --git a/src/compiler/OPM.cmdln.Mod b/src/compiler/OPM.cmdln.Mod index 5bd9b015..74c0f5dc 100644 --- a/src/compiler/OPM.cmdln.Mod +++ b/src/compiler/OPM.cmdln.Mod @@ -79,6 +79,9 @@ MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *) HFext = ".h"; (* header file extension *) SFtag = 0F7X; (* symbol file tag *) + + + TYPE FileName = ARRAY 32 OF CHAR; @@ -89,11 +92,9 @@ MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *) ByteSize*, CharSize*, BoolSize*, SIntSize*, IntSize*, LIntSize*, SetSize*, RealSize*, LRealSize*, PointerSize*, ProcSize*, RecSize*, - CharAlign*, BoolAlign*, SIntAlign*, IntAlign*, - LIntAlign*, SetAlign*, RealAlign*, LRealAlign*, PointerAlign*, ProcAlign*, RecAlign*, MaxSet*: INTEGER; - MinSInt*, MinInt*, MinLInt*, MaxSInt*, MaxInt*, MaxLInt*, MaxIndex*: LONGINT; + MaxIndex*: LONGINT; MinReal*, MaxReal*, MinLReal*, MaxLReal*: LONGREAL; @@ -142,27 +143,30 @@ MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *) i := 1; (* skip - *) WHILE s[i] # 0X DO CASE s[i] OF - | "e": opt := opt / {extsf} - | "s": opt := opt / {newsf} - | "m": opt := opt / {mainprog} - | "x": opt := opt / {inxchk} - | "r": opt := opt / {ranchk} - | "t": opt := opt / {typchk} + | "a": opt := opt / {assert} - | "k": opt := opt / {ansi} (* undocumented *) - | "p": opt := opt / {ptrinit} - | "S": opt := opt / {dontasm} | "c": opt := opt / {dontlink} - | "M": opt := opt / {mainlinkstat} + | "e": opt := opt / {extsf} | "f": opt := opt / {notcoloroutput} - | "F": opt := opt / {forcenewsym} - | "V": opt := opt / {verbose} + | "k": opt := opt / {ansi} (* undocumented *) + | "m": opt := opt / {mainprog} + | "p": opt := opt / {ptrinit} + | "r": opt := opt / {ranchk} + | "s": opt := opt / {newsf} + | "t": opt := opt / {typchk} + | "x": opt := opt / {inxchk} + | "B": IF s[i+1] # 0X THEN INC(i); IntSize := ORD(s[i]) - ORD('0') END; IF s[i+1] # 0X THEN INC(i); PointerSize := ORD(s[i]) - ORD('0') END; IF s[i+1] # 0X THEN INC(i); Alignment := ORD(s[i]) - ORD('0') END; ASSERT((IntSize = 2) OR (IntSize = 4)); ASSERT((PointerSize = 4) OR (PointerSize = 8)); - ASSERT((Alignment = 4) OR (Alignment = 8)) + ASSERT((Alignment = 4) OR (Alignment = 8)); + Files.SetSearchPath("") + | "F": opt := opt / {forcenewsym} + | "M": opt := opt / {mainlinkstat} + | "S": opt := opt / {dontasm} + | "V": opt := opt / {verbose} ELSE LogWStr(" warning: option "); LogW(OptionChar); @@ -458,15 +462,28 @@ MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *) PROCEDURE FPrintReal*(VAR fp: LONGINT; real: REAL); - BEGIN FPrint(fp, SYSTEM.VAL(LONGINT, real)) + VAR i: INTEGER; l: LONGINT; + BEGIN + IF SIZE(REAL) = SIZE(INTEGER) THEN + SYSTEM.GET(SYSTEM.ADR(real), i); l := i; + ELSE + SYSTEM.GET(SYSTEM.ADR(real), l); + END; + FPrint(fp, l) END FPrintReal; PROCEDURE FPrintLReal*(VAR fp: LONGINT; lr: LONGREAL); VAR l, h: LONGINT; BEGIN - SYSTEM.GET(SYSTEM.ADR(lr), l); SYSTEM.GET(SYSTEM.ADR(lr)+4, h); - FPrint(fp, l); FPrint(fp, h) + IF SIZE(LONGREAL) = SIZE(LONGINT) THEN + (* 64 bit LONGINT *) + FPrint(fp, SYSTEM.VAL(LONGINT, lr)) + ELSE + (* 32 bit LONGINT *) + SYSTEM.GET(SYSTEM.ADR(lr), l); SYSTEM.GET(SYSTEM.ADR(lr)+4, h); + FPrint(fp, l); FPrint(fp, h) + END END FPrintLReal; @@ -484,10 +501,10 @@ MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *) END GetProperty; - PROCEDURE minus(i: LONGINT): LONGINT; + PROCEDURE minusop(i: LONGINT): LONGINT; BEGIN RETURN -i; - END minus; + END minusop; PROCEDURE power0(i, j : LONGINT) : LONGINT; (* we would like to calculate exact Min Max values in GetProperties, not hardcode em, noch *) @@ -508,34 +525,63 @@ MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *) BEGIN LogWLn; LogWStr("Type Size Alignement"); LogWLn; - LogWStr("CHAR "); LogWNum(CharSize, 4); LogWNum(CharAlign, 5); LogWLn; - LogWStr("BOOLEAN "); LogWNum(BoolSize, 4); LogWNum(BoolAlign, 5); LogWLn; - LogWStr("SHORTINT "); LogWNum(SIntSize, 4); LogWNum(SIntAlign, 5); LogWLn; - LogWStr("INTEGER "); LogWNum(IntSize, 4); LogWNum(IntAlign, 5); LogWLn; - LogWStr("LONGINT "); LogWNum(LIntSize, 4); LogWNum(LIntAlign, 5); LogWLn; - LogWStr("SET "); LogWNum(SetSize, 4); LogWNum(SetAlign, 5); LogWLn; - LogWStr("REAL "); LogWNum(RealSize, 4); LogWNum(RealAlign, 5); LogWLn; - LogWStr("LONGREAL "); LogWNum(LRealSize, 4); LogWNum(LRealAlign, 5); LogWLn; - LogWStr("PTR "); LogWNum(PointerSize, 4); LogWNum(PointerAlign, 5); LogWLn; - LogWStr("PROC "); LogWNum(ProcSize, 4); LogWNum(ProcAlign, 5); LogWLn; - LogWStr("RECORD "); LogWNum(RecSize, 4); LogWNum(RecAlign, 5); LogWLn; + LogWStr("CHAR "); LogWNum(CharSize, 4); (* LogWNum(CharAlign, 5); *) LogWLn; + LogWStr("BOOLEAN "); LogWNum(BoolSize, 4); (* LogWNum(BoolAlign, 5); *) LogWLn; + LogWStr("SHORTINT "); LogWNum(SIntSize, 4); (* LogWNum(SIntAlign, 5); *) LogWLn; + LogWStr("INTEGER "); LogWNum(IntSize, 4); (* LogWNum(IntAlign, 5); *) LogWLn; + LogWStr("LONGINT "); LogWNum(LIntSize, 4); (* LogWNum(LIntAlign, 5); *) LogWLn; + LogWStr("SET "); LogWNum(SetSize, 4); (* LogWNum(SetAlign, 5); *) LogWLn; + LogWStr("REAL "); LogWNum(RealSize, 4); (* LogWNum(RealAlign, 5); *) LogWLn; + LogWStr("LONGREAL "); LogWNum(LRealSize, 4); (* LogWNum(LRealAlign, 5); *) LogWLn; + LogWStr("PTR "); LogWNum(PointerSize, 4); (* LogWNum(PointerAlign, 5); *) LogWLn; + LogWStr("PROC "); LogWNum(ProcSize, 4); (* LogWNum(ProcAlign, 5); *) LogWLn; + LogWStr("RECORD "); LogWNum(RecSize, 4); (* LogWNum(RecAlign, 5); *) LogWLn; (*LogWStr("ENDIAN "); LogWNum(ByteOrder, 4); LogWNum(BitOrder, 5); LogWLn;*) LogWLn; + (* LogWStr("Min shortint "); LogWNum(MinSInt, 4); LogWLn; LogWStr("Max shortint "); LogWNum(MaxSInt, 4); LogWLn; LogWStr("Min integer "); LogWNum(MinInt, 4); LogWLn; LogWStr("Max integer "); LogWNum(MaxInt, 4); LogWLn; LogWStr("Min longint "); LogWNum(MinLInt, 4); LogWLn; + *) END VerboseListSizes; - PROCEDURE Min(a,b: INTEGER): INTEGER; - BEGIN IF a 8 THEN align := 16 + ELSIF size > 4 THEN align := 8 + ELSIF size > 2 THEN align := 4 + ELSE align := SHORT(size) + END + ELSE + align := Alignment + END; + RETURN align + END AlignSize; + *) + + PROCEDURE SignedMaximum*(bytecount: LONGINT): LONGINT; + VAR result: LONGINT; + BEGIN + result := 1; + result := SYSTEM.LSH(result, bytecount*8-1); + RETURN result - 1; + END SignedMaximum; + + PROCEDURE SignedMinimum*(bytecount: LONGINT): LONGINT; + BEGIN RETURN -SignedMaximum(bytecount) - 1 + END SignedMinimum; + + + PROCEDURE GetProperties(); - VAR - base: LONGINT; + (* VAR base: LONGINT; *) BEGIN (* Fixed and Configuration.Mod based sizes have been initialised in the module startup code, and maybe overridden by the -Bnnn bootstrap @@ -546,30 +592,6 @@ MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *) LIntSize := IntSize * 2; SetSize := LIntSize; - (* Calculate all type alignments *) - CharAlign := Min(Alignment, CharSize); - BoolAlign := Min(Alignment, BoolSize); - SIntAlign := Min(Alignment, SIntSize); - RecAlign := Min(Alignment, RecSize); - RealAlign := Min(Alignment, RealSize); - LRealAlign := Min(Alignment, LRealSize); - PointerAlign := Min(Alignment, PointerSize); - ProcAlign := Min(Alignment, ProcSize); - IntAlign := Min(Alignment, IntSize); - LIntAlign := Min(Alignment, LIntSize); - SetAlign := Min(Alignment, SetSize); - - (* and I'd like to calculate it, not hardcode constants *) - base := -2; - MinSInt := ASH(base, SIntSize*8-2); - MaxSInt := minus(MinSInt + 1); - - MinInt := ASH(base, IntSize*8-2); - MaxInt := minus(MinInt + 1); - - MinLInt := ASH(base, LIntSize*8-2); - MaxLInt := minus(MinLInt +1); - IF RealSize = 4 THEN MaxReal := 3.40282346D38 ELSIF RealSize = 8 THEN MaxReal := 1.7976931348623157D307 * 9.999999 (*should be 1.7976931348623157D308 *) @@ -580,20 +602,17 @@ MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *) (*should be 1.7976931348623157D308 *) END ; - MinReal := -MaxReal; + MinReal := -MaxReal; MinLReal := -MaxLReal; - - MaxSet := SetSize * 8 - 1; - MaxIndex := MaxLInt; (* shouldn't it be like max(int)? so that for loop will be safe, noch *) + MaxSet := SetSize * 8 - 1; + MaxIndex := SignedMaximum(PointerSize); IF Verbose THEN VerboseListSizes END; END GetProperties; - - - (* ------------------------- Read Symbol File ------------------------- *) + PROCEDURE SymRCh*(VAR ch: CHAR); BEGIN Files.Read(oldSF, ch) END SymRCh; @@ -715,7 +734,7 @@ MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *) PROCEDURE WriteInt* (i: LONGINT); VAR s: ARRAY 20 OF CHAR; i1, k: LONGINT; BEGIN - IF (i = MinInt) OR (i = MinLInt) THEN + IF (i = SignedMinimum(IntSize)) OR (i = SignedMinimum(LIntSize)) THEN (* abs(minint) is one more than maxint, causing problems representing the value as a minus sign followed by absoute value. Therefore represent as -maxint - 1. For INTEGER this avoids a compiler warning 'this decimal constant is unsigned only in ISO C90', for LONGINT it is the @@ -733,7 +752,7 @@ MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *) VAR W: Texts.Writer; T: Texts.Text; R: Texts.Reader; s: ARRAY 32 OF CHAR; ch: CHAR; i: INTEGER; BEGIN (*should be improved *) - IF (r < MaxLInt) & (r > MinLInt) & (r = ENTIER(r)) THEN + IF (r < SignedMaximum(LIntSize)) & (r > SignedMinimum(LIntSize)) & (r = ENTIER(r)) THEN IF suffx = "f" THEN WriteString("(REAL)") ELSE WriteString("(LONGREAL)") END ; WriteInt(ENTIER(r)) ELSE diff --git a/src/compiler/OPP.Mod b/src/compiler/OPP.Mod index a9f30a0c..56f2a3d0 100644 --- a/src/compiler/OPP.Mod +++ b/src/compiler/OPP.Mod @@ -3,68 +3,6 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) IMPORT OPB, OPT, OPS, OPM; - CONST - (* numtyp values *) - char = 1; integer = 2; real = 3; longreal = 4; - - (* symbol values *) - null = 0; times = 1; slash = 2; div = 3; mod = 4; - and = 5; plus = 6; minus = 7; or = 8; eql = 9; - neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; - in = 15; is = 16; arrow = 17; period = 18; comma = 19; - colon = 20; upto = 21; rparen = 22; rbrak = 23; rbrace = 24; - of = 25; then = 26; do = 27; to = 28; by = 29; - lparen = 30; lbrak = 31; lbrace = 32; not = 33; becomes = 34; - number = 35; nil = 36; string = 37; ident = 38; semicolon = 39; - bar = 40; end = 41; else = 42; elsif = 43; until = 44; - if = 45; case = 46; while = 47; repeat = 48; for = 49; - loop = 50; with = 51; exit = 52; return = 53; array = 54; - record = 55; pointer = 56; begin = 57; const = 58; type = 59; - var = 60; procedure = 61; import = 62; module = 63; eof = 64; - - (* object modes *) - Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; - SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; - - (* Structure forms *) - Undef = 0; Byte = 1; Bool = 2; Char = 3; - SInt = 4; Int = 5; LInt = 6; - Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Comp = 15; - (*Int8 = 7; Int16 = 8; Int32 = 9; Int64 = 10; - Real = 11; LReal = 12; Set = 13; String = 14; NilTyp = 15; NoTyp = 16; - Pointer = 17; ProcTyp = 18; - Comp = 19;*) - (*Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18; - Comp = (*15*)19;*) - - intSet = {SInt..LInt(*, Int8..Int64*)}; - - (* composite structure forms *) - Basic = 1; Array = 2; DynArr = 3; Record = 4; - - (*function number*) - haltfn = 0; newfn = 1; incfn = 13; sysnewfn = 30; - - (* nodes classes *) - Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; - Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; - Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; - Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; - Nreturn = 26; Nwith = 27; Ntrap = 28; - - (* node subclasses *) - super = 1; - - (* module visibility of objects *) - internal = 0; external = 1; externalR = 2; - - (* procedure flags (conval^.setval) *) - hasBody = 1; isRedef = 2; slNeeded = 3; - TYPE CaseTable = ARRAY OPM.MaxCases OF RECORD @@ -93,19 +31,19 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE qualident(VAR id: OPT.Object); VAR obj: OPT.Object; lev: SHORTINT; - BEGIN (*sym = ident*) + BEGIN (*sym = OPS.ident*) OPT.Find(obj); OPS.Get(sym); - IF (sym = period) & (obj # NIL) & (obj^.mode = Mod) THEN + IF (sym = OPS.period) & (obj # NIL) & (obj^.mode = OPT.Mod) THEN OPS.Get(sym); - IF sym = ident THEN + IF sym = OPS.ident THEN OPT.FindImport(obj, obj); OPS.Get(sym) - ELSE err(ident); obj := NIL + ELSE err(OPS.ident); obj := NIL END END ; IF obj = NIL THEN err(0); - obj := OPT.NewObj(); obj^.mode := Var; obj^.typ := OPT.undftyp; obj^.adr := 0 + obj := OPT.NewObj(); obj^.mode := OPT.Var; obj^.typ := OPT.undftyp; obj^.adr := 0 ELSE lev := obj^.mnolev; - IF (obj^.mode IN {Var, VarPar}) & (lev # level) THEN + IF (obj^.mode IN {OPT.Var, OPT.VarPar}) & (lev # level) THEN obj^.leaf := FALSE; IF lev > 0 THEN OPB.StaticLink(level-lev) END END @@ -115,32 +53,32 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE ConstExpression(VAR x: OPT.Node); BEGIN Expression(x); - IF x^.class # Nconst THEN + IF x^.class # OPT.Nconst THEN err(50); x := OPB.NewIntConst(1) END END ConstExpression; PROCEDURE CheckMark(VAR vis: SHORTINT); BEGIN OPS.Get(sym); - IF (sym = times) OR (sym = minus) THEN + IF (sym = OPS.times) OR (sym = OPS.minus) THEN IF level > 0 THEN err(47) END ; - IF sym = times THEN vis := external ELSE vis := externalR END ; + IF sym = OPS.times THEN vis := OPT.external ELSE vis := OPT.externalR END ; OPS.Get(sym) - ELSE vis := internal + ELSE vis := OPT.internal END END CheckMark; PROCEDURE CheckSysFlag(VAR sysflag: INTEGER; default: INTEGER); VAR x: OPT.Node; sf: LONGINT; BEGIN - IF sym = lbrak THEN OPS.Get(sym); + IF sym = OPS.lbrak THEN OPS.Get(sym); IF ~OPT.SYSimported THEN err(135) END; ConstExpression(x); - IF x^.typ^.form IN intSet THEN sf := x^.conval^.intval; + IF x^.typ^.form IN OPT.intSet THEN sf := x^.conval^.intval; IF (sf < 0) OR (sf > OPM.MaxSysFlag) THEN err(220); sf := 0 END ELSE err(51); sf := 0 END ; - sysflag := SHORT(sf); CheckSym(rbrak) + sysflag := SHORT(sf); CheckSym(OPS.rbrak) ELSE sysflag := default END END CheckSysFlag; @@ -148,54 +86,54 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE RecordType(VAR typ, banned: OPT.Struct); VAR fld, first, last, base: OPT.Object; ftyp: OPT.Struct; sysflag: INTEGER; - BEGIN typ := OPT.NewStr(Comp, Record); typ^.BaseTyp := NIL; + BEGIN typ := OPT.NewStr(OPT.Comp, OPT.Record); typ^.BaseTyp := NIL; CheckSysFlag(sysflag, -1); - IF sym = lparen THEN + IF sym = OPS.lparen THEN OPS.Get(sym); (*record extension*) - IF sym = ident THEN + IF sym = OPS.ident THEN qualident(base); - IF (base^.mode = Typ) & (base^.typ^.comp = Record) THEN + IF (base^.mode = OPT.Typ) & (base^.typ^.comp = OPT.Record) THEN IF base^.typ = banned THEN err(58) ELSE base^.typ^.pvused := TRUE; typ^.BaseTyp := base^.typ; typ^.extlev := base^.typ^.extlev + 1; typ^.sysflag := base^.typ^.sysflag END ELSE err(52) END - ELSE err(ident) + ELSE err(OPS.ident) END ; - CheckSym(rparen) + CheckSym(OPS.rparen) END ; IF sysflag >= 0 THEN typ^.sysflag := sysflag END ; OPT.OpenScope(0, NIL); first := NIL; last := NIL; LOOP - IF sym = ident THEN + IF sym = OPS.ident THEN LOOP - IF sym = ident THEN + IF sym = OPS.ident THEN IF typ^.BaseTyp # NIL THEN OPT.FindField(OPS.name, typ^.BaseTyp, fld); IF fld # NIL THEN err(1) END END ; OPT.Insert(OPS.name, fld); CheckMark(fld^.vis); - fld^.mode := Fld; fld^.link := NIL; fld^.typ := OPT.undftyp; + fld^.mode := OPT.Fld; fld^.link := NIL; fld^.typ := OPT.undftyp; IF first = NIL THEN first := fld END ; IF last = NIL THEN typ^.link := fld ELSE last^.link := fld END ; last := fld - ELSE err(ident) + ELSE err(OPS.ident) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF sym = ident THEN err(comma) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF sym = OPS.ident THEN err(OPS.comma) ELSE EXIT END END ; - CheckSym(colon); Type(ftyp, banned); + CheckSym(OPS.colon); Type(ftyp, banned); ftyp^.pvused := TRUE; - IF ftyp^.comp = DynArr THEN ftyp := OPT.undftyp; err(88) END ; + IF ftyp^.comp = OPT.DynArr THEN ftyp := OPT.undftyp; err(88) END ; WHILE first # NIL DO first^.typ := ftyp; first := first^.link END END ; - IF sym = semicolon THEN OPS.Get(sym) - ELSIF sym = ident THEN err(semicolon) + IF sym = OPS.semicolon THEN OPS.Get(sym) + ELSIF sym = OPS.ident THEN err(OPS.semicolon) ELSE EXIT END END ; @@ -205,36 +143,36 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE ArrayType(VAR typ, banned: OPT.Struct); VAR x: OPT.Node; n: LONGINT; sysflag: INTEGER; BEGIN CheckSysFlag(sysflag, 0); - IF sym = of THEN (*dynamic array*) - typ := OPT.NewStr(Comp, DynArr); typ^.mno := 0; typ^.sysflag := sysflag; + IF sym = OPS.of THEN (*dynamic array*) + typ := OPT.NewStr(OPT.Comp, OPT.DynArr); typ^.mno := 0; typ^.sysflag := sysflag; OPS.Get(sym); Type(typ^.BaseTyp, banned); typ^.BaseTyp^.pvused := TRUE; - IF typ^.BaseTyp^.comp = DynArr THEN typ^.n := typ^.BaseTyp^.n + 1 + IF typ^.BaseTyp^.comp = OPT.DynArr THEN typ^.n := typ^.BaseTyp^.n + 1 ELSE typ^.n := 0 END ELSE - typ := OPT.NewStr(Comp, Array); typ^.sysflag := sysflag; ConstExpression(x); - IF x^.typ^.form IN intSet THEN n := x^.conval^.intval; + typ := OPT.NewStr(OPT.Comp, OPT.Array); typ^.sysflag := sysflag; ConstExpression(x); + IF x^.typ^.form IN OPT.intSet THEN n := x^.conval^.intval; IF (n <= 0) OR (n > OPM.MaxIndex) THEN err(63); n := 1 END ELSE err(51); n := 1 END ; typ^.n := n; - IF sym = of THEN + IF sym = OPS.of THEN OPS.Get(sym); Type(typ^.BaseTyp, banned); typ^.BaseTyp^.pvused := TRUE - ELSIF sym = comma THEN - OPS.Get(sym); IF sym # of THEN ArrayType(typ^.BaseTyp, banned) END + ELSIF sym = OPS.comma THEN + OPS.Get(sym); IF sym # OPS.of THEN ArrayType(typ^.BaseTyp, banned) END ELSE err(35) END ; - IF typ^.BaseTyp^.comp = DynArr THEN typ^.BaseTyp := OPT.undftyp; err(88) END + IF typ^.BaseTyp^.comp = OPT.DynArr THEN typ^.BaseTyp := OPT.undftyp; err(88) END END END ArrayType; PROCEDURE PointerType(VAR typ: OPT.Struct); VAR id: OPT.Object; - BEGIN typ := OPT.NewStr(Pointer, Basic); CheckSysFlag(typ^.sysflag, 0); - CheckSym(to); - IF sym = ident THEN OPT.Find(id); + BEGIN typ := OPT.NewStr(OPT.Pointer, OPT.Basic); CheckSysFlag(typ^.sysflag, 0); + CheckSym(OPS.to); + IF sym = OPS.ident THEN OPT.Find(id); IF id = NIL THEN IF nofFwdPtr < LEN(FwdPtr) THEN FwdPtr[nofFwdPtr] := typ; INC(nofFwdPtr) ELSE err(224) @@ -242,8 +180,8 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) typ^.link := OPT.NewObj(); COPY(OPS.name, typ^.link^.name); typ^.BaseTyp := OPT.undftyp; OPS.Get(sym) (*forward ref*) ELSE qualident(id); - IF id^.mode = Typ THEN - IF id^.typ^.comp IN {Array, DynArr, Record} THEN + IF id^.mode = OPT.Typ THEN + IF id^.typ^.comp IN {OPT.Array, OPT.DynArr, OPT.Record} THEN typ^.BaseTyp := id^.typ ELSE typ^.BaseTyp := OPT.undftyp; err(57) END @@ -251,7 +189,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) END END ELSE Type(typ^.BaseTyp, OPT.notyp); - IF ~(typ^.BaseTyp^.comp IN {Array, DynArr, Record}) THEN + IF ~(typ^.BaseTyp^.comp IN {OPT.Array, OPT.DynArr, OPT.Record}) THEN typ^.BaseTyp := OPT.undftyp; err(57) END END @@ -261,45 +199,45 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) VAR mode: SHORTINT; par, first, last, res: OPT.Object; typ: OPT.Struct; BEGIN first := NIL; last := firstPar; - IF (sym = ident) OR (sym = var) THEN + IF (sym = OPS.ident) OR (sym = OPS.var) THEN LOOP - IF sym = var THEN OPS.Get(sym); mode := VarPar ELSE mode := Var END ; + IF sym = OPS.var THEN OPS.Get(sym); mode := OPT.VarPar ELSE mode := OPT.Var END ; LOOP - IF sym = ident THEN + IF sym = OPS.ident THEN OPT.Insert(OPS.name, par); OPS.Get(sym); par^.mode := mode; par^.link := NIL; IF first = NIL THEN first := par END ; IF firstPar = NIL THEN firstPar := par ELSE last^.link := par END ; last := par - ELSE err(ident) + ELSE err(OPS.ident) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF sym = ident THEN err(comma) - ELSIF sym = var THEN err(comma); OPS.Get(sym) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF sym = OPS.ident THEN err(OPS.comma) + ELSIF sym = OPS.var THEN err(OPS.comma); OPS.Get(sym) ELSE EXIT END END ; - CheckSym(colon); Type(typ, OPT.notyp); - IF mode = Var THEN typ^.pvused := TRUE END ; + CheckSym(OPS.colon); Type(typ, OPT.notyp); + IF mode = OPT.Var THEN typ^.pvused := TRUE END ; (* typ^.pbused is set when parameter type name is parsed *) WHILE first # NIL DO first^.typ := typ; first := first^.link END ; - IF sym = semicolon THEN OPS.Get(sym) - ELSIF sym = ident THEN err(semicolon) + IF sym = OPS.semicolon THEN OPS.Get(sym) + ELSIF sym = OPS.ident THEN err(OPS.semicolon) ELSE EXIT END END END ; - CheckSym(rparen); - IF sym = colon THEN + CheckSym(OPS.rparen); + IF sym = OPS.colon THEN OPS.Get(sym); resTyp := OPT.undftyp; - IF sym = ident THEN qualident(res); - IF res^.mode = Typ THEN - IF (res^.typ^.form < Comp) (*OR (res^.typ^.form >= Int8) & (res^.typ^.form <= Int64)*) THEN resTyp := res^.typ; + IF sym = OPS.ident THEN qualident(res); + IF res^.mode = OPT.Typ THEN + IF (res^.typ^.form < OPT.Comp) (*OR (res^.typ^.form >= Int8) & (res^.typ^.form <= Int64)*) THEN resTyp := res^.typ; ELSE err(54) END ELSE err(52) END - ELSE err(ident) + ELSE err(OPS.ident) END ELSE resTyp := OPT.notyp END @@ -308,24 +246,26 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE TypeDecl(VAR typ, banned: OPT.Struct); VAR id: OPT.Object; BEGIN typ := OPT.undftyp; - IF sym < lparen THEN err(12); - REPEAT OPS.Get(sym) UNTIL sym >= lparen + IF sym < OPS.lparen THEN err(12); + REPEAT OPS.Get(sym) UNTIL sym >= OPS.lparen END ; - IF sym = ident THEN qualident(id); - IF id^.mode = Typ THEN - IF id^.typ # banned THEN typ := id^.typ ELSE err(58) END + IF sym = OPS.ident THEN qualident(id); + IF id^.mode = OPT.Typ THEN + IF id^.typ = banned THEN err(58) ELSE + typ := id.typ + END ELSE err(52) END - ELSIF sym = array THEN + ELSIF sym = OPS.array THEN OPS.Get(sym); ArrayType(typ, banned) - ELSIF sym = record THEN + ELSIF sym = OPS.record THEN OPS.Get(sym); RecordType(typ, banned); - OPB.Inittd(TDinit, lastTDinit, typ); CheckSym(end) - ELSIF sym = pointer THEN + OPB.Inittd(TDinit, lastTDinit, typ); CheckSym(OPS.end) + ELSIF sym = OPS.pointer THEN OPS.Get(sym); PointerType(typ) - ELSIF sym = procedure THEN - OPS.Get(sym); typ := OPT.NewStr(ProcTyp, Basic); CheckSysFlag(typ^.sysflag, 0); - IF sym = lparen THEN + ELSIF sym = OPS.procedure THEN + OPS.Get(sym); typ := OPT.NewStr(OPT.ProcTyp, OPT.Basic); CheckSysFlag(typ^.sysflag, 0); + IF sym = OPS.lparen THEN OPS.Get(sym); OPT.OpenScope(level, NIL); FormalParameters(typ^.link, typ^.BaseTyp); OPT.CloseScope ELSE typ^.BaseTyp := OPT.notyp; typ^.link := NIL @@ -333,69 +273,69 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) ELSE err(12) END ; LOOP - IF (sym >= semicolon) & (sym <= else) OR (sym = rparen) OR (sym = eof) THEN EXIT END; - err(15); IF sym = ident THEN EXIT END; + IF (sym >= OPS.semicolon) & (sym <= OPS.else) OR (sym = OPS.rparen) OR (sym = OPS.eof) THEN EXIT END; + err(15); IF sym = OPS.ident THEN EXIT END; OPS.Get(sym) END END TypeDecl; PROCEDURE Type(VAR typ, banned: OPT.Struct); BEGIN TypeDecl(typ, banned); - IF (typ^.form = Pointer) & (typ^.BaseTyp = OPT.undftyp) & (typ^.strobj = NIL) THEN err(0) END + IF (typ^.form = OPT.Pointer) & (typ^.BaseTyp = OPT.undftyp) & (typ^.strobj = NIL) THEN err(0) END END Type; PROCEDURE selector(VAR x: OPT.Node); VAR obj, proc: OPT.Object; y: OPT.Node; typ: OPT.Struct; name: OPS.Name; BEGIN LOOP - IF sym = lbrak THEN OPS.Get(sym); + IF sym = OPS.lbrak THEN OPS.Get(sym); LOOP - IF (x^.typ # NIL) & (x^.typ^.form = Pointer) THEN OPB.DeRef(x) END ; + IF (x^.typ # NIL) & (x^.typ^.form = OPT.Pointer) THEN OPB.DeRef(x) END ; Expression(y); OPB.Index(x, y); - IF sym = comma THEN OPS.Get(sym) ELSE EXIT END + IF sym = OPS.comma THEN OPS.Get(sym) ELSE EXIT END END ; - CheckSym(rbrak) - ELSIF sym = period THEN OPS.Get(sym); - IF sym = ident THEN name := OPS.name; OPS.Get(sym); + CheckSym(OPS.rbrak) + ELSIF sym = OPS.period THEN OPS.Get(sym); + IF sym = OPS.ident THEN name := OPS.name; OPS.Get(sym); IF x^.typ # NIL THEN - IF x^.typ^.form = Pointer THEN OPB.DeRef(x) END ; - IF x^.typ^.comp = Record THEN + IF x^.typ^.form = OPT.Pointer THEN OPB.DeRef(x) END ; + IF x^.typ^.comp = OPT.Record THEN OPT.FindField(name, x^.typ, obj); OPB.Field(x, obj); - IF (obj # NIL) & (obj^.mode = TProc) THEN - IF sym = arrow THEN (* super call *) OPS.Get(sym); + IF (obj # NIL) & (obj^.mode = OPT.TProc) THEN + IF sym = OPS.arrow THEN (* super call *) OPS.Get(sym); y := x^.left; - IF y^.class = Nderef THEN y := y^.left END ; (* y = record variable *) + IF y^.class = OPT.Nderef THEN y := y^.left END ; (* y = record variable *) IF y^.obj # NIL THEN - proc := OPT.topScope; (* find innermost scope which owner is a TProc *) - WHILE (proc^.link # NIL) & (proc^.link^.mode # TProc) DO proc := proc^.left END ; + proc := OPT.topScope; (* find innermost scope which owner is a OPT.TProc *) + WHILE (proc^.link # NIL) & (proc^.link^.mode # OPT.TProc) DO proc := proc^.left END ; IF (proc^.link = NIL) OR (proc^.link^.link # y^.obj) THEN err(75) END ; typ := y^.obj^.typ; - IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ; + IF typ^.form = OPT.Pointer THEN typ := typ^.BaseTyp END ; OPT.FindField(x^.obj^.name, typ^.BaseTyp, proc); - IF proc # NIL THEN x^.subcl := super ELSE err(74) END + IF proc # NIL THEN x^.subcl := OPT.super ELSE err(74) END ELSE err(75) END END ; - IF (obj^.typ # OPT.notyp) & (sym # lparen) THEN err(lparen) END + IF (obj^.typ # OPT.notyp) & (sym # OPS.lparen) THEN err(OPS.lparen) END END ELSE err(53) END ELSE err(52) END - ELSE err(ident) + ELSE err(OPS.ident) END - ELSIF sym = arrow THEN OPS.Get(sym); OPB.DeRef(x) - ELSIF (sym = lparen) & (x^.class < Nconst) & (x^.typ^.form # ProcTyp) & - ((x^.obj = NIL) OR (x^.obj^.mode # TProc)) THEN + ELSIF sym = OPS.arrow THEN OPS.Get(sym); OPB.DeRef(x) + ELSIF (sym = OPS.lparen) & (x^.class < OPT.Nconst) & (x^.typ^.form # OPT.ProcTyp) & + ((x^.obj = NIL) OR (x^.obj^.mode # OPT.TProc)) THEN OPS.Get(sym); - IF sym = ident THEN + IF sym = OPS.ident THEN qualident(obj); - IF obj^.mode = Typ THEN OPB.TypTest(x, obj, TRUE) + IF obj^.mode = OPT.Typ THEN OPB.TypTest(x, obj, TRUE) ELSE err(52) END - ELSE err(ident) + ELSE err(OPS.ident) END ; - CheckSym(rparen) + CheckSym(OPS.rparen) ELSE EXIT END END @@ -404,15 +344,15 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE ActualParameters(VAR aparlist: OPT.Node; fpar: OPT.Object); VAR apar, last: OPT.Node; BEGIN aparlist := NIL; last := NIL; - IF sym # rparen THEN + IF sym # OPS.rparen THEN LOOP Expression(apar); IF fpar # NIL THEN OPB.Param(apar, fpar); OPB.Link(aparlist, last, apar); fpar := fpar^.link; ELSE err(64) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF (OPS.lparen <= sym) & (sym <= OPS.ident) THEN err(OPS.comma) ELSE EXIT END END @@ -423,31 +363,31 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE StandProcCall(VAR x: OPT.Node); VAR y: OPT.Node; m: SHORTINT; n: INTEGER; BEGIN m := SHORT(SHORT(x^.obj^.adr)); n := 0; - IF sym = lparen THEN OPS.Get(sym); - IF sym # rparen THEN + IF sym = OPS.lparen THEN OPS.Get(sym); + IF sym # OPS.rparen THEN LOOP IF n = 0 THEN Expression(x); OPB.StPar0(x, m); n := 1 ELSIF n = 1 THEN Expression(y); OPB.StPar1(x, y, m); n := 2 ELSE Expression(y); OPB.StParN(x, y, m, n); INC(n) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF (OPS.lparen <= sym) & (sym <= OPS.ident) THEN err(OPS.comma) ELSE EXIT END END ; - CheckSym(rparen) + CheckSym(OPS.rparen) ELSE OPS.Get(sym) END ; OPB.StFct(x, m, n) - ELSE err(lparen) + ELSE err(OPS.lparen) END ; - IF (level > 0) & ((m = newfn) OR (m = sysnewfn)) THEN OPT.topScope^.link^.leaf := FALSE END + IF (level > 0) & ((m = OPT.newfn) OR (m = OPT.sysnewfn)) THEN OPT.topScope^.link^.leaf := FALSE END END StandProcCall; PROCEDURE Element(VAR x: OPT.Node); VAR y: OPT.Node; BEGIN Expression(x); - IF sym = upto THEN + IF sym = OPS.upto THEN OPS.Get(sym); Expression(y); OPB.SetRange(x, y) ELSE OPB.SetElem(x) END @@ -456,57 +396,57 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE Sets(VAR x: OPT.Node); VAR y: OPT.Node; BEGIN - IF sym # rbrace THEN + IF sym # OPS.rbrace THEN Element(x); LOOP - IF sym = comma THEN OPS.Get(sym) - ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF (OPS.lparen <= sym) & (sym <= OPS.ident) THEN err(OPS.comma) ELSE EXIT END ; - Element(y); OPB.Op(plus, x, y) + Element(y); OPB.Op(OPS.plus, x, y) END ELSE x := OPB.EmptySet() END ; - CheckSym(rbrace) + CheckSym(OPS.rbrace) END Sets; PROCEDURE Factor(VAR x: OPT.Node); VAR fpar, id: OPT.Object; apar: OPT.Node; BEGIN - IF sym < lparen THEN err(13); - REPEAT OPS.Get(sym) UNTIL sym >= lparen + IF sym < OPS.lparen THEN err(13); + REPEAT OPS.Get(sym) UNTIL sym >= OPS.lparen END ; - IF sym = ident THEN + IF sym = OPS.ident THEN qualident(id); x := OPB.NewLeaf(id); selector(x); - IF (x^.class = Nproc) & (x^.obj^.mode = SProc) THEN StandProcCall(x) (* x may be NIL *) - ELSIF sym = lparen THEN + IF (x^.class = OPT.Nproc) & (x^.obj^.mode = OPT.SProc) THEN StandProcCall(x) (* x may be NIL *) + ELSIF sym = OPS.lparen THEN OPS.Get(sym); OPB.PrepCall(x, fpar); ActualParameters(apar, fpar); OPB.Call(x, apar, fpar); - CheckSym(rparen); + CheckSym(OPS.rparen); IF level > 0 THEN OPT.topScope^.link^.leaf := FALSE END END - ELSIF sym = number THEN + ELSIF sym = OPS.number THEN CASE OPS.numtyp OF - char: x := OPB.NewIntConst(OPS.intval); x^.typ := OPT.chartyp - | integer: x := OPB.NewIntConst(OPS.intval) - | real: x := OPB.NewRealConst(OPS.realval, OPT.realtyp) - | longreal: x := OPB.NewRealConst(OPS.lrlval, OPT.lrltyp) + | OPS.char: x := OPB.NewIntConst(OPS.intval); x^.typ := OPT.chartyp + | OPS.integer: x := OPB.NewIntConst(OPS.intval) + | OPS.real: x := OPB.NewRealConst(OPS.realval, OPT.realtyp) + | OPS.longreal: x := OPB.NewRealConst(OPS.lrlval, OPT.lrltyp) ELSE OPM.LogWStr("unhandled case in OPP.Factor, OPS.numtyp = "); OPM.LogWNum(OPS.numtyp, 0); OPM.LogWLn; END ; OPS.Get(sym) - ELSIF sym = string THEN + ELSIF sym = OPS.string THEN x := OPB.NewString(OPS.str, OPS.intval); OPS.Get(sym) - ELSIF sym = nil THEN + ELSIF sym = OPS.nil THEN x := OPB.Nil(); OPS.Get(sym) - ELSIF sym = lparen THEN - OPS.Get(sym); Expression(x); CheckSym(rparen) - ELSIF sym = lbrak THEN - OPS.Get(sym); err(lparen); Expression(x); CheckSym(rparen) - ELSIF sym = lbrace THEN OPS.Get(sym); Sets(x) - ELSIF sym = not THEN - OPS.Get(sym); Factor(x); OPB.MOp(not, x) + ELSIF sym = OPS.lparen THEN + OPS.Get(sym); Expression(x); CheckSym(OPS.rparen) + ELSIF sym = OPS.lbrak THEN + OPS.Get(sym); err(OPS.lparen); Expression(x); CheckSym(OPS.rparen) + ELSIF sym = OPS.lbrace THEN OPS.Get(sym); Sets(x) + ELSIF sym = OPS.not THEN + OPS.Get(sym); Factor(x); OPB.MOp(OPS.not, x) ELSE err(13); OPS.Get(sym); x := NIL END ; IF x = NIL THEN x := OPB.NewIntConst(1); x^.typ := OPT.undftyp END @@ -515,7 +455,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE Term(VAR x: OPT.Node); VAR y: OPT.Node; mulop: SHORTINT; BEGIN Factor(x); - WHILE (times <= sym) & (sym <= and) DO + WHILE (OPS.times <= sym) & (sym <= OPS.and) DO mulop := sym; OPS.Get(sym); Factor(y); OPB.Op(mulop, x, y) END @@ -524,11 +464,11 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE SimpleExpression(VAR x: OPT.Node); VAR y: OPT.Node; addop: SHORTINT; BEGIN - IF sym = minus THEN OPS.Get(sym); Term(x); OPB.MOp(minus, x) - ELSIF sym = plus THEN OPS.Get(sym); Term(x); OPB.MOp(plus, x) + IF sym = OPS.minus THEN OPS.Get(sym); Term(x); OPB.MOp(OPS.minus, x) + ELSIF sym = OPS.plus THEN OPS.Get(sym); Term(x); OPB.MOp(OPS.plus, x) ELSE Term(x) END ; - WHILE (plus <= sym) & (sym <= or) DO + WHILE (OPS.plus <= sym) & (sym <= OPS.or) DO addop := sym; OPS.Get(sym); Term(y); OPB.Op(addop, x, y) END @@ -537,19 +477,19 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE Expression(VAR x: OPT.Node); VAR y: OPT.Node; obj: OPT.Object; relation: SHORTINT; BEGIN SimpleExpression(x); - IF (eql <= sym) & (sym <= geq) THEN + IF (OPS.eql <= sym) & (sym <= OPS.geq) THEN relation := sym; OPS.Get(sym); SimpleExpression(y); OPB.Op(relation, x, y) - ELSIF sym = in THEN + ELSIF sym = OPS.in THEN OPS.Get(sym); SimpleExpression(y); OPB.In(x, y) - ELSIF sym = is THEN + ELSIF sym = OPS.is THEN OPS.Get(sym); - IF sym = ident THEN + IF sym = OPS.ident THEN qualident(obj); - IF obj^.mode = Typ THEN OPB.TypTest(x, obj, FALSE) + IF obj^.mode = OPT.Typ THEN OPB.TypTest(x, obj, FALSE) ELSE err(52) END - ELSE err(ident) + ELSE err(OPS.ident) END END END Expression; @@ -557,27 +497,27 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE Receiver(VAR mode: SHORTINT; VAR name: OPS.Name; VAR typ, rec: OPT.Struct); VAR obj: OPT.Object; BEGIN typ := OPT.undftyp; rec := NIL; - IF sym = var THEN OPS.Get(sym); mode := VarPar ELSE mode := Var END ; - name := OPS.name; CheckSym(ident); CheckSym(colon); - IF sym = ident THEN OPT.Find(obj); OPS.Get(sym); + IF sym = OPS.var THEN OPS.Get(sym); mode := OPT.VarPar ELSE mode := OPT.Var END ; + name := OPS.name; CheckSym(OPS.ident); CheckSym(OPS.colon); + IF sym = OPS.ident THEN OPT.Find(obj); OPS.Get(sym); IF obj = NIL THEN err(0) - ELSIF obj^.mode # Typ THEN err(72) + ELSIF obj^.mode # OPT.Typ THEN err(72) ELSE typ := obj^.typ; rec := typ; - IF rec^.form = Pointer THEN rec := rec^.BaseTyp END ; - IF ~((mode = Var) & (typ^.form = Pointer) & (rec^.comp = Record) OR - (mode = VarPar) & (typ^.comp = Record)) THEN err(70); rec := NIL END ; + IF rec^.form = OPT.Pointer THEN rec := rec^.BaseTyp END ; + IF ~((mode = OPT.Var) & (typ^.form = OPT.Pointer) & (rec^.comp = OPT.Record) OR + (mode = OPT.VarPar) & (typ^.comp = OPT.Record)) THEN err(70); rec := NIL END ; IF (rec # NIL) & (rec^.mno # level) THEN err(72); rec := NIL END END - ELSE err(ident) + ELSE err(OPS.ident) END ; - CheckSym(rparen); - IF rec = NIL THEN rec := OPT.NewStr(Comp, Record); rec^.BaseTyp := NIL END + CheckSym(OPS.rparen); + IF rec = NIL THEN rec := OPT.NewStr(OPT.Comp, OPT.Record); rec^.BaseTyp := NIL END END Receiver; PROCEDURE Extends(x, b: OPT.Struct): BOOLEAN; BEGIN - IF (b^.form = Pointer) & (x^.form = Pointer) THEN b := b^.BaseTyp; x := x^.BaseTyp END ; - IF (b^.comp = Record) & (x^.comp = Record) THEN + IF (b^.form = OPT.Pointer) & (x^.form = OPT.Pointer) THEN b := b^.BaseTyp; x := x^.BaseTyp END ; + IF (b^.comp = OPT.Record) & (x^.comp = OPT.Record) THEN REPEAT x := x^.BaseTyp UNTIL (x = NIL) OR (x = b) END ; RETURN x = b @@ -593,7 +533,7 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) VAR ext: OPT.ConstExt; n: INTEGER; c: LONGINT; BEGIN ext := OPT.NewExt(); proc^.conval^.ext := ext; n := 0; - IF sym = string THEN + IF sym = OPS.string THEN WHILE OPS.str[n] # 0X DO ext[n+1] := OPS.str[n]; INC(n) END ; ext^[0] := CHR(n); OPS.Get(sym); (* @@ -602,33 +542,33 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) *) ELSE LOOP - IF sym = number THEN c := OPS.intval; INC(n); + IF sym = OPS.number THEN c := OPS.intval; INC(n); IF (c < 0) OR (c > 255) OR (n = OPT.MaxConstLen) THEN err(64); c := 1; n := 1 END ; OPS.Get(sym); ext^[n] := CHR(c) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF sym = number THEN err(comma) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF sym = OPS.number THEN err(OPS.comma) ELSE ext^[0] := CHR(n); EXIT END END END ; - INCL(proc^.conval^.setval, hasBody) + INCL(proc^.conval^.setval, OPT.hasBody) END GetCode; PROCEDURE GetParams; BEGIN proc^.vis := vis; proc^.mode := mode; proc^.typ := OPT.notyp; proc^.conval := OPT.NewConst(); proc^.conval^.setval := {}; - IF sym = lparen THEN + IF sym = OPS.lparen THEN OPS.Get(sym); FormalParameters(proc^.link, proc^.typ) END ; IF fwd # NIL THEN OPB.CheckParameters(proc^.link, fwd^.link, TRUE); IF proc^.typ # fwd^.typ THEN err(117) END ; proc := fwd; OPT.topScope := proc^.scope; - IF mode = IProc THEN proc^.mode := IProc END + IF mode = OPT.IProc THEN proc^.mode := OPT.IProc END END END GetParams; @@ -636,14 +576,14 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) VAR procdec, statseq: OPT.Node; c: LONGINT; BEGIN c := OPM.errpos; - INCL(proc^.conval^.setval, hasBody); - CheckSym(semicolon); Block(procdec, statseq); + INCL(proc^.conval^.setval, OPT.hasBody); + CheckSym(OPS.semicolon); Block(procdec, statseq); OPB.Enter(procdec, statseq, proc); x := procdec; x^.conval := OPT.NewConst(); x^.conval^.intval := c; - IF sym = ident THEN + IF sym = OPS.ident THEN IF OPS.name # proc^.name THEN err(4) END ; OPS.Get(sym) - ELSE err(ident) + ELSE err(OPS.ident) END END Body; @@ -653,17 +593,17 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) objMode: SHORTINT; objName: OPS.Name; BEGIN - OPS.Get(sym); mode := TProc; + OPS.Get(sym); mode := OPT.TProc; IF level > 0 THEN err(73) END ; Receiver(objMode, objName, objTyp, recTyp); - IF sym = ident THEN + IF sym = OPS.ident THEN name := OPS.name; CheckMark(vis); OPT.FindField(name, recTyp, fwd); OPT.FindField(name, recTyp^.BaseTyp, baseProc); - IF (baseProc # NIL) & (baseProc^.mode # TProc) THEN baseProc := NIL END ; + IF (baseProc # NIL) & (baseProc^.mode # OPT.TProc) THEN baseProc := NIL END ; IF fwd = baseProc THEN fwd := NIL END ; IF (fwd # NIL) & (fwd^.mnolev # level) THEN fwd := NIL END ; - IF (fwd # NIL) & (fwd^.mode = TProc) & ~(hasBody IN fwd^.conval^.setval) THEN + IF (fwd # NIL) & (fwd^.mode = OPT.TProc) & ~(OPT.hasBody IN fwd^.conval^.setval) THEN (* there exists a corresponding forward declaration *) proc := OPT.NewObj(); proc^.leaf := TRUE; IF fwd^.vis # vis THEN err(118) END @@ -679,34 +619,34 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) IF (objMode # baseProc^.link^.mode) OR ~Extends(objTyp, baseProc^.link^.typ) THEN err(115) END ; OPB.CheckParameters(proc^.link^.link, baseProc^.link^.link, FALSE); IF proc^.typ # baseProc^.typ THEN err(117) END ; - IF (baseProc^.vis = external) & (proc^.vis = internal) & - (recTyp^.strobj # NIL) & (recTyp^.strobj^.vis = external) THEN err(109) + IF (baseProc^.vis = OPT.external) & (proc^.vis = OPT.internal) & + (recTyp^.strobj # NIL) & (recTyp^.strobj^.vis = OPT.external) THEN err(109) END ; - INCL(proc^.conval^.setval, isRedef) + INCL(proc^.conval^.setval, OPT.isRedef) END ; IF ~forward THEN Body END ; DEC(level); OPT.CloseScope - ELSE err(ident) + ELSE err(OPS.ident) END END TProcDecl; - BEGIN proc := NIL; forward := FALSE; x := NIL; mode := LProc; - IF (sym # ident) & (sym # lparen) THEN - IF sym = times THEN (* mode set later in OPB.CheckAssign *) - ELSIF sym = arrow THEN forward := TRUE - ELSIF sym = plus THEN mode := IProc - ELSIF sym = minus THEN mode := CProc - ELSE err(ident) + BEGIN proc := NIL; forward := FALSE; x := NIL; mode := OPT.LProc; + IF (sym # OPS.ident) & (sym # OPS.lparen) THEN + IF sym = OPS.times THEN (* mode set later in OPB.CheckAssign *) + ELSIF sym = OPS.arrow THEN forward := TRUE + ELSIF sym = OPS.plus THEN mode := OPT.IProc + ELSIF sym = OPS.minus THEN mode := OPT.CProc + ELSE err(OPS.ident) END ; - IF (mode IN {IProc, CProc}) & ~OPT.SYSimported THEN err(135) END ; + IF (mode IN {OPT.IProc, OPT.CProc}) & ~OPT.SYSimported THEN err(135) END ; OPS.Get(sym) END ; - IF sym = lparen THEN TProcDecl - ELSIF sym = ident THEN OPT.Find(fwd); + IF sym = OPS.lparen THEN TProcDecl + ELSIF sym = OPS.ident THEN OPT.Find(fwd); name := OPS.name; CheckMark(vis); - IF (vis # internal) & (mode = LProc) THEN mode := XProc END ; - IF (fwd # NIL) & ((fwd^.mnolev # level) OR (fwd^.mode = SProc)) THEN fwd := NIL END ; - IF (fwd # NIL) & (fwd^.mode IN {LProc, XProc}) & ~(hasBody IN fwd^.conval^.setval) THEN + IF (vis # OPT.internal) & (mode = OPT.LProc) THEN mode := OPT.XProc END ; + IF (fwd # NIL) & ((fwd^.mnolev # level) OR (fwd^.mode = OPT.SProc)) THEN fwd := NIL END ; + IF (fwd # NIL) & (fwd^.mode IN {OPT.LProc, OPT.XProc}) & ~(OPT.hasBody IN fwd^.conval^.setval) THEN (* there exists a corresponding forward declaration *) proc := OPT.NewObj(); proc^.leaf := TRUE; IF fwd^.vis # vis THEN err(118) END @@ -714,14 +654,14 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) IF fwd # NIL THEN err(1); fwd := NIL END ; OPT.Insert(name, proc) END ; - IF (mode # LProc) & (level > 0) THEN err(73) END ; + IF (mode # OPT.LProc) & (level > 0) THEN err(73) END ; INC(level); OPT.OpenScope(level, proc); proc^.link := NIL; GetParams; - IF mode = CProc THEN GetCode + IF mode = OPT.CProc THEN GetCode ELSIF ~forward THEN Body END ; DEC(level); OPT.CloseScope - ELSE err(ident) + ELSE err(OPS.ident) END END ProcedureDeclaration; @@ -729,16 +669,16 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) VAR x, y, lastlab: OPT.Node; i, f: INTEGER; xval, yval: LONGINT; BEGIN lab := NIL; lastlab := NIL; LOOP ConstExpression(x); f := x^.typ^.form; - IF f IN intSet + {Char} THEN xval := x^.conval^.intval + IF f IN OPT.intSet + {OPT.Char} THEN xval := x^.conval^.intval ELSE err(61); xval := 1 END ; - IF f IN intSet THEN + IF f IN OPT.intSet THEN IF LabelForm < f THEN err(60) END ELSIF LabelForm # f THEN err(60) END ; - IF sym = upto THEN + IF sym = OPS.upto THEN OPS.Get(sym); ConstExpression(y); yval := y^.conval^.intval; - IF (y^.typ^.form # f) & ~((f IN intSet) & (y^.typ^.form IN intSet)) THEN err(60) END ; + IF (y^.typ^.form # f) & ~((f IN OPT.intSet) & (y^.typ^.form IN OPT.intSet)) THEN err(60) END ; IF yval < xval THEN err(63); yval := xval END ELSE yval := xval END ; @@ -757,8 +697,8 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) ELSE err(213) END ; OPB.Link(lab, lastlab, x); - IF sym = comma THEN OPS.Get(sym) - ELSIF (sym = number) OR (sym = ident) THEN err(comma) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF (sym = OPS.number) OR (sym = OPS.ident) THEN err(OPS.comma) ELSE EXIT END END @@ -773,29 +713,29 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) tab: CaseTable; cases, lab, y, lastcase: OPT.Node; BEGIN Expression(x); pos := OPM.errpos; - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126) - ELSIF ~(x^.typ^.form IN {Char..LInt}) THEN err(125) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126) + ELSIF ~(x^.typ^.form IN {OPT.Char..OPT.LInt}) THEN err(125) END ; - CheckSym(of); cases := NIL; lastcase := NIL; n := 0; + CheckSym(OPS.of); cases := NIL; lastcase := NIL; n := 0; LOOP - IF sym < bar THEN + IF sym < OPS.bar THEN CaseLabelList(lab, x^.typ^.form, n, tab); - CheckSym(colon); StatSeq(y); - OPB.Construct(Ncasedo, lab, y); OPB.Link(cases, lastcase, lab) + CheckSym(OPS.colon); StatSeq(y); + OPB.Construct(OPT.Ncasedo, lab, y); OPB.Link(cases, lastcase, lab) END ; - IF sym = bar THEN OPS.Get(sym) ELSE EXIT END + IF sym = OPS.bar THEN OPS.Get(sym) ELSE EXIT END END ; IF n > 0 THEN low := tab[0].low; high := tab[n-1].high; IF high - low > OPM.MaxCaseRange THEN err(209) END ELSE low := 1; high := 0 END ; - e := sym = else; + e := sym = OPS.else; IF e THEN OPS.Get(sym); StatSeq(y) ELSE y := NIL; - OPM.Mark(-307, OPM.curpos); (* notice about no else symbol; -- noch *) + OPM.Mark(-307, OPM.curpos); (* notice about no OPS.else symbol; -- noch *) END ; - OPB.Construct(Ncaselse, cases, y); OPB.Construct(Ncase, x, cases); + OPB.Construct(OPT.Ncaselse, cases, y); OPB.Construct(OPT.Ncase, x, cases); cases^.conval := OPT.NewConst(); cases^.conval^.intval := low; cases^.conval^.intval2 := high; IF e THEN cases^.conval^.setval := {1} ELSE cases^.conval^.setval := {} END @@ -808,29 +748,29 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) PROCEDURE CheckBool(VAR x: OPT.Node); BEGIN - IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); x := OPB.NewBoolConst(FALSE) - ELSIF x^.typ^.form # Bool THEN err(120); x := OPB.NewBoolConst(FALSE) + IF (x^.class = OPT.Ntype) OR (x^.class = OPT.Nproc) THEN err(126); x := OPB.NewBoolConst(FALSE) + ELSIF x^.typ^.form # OPT.Bool THEN err(120); x := OPB.NewBoolConst(FALSE) END ; pos := OPM.errpos END CheckBool; BEGIN stat := NIL; last := NIL; LOOP x := NIL; - IF sym < ident THEN err(14); - REPEAT OPS.Get(sym) UNTIL sym >= ident + IF sym < OPS.ident THEN err(14); + REPEAT OPS.Get(sym) UNTIL sym >= OPS.ident END ; - IF sym = ident THEN + IF sym = OPS.ident THEN qualident(id); x := OPB.NewLeaf(id); selector(x); - IF sym = becomes THEN + IF sym = OPS.becomes THEN OPS.Get(sym); Expression(y); OPB.Assign(x, y) - ELSIF sym = eql THEN - err(becomes); OPS.Get(sym); Expression(y); OPB.Assign(x, y) - ELSIF (x^.class = Nproc) & (x^.obj^.mode = SProc) THEN + ELSIF sym = OPS.eql THEN + err(OPS.becomes); OPS.Get(sym); Expression(y); OPB.Assign(x, y) + ELSIF (x^.class = OPT.Nproc) & (x^.obj^.mode = OPT.SProc) THEN StandProcCall(x); IF (x # NIL) & (x^.typ # OPT.notyp) THEN err(55) END ELSE OPB.PrepCall(x, fpar); - IF sym = lparen THEN - OPS.Get(sym); ActualParameters(apar, fpar); CheckSym(rparen) + IF sym = OPS.lparen THEN + OPS.Get(sym); ActualParameters(apar, fpar); CheckSym(OPS.rparen) ELSE apar := NIL; IF fpar # NIL THEN err(65) END END ; @@ -839,36 +779,36 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) IF level > 0 THEN OPT.topScope^.link^.leaf := FALSE END END ; pos := OPM.errpos - ELSIF sym = if THEN - OPS.Get(sym); Expression(x); CheckBool(x); CheckSym(then); StatSeq(y); - OPB.Construct(Nif, x, y); SetPos(x); lastif := x; - WHILE sym = elsif DO - OPS.Get(sym); Expression(y); CheckBool(y); CheckSym(then); StatSeq(z); - OPB.Construct(Nif, y, z); SetPos(y); OPB.Link(x, lastif, y) + ELSIF sym = OPS.if THEN + OPS.Get(sym); Expression(x); CheckBool(x); CheckSym(OPS.then); StatSeq(y); + OPB.Construct(OPT.Nif, x, y); SetPos(x); lastif := x; + WHILE sym = OPS.elsif DO + OPS.Get(sym); Expression(y); CheckBool(y); CheckSym(OPS.then); StatSeq(z); + OPB.Construct(OPT.Nif, y, z); SetPos(y); OPB.Link(x, lastif, y) END ; - IF sym = else THEN OPS.Get(sym); StatSeq(y) ELSE y := NIL END ; - OPB.Construct(Nifelse, x, y); CheckSym(end); OPB.OptIf(x); pos := OPM.errpos - ELSIF sym = case THEN - OPS.Get(sym); CasePart(x); CheckSym(end) - ELSIF sym = while THEN - OPS.Get(sym); Expression(x); CheckBool(x); CheckSym(do); StatSeq(y); - OPB.Construct(Nwhile, x, y); CheckSym(end) - ELSIF sym = repeat THEN + IF sym = OPS.else THEN OPS.Get(sym); StatSeq(y) ELSE y := NIL END ; + OPB.Construct(OPT.Nifelse, x, y); CheckSym(OPS.end); OPB.OptIf(x); pos := OPM.errpos + ELSIF sym = OPS.case THEN + OPS.Get(sym); CasePart(x); CheckSym(OPS.end) + ELSIF sym = OPS.while THEN + OPS.Get(sym); Expression(x); CheckBool(x); CheckSym(OPS.do); StatSeq(y); + OPB.Construct(OPT.Nwhile, x, y); CheckSym(OPS.end) + ELSIF sym = OPS.repeat THEN OPS.Get(sym); StatSeq(x); - IF sym = until THEN OPS.Get(sym); Expression(y); CheckBool(y) - ELSE err(until) + IF sym = OPS.until THEN OPS.Get(sym); Expression(y); CheckBool(y) + ELSE err(OPS.until) END ; - OPB.Construct(Nrepeat, x, y) - ELSIF sym = for THEN + OPB.Construct(OPT.Nrepeat, x, y) + ELSIF sym = OPS.for THEN OPS.Get(sym); - IF sym = ident THEN qualident(id); - IF ~(id^.typ^.form IN intSet) THEN err(68) END ; - CheckSym(becomes); Expression(y); pos := OPM.errpos; + IF sym = OPS.ident THEN qualident(id); + IF ~(id^.typ^.form IN OPT.intSet) THEN err(68) END ; + CheckSym(OPS.becomes); Expression(y); pos := OPM.errpos; x := OPB.NewLeaf(id); OPB.Assign(x, y); SetPos(x); - CheckSym(to); Expression(y); pos := OPM.errpos; - IF y^.class # Nconst THEN + CheckSym(OPS.to); Expression(y); pos := OPM.errpos; + IF y^.class # OPT.Nconst THEN name := "@@"; OPT.Insert(name, t); t^.name := "@for"; (* avoid err 1 *) - t^.mode := Var; t^.typ := x^.left^.typ; + t^.mode := OPT.Var; t^.typ := x^.left^.typ; obj := OPT.topScope^.scope; IF obj = NIL THEN OPT.topScope^.scope := t ELSE @@ -877,73 +817,73 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) END ; z := OPB.NewLeaf(t); OPB.Assign(z, y); SetPos(z); OPB.Link(stat, last, z); y := OPB.NewLeaf(t) - ELSIF (y^.typ^.form < SInt) OR (y^.typ^.form > x^.left^.typ^.form) THEN err(113) + ELSIF (y^.typ^.form < OPT.SInt) OR (y^.typ^.form > x^.left^.typ^.form) THEN err(113) END ; OPB.Link(stat, last, x); - IF sym = by THEN OPS.Get(sym); ConstExpression(z) ELSE z := OPB.NewIntConst(1) END ; + IF sym = OPS.by THEN OPS.Get(sym); ConstExpression(z) ELSE z := OPB.NewIntConst(1) END ; pos := OPM.errpos; x := OPB.NewLeaf(id); - IF z^.conval^.intval > 0 THEN OPB.Op(leq, x, y) - ELSIF z^.conval^.intval < 0 THEN OPB.Op(geq, x, y) - ELSE err(63); OPB.Op(geq, x, y) + IF z^.conval^.intval > 0 THEN OPB.Op(OPS.leq, x, y) + ELSIF z^.conval^.intval < 0 THEN OPB.Op(OPS.geq, x, y) + ELSE err(63); OPB.Op(OPS.geq, x, y) END ; - CheckSym(do); StatSeq(s); - y := OPB.NewLeaf(id); OPB.StPar1(y, z, incfn); SetPos(y); + CheckSym(OPS.do); StatSeq(s); + y := OPB.NewLeaf(id); OPB.StPar1(y, z, OPT.incfn); SetPos(y); IF s = NIL THEN s := y ELSE z := s; WHILE z^.link # NIL DO z := z^.link END ; z^.link := y END ; - CheckSym(end); OPB.Construct(Nwhile, x, s) - ELSE err(ident) + CheckSym(OPS.end); OPB.Construct(OPT.Nwhile, x, s) + ELSE err(OPS.ident) END - ELSIF sym = loop THEN + ELSIF sym = OPS.loop THEN OPS.Get(sym); INC(LoopLevel); StatSeq(x); DEC(LoopLevel); - OPB.Construct(Nloop, x, NIL); CheckSym(end); pos := OPM.errpos - ELSIF sym = with THEN + OPB.Construct(OPT.Nloop, x, NIL); CheckSym(OPS.end); pos := OPM.errpos + ELSIF sym = OPS.with THEN OPS.Get(sym); idtyp := NIL; x := NIL; LOOP - IF sym = ident THEN + IF sym = OPS.ident THEN qualident(id); y := OPB.NewLeaf(id); - IF (id # NIL) & (id^.typ^.form = Pointer) & ((id^.mode = VarPar) OR ~id^.leaf) THEN + IF (id # NIL) & (id^.typ^.form = OPT.Pointer) & ((id^.mode = OPT.VarPar) OR ~id^.leaf) THEN err(245) (* jt: do not allow WITH on non-local pointers *) END ; - CheckSym(colon); - IF sym = ident THEN qualident(t); - IF t^.mode = Typ THEN + CheckSym(OPS.colon); + IF sym = OPS.ident THEN qualident(t); + IF t^.mode = OPT.Typ THEN IF id # NIL THEN idtyp := id^.typ; OPB.TypTest(y, t, FALSE); id^.typ := t^.typ ELSE err(130) END ELSE err(52) END - ELSE err(ident) + ELSE err(OPS.ident) END - ELSE err(ident) + ELSE err(OPS.ident) END ; - pos := OPM.errpos; CheckSym(do); StatSeq(s); OPB.Construct(Nif, y, s); SetPos(y); + pos := OPM.errpos; CheckSym(OPS.do); StatSeq(s); OPB.Construct(OPT.Nif, y, s); SetPos(y); IF idtyp # NIL THEN id^.typ := idtyp; idtyp := NIL END ; IF x = NIL THEN x := y; lastif := x ELSE OPB.Link(x, lastif, y) END ; - IF sym = bar THEN OPS.Get(sym) ELSE EXIT END + IF sym = OPS.bar THEN OPS.Get(sym) ELSE EXIT END END; - e := sym = else; + e := sym = OPS.else; IF e THEN OPS.Get(sym); StatSeq(s) ELSE s := NIL END ; - OPB.Construct(Nwith, x, s); CheckSym(end); + OPB.Construct(OPT.Nwith, x, s); CheckSym(OPS.end); IF e THEN x^.subcl := 1 END - ELSIF sym = exit THEN + ELSIF sym = OPS.exit THEN OPS.Get(sym); IF LoopLevel = 0 THEN err(46) END ; - OPB.Construct(Nexit, x, NIL); + OPB.Construct(OPT.Nexit, x, NIL); pos := OPM.errpos - ELSIF sym = return THEN OPS.Get(sym); - IF sym < semicolon THEN Expression(x) END ; + ELSIF sym = OPS.return THEN OPS.Get(sym); + IF sym < OPS.semicolon THEN Expression(x) END ; IF level > 0 THEN OPB.Return(x, OPT.topScope^.link) ELSE (* not standard Oberon *) OPB.Return(x, NIL) END ; pos := OPM.errpos END ; IF x # NIL THEN SetPos(x); OPB.Link(stat, last, x) END ; - IF sym = semicolon THEN OPS.Get(sym) - ELSIF (sym <= ident) OR (if <= sym) & (sym <= return) THEN err(semicolon) + IF sym = OPS.semicolon THEN OPS.Get(sym) + ELSIF (sym <= OPS.ident) OR (OPS.if <= sym) & (sym <= OPS.return) THEN err(OPS.semicolon) ELSE EXIT END END @@ -957,67 +897,67 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) BEGIN first := NIL; last := NIL; nofFwdPtr := 0; LOOP - IF sym = const THEN + IF sym = OPS.const THEN OPS.Get(sym); - WHILE sym = ident DO + WHILE sym = OPS.ident DO OPT.Insert(OPS.name, obj); CheckMark(obj^.vis); - obj^.typ := OPT.sinttyp; obj^.mode := Var; (* Var to avoid recursive definition *) - IF sym = eql THEN + obj^.typ := OPT.sinttyp; obj^.mode := OPT.Var; (* OPT.Var to avoid recursive definition *) + IF sym = OPS.eql THEN OPS.Get(sym); ConstExpression(x) - ELSIF sym = becomes THEN - err(eql); OPS.Get(sym); ConstExpression(x) - ELSE err(eql); x := OPB.NewIntConst(1) + ELSIF sym = OPS.becomes THEN + err(OPS.eql); OPS.Get(sym); ConstExpression(x) + ELSE err(OPS.eql); x := OPB.NewIntConst(1) END ; - obj^.mode := Con; obj^.typ := x^.typ; obj^.conval := x^.conval; (* ConstDesc ist not copied *) - CheckSym(semicolon) + obj^.mode := OPT.Con; obj^.typ := x^.typ; obj^.conval := x^.conval; (* ConstDesc ist not copied *) + CheckSym(OPS.semicolon) END END ; - IF sym = type THEN + IF sym = OPS.type THEN OPS.Get(sym); - WHILE sym = ident DO - OPT.Insert(OPS.name, obj); obj^.mode := Typ; obj^.typ := OPT.undftyp; + WHILE sym = OPS.ident DO + OPT.Insert(OPS.name, obj); obj^.mode := OPT.Typ; obj^.typ := OPT.undftyp; CheckMark(obj^.vis); - IF sym = eql THEN + IF sym = OPS.eql THEN OPS.Get(sym); TypeDecl(obj^.typ, obj^.typ) - ELSIF (sym = becomes) OR (sym = colon) THEN - err(eql); OPS.Get(sym); TypeDecl(obj^.typ, obj^.typ) - ELSE err(eql) + ELSIF (sym = OPS.becomes) OR (sym = OPS.colon) THEN + err(OPS.eql); OPS.Get(sym); TypeDecl(obj^.typ, obj^.typ) + ELSE err(OPS.eql) END ; IF obj^.typ^.strobj = NIL THEN obj^.typ^.strobj := obj END ; - IF obj^.typ^.comp IN {Record, Array, DynArr} THEN + IF obj^.typ^.comp IN {OPT.Record, OPT.Array, OPT.DynArr} THEN i := 0; WHILE i < nofFwdPtr DO typ := FwdPtr[i]; INC(i); IF typ^.link^.name = obj^.name THEN typ^.BaseTyp := obj^.typ; typ^.link^.name := "" END END END ; - CheckSym(semicolon) + CheckSym(OPS.semicolon) END END ; - IF sym = var THEN + IF sym = OPS.var THEN OPS.Get(sym); - WHILE sym = ident DO + WHILE sym = OPS.ident DO LOOP - IF sym = ident THEN + IF sym = OPS.ident THEN OPT.Insert(OPS.name, obj); CheckMark(obj^.vis); - obj^.mode := Var; obj^.link := NIL; obj^.leaf := obj^.vis = internal; obj^.typ := OPT.undftyp; + obj^.mode := OPT.Var; obj^.link := NIL; obj^.leaf := obj^.vis = OPT.internal; obj^.typ := OPT.undftyp; IF first = NIL THEN first := obj END ; IF last = NIL THEN OPT.topScope^.scope := obj ELSE last^.link := obj END ; last := obj - ELSE err(ident) + ELSE err(OPS.ident) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF sym = ident THEN err(comma) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF sym = OPS.ident THEN err(OPS.comma) ELSE EXIT END END ; - CheckSym(colon); Type(typ, OPT.notyp); + CheckSym(OPS.colon); Type(typ, OPT.notyp); typ^.pvused := TRUE; - IF typ^.comp = DynArr THEN typ := OPT.undftyp; err(88) END ; + IF typ^.comp = OPT.DynArr THEN typ := OPT.undftyp; err(88) END ; WHILE first # NIL DO first^.typ := typ; first := first^.link END ; - CheckSym(semicolon) + CheckSym(OPS.semicolon) END END ; - IF (sym < const) OR (sym > var) THEN EXIT END ; + IF (sym < OPS.const) OR (sym > OPS.var) THEN EXIT END ; END ; i := 0; WHILE i < nofFwdPtr DO @@ -1027,21 +967,21 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) END ; OPT.topScope^.adr := OPM.errpos; procdec := NIL; lastdec := NIL; - WHILE sym = procedure DO + WHILE sym = OPS.procedure DO OPS.Get(sym); ProcedureDeclaration(x); IF x # NIL THEN IF lastdec = NIL THEN procdec := x ELSE lastdec^.link := x END ; lastdec := x END ; - CheckSym(semicolon) + CheckSym(OPS.semicolon) END ; - IF sym = begin THEN OPS.Get(sym); StatSeq(statseq) + IF sym = OPS.begin THEN OPS.Get(sym); StatSeq(statseq) ELSE statseq := NIL END ; IF (level = 0) & (TDinit # NIL) THEN lastTDinit^.link := statseq; statseq := TDinit END ; - CheckSym(end) + CheckSym(OPS.end) END Block; PROCEDURE Module*(VAR prog: OPT.Node; opt: SET); @@ -1050,38 +990,48 @@ MODULE OPP; (* NW, RC 6.3.89 / 10.2.94 *) (* object model 4.12.93 *) c: LONGINT; done: BOOLEAN; BEGIN OPS.Init; LoopLevel := 0; level := 0; OPS.Get(sym); - IF sym = module THEN OPS.Get(sym) ELSE err(16) END ; - IF sym = ident THEN + IF sym = OPS.module THEN OPS.Get(sym) ELSE + (* Debug intermittent failure only found on OpenBSD *) + OPM.LogWLn; + OPM.LogWStr("Unexpected symbol found when MODULE expected:"); OPM.LogWLn; + OPM.LogWStr(" sym: "); OPM.LogWNum(sym,1); OPM.LogWLn; + OPM.LogWStr(" OPS.name: "); OPM.LogWStr(OPS.name); OPM.LogWLn; + OPM.LogWStr(" OPS.str: "); OPM.LogWStr(OPS.str); OPM.LogWLn; + OPM.LogWStr(" OPS.numtyp: "); OPM.LogWNum(OPS.numtyp,1); OPM.LogWLn; + OPM.LogWStr(" OPS.intval: "); OPM.LogWNum(OPS.intval,1); OPM.LogWLn; + err(16) + END; + IF sym = OPS.ident THEN OPM.LogWStr("compiling "); OPM.LogWStr(OPS.name); OPM.LogW("."); - OPT.Init(OPS.name, opt); OPS.Get(sym); CheckSym(semicolon); - IF sym = import THEN OPS.Get(sym); + OPT.Init(OPS.name, opt); OPS.Get(sym); CheckSym(OPS.semicolon); + IF sym = OPS.import THEN OPS.Get(sym); LOOP - IF sym = ident THEN + IF sym = OPS.ident THEN COPY(OPS.name, aliasName); COPY(aliasName, impName); OPS.Get(sym); - IF sym = becomes THEN OPS.Get(sym); - IF sym = ident THEN COPY(OPS.name, impName); OPS.Get(sym) ELSE err(ident) END + IF sym = OPS.becomes THEN OPS.Get(sym); + IF sym = OPS.ident THEN COPY(OPS.name, impName); OPS.Get(sym) ELSE err(OPS.ident) END END ; OPT.Import(aliasName, impName, done) - ELSE err(ident) + ELSE err(OPS.ident) END ; - IF sym = comma THEN OPS.Get(sym) - ELSIF sym = ident THEN err(comma) + IF sym = OPS.comma THEN OPS.Get(sym) + ELSIF sym = OPS.ident THEN err(OPS.comma) ELSE EXIT END END ; - CheckSym(semicolon) + CheckSym(OPS.semicolon) END ; IF OPM.noerr THEN TDinit := NIL; lastTDinit := NIL; c := OPM.errpos; Block(procdec, statseq); OPB.Enter(procdec, statseq, NIL); prog := procdec; prog^.conval := OPT.NewConst(); prog^.conval^.intval := c; - IF sym = ident THEN + IF sym = OPS.ident THEN IF OPS.name # OPT.SelfName THEN err(4) END ; OPS.Get(sym) - ELSE err(ident) + ELSE err(OPS.ident) END ; - IF sym # period THEN err(period) END + IF sym # OPS.period THEN err(OPS.period) END END - ELSE err(ident) + ELSE err(OPS.ident) END ; TDinit := NIL; lastTDinit := NIL END Module; diff --git a/src/compiler/OPS.Mod b/src/compiler/OPS.Mod index 8514886c..33b325d8 100644 --- a/src/compiler/OPS.Mod +++ b/src/compiler/OPS.Mod @@ -6,13 +6,49 @@ MODULE OPS; (* NW, RC 6.3.89 / 18.10.92 *) (* object model 3.6.92 *) MaxStrLen* = 256; MaxIdLen = 256; + + (* Symbols values (also used as op values): + | 0 1 2 3 4 + ---|-------------------------------------------------------- + 0 | null * / DIV MOD + 5 | & + - OR = + 10 | # < <= > >= + 15 | IN IS ^ . , + 20 | : .. ) ] } + 25 | OF THEN DO TO BY + 30 | ( [ { ~ := + 35 | number NIL string ident ; + 40 | | END ELSE ELSIF UNTIL + 45 | IF CASE WHILE REPEAT FOR + 50 | LOOP WITH EXIT RETURN ARRAY + 55 | RECORD POINTER BEGIN CONST TYPE + 60 | VAR PROCEDURE IMPORT MODULE eof + *) + + null* = 0; times* = 1; slash* = 2; div* = 3; mod* = 4; + and* = 5; plus* = 6; minus* = 7; or* = 8; eql* = 9; + neq* = 10; lss* = 11; leq* = 12; gtr* = 13; geq* = 14; + in* = 15; is* = 16; arrow* = 17; period* = 18; comma* = 19; + colon* = 20; upto* = 21; rparen* = 22; rbrak* = 23; rbrace* = 24; + of* = 25; then* = 26; do* = 27; to* = 28; by* = 29; + lparen* = 30; lbrak* = 31; lbrace* = 32; not* = 33; becomes* = 34; + number* = 35; nil* = 36; string* = 37; ident* = 38; semicolon* = 39; + bar* = 40; end* = 41; else* = 42; elsif* = 43; until* = 44; + if* = 45; case* = 46; while* = 47; repeat* = 48; for* = 49; + loop* = 50; with* = 51; exit* = 52; return* = 53; array* = 54; + record* = 55; pointer* = 56; begin* = 57; const* = 58; type* = 59; + var* = 60; procedure* = 61; import* = 62; module* = 63; eof* = 64; + + (* Symbol numtyp values *) + char* = 1; integer* = 2; real* = 3; longreal* = 4; + + TYPE Name* = ARRAY MaxIdLen OF CHAR; String* = ARRAY MaxStrLen OF CHAR; - (* name, str, numtyp, intval, realval, lrlval are implicit results of Get *) - VAR + (* name, str, numtyp, intval, realval, lrlval are implicit results of Get *) name*: Name; str*: String; numtyp*: INTEGER; (* 1 = char, 2 = integer, 3 = real, 4 = longreal *) @@ -20,43 +56,6 @@ MODULE OPS; (* NW, RC 6.3.89 / 18.10.92 *) (* object model 3.6.92 *) realval*: REAL; lrlval*: LONGREAL; - (*symbols: - | 0 1 2 3 4 - ---|-------------------------------------------------------- - 0 | null * / DIV MOD - 5 | & + - OR = - 10 | # < <= > >= - 15 | IN IS ^ . , - 20 | : .. ) ] } - 25 | OF THEN DO TO BY - 30 | ( [ { ~ := - 35 | number NIL string ident ; - 40 | | END ELSE ELSIF UNTIL - 45 | IF CASE WHILE REPEAT FOR - 50 | LOOP WITH EXIT RETURN ARRAY - 55 | RECORD POINTER BEGIN CONST TYPE - 60 | VAR PROCEDURE IMPORT MODULE eof *) - - CONST - (* numtyp values *) - char = 1; integer = 2; real = 3; longreal = 4; - - (*symbol values*) - null = 0; times = 1; slash = 2; div = 3; mod = 4; - and = 5; plus = 6; minus = 7; or = 8; eql = 9; - neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; - in = 15; is = 16; arrow = 17; period = 18; comma = 19; - colon = 20; upto = 21; rparen = 22; rbrak = 23; rbrace = 24; - of = 25; then = 26; do = 27; to = 28; by = 29; - lparen = 30; lbrak = 31; lbrace = 32; not = 33; becomes = 34; - number = 35; nil = 36; string = 37; ident = 38; semicolon = 39; - bar = 40; end = 41; else = 42; elsif = 43; until = 44; - if = 45; case = 46; while = 47; repeat = 48; for = 49; - loop = 50; with = 51; exit = 52; return = 53; array = 54; - record = 55; pointer = 56; begin = 57; const = 58; type = 59; - var = 60; procedure = 61; import = 62; module = 63; eof = 64; - - VAR ch: CHAR; (*current character*) PROCEDURE err(n: INTEGER); @@ -214,97 +213,99 @@ MODULE OPS; (* NW, RC 6.3.89 / 18.10.92 *) (* object model 3.6.92 *) END END ; CASE ch OF (* ch > " " *) - | 22X, 27X : Str(s) - | "#" : s := neq; OPM.Get(ch) - | "&" : s := and; OPM.Get(ch) - | "(" : OPM.Get(ch); - IF ch = "*" THEN Comment; Get(s) - ELSE s := lparen - END - | ")" : s := rparen; OPM.Get(ch) - | "*" : s := times; OPM.Get(ch) - | "+" : s := plus; OPM.Get(ch) - | "," : s := comma; OPM.Get(ch) - | "-" : s := minus; OPM.Get(ch) - | "." : OPM.Get(ch); - IF ch = "." THEN OPM.Get(ch); s := upto ELSE s := period END - | "/" : s := slash; OPM.Get(ch) - | "0".."9": Number; s := number - | ":" : OPM.Get(ch); - IF ch = "=" THEN OPM.Get(ch); s := becomes ELSE s := colon END - | ";" : s := semicolon; OPM.Get(ch) - | "<" : OPM.Get(ch); - IF ch = "=" THEN OPM.Get(ch); s := leq ELSE s := lss END - | "=" : s := eql; OPM.Get(ch) - | ">" : OPM.Get(ch); - IF ch = "=" THEN OPM.Get(ch); s := geq ELSE s := gtr END - | "A": Identifier(s); IF name = "ARRAY" THEN s := array END - | "B": Identifier(s); - IF name = "BEGIN" THEN s := begin - ELSIF name = "BY" THEN s := by - END - | "C": Identifier(s); - IF name = "CASE" THEN s := case - ELSIF name = "CONST" THEN s := const - END - | "D": Identifier(s); - IF name = "DO" THEN s := do - ELSIF name = "DIV" THEN s := div - END - | "E": Identifier(s); - IF name = "END" THEN s := end - ELSIF name = "ELSE" THEN s := else - ELSIF name = "ELSIF" THEN s := elsif - ELSIF name = "EXIT" THEN s := exit - END - | "F": Identifier(s); IF name = "FOR" THEN s := for END - | "I": Identifier(s); - IF name = "IF" THEN s := if - ELSIF name = "IN" THEN s := in - ELSIF name = "IS" THEN s := is - ELSIF name = "IMPORT" THEN s := import - END - | "L": Identifier(s); IF name = "LOOP" THEN s := loop END - | "M": Identifier(s); - IF name = "MOD" THEN s := mod - ELSIF name = "MODULE" THEN s := module - END - | "N": Identifier(s); IF name = "NIL" THEN s := nil END - | "O": Identifier(s); - IF name = "OR" THEN s := or - ELSIF name = "OF" THEN s := of - END - | "P": Identifier(s); - IF name = "PROCEDURE" THEN s := procedure - ELSIF name = "POINTER" THEN s := pointer - END - | "R": Identifier(s); - IF name = "RECORD" THEN s := record - ELSIF name = "REPEAT" THEN s := repeat - ELSIF name = "RETURN" THEN s := return - END - | "T": Identifier(s); - IF name = "THEN" THEN s := then - ELSIF name = "TO" THEN s := to - ELSIF name = "TYPE" THEN s := type - END - | "U": Identifier(s); IF name = "UNTIL" THEN s := until END - | "V": Identifier(s); IF name = "VAR" THEN s := var END - | "W": Identifier(s); - IF name = "WHILE" THEN s := while - ELSIF name = "WITH" THEN s := with - END - | "G".."H", "J", "K", "Q", "S", "X".."Z": Identifier(s) - | "[" : s := lbrak; OPM.Get(ch) - | "]" : s := rbrak; OPM.Get(ch) - | "^" : s := arrow; OPM.Get(ch) - | "a".."z": Identifier(s) - | "{" : s := lbrace; OPM.Get(ch) - | "|" : s := bar; OPM.Get(ch) - | "}" : s := rbrace; OPM.Get(ch) - | "~" : s := not; OPM.Get(ch) - | 7FX : s := upto; OPM.Get(ch) - ELSE s := null; OPM.Get(ch) + | 22X, + 27X: Str(s) + | "#": s := neq; OPM.Get(ch) + | "&": s := and; OPM.Get(ch) + | "(": OPM.Get(ch); + IF ch = "*" THEN Comment; Get(s) ELSE s := lparen END + | ")": s := rparen; OPM.Get(ch) + | "*": s := times; OPM.Get(ch) + | "+": s := plus; OPM.Get(ch) + | ",": s := comma; OPM.Get(ch) + | "-": s := minus; OPM.Get(ch) + | ".": OPM.Get(ch); + IF ch = "." THEN OPM.Get(ch); s := upto ELSE s := period END + | "/": s := slash; OPM.Get(ch) + | "0".."9": Number; s := number + | ":": OPM.Get(ch); + IF ch = "=" THEN OPM.Get(ch); s := becomes ELSE s := colon END + | ";": s := semicolon; OPM.Get(ch) + | "<": OPM.Get(ch); + IF ch = "=" THEN OPM.Get(ch); s := leq ELSE s := lss END + | "=": s := eql; OPM.Get(ch) + | ">": OPM.Get(ch); + IF ch = "=" THEN OPM.Get(ch); s := geq ELSE s := gtr END + | "A": Identifier(s); IF name = "ARRAY" THEN s := array END + | "B": Identifier(s); + IF name = "BEGIN" THEN s := begin + ELSIF name = "BY" THEN s := by + END + | "C": Identifier(s); + IF name = "CASE" THEN s := case + ELSIF name = "CONST" THEN s := const + END + | "D": Identifier(s); + IF name = "DO" THEN s := do + ELSIF name = "DIV" THEN s := div + END + | "E": Identifier(s); + IF name = "END" THEN s := end + ELSIF name = "ELSE" THEN s := else + ELSIF name = "ELSIF" THEN s := elsif + ELSIF name = "EXIT" THEN s := exit + END + | "F": Identifier(s); IF name = "FOR" THEN s := for END + | "I": Identifier(s); + IF name = "IF" THEN s := if + ELSIF name = "IN" THEN s := in + ELSIF name = "IS" THEN s := is + ELSIF name = "IMPORT" THEN s := import + END + | "L": Identifier(s); IF name = "LOOP" THEN s := loop END + | "M": Identifier(s); + IF name = "MOD" THEN s := mod + ELSIF name = "MODULE" THEN s := module + END + | "N": Identifier(s); IF name = "NIL" THEN s := nil END + | "O": Identifier(s); + IF name = "OR" THEN s := or + ELSIF name = "OF" THEN s := of + END + | "P": Identifier(s); + IF name = "PROCEDURE" THEN s := procedure + ELSIF name = "POINTER" THEN s := pointer + END + | "R": Identifier(s); + IF name = "RECORD" THEN s := record + ELSIF name = "REPEAT" THEN s := repeat + ELSIF name = "RETURN" THEN s := return + END + | "T": Identifier(s); + IF name = "THEN" THEN s := then + ELSIF name = "TO" THEN s := to + ELSIF name = "TYPE" THEN s := type + END + | "U": Identifier(s); IF name = "UNTIL" THEN s := until END + | "V": Identifier(s); IF name = "VAR" THEN s := var END + | "W": Identifier(s); + IF name = "WHILE" THEN s := while + ELSIF name = "WITH" THEN s := with + END + | "G".."H", + "J".."K", + "Q", "S", + "X".."Z": Identifier(s) + | "[": s := lbrak; OPM.Get(ch) + | "]": s := rbrak; OPM.Get(ch) + | "^": s := arrow; OPM.Get(ch) + | "a".."z": Identifier(s) + | "{": s := lbrace; OPM.Get(ch) + | "|": s := bar; OPM.Get(ch) + | "}": s := rbrace; OPM.Get(ch) + | "~": s := not; OPM.Get(ch) + | 7FX: s := upto; OPM.Get(ch) + ELSE s := null; OPM.Get(ch) END ; sym := s END Get; diff --git a/src/compiler/OPT.Mod b/src/compiler/OPT.Mod index 5912149b..fb77b0ea 100644 --- a/src/compiler/OPT.Mod +++ b/src/compiler/OPT.Mod @@ -6,24 +6,32 @@ MODULE OPT; (* NW, RC 6.3.89 / 23.1.92 *) (* object model 24.2.94 *) IMPORT OPS, OPM; -CONST - MaxConstLen* = OPS.MaxStrLen; +(* Constants - value of literals *) TYPE - Const* = POINTER TO ConstDesc; - Object* = POINTER TO ObjDesc; - Struct* = POINTER TO StrDesc; - Node* = POINTER TO NodeDesc; - ConstExt* = POINTER TO OPS.String; - + Const* = POINTER TO ConstDesc; + ConstExt* = POINTER TO OPS.String; ConstDesc* = RECORD ext*: ConstExt; (* string or code for code proc *) intval*: LONGINT; (* constant value or adr, proc par size, text position or least case label *) intval2*: LONGINT; (* string length, proc var size or larger case label *) setval*: SET; (* constant value, procedure body present or "ELSE" present in case *) realval*: LONGREAL (* real or longreal constant value *) - END ; + END; +CONST + MaxConstLen* = OPS.MaxStrLen; + + (* conval^.setval procedure flags *) + hasBody* = 1; isRedef* = 2; slNeeded* = 3; + + + + +(* Objects - named items - constants, types, variables, procedures *) +TYPE + Object* = POINTER TO ObjDesc; + Struct* = POINTER TO StrDesc; ObjDesc* = RECORD left*, right*: Object; link*, scope*: Object; @@ -38,22 +46,67 @@ TYPE conval*: Const; adr*, linkadr*: LONGINT; x*: INTEGER (* linkadr and x can be freely used by the backend *) - END ; + END; +CONST + (* Object.mode values *) + Var* = 1; VarPar* = 2; Con* = 3; Fld* = 4; Typ* = 5; LProc* = 6; XProc* = 7; + SProc* = 8; CProc* = 9; IProc* = 10; Mod* = 11; Head* = 12; TProc* = 13; + + (* Object.vis - module visibility of objects *) + internal* = 0; external* = 1; externalR* = 2; + + (* Object.history - History of imported objects *) + inserted* = 0; same* = 1; pbmodified* = 2; pvmodified* = 3; removed* = 4; inconsistent* = 5; + + (* Object.adr Function numbers *) + haltfn* = 0; newfn* = 1; absfn* = 2; capfn* = 3; ordfn* = 4; + entierfn* = 5; oddfn* = 6; minfn* = 7; maxfn* = 8; chrfn* = 9; + shortfn* = 10; longfn* = 11; sizefn* = 12; incfn* = 13; decfn* = 14; + inclfn* = 15; exclfn* = 16; lenfn* = 17; copyfn* = 18; ashfn* = 19; + adrfn* = 20; ccfn* = 21; lshfn* = 22; rotfn* = 23; getfn* = 24; (* SYSTEM *) + putfn* = 25; getrfn* = 26; putrfn* = 27; bitfn* = 28; valfn* = 29; (* SYSTEM *) + sysnewfn* = 30; movefn* = 31; (* SYSTEM *) + assertfn* = 32; + + + + +(* Structures - describe types independently of their name *) +TYPE StrDesc* = RECORD - form*, comp*: SHORTINT; - mno*, extlev*: SHORTINT; - ref*, sysflag*: INTEGER; - n*, size*: LONGINT; - align*, txtpos*: LONGINT; (* align is alignment for records and len offset for dynarrs *) - allocated*: BOOLEAN; - pbused*, pvused*: BOOLEAN; - fpdone, idfpdone: BOOLEAN; - idfp, pbfp*, pvfp*: LONGINT; - BaseTyp*: Struct; - link*, strobj*: Object - END ; + form*, comp*: SHORTINT; + mno*, extlev*: SHORTINT; + ref*, sysflag*: INTEGER; + n*, size*: LONGINT; + align*, txtpos*: LONGINT; (* align is alignment for records, len is offset for dynarrs *) + allocated*: BOOLEAN; + pbused*, pvused*: BOOLEAN; + fpdone, idfpdone: BOOLEAN; + idfp, pbfp, pvfp: LONGINT; + BaseTyp*: Struct; + link*, strobj*: Object + END; +CONST + (* Struct.form values *) + Undef* = 0; Byte* = 1; Bool* = 2; Char* = 3; + SInt* = 4; Int* = 5; LInt* = 6; + Real* = 7; LReal* = 8; Set* = 9; String* = 10; + NilTyp* = 11; NoTyp* = 12; Pointer* = 13; ProcTyp* = 14; + Comp* = 15; + + intSet* = {SInt..LInt}; realSet* = {Real, LReal}; + + (* Struct.comp - Composite structure forms *) + Basic* = 1; Array* = 2; DynArr* = 3; Record* = 4; + + + + +(* Nodes - statements, expressions and sub-expressions *) +TYPE + Node* = POINTER TO NodeDesc; NodeDesc* = RECORD left*, right*, link*: Node; class*, subcl*: SHORTINT; @@ -61,70 +114,66 @@ TYPE typ*: Struct; obj*: Object; conval*: Const - END ; + END; CONST - maxImps = 64; (* must be <= MAX(SHORTINT) *) + (* Node.class values *) + Nvar* = 0; Nvarpar* = 1; Nfield* = 2; Nderef* = 3; Nindex* = 4; Nguard* = 5; Neguard* = 6; + Nconst* = 7; Ntype* = 8; Nproc* = 9; Nupto* = 10; Nmop* = 11; Ndop* = 12; Ncall* = 13; + Ninittd* = 14; Nif* = 15; Ncaselse* = 16; Ncasedo* = 17; Nenter* = 18; Nassign* = 19; + Nifelse* = 20; Ncase* = 21; Nwhile* = 22; Nrepeat* = 23; Nloop* = 24; Nexit* = 25; + Nreturn* = 26; Nwith* = 27; Ntrap* = 28; + + + (* Node.subcl values - general *) + assign* = 0; (* Pseudo function number for assignment *) + super* = 1; + + (* Node.subcl values - functions *) + ash* = 17; msk* = 18; len* = 19; + conv* = 20; abs* = 21; cap* = 22; odd* = 23; + + (* Node.subcl values - SYSTEM functions *) + adr* = 24; cc* = 25; bit* = 26; lsh* = 27; rot* = 28; val* = 29; + + (* Note: some object.adr function numbers and some symbol types are + also are used as Node.subcl function ids *) + eql* = OPS.eql; neq* = OPS.neq; lss* = OPS.lss; + leq* = OPS.leq; gtr* = OPS.gtr; geq* = OPS.geq; + + + +CONST + maxImps = 64; (* must be <= MAX(SHORTINT) *) maxStruct = OPM.MaxStruct; (* must be < MAX(INTEGER) DIV 2 *) - FirstRef = (*20*)16; (* comp + 1 *) + FirstRef = Comp + 1; VAR - typSize*: PROCEDURE(typ: Struct); + typSize*: PROCEDURE(typ: Struct); topScope*: Object; - undftyp*, bytetyp*, booltyp*, chartyp*, sinttyp*, inttyp*, linttyp*, - realtyp*, lrltyp*, settyp*, stringtyp*, niltyp*, notyp*, sysptrtyp*(*, - int8typ*, int16typ*, int32typ*, int64typ* *): Struct; + + undftyp*, + bytetyp*, booltyp*, chartyp*, + sinttyp*, inttyp*, linttyp*, + realtyp*, lrltyp*, settyp*, stringtyp*, + niltyp*, notyp*, sysptrtyp*: Struct; + nofGmod*: SHORTINT; (*nof imports*) - GlbMod*: ARRAY maxImps OF Object; (* ^.right = first object, ^.name = module import name (not alias) *) - SelfName*: OPS.Name; (* name of module being compiled *) + GlbMod*: ARRAY maxImps OF Object; (* ^.right = first object, ^.name = module import name (not alias) *) + + SelfName*: OPS.Name; (* name of module being compiled *) SYSimported*: BOOLEAN; CONST - (* object modes *) - Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; - SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; - (* structure forms *) - Undef = 0; Byte = 1; Bool = 2; Char = 3; - SInt = 4; Int = 5; LInt = 6; - Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Comp = 15; - (*Int8 = 7; Int16 = 8; Int32 = 9; Int64 = 10; - Real = 11; LReal = 12; Set = 13; String = 14; NilTyp = 15; NoTyp = 16; - Pointer = 17; ProcTyp = 18; - Comp = 19;*) - (*Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18; - Comp = 19;*) - (* composite structure forms *) - Basic = 1; Array = 2; DynArr = 3; Record = 4; - - (*function number*) - assign = 0; - haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4; - entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9; - shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14; - inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32; - - (*SYSTEM function number*) - adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23; - getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; - bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31; - - (* module visibility of objects *) - internal = 0; external = 1; externalR = 2; - - (* history of imported objects *) - inserted = 0; same = 1; pbmodified = 2; pvmodified = 3; removed = 4; inconsistent = 5; - - (* symbol file items *) - Smname = 16; Send = 18; Stype = 19; Salias = 20; Svar = 21; Srvar = 22; - Svalpar = 23; Svarpar = 24; Sfld = 25; Srfld = 26; Shdptr = 27; Shdpro = 28; Stpro = 29; Shdtpro = 30; - Sxpro = 31; Sipro = 32; Scpro = 33; Sstruct = 34; Ssys = 35; Sptr = 36; Sarr = 37; Sdarr = 38; Srec = 39; Spro = 40; + (* Symbol file items *) + Smname* = 16; Send* = 18; Stype* = 19; Salias* = 20; Svar* = 21; + Srvar* = 22; Svalpar* = 23; Svarpar* = 24; Sfld* = 25; Srfld* = 26; + Shdptr* = 27; Shdpro* = 28; Stpro* = 29; Shdtpro* = 30; Sxpro* = 31; + Sipro* = 32; Scpro* = 33; Sstruct* = 34; Ssys* = 35; Sptr* = 36; + Sarr* = 37; Sdarr* = 38; Srec* = 39; Spro* = 40; TYPE ImpCtxt = RECORD @@ -135,14 +184,14 @@ TYPE old: ARRAY maxStruct OF Object; pvfp: ARRAY maxStruct OF LONGINT; (* set only if old # NIL *) glbmno: ARRAY maxImps OF SHORTINT (* index is local mno *) - END ; + END; ExpCtxt = RECORD reffp: LONGINT; ref: INTEGER; nofm: SHORTINT; locmno: ARRAY maxImps OF SHORTINT (* index is global mno *) - END ; + END; VAR universe, syslink: Object; @@ -158,38 +207,38 @@ BEGIN OPM.err(n) END err; PROCEDURE NewConst*(): Const; -VAR const: Const; + VAR const: Const; BEGIN NEW(const); RETURN const END NewConst; PROCEDURE NewObj*(): Object; -VAR obj: Object; + VAR obj: Object; BEGIN NEW(obj); RETURN obj END NewObj; PROCEDURE NewStr*(form, comp: SHORTINT): Struct; -VAR typ: Struct; + VAR typ: Struct; BEGIN NEW(typ); typ^.form := form; typ^.comp := comp; typ^.ref := maxStruct; (* ref >= maxStruct: not exported yet *) -IF form # Undef THEN typ^.txtpos := OPM.errpos END ; (* txtpos remains 0 for structs read from symbol file *) -typ^.size := -1; typ^.BaseTyp := undftyp; RETURN typ + IF form # Undef THEN typ^.txtpos := OPM.errpos END ; (* txtpos remains 0 for structs read from symbol file *) + typ^.size := -1; typ^.BaseTyp := undftyp; RETURN typ END NewStr; PROCEDURE NewNode*(class: SHORTINT): Node; -VAR node: Node; + VAR node: Node; BEGIN NEW(node); node^.class := class; RETURN node END NewNode; PROCEDURE NewExt*(): ConstExt; -VAR ext: ConstExt; + VAR ext: ConstExt; BEGIN NEW(ext); RETURN ext END NewExt; PROCEDURE OpenScope*(level: SHORTINT; owner: Object); -VAR head: Object; + VAR head: Object; BEGIN head := NewObj(); -head^.mode := Head; head^.mnolev := level; head^.link := owner; -IF owner # NIL THEN owner^.scope := head END ; -head^.left := topScope; head^.right := NIL; head^.scope := NIL; topScope := head + head^.mode := Head; head^.mnolev := level; head^.link := owner; + IF owner # NIL THEN owner^.scope := head END; + head^.left := topScope; head^.right := NIL; head^.scope := NIL; topScope := head END OpenScope; PROCEDURE CloseScope*; @@ -197,97 +246,100 @@ BEGIN topScope := topScope^.left END CloseScope; PROCEDURE Init*(VAR name: OPS.Name; opt: SET); -CONST nsf = 4; fpc = 8; esf = 9; + CONST nsf = 4; fpc = 8; esf = 9; BEGIN -topScope := universe; OpenScope(0, NIL); SYSimported := FALSE; -SelfName := name; topScope^.name := name; -GlbMod[0] := topScope; nofGmod := 1; -newsf := nsf IN opt; findpc := fpc IN opt; extsf := newsf OR (esf IN opt); sfpresent := TRUE + topScope := universe; OpenScope(0, NIL); SYSimported := FALSE; + SelfName := name; topScope^.name := name; + GlbMod[0] := topScope; nofGmod := 1; + newsf := nsf IN opt; findpc := fpc IN opt; extsf := newsf OR (esf IN opt); sfpresent := TRUE END Init; PROCEDURE Close*; -VAR i: INTEGER; + VAR i: INTEGER; BEGIN (* garbage collection *) -CloseScope; -i := 0; WHILE i < maxImps DO GlbMod[i] := NIL; INC(i) END ; -i := FirstRef; WHILE i < maxStruct DO impCtxt.ref[i] := NIL; impCtxt.old[i] := NIL; INC(i) END + CloseScope; + i := 0; WHILE i < maxImps DO GlbMod[i] := NIL; INC(i) END; + i := FirstRef; WHILE i < maxStruct DO impCtxt.ref[i] := NIL; impCtxt.old[i] := NIL; INC(i) END END Close; PROCEDURE FindImport*(mod: Object; VAR res: Object); -VAR obj: Object; + VAR obj: Object; BEGIN obj := mod^.scope; -LOOP -IF obj = NIL THEN EXIT END ; -IF OPS.name < obj^.name THEN obj := obj^.left -ELSIF OPS.name > obj^.name THEN obj := obj^.right -ELSE (*found*) -IF (obj^.mode = Typ) & (obj^.vis = internal) THEN obj := NIL -ELSE obj^.used := TRUE -END ; -EXIT -END -END ; -res := obj + LOOP + IF obj = NIL THEN EXIT END; + IF OPS.name < obj^.name THEN obj := obj^.left + ELSIF OPS.name > obj^.name THEN obj := obj^.right + ELSE (*found*) + IF (obj^.mode = Typ) & (obj^.vis = internal) THEN obj := NIL + ELSE obj^.used := TRUE + END; + EXIT + END + END; + res := obj END FindImport; PROCEDURE Find*(VAR res: Object); -VAR obj, head: Object; + VAR obj, head: Object; BEGIN head := topScope; -LOOP obj := head^.right; -LOOP -IF obj = NIL THEN EXIT END ; -IF OPS.name < obj^.name THEN obj := obj^.left -ELSIF OPS.name > obj^.name THEN obj := obj^.right -ELSE (* found, obj^.used not set for local objects *) EXIT -END -END ; -IF obj # NIL THEN EXIT END ; -head := head^.left; -IF head = NIL THEN EXIT END -END ; -res := obj + LOOP obj := head^.right; + LOOP + IF obj = NIL THEN EXIT END; + IF OPS.name < obj^.name THEN obj := obj^.left + ELSIF OPS.name > obj^.name THEN obj := obj^.right + ELSE (* found, obj^.used not set for local objects *) EXIT + END + END; + IF obj # NIL THEN EXIT END; + head := head^.left; + IF head = NIL THEN EXIT END + END; + res := obj END Find; PROCEDURE FindField*(VAR name: OPS.Name; typ: Struct; VAR res: Object); -VAR obj: Object; + VAR obj: Object; BEGIN -WHILE typ # NIL DO obj := typ^.link; -WHILE obj # NIL DO -IF name < obj^.name THEN obj := obj^.left -ELSIF name > obj^.name THEN obj := obj^.right -ELSE (*found*) res := obj; RETURN -END -END ; -typ := typ^.BaseTyp -END ; -res := NIL + WHILE typ # NIL DO obj := typ^.link; + WHILE obj # NIL DO + IF name < obj^.name THEN obj := obj^.left + ELSIF name > obj^.name THEN obj := obj^.right + ELSE (*found*) res := obj; RETURN + END + END; + typ := typ^.BaseTyp + END; + res := NIL END FindField; PROCEDURE Insert*(VAR name: OPS.Name; VAR obj: Object); -VAR ob0, ob1: Object; left: BOOLEAN; mnolev: SHORTINT; + VAR ob0, ob1: Object; left: BOOLEAN; mnolev: SHORTINT; BEGIN ob0 := topScope; ob1 := ob0^.right; left := FALSE; -LOOP -IF ob1 # NIL THEN -IF name < ob1^.name THEN ob0 := ob1; ob1 := ob0^.left; left := TRUE -ELSIF name > ob1^.name THEN ob0 := ob1; ob1 := ob0^.right; left := FALSE -ELSE (*double def*) err(1); ob0 := ob1; ob1 := ob0^.right -END -ELSE (*insert*) ob1 := NewObj(); ob1^.leaf := TRUE; -IF left THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END ; -ob1^.left := NIL; ob1^.right := NIL; COPY(name, ob1^.name); -mnolev := topScope^.mnolev; ob1^.mnolev := mnolev; -EXIT -END -END ; -obj := ob1 + LOOP + IF ob1 # NIL THEN + IF name < ob1^.name THEN ob0 := ob1; ob1 := ob0^.left; left := TRUE + ELSIF name > ob1^.name THEN ob0 := ob1; ob1 := ob0^.right; left := FALSE + ELSE (*double def*) err(1); ob0 := ob1; ob1 := ob0^.right + END + ELSE (*insert*) ob1 := NewObj(); ob1^.leaf := TRUE; + IF left THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END; + ob1^.left := NIL; ob1^.right := NIL; COPY(name, ob1^.name); + mnolev := topScope^.mnolev; ob1^.mnolev := mnolev; + EXIT + END + END; + obj := ob1 END Insert; + (*-------------------------- Fingerprinting --------------------------*) +(* Fingerprints prevent structural type equivalence. *) + PROCEDURE FPrintName(VAR fp: LONGINT; VAR name: ARRAY OF CHAR); -VAR i: INTEGER; ch: CHAR; + VAR i: INTEGER; ch: CHAR; BEGIN i := 0; -REPEAT ch := name[i]; OPM.FPrint(fp, ORD(ch)); INC(i) UNTIL ch = 0X + REPEAT ch := name[i]; OPM.FPrint(fp, ORD(ch)); INC(i) UNTIL ch = 0X END FPrintName; PROCEDURE ^IdFPrint*(typ: Struct); @@ -328,134 +380,133 @@ BEGIN btyp := typ^.BaseTyp; strobj := typ^.strobj; IF (strobj # NIL) & (strobj^.name # "") THEN FPrintName(idfp, GlbMod[typ^.mno]^.name); FPrintName(idfp, strobj^.name) - END ; + END; IF (f = Pointer) OR (c = Record) & (btyp # NIL) OR (c = DynArr) THEN IdFPrint(btyp); OPM.FPrint(idfp, btyp^.idfp) ELSIF c = Array THEN IdFPrint(btyp); OPM.FPrint(idfp, btyp^.idfp); OPM.FPrint(idfp, typ^.n) ELSIF f = ProcTyp THEN FPrintSign(idfp, btyp, typ^.link) - END ; + END; typ^.idfp := idfp END END IdFPrint; PROCEDURE FPrintStr*(typ: Struct); -VAR f, c: INTEGER; btyp: Struct; strobj, bstrobj: Object; pbfp, pvfp: LONGINT; + VAR f, c: INTEGER; btyp: Struct; strobj, bstrobj: Object; pbfp, pvfp: LONGINT; -PROCEDURE ^FPrintFlds(fld: Object; adr: LONGINT; visible: BOOLEAN); + PROCEDURE ^FPrintFlds(fld: Object; adr: LONGINT; visible: BOOLEAN); -PROCEDURE FPrintHdFld(typ: Struct; fld: Object; adr: LONGINT); (* modifies pvfp only *) -VAR i, j, n: LONGINT; btyp: Struct; -BEGIN -IF typ^.comp = Record THEN FPrintFlds(typ^.link, adr, FALSE) -ELSIF typ^.comp = Array THEN btyp := typ^.BaseTyp; n := typ^.n; -WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; -IF (btyp^.form = Pointer) OR (btyp^.comp = Record) THEN - j := nofhdfld; FPrintHdFld(btyp, fld, adr); - IF j # nofhdfld THEN i := 1; - WHILE (i < n) & (nofhdfld <= OPM.MaxHdFld) DO - INC(adr, btyp^.size); FPrintHdFld(btyp, fld, adr); INC(i) + PROCEDURE FPrintHdFld(typ: Struct; fld: Object; adr: LONGINT); (* modifies pvfp only *) + VAR i, j, n: LONGINT; btyp: Struct; + BEGIN + IF typ^.comp = Record THEN FPrintFlds(typ^.link, adr, FALSE) + ELSIF typ^.comp = Array THEN btyp := typ^.BaseTyp; n := typ^.n; + WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END; + IF (btyp^.form = Pointer) OR (btyp^.comp = Record) THEN + j := nofhdfld; FPrintHdFld(btyp, fld, adr); + IF j # nofhdfld THEN i := 1; + WHILE (i < n) & (nofhdfld <= OPM.MaxHdFld) DO + INC(adr, btyp^.size); FPrintHdFld(btyp, fld, adr); INC(i) + END + END + END + ELSIF OPM.ExpHdPtrFld & ((typ^.form = Pointer) OR (fld^.name = OPM.HdPtrName)) THEN + OPM.FPrint(pvfp, Pointer); OPM.FPrint(pvfp, adr); INC(nofhdfld) + ELSIF OPM.ExpHdProcFld & ((typ^.form = ProcTyp) OR (fld^.name = OPM.HdProcName)) THEN + OPM.FPrint(pvfp, ProcTyp); OPM.FPrint(pvfp, adr); INC(nofhdfld) + END + END FPrintHdFld; + + PROCEDURE FPrintFlds(fld: Object; adr: LONGINT; visible: BOOLEAN); (* modifies pbfp and pvfp *) + BEGIN + WHILE (fld # NIL) & (fld^.mode = Fld) DO + IF (fld^.vis # internal) & visible THEN + OPM.FPrint(pbfp, fld^.vis); FPrintName(pbfp, fld^.name); OPM.FPrint(pbfp, fld^.adr); + FPrintStr(fld^.typ); OPM.FPrint(pbfp, fld^.typ^.pbfp); OPM.FPrint(pvfp, fld^.typ^.pvfp) + ELSE + FPrintHdFld(fld^.typ, fld, fld^.adr + adr) + END; + fld := fld^.link END; - END -END -ELSIF OPM.ExpHdPtrFld & ((typ^.form = Pointer) OR (fld^.name = OPM.HdPtrName)) THEN -OPM.FPrint(pvfp, Pointer); OPM.FPrint(pvfp, adr); INC(nofhdfld) -ELSIF OPM.ExpHdProcFld & ((typ^.form = ProcTyp) OR (fld^.name = OPM.HdProcName)) THEN -OPM.FPrint(pvfp, ProcTyp); OPM.FPrint(pvfp, adr); INC(nofhdfld) -END -END FPrintHdFld; + END FPrintFlds; -PROCEDURE FPrintFlds(fld: Object; adr: LONGINT; visible: BOOLEAN); (* modifies pbfp and pvfp *) -BEGIN -WHILE (fld # NIL) & (fld^.mode = Fld) DO - IF (fld^.vis # internal) & visible THEN - OPM.FPrint(pbfp, fld^.vis); FPrintName(pbfp, fld^.name); OPM.FPrint(pbfp, fld^.adr); - FPrintStr(fld^.typ); OPM.FPrint(pbfp, fld^.typ^.pbfp); OPM.FPrint(pvfp, fld^.typ^.pvfp) - ELSE - FPrintHdFld(fld^.typ, fld, fld^.adr + adr) - END ; - fld := fld^.link -END; -END FPrintFlds; - -PROCEDURE FPrintTProcs(obj: Object); (* modifies pbfp and pvfp *) -BEGIN - IF obj # NIL THEN + PROCEDURE FPrintTProcs(obj: Object); (* modifies pbfp and pvfp *) + BEGIN + IF obj # NIL THEN FPrintTProcs(obj^.left); IF obj^.mode = TProc THEN - IF obj^.vis # internal THEN - OPM.FPrint(pbfp, TProc); OPM.FPrint(pbfp, obj^.adr DIV 10000H); - FPrintSign(pbfp, obj^.typ, obj^.link); FPrintName(pbfp, obj^.name) - ELSIF OPM.ExpHdTProc THEN - OPM.FPrint(pvfp, TProc); OPM.FPrint(pvfp, obj^.adr DIV 10000H) - END - END ; + IF obj^.vis # internal THEN + OPM.FPrint(pbfp, TProc); OPM.FPrint(pbfp, obj^.adr DIV 10000H); + FPrintSign(pbfp, obj^.typ, obj^.link); FPrintName(pbfp, obj^.name) + ELSIF OPM.ExpHdTProc THEN + OPM.FPrint(pvfp, TProc); OPM.FPrint(pvfp, obj^.adr DIV 10000H) + END + END; FPrintTProcs(obj^.right) - END; -END FPrintTProcs; + END; + END FPrintTProcs; BEGIN - IF ~typ^.fpdone THEN - IdFPrint(typ); pbfp := typ^.idfp; - IF typ^.sysflag # 0 THEN OPM.FPrint(pbfp, typ^.sysflag) END ; - pvfp := pbfp; typ^.pbfp := pbfp; typ^.pvfp := pvfp; (* initial fprints may be used recursively *) - typ^.fpdone := TRUE; - f := typ^.form; c := typ^.comp; btyp := typ^.BaseTyp; - IF f = Pointer THEN - strobj := typ^.strobj; bstrobj := btyp^.strobj; - IF (strobj = NIL) OR (strobj^.name = "") OR (bstrobj = NIL) OR (bstrobj^.name = "") THEN - FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pbfp); pvfp := pbfp - (* else use idfp as pbfp and as pvfp, do not call FPrintStr(btyp) here, else cycle not broken *) - END - ELSIF f = ProcTyp THEN (* use idfp as pbfp and as pvfp *) - ELSIF c IN {Array, DynArr} THEN FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pvfp); pvfp := pbfp - ELSE (* c = Record *) - IF btyp # NIL THEN FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pbfp); OPM.FPrint(pvfp, btyp^.pvfp) END ; - OPM.FPrint(pvfp, typ^.size); OPM.FPrint(pvfp, typ^.align); OPM.FPrint(pvfp, typ^.n); - nofhdfld := 0; FPrintFlds(typ^.link, 0, TRUE); - IF nofhdfld > OPM.MaxHdFld THEN OPM.Mark(225, typ^.txtpos) END ; - FPrintTProcs(typ^.link); OPM.FPrint(pvfp, pbfp); strobj := typ^.strobj; - IF (strobj = NIL) OR (strobj^.name = "") THEN pbfp := pvfp END - END ; - typ^.pbfp := pbfp; typ^.pvfp := pvfp - END; + IF ~typ^.fpdone THEN + IdFPrint(typ); pbfp := typ^.idfp; + IF typ^.sysflag # 0 THEN OPM.FPrint(pbfp, typ^.sysflag) END; + pvfp := pbfp; typ^.pbfp := pbfp; typ^.pvfp := pvfp; (* initial fprints may be used recursively *) + typ^.fpdone := TRUE; + f := typ^.form; c := typ^.comp; btyp := typ^.BaseTyp; + IF f = Pointer THEN + strobj := typ^.strobj; bstrobj := btyp^.strobj; + IF (strobj = NIL) OR (strobj^.name = "") OR (bstrobj = NIL) OR (bstrobj^.name = "") THEN + FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pbfp); pvfp := pbfp + (* else use idfp as pbfp and as pvfp, do not call FPrintStr(btyp) here, else cycle not broken *) + END + ELSIF f = ProcTyp THEN (* use idfp as pbfp and as pvfp *) + ELSIF c IN {Array, DynArr} THEN FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pvfp); pvfp := pbfp + ELSE (* c = Record *) + IF btyp # NIL THEN FPrintStr(btyp); OPM.FPrint(pbfp, btyp^.pbfp); OPM.FPrint(pvfp, btyp^.pvfp) END; + OPM.FPrint(pvfp, typ^.size); OPM.FPrint(pvfp, typ^.align); OPM.FPrint(pvfp, typ^.n); + nofhdfld := 0; FPrintFlds(typ^.link, 0, TRUE); + IF nofhdfld > OPM.MaxHdFld THEN OPM.Mark(225, typ^.txtpos) END; + FPrintTProcs(typ^.link); OPM.FPrint(pvfp, pbfp); strobj := typ^.strobj; + IF (strobj = NIL) OR (strobj^.name = "") THEN pbfp := pvfp END + END; + typ^.pbfp := pbfp; typ^.pvfp := pvfp + END END FPrintStr; PROCEDURE FPrintObj*(obj: Object); VAR fprint: LONGINT; f, m: INTEGER; rval: REAL; ext: ConstExt; BEGIN - IF ~obj^.fpdone THEN - fprint := 0; obj^.fpdone := TRUE; - OPM.FPrint(fprint, obj^.mode); - IF obj^.mode = Con THEN - f := obj^.typ^.form; OPM.FPrint(fprint, f); - CASE f OF - | Bool, Char, SInt, Int, LInt(*, Int8, Int16, Int32, Int64*): - OPM.FPrint(fprint, obj^.conval^.intval) - | Set: - OPM.FPrintSet(fprint, obj^.conval^.setval) - | Real: - rval := SHORT(obj^.conval^.realval); OPM.FPrintReal(fprint, rval) - | LReal: - OPM.FPrintLReal(fprint, obj^.conval^.realval) - | String: - FPrintName(fprint, obj^.conval^.ext^) - | NilTyp: - ELSE err(127) - END - ELSIF obj^.mode = Var THEN - OPM.FPrint(fprint, obj^.vis); FPrintStr(obj^.typ); OPM.FPrint(fprint, obj^.typ^.pbfp) - ELSIF obj^.mode IN {XProc, IProc} THEN - FPrintSign(fprint, obj^.typ, obj^.link) - ELSIF obj^.mode = CProc THEN - FPrintSign(fprint, obj^.typ, obj^.link); ext := obj^.conval^.ext; - m := ORD(ext^[0]); f := 1; OPM.FPrint(fprint, m); - WHILE f <= m DO OPM.FPrint(fprint, ORD(ext^[f])); INC(f) END; - ELSIF obj^.mode = Typ THEN - FPrintStr(obj^.typ); OPM.FPrint(fprint, obj^.typ^.pbfp) - END ; - obj^.fprint := fprint - END + IF ~obj^.fpdone THEN + fprint := 0; obj^.fpdone := TRUE; + OPM.FPrint(fprint, obj^.mode); + IF obj^.mode = Con THEN + f := obj^.typ^.form; OPM.FPrint(fprint, f); + CASE f OF + | Bool, + Char, + SInt, + Int, + LInt: OPM.FPrint(fprint, obj^.conval^.intval) + | Set: OPM.FPrintSet(fprint, obj^.conval^.setval) + | Real: rval := SHORT(obj^.conval^.realval); OPM.FPrintReal(fprint, rval) + | LReal: OPM.FPrintLReal(fprint, obj^.conval^.realval) + | String: FPrintName(fprint, obj^.conval^.ext^) + | NilTyp: + ELSE err(127) + END + ELSIF obj^.mode = Var THEN + OPM.FPrint(fprint, obj^.vis); FPrintStr(obj^.typ); OPM.FPrint(fprint, obj^.typ^.pbfp) + ELSIF obj^.mode IN {XProc, IProc} THEN + FPrintSign(fprint, obj^.typ, obj^.link) + ELSIF obj^.mode = CProc THEN + FPrintSign(fprint, obj^.typ, obj^.link); ext := obj^.conval^.ext; + m := ORD(ext^[0]); f := 1; OPM.FPrint(fprint, m); + WHILE f <= m DO OPM.FPrint(fprint, ORD(ext^[f])); INC(f) END; + ELSIF obj^.mode = Typ THEN + FPrintStr(obj^.typ); OPM.FPrint(fprint, obj^.typ^.pbfp) + END; + obj^.fprint := fprint + END END FPrintObj; PROCEDURE FPrintErr*(obj: Object; errcode: INTEGER); @@ -463,19 +514,19 @@ VAR i, j: INTEGER; ch: CHAR; BEGIN IF obj^.mnolev # 0 THEN COPY(GlbMod[-obj^.mnolev]^.name, OPM.objname); i := 0; - WHILE OPM.objname[i] # 0X DO INC(i) END ; + WHILE OPM.objname[i] # 0X DO INC(i) END; OPM.objname[i] := "."; j := 0; INC(i); REPEAT ch := obj^.name[j]; OPM.objname[i] := ch; INC(j); INC(i) UNTIL ch = 0X; ELSE COPY(obj^.name, OPM.objname) - END ; + END; IF errcode = 249 THEN IF OPM.noerr THEN err(errcode) END ELSIF errcode = 253 THEN (* extension *) - IF ~symNew & ~symExtended & ~extsf THEN err(errcode) END ; + IF ~symNew & ~symExtended & ~extsf THEN err(errcode) END; symExtended := TRUE ELSE - IF ~symNew & ~newsf THEN err(errcode) END ; + IF ~symNew & ~newsf THEN err(errcode) END; symNew := TRUE END END FPrintErr; @@ -483,372 +534,361 @@ END FPrintErr; (*-------------------------- Import --------------------------*) PROCEDURE InsertImport*(obj: Object; VAR root, old: Object); -VAR ob0, ob1: Object; left: BOOLEAN; + VAR ob0, ob1: Object; left: BOOLEAN; BEGIN -IF root = NIL THEN root := obj; old := NIL -ELSE -ob0 := root; ob1 := ob0^.right; left := FALSE; -IF obj^.name < ob0^.name THEN ob1 := ob0^.left; left := TRUE -ELSIF obj^.name > ob0^.name THEN ob1 := ob0^.right; left := FALSE -ELSE old := ob0; RETURN -END ; -LOOP -IF ob1 # NIL THEN - IF obj^.name < ob1^.name THEN ob0 := ob1; ob1 := ob1^.left; left := TRUE - ELSIF obj^.name > ob1^.name THEN ob0 := ob1; ob1 := ob1^.right; left := FALSE - ELSE old := ob1; EXIT + IF root = NIL THEN root := obj; old := NIL + ELSE + ob0 := root; ob1 := ob0^.right; left := FALSE; + IF obj^.name < ob0^.name THEN ob1 := ob0^.left; left := TRUE + ELSIF obj^.name > ob0^.name THEN ob1 := ob0^.right; left := FALSE + ELSE old := ob0; RETURN + END; + LOOP + IF ob1 # NIL THEN + IF obj^.name < ob1^.name THEN ob0 := ob1; ob1 := ob1^.left; left := TRUE + ELSIF obj^.name > ob1^.name THEN ob0 := ob1; ob1 := ob1^.right; left := FALSE + ELSE old := ob1; EXIT + END + ELSE ob1 := obj; + IF left THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END; + ob1^.left := NIL; ob1^.right := NIL; old := NIL; EXIT + END + END END -ELSE ob1 := obj; - IF left THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END ; - ob1^.left := NIL; ob1^.right := NIL; old := NIL; EXIT -END -END -END END InsertImport; PROCEDURE InName(VAR name: ARRAY OF CHAR); VAR i: INTEGER; ch: CHAR; BEGIN i := 0; -REPEAT -OPM.SymRCh(ch); name[i] := ch; INC(i) -UNTIL ch = 0X + REPEAT + OPM.SymRCh(ch); name[i] := ch; INC(i) + UNTIL ch = 0X END InName; PROCEDURE InMod(VAR mno: SHORTINT); (* mno is global *) -VAR head: Object; name: OPS.Name; mn: LONGINT; i: SHORTINT; + VAR head: Object; name: OPS.Name; mn: LONGINT; i: SHORTINT; BEGIN -mn := OPM.SymRInt(); -IF mn = 0 THEN mno := impCtxt.glbmno[0] -ELSE -IF mn = Smname THEN -InName(name); -IF (name = SelfName) & ~impCtxt.self THEN err(154) END ; -i := 0; -WHILE (i < nofGmod) & (name # GlbMod[i].name) DO INC(i) END ; -IF i < nofGmod THEN mno := i (*module already present*) -ELSE - head := NewObj(); head^.mode := Head; COPY(name, head^.name); - mno := nofGmod; head^.mnolev := -mno; - IF nofGmod < maxImps THEN - GlbMod[mno] := head; INC(nofGmod) - ELSE err(227) + mn := OPM.SymRInt(); + IF mn = 0 THEN mno := impCtxt.glbmno[0] + ELSE + IF mn = Smname THEN + InName(name); + IF (name = SelfName) & ~impCtxt.self THEN err(154) END; + i := 0; + WHILE (i < nofGmod) & (name # GlbMod[i].name) DO INC(i) END; + IF i < nofGmod THEN mno := i (*module already present*) + ELSE + head := NewObj(); head^.mode := Head; COPY(name, head^.name); + mno := nofGmod; head^.mnolev := -mno; + IF nofGmod < maxImps THEN + GlbMod[mno] := head; INC(nofGmod) + ELSE err(227) + END + END; + impCtxt.glbmno[impCtxt.nofm] := mno; INC(impCtxt.nofm) + ELSE + mno := impCtxt.glbmno[-mn] + END END -END ; -impCtxt.glbmno[impCtxt.nofm] := mno; INC(impCtxt.nofm) -ELSE -mno := impCtxt.glbmno[-mn] -END -END END InMod; PROCEDURE InConstant(f: LONGINT; conval: Const); -VAR ch: CHAR; i: INTEGER; ext: ConstExt; rval: REAL; + VAR ch: CHAR; i: INTEGER; ext: ConstExt; rval: REAL; BEGIN -CASE f OF -| (*Int8,*) Byte, Char, Bool: -OPM.SymRCh(ch); conval^.intval := ORD(ch) -(*| Int8, Int16, Int32, Int64: -conval^.intval := OPM.SymRInt()*) -| SInt, Int, LInt: -conval^.intval := OPM.SymRInt() -| Set: -OPM.SymRSet(conval^.setval) -| Real: -OPM.SymRReal(rval); conval^.realval := rval; -conval^.intval := OPM.ConstNotAlloc -| LReal: -OPM.SymRLReal(conval^.realval); -conval^.intval := OPM.ConstNotAlloc -| String: -ext := NewExt(); conval^.ext := ext; i := 0; -REPEAT -OPM.SymRCh(ch); ext^[i] := ch; INC(i) -UNTIL ch = 0X; -conval^.intval2 := i; -conval^.intval := OPM.ConstNotAlloc -| NilTyp: -conval^.intval := OPM.nilval -ELSE -OPM.LogWStr("unhandled case in OPT.InConstant(), f = "); OPM.LogWNum(f, 0); OPM.LogWLn; -END + CASE f OF + | Byte, + Char, + Bool: OPM.SymRCh(ch); conval^.intval := ORD(ch) + | SInt, + Int, + LInt: conval^.intval := OPM.SymRInt() + | Set: OPM.SymRSet(conval^.setval) + | Real: OPM.SymRReal(rval); conval^.realval := rval; + conval^.intval := OPM.ConstNotAlloc + | LReal: OPM.SymRLReal(conval^.realval); + conval^.intval := OPM.ConstNotAlloc + | String: ext := NewExt(); conval^.ext := ext; i := 0; + REPEAT + OPM.SymRCh(ch); ext^[i] := ch; INC(i) + UNTIL ch = 0X; + conval^.intval2 := i; + conval^.intval := OPM.ConstNotAlloc + | NilTyp: conval^.intval := OPM.nilval + ELSE OPM.LogWStr("unhandled case in InConstant(), f = "); OPM.LogWNum(f, 0); OPM.LogWLn; + END END InConstant; PROCEDURE ^InStruct(VAR typ: Struct); PROCEDURE InSign(mno: SHORTINT; VAR res: Struct; VAR par: Object); -VAR last, new: Object; tag: LONGINT; + VAR last, new: Object; tag: LONGINT; BEGIN -InStruct(res); -tag := OPM.SymRInt(); last := NIL; -WHILE tag # Send DO -new := NewObj(); new^.mnolev := -mno; -IF last = NIL THEN par := new ELSE last^.link := new END ; -IF tag = Svalpar THEN new^.mode := Var ELSE new^.mode := VarPar END ; -InStruct(new^.typ); new^.adr := OPM.SymRInt(); InName(new^.name); -last := new; tag := OPM.SymRInt() -END + InStruct(res); + tag := OPM.SymRInt(); last := NIL; + WHILE tag # Send DO + new := NewObj(); new^.mnolev := -mno; + IF last = NIL THEN par := new ELSE last^.link := new END; + IF tag = Svalpar THEN new^.mode := Var ELSE new^.mode := VarPar END; + InStruct(new^.typ); new^.adr := OPM.SymRInt(); InName(new^.name); + last := new; tag := OPM.SymRInt() + END END InSign; PROCEDURE InFld(): Object; (* first number in impCtxt.nextTag, mno set outside *) -VAR tag: LONGINT; obj: Object; + VAR tag: LONGINT; obj: Object; BEGIN -tag := impCtxt.nextTag; obj := NewObj(); -IF tag <= Srfld THEN -obj^.mode := Fld; -IF tag = Srfld THEN obj^.vis := externalR ELSE obj^.vis := external END ; -InStruct(obj^.typ); InName(obj^.name); -obj^.adr := OPM.SymRInt() -ELSE -obj^.mode := Fld; -IF tag = Shdptr THEN obj^.name := OPM.HdPtrName ELSE obj^.name := OPM.HdProcName END ; -obj^.typ := undftyp; obj^.vis := internal; -obj^.adr := OPM.SymRInt() -END ; -RETURN obj + tag := impCtxt.nextTag; obj := NewObj(); + IF tag <= Srfld THEN + obj^.mode := Fld; + IF tag = Srfld THEN obj^.vis := externalR ELSE obj^.vis := external END; + InStruct(obj^.typ); InName(obj^.name); + obj^.adr := OPM.SymRInt() + ELSE + obj^.mode := Fld; + IF tag = Shdptr THEN obj^.name := OPM.HdPtrName ELSE obj^.name := OPM.HdProcName END; + obj^.typ := undftyp; obj^.vis := internal; + obj^.adr := OPM.SymRInt() + END; + RETURN obj END InFld; PROCEDURE InTProc(mno: SHORTINT): Object; (* first number in impCtxt.nextTag *) -VAR tag: LONGINT; obj: Object; + VAR tag: LONGINT; obj: Object; BEGIN -tag := impCtxt.nextTag; -obj := NewObj(); obj^.mnolev := -mno; -IF tag = Stpro THEN -obj^.mode := TProc; obj^.conval := NewConst(); obj^.conval^.intval := -1; -InSign(mno, obj^.typ, obj^.link); obj^.vis := external; InName(obj^.name); -obj^.adr := 10000H*OPM.SymRInt() -ELSE (* tag = Shdtpro *) -obj^.mode := TProc; obj^.name := OPM.HdTProcName; -obj^.link := NewObj(); (* dummy, easier in Browser *) -obj^.typ := undftyp; obj^.vis := internal; -obj^.adr := 10000H*OPM.SymRInt() -END ; -RETURN obj + tag := impCtxt.nextTag; + obj := NewObj(); obj^.mnolev := -mno; + IF tag = Stpro THEN + obj^.mode := TProc; obj^.conval := NewConst(); obj^.conval^.intval := -1; + InSign(mno, obj^.typ, obj^.link); obj^.vis := external; InName(obj^.name); + obj^.adr := 10000H*OPM.SymRInt() + ELSE (* tag = Shdtpro *) + obj^.mode := TProc; obj^.name := OPM.HdTProcName; + obj^.link := NewObj(); (* dummy, easier in Browser *) + obj^.typ := undftyp; obj^.vis := internal; + obj^.adr := 10000H*OPM.SymRInt() + END; + RETURN obj END InTProc; PROCEDURE InStruct(VAR typ: Struct); -VAR mno: SHORTINT; ref: INTEGER; tag: LONGINT; name: OPS.Name; -t: Struct; obj, last, fld, old, dummy: Object; + VAR mno: SHORTINT; ref: INTEGER; tag: LONGINT; name: OPS.Name; + t: Struct; obj, last, fld, old, dummy: Object; BEGIN - tag := OPM.SymRInt(); - IF tag # Sstruct THEN - typ := impCtxt.ref[-tag] - ELSE - ref := impCtxt.nofr; INC(impCtxt.nofr); - IF ref < impCtxt.minr THEN impCtxt.minr := ref END ; - InMod(mno); InName(name); obj := NewObj(); - IF name = "" THEN - IF impCtxt.self THEN - old := NIL (* do not insert type desc anchor here, but in OPL *) - ELSE - obj^.name := "@"; InsertImport(obj, GlbMod[mno].right, old(*=NIL*)); obj^.name := "" - END ; - typ := NewStr(Undef, Basic) - ELSE - obj^.name := name; InsertImport(obj, GlbMod[mno].right, old); - IF old # NIL THEN (* recalculate fprints to compare with old fprints *) - FPrintObj(old); impCtxt.pvfp[ref] := old^.typ^.pvfp; - IF impCtxt.self THEN (* do not overwrite old typ *) - typ := NewStr(Undef, Basic) - ELSE (* overwrite old typ for compatibility reason *) - typ := old^.typ; typ^.link := NIL; typ^.sysflag := 0; - typ^.fpdone := FALSE; typ^.idfpdone := FALSE - END - ELSE - typ := NewStr(Undef, Basic) - END - END ; - impCtxt.ref[ref] := typ; impCtxt.old[ref] := old; - typ^.ref := ref + maxStruct; - (* ref >= maxStruct: not exported yet, ref used for err 155 *) - typ^.mno := mno; typ^.allocated := TRUE; - typ^.strobj := obj; obj^.mode := Typ; obj^.typ := typ; - obj^.mnolev := -mno; obj^.vis := internal; (* name not visible here *) - tag := OPM.SymRInt(); - IF tag = Ssys THEN typ^.sysflag := SHORT(OPM.SymRInt()); tag := OPM.SymRInt() END ; - CASE tag OF - | Sptr: - typ^.form := Pointer; typ^.size := OPM.PointerSize; - typ^.n := 0; InStruct(typ^.BaseTyp) - | Sarr: - typ^.form := Comp; typ^.comp := Array; - InStruct(typ^.BaseTyp); typ^.n := OPM.SymRInt(); - typSize(typ) (* no bounds address !! *) - | Sdarr: - typ^.form := Comp; typ^.comp := DynArr; InStruct(typ^.BaseTyp); - IF typ^.BaseTyp^.comp = DynArr THEN - typ^.n := typ^.BaseTyp^.n + 1 - ELSE - typ^.n := 0 - END ; - typSize(typ) - | Srec: - typ^.form := Comp; typ^.comp := Record; - InStruct(typ^.BaseTyp); - IF typ^.BaseTyp = notyp THEN typ^.BaseTyp := NIL END; - typ.extlev := 0; t := typ.BaseTyp; - (* do not take extlev from base type due to possible cycles! *) - WHILE (t # NIL) (*& (t^.BaseTyp # t)*)(*(t^.(*BaseTyp^.*)form # 0)*) DO INC(typ^.extlev); t := t.BaseTyp END; (* !!! *) - typ^.size := OPM.SymRInt(); typ^.align := OPM.SymRInt(); - typ^.n := OPM.SymRInt(); - impCtxt.nextTag := OPM.SymRInt(); last := NIL; - WHILE (impCtxt.nextTag >= Sfld) & (impCtxt.nextTag <= Shdpro) DO - fld := InFld(); fld^.mnolev := -mno; - IF last # NIL THEN last^.link := fld END ; - last := fld; InsertImport(fld, typ^.link, dummy); - impCtxt.nextTag := OPM.SymRInt() - END ; - WHILE impCtxt.nextTag # Send DO - fld := InTProc(mno); - InsertImport(fld, typ^.link, dummy); - impCtxt.nextTag := OPM.SymRInt() - END - | Spro: - typ^.form := ProcTyp; typ^.size := OPM.ProcSize; - InSign(mno, typ^.BaseTyp, typ^.link) - ELSE - OPM.LogWStr("unhandled case at OPT.InStruct, tag = "); OPM.LogWNum(tag, 0); OPM.LogWLn; -END ; - IF ref = impCtxt.minr THEN - WHILE (ref < impCtxt.nofr) (*OR ((ref >= Int8) & (ref <= Int64))*) DO - t := impCtxt.ref[ref]; FPrintStr(t); - obj := t^.strobj; (* obj^.typ^.strobj = obj, else obj^.fprint differs (alias) *) - IF obj^.name # "" THEN FPrintObj(obj) END ; - old := impCtxt.old[ref]; - IF old # NIL THEN - t^.strobj := old; (* restore strobj *) - IF impCtxt.self THEN - IF old^.mnolev < 0 THEN - IF old^.history # inconsistent THEN - IF old^.fprint # obj^.fprint THEN - old^.history := pbmodified - ELSIF impCtxt.pvfp[ref] # t^.pvfp THEN - old^.history := pvmodified - END - (* ELSE remain inconsistent *) - END - ELSIF old^.fprint # obj^.fprint THEN - old^.history := pbmodified - ELSIF impCtxt.pvfp[ref] # t^.pvfp THEN - old^.history := pvmodified - ELSIF old^.vis = internal THEN - old^.history := same (* may be changed to "removed" in InObj *) - ELSE - old^.history := inserted (* may be changed to "same" in InObj *) - END - ELSE - (* check private part, delay error message until really used *) - IF impCtxt.pvfp[ref] # t^.pvfp THEN - old^.history := inconsistent - END ; - IF old^.fprint # obj^.fprint THEN - FPrintErr(old, 249) - END - END - ELSIF impCtxt.self THEN - obj^.history := removed - ELSE - obj^.history := same - END ; - INC(ref) - END ; - impCtxt.minr := maxStruct - END - END -END InStruct; - - PROCEDURE InObj(mno: SHORTINT): Object; (* first number in impCtxt.nextTag *) - VAR i, s: INTEGER; ch: CHAR; obj, old: Object; typ: Struct; - tag: LONGINT; ext: ConstExt; - BEGIN - tag := impCtxt.nextTag; - IF tag = Stype THEN - InStruct(typ); obj := typ^.strobj; - IF ~impCtxt.self THEN obj^.vis := external END (* type name visible now, obj^.fprint already done *) - ELSE - obj := NewObj(); obj^.mnolev := -mno; obj^.vis := external; - IF tag <= Pointer THEN (* Constant *) - obj^.mode := Con; obj^.typ := impCtxt.ref[tag]; obj^.conval := NewConst(); InConstant(tag, obj^.conval) - ELSIF tag >= Sxpro THEN - obj^.conval := NewConst(); - obj^.conval^.intval := -1; - InSign(mno, obj^.typ, obj^.link); - CASE tag OF - | Sxpro: obj^.mode := XProc - | Sipro: obj^.mode := IProc - | Scpro: obj^.mode := CProc; - ext := NewExt(); obj^.conval^.ext := ext; - s := SHORT(OPM.SymRInt()); ext^[0] := CHR(s); i := 1; - WHILE i <= s DO OPM.SymRCh(ext^[i]); INC(i) END + tag := OPM.SymRInt(); + IF tag # Sstruct THEN + typ := impCtxt.ref[-tag] ELSE - OPM.LogWStr("unhandled case at OPT.InObj, tag = "); OPM.LogWNum(tag, 0); OPM.LogWLn; - END - ELSIF tag = Salias THEN - obj^.mode := Typ; InStruct(obj^.typ) - ELSE - obj^.mode := Var; - IF tag = Srvar THEN obj^.vis := externalR END ; - InStruct(obj^.typ) - END ; - InName(obj^.name) - END ; - FPrintObj(obj); - IF (obj^.mode = Var) & ((obj^.typ^.strobj = NIL) OR (obj^.typ^.strobj^.name = "")) THEN - (* compute a global fingerprint to avoid structural type equivalence for anonymous types *) - OPM.FPrint(impCtxt.reffp, obj^.typ^.ref - maxStruct) - END ; - IF tag # Stype THEN - InsertImport(obj, GlbMod[mno].right, old); + ref := impCtxt.nofr; INC(impCtxt.nofr); + IF ref < impCtxt.minr THEN impCtxt.minr := ref END; + InMod(mno); InName(name); obj := NewObj(); + IF name = "" THEN IF impCtxt.self THEN + old := NIL (* do not insert type desc anchor here, but in OPL *) + ELSE + obj^.name := "@"; InsertImport(obj, GlbMod[mno].right, old(*=NIL*)); obj^.name := "" + END; + typ := NewStr(Undef, Basic) + ELSE + obj^.name := name; InsertImport(obj, GlbMod[mno].right, old); + IF old # NIL THEN (* recalculate fprints to compare with old fprints *) + FPrintObj(old); impCtxt.pvfp[ref] := old^.typ^.pvfp; + IF impCtxt.self THEN (* do not overwrite old typ *) + typ := NewStr(Undef, Basic) + ELSE (* overwrite old typ for compatibility reason *) + typ := old^.typ; typ^.link := NIL; typ^.sysflag := 0; + typ^.fpdone := FALSE; typ^.idfpdone := FALSE + END + ELSE + typ := NewStr(Undef, Basic) + END + END; + impCtxt.ref[ref] := typ; impCtxt.old[ref] := old; + typ^.ref := ref + maxStruct; + (* ref >= maxStruct: not exported yet, ref used for err 155 *) + typ^.mno := mno; typ^.allocated := TRUE; + typ^.strobj := obj; obj^.mode := Typ; obj^.typ := typ; + obj^.mnolev := -mno; obj^.vis := internal; (* name not visible here *) + tag := OPM.SymRInt(); + IF tag = Ssys THEN typ^.sysflag := SHORT(OPM.SymRInt()); tag := OPM.SymRInt() END; + CASE tag OF + | Sptr: typ^.form := Pointer; typ^.size := OPM.PointerSize; + typ^.n := 0; InStruct(typ^.BaseTyp) + | Sarr: typ^.form := Comp; typ^.comp := Array; + InStruct(typ^.BaseTyp); typ^.n := OPM.SymRInt(); + typSize(typ) (* no bounds address !! *) + | Sdarr: typ^.form := Comp; typ^.comp := DynArr; InStruct(typ^.BaseTyp); + IF typ^.BaseTyp^.comp = DynArr THEN + typ^.n := typ^.BaseTyp^.n + 1 + ELSE + typ^.n := 0 + END; + typSize(typ) + | Srec: typ^.form := Comp; typ^.comp := Record; + InStruct(typ^.BaseTyp); + IF typ^.BaseTyp = notyp THEN typ^.BaseTyp := NIL END; + typ.extlev := 0; t := typ.BaseTyp; + (* do not take extlev from base type due to possible cycles! *) + WHILE (t # NIL) (*& (t^.BaseTyp # t)*)(*(t^.(*BaseTyp^.*)form # 0)*) DO + INC(typ^.extlev); t := t.BaseTyp + END; (* !!! *) + typ^.size := OPM.SymRInt(); typ^.align := OPM.SymRInt(); + typ^.n := OPM.SymRInt(); + impCtxt.nextTag := OPM.SymRInt(); last := NIL; + WHILE (impCtxt.nextTag >= Sfld) & (impCtxt.nextTag <= Shdpro) DO + fld := InFld(); fld^.mnolev := -mno; + IF last # NIL THEN last^.link := fld END; + last := fld; InsertImport(fld, typ^.link, dummy); + impCtxt.nextTag := OPM.SymRInt() + END; + WHILE impCtxt.nextTag # Send DO + fld := InTProc(mno); + InsertImport(fld, typ^.link, dummy); + impCtxt.nextTag := OPM.SymRInt() + END + | Spro: typ^.form := ProcTyp; typ^.size := OPM.ProcSize; + InSign(mno, typ^.BaseTyp, typ^.link) + ELSE OPM.LogWStr("unhandled case at InStruct, tag = "); OPM.LogWNum(tag, 0); OPM.LogWLn; + END; + IF ref = impCtxt.minr THEN + WHILE (ref < impCtxt.nofr) (*OR ((ref >= Int8) & (ref <= Int64))*) DO + t := impCtxt.ref[ref]; FPrintStr(t); + obj := t^.strobj; (* obj^.typ^.strobj = obj, else obj^.fprint differs (alias) *) + IF obj^.name # "" THEN FPrintObj(obj) END; + old := impCtxt.old[ref]; IF old # NIL THEN - (* obj is from old symbol file, old is new declaration *) - IF old^.vis = internal THEN old^.history := removed - ELSE FPrintObj(old); (* FPrint(obj) already called *) - IF obj^.fprint # old^.fprint THEN old^.history := pbmodified - ELSIF obj^.typ^.pvfp # old^.typ^.pvfp THEN old^.history := pvmodified - ELSE old^.history := same + t^.strobj := old; (* restore strobj *) + IF impCtxt.self THEN + IF old^.mnolev < 0 THEN + IF old^.history # inconsistent THEN + IF old^.fprint # obj^.fprint THEN + old^.history := pbmodified + ELSIF impCtxt.pvfp[ref] # t^.pvfp THEN + old^.history := pvmodified + END + (* ELSE remain inconsistent *) + END + ELSIF old^.fprint # obj^.fprint THEN + old^.history := pbmodified + ELSIF impCtxt.pvfp[ref] # t^.pvfp THEN + old^.history := pvmodified + ELSIF old^.vis = internal THEN + old^.history := same (* may be changed to "removed" in InObj *) + ELSE + old^.history := inserted (* may be changed to "same" in InObj *) + END + ELSE + (* check private part, delay error message until really used *) + IF impCtxt.pvfp[ref] # t^.pvfp THEN + old^.history := inconsistent + END; + IF old^.fprint # obj^.fprint THEN + FPrintErr(old, 249) END END - ELSE obj^.history := removed (* OutObj not called if mnolev < 0 *) - END - (* ELSE old = NIL, or file read twice, consistent, OutObj not called *) - END - ELSE (* obj already inserted in InStruct *) - IF impCtxt.self THEN (* obj^.mnolev = 0 *) - IF obj^.vis = internal THEN obj^.history := removed - ELSIF obj^.history = inserted THEN obj^.history := same - END - (* ELSE OutObj not called for obj with mnolev < 0 *) - END - END ; - RETURN obj - END InObj; - - PROCEDURE Import*(aliasName: OPS.Name; VAR name: OPS.Name; VAR done: BOOLEAN); - VAR obj: Object; mno: SHORTINT; (* done used in Browser *) - BEGIN - IF name = "SYSTEM" THEN SYSimported := TRUE; - Insert(aliasName, obj); obj^.mode := Mod; obj^.mnolev := 0; obj^.scope := syslink; obj^.typ := notyp - ELSE - impCtxt.nofr := FirstRef(*Comp+1*); impCtxt.minr := maxStruct; impCtxt.nofm := 0; - impCtxt.self := aliasName = "@self"; impCtxt.reffp := 0; - OPM.OldSym(name, done); - IF done THEN - InMod(mno); - impCtxt.nextTag := OPM.SymRInt(); - WHILE ~OPM.eofSF() DO - obj := InObj(mno); impCtxt.nextTag := OPM.SymRInt() - END ; - Insert(aliasName, obj); - obj^.mode := Mod; obj^.scope := GlbMod[mno].right; - GlbMod[mno].link := obj; - obj^.mnolev := -mno; obj^.typ := notyp; - OPM.CloseOldSym - ELSIF impCtxt.self THEN - newsf := TRUE; extsf := TRUE; sfpresent := FALSE - ELSE err(152) (*sym file not found*) - END + ELSIF impCtxt.self THEN + obj^.history := removed + ELSE + obj^.history := same + END; + INC(ref) + END; + impCtxt.minr := maxStruct END - END Import; + END +END InStruct; + +PROCEDURE InObj(mno: SHORTINT): Object; (* first number in impCtxt.nextTag *) + VAR i, s: INTEGER; ch: CHAR; obj, old: Object; typ: Struct; + tag: LONGINT; ext: ConstExt; +BEGIN + tag := impCtxt.nextTag; + IF tag = Stype THEN + InStruct(typ); obj := typ^.strobj; + IF ~impCtxt.self THEN obj^.vis := external END (* type name visible now, obj^.fprint already done *) + ELSE + obj := NewObj(); obj^.mnolev := -mno; obj^.vis := external; + IF tag <= Pointer THEN (* Constant *) + obj^.mode := Con; obj^.typ := impCtxt.ref[tag]; obj^.conval := NewConst(); InConstant(tag, obj^.conval) + ELSIF tag >= Sxpro THEN + obj^.conval := NewConst(); + obj^.conval^.intval := -1; + InSign(mno, obj^.typ, obj^.link); + CASE tag OF + | Sxpro: obj^.mode := XProc + | Sipro: obj^.mode := IProc + | Scpro: obj^.mode := CProc; + ext := NewExt(); obj^.conval^.ext := ext; + s := SHORT(OPM.SymRInt()); ext^[0] := CHR(s); i := 1; + WHILE i <= s DO OPM.SymRCh(ext^[i]); INC(i) END + ELSE OPM.LogWStr("unhandled case at InObj, tag = "); OPM.LogWNum(tag, 0); OPM.LogWLn; + END + ELSIF tag = Salias THEN + obj^.mode := Typ; InStruct(obj^.typ) + ELSE + obj^.mode := Var; + IF tag = Srvar THEN obj^.vis := externalR END; + InStruct(obj^.typ) + END; + InName(obj^.name) + END; + FPrintObj(obj); + IF (obj^.mode = Var) & ((obj^.typ^.strobj = NIL) OR (obj^.typ^.strobj^.name = "")) THEN + (* compute a global fingerprint to avoid structural type equivalence for anonymous types *) + OPM.FPrint(impCtxt.reffp, obj^.typ^.ref - maxStruct) + END; + IF tag # Stype THEN + InsertImport(obj, GlbMod[mno].right, old); + IF impCtxt.self THEN + IF old # NIL THEN + (* obj is from old symbol file, old is new declaration *) + IF old^.vis = internal THEN old^.history := removed + ELSE FPrintObj(old); (* FPrint(obj) already called *) + IF obj^.fprint # old^.fprint THEN old^.history := pbmodified + ELSIF obj^.typ^.pvfp # old^.typ^.pvfp THEN old^.history := pvmodified + ELSE old^.history := same + END + END + ELSE obj^.history := removed (* OutObj not called if mnolev < 0 *) + END + (* ELSE old = NIL, or file read twice, consistent, OutObj not called *) + END + ELSE (* obj already inserted in InStruct *) + IF impCtxt.self THEN (* obj^.mnolev = 0 *) + IF obj^.vis = internal THEN obj^.history := removed + ELSIF obj^.history = inserted THEN obj^.history := same + END + (* ELSE OutObj not called for obj with mnolev < 0 *) + END + END; +RETURN obj +END InObj; + +PROCEDURE Import*(aliasName: OPS.Name; VAR name: OPS.Name; VAR done: BOOLEAN); + VAR obj: Object; mno: SHORTINT; (* done used in Browser *) +BEGIN + IF name = "SYSTEM" THEN SYSimported := TRUE; + Insert(aliasName, obj); obj^.mode := Mod; obj^.mnolev := 0; obj^.scope := syslink; obj^.typ := notyp + ELSE + impCtxt.nofr := FirstRef(*Comp+1*); impCtxt.minr := maxStruct; impCtxt.nofm := 0; + impCtxt.self := aliasName = "@self"; impCtxt.reffp := 0; + OPM.OldSym(name, done); + IF done THEN + InMod(mno); + impCtxt.nextTag := OPM.SymRInt(); + WHILE ~OPM.eofSF() DO + obj := InObj(mno); impCtxt.nextTag := OPM.SymRInt() + END; + Insert(aliasName, obj); + obj^.mode := Mod; obj^.scope := GlbMod[mno].right; + GlbMod[mno].link := obj; + obj^.mnolev := -mno; obj^.typ := notyp; + OPM.CloseOldSym + ELSIF impCtxt.self THEN + newsf := TRUE; extsf := TRUE; sfpresent := FALSE + ELSE err(152) (*sym file not found*) + END + END +END Import; (*-------------------------- Export --------------------------*) @@ -876,7 +916,7 @@ END InStruct; BEGIN IF typ^.comp = Record THEN OutFlds(typ^.link, adr, FALSE) ELSIF typ^.comp = Array THEN btyp := typ^.BaseTyp; n := typ^.n; - WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END ; + WHILE btyp^.comp = Array DO n := btyp^.n * n; btyp := btyp^.BaseTyp END; IF (btyp^.form = Pointer) OR (btyp^.comp = Record) THEN j := nofhdfld; OutHdFld(btyp, fld, adr); IF j # nofhdfld THEN i := 1; @@ -896,10 +936,10 @@ END InStruct; BEGIN WHILE (fld # NIL) & (fld^.mode = Fld) DO IF (fld^.vis # internal) & visible THEN - IF fld^.vis = externalR THEN OPM.SymWInt(Srfld) ELSE OPM.SymWInt(Sfld) END ; + IF fld^.vis = externalR THEN OPM.SymWInt(Srfld) ELSE OPM.SymWInt(Sfld) END; OutStr(fld^.typ); OutName(fld^.name); OPM.SymWInt(fld^.adr) ELSE OutHdFld(fld^.typ, fld, fld^.adr + adr) - END ; + END; fld := fld^.link END END OutFlds; @@ -908,11 +948,11 @@ END InStruct; BEGIN OutStr(result); WHILE par # NIL DO - IF par^.mode = Var THEN OPM.SymWInt(Svalpar) ELSE OPM.SymWInt(Svarpar) END ; + IF par^.mode = Var THEN OPM.SymWInt(Svalpar) ELSE OPM.SymWInt(Svarpar) END; OutStr(par^.typ); OPM.SymWInt(par^.adr); OutName(par^.name); par := par^.link - END ; + END; OPM.SymWInt(Send) END OutSign; @@ -924,7 +964,7 @@ END InStruct; IF (typ^.BaseTyp # NIL) & (obj^.adr DIV 10000H < typ^.BaseTyp^.n) & (obj^.vis = internal) THEN OPM.Mark(109, typ^.txtpos) (* hidden and overriding, not detected in OPP because record exported indirectly or via aliasing *) - END ; + END; IF OPM.ExpHdTProc OR (obj^.vis # internal) THEN IF obj^.vis # internal THEN OPM.SymWInt(Stpro); OutSign(obj^.typ, obj^.link); OutName(obj^.name); @@ -934,7 +974,7 @@ END InStruct; OPM.SymWInt(obj^.adr DIV 10000H) END END - END ; + END; OutTProcs(typ, obj^.right) END END OutTProcs; @@ -946,43 +986,36 @@ END InStruct; ELSE OPM.SymWInt(Sstruct); typ^.ref := expCtxt.ref; INC(expCtxt.ref); - IF expCtxt.ref >= maxStruct THEN err(228) END ; + IF expCtxt.ref >= maxStruct THEN err(228) END; OutMod(typ^.mno); strobj := typ^.strobj; IF (strobj # NIL) & (strobj^.name # "") THEN OutName(strobj^.name); CASE strobj^.history OF - | pbmodified: FPrintErr(strobj, 252) - | pvmodified: FPrintErr(strobj, 251) + | pbmodified: FPrintErr(strobj, 252) + | pvmodified: FPrintErr(strobj, 251) | inconsistent: FPrintErr(strobj, 249) ELSE (* checked in OutObj or correct indirect export *) - (* OPM.LogWStr("unhandled case at OPT.OutStr, strobj^.history = "); OPM.LogWNum(strobj^.history, 0); OPM.LogWLn;*) + (* OPM.LogWStr("unhandled case at OutStr, strobj^.history = "); OPM.LogWNum(strobj^.history, 0); OPM.LogWLn;*) END ELSE OPM.SymWCh(0X) (* anonymous => never inconsistent, pvfp influences the client fp *) - END ; - IF typ^.sysflag # 0 THEN OPM.SymWInt(Ssys); OPM.SymWInt(typ^.sysflag) END ; + END; + IF typ^.sysflag # 0 THEN OPM.SymWInt(Ssys); OPM.SymWInt(typ^.sysflag) END; CASE typ^.form OF - | Pointer: - OPM.SymWInt(Sptr); OutStr(typ^.BaseTyp) - | ProcTyp: - OPM.SymWInt(Spro); OutSign(typ^.BaseTyp, typ^.link) - | Comp: - CASE typ^.comp OF - | Array: - OPM.SymWInt(Sarr); OutStr(typ^.BaseTyp); OPM.SymWInt(typ^.n) - | DynArr: - OPM.SymWInt(Sdarr); OutStr(typ^.BaseTyp) - | Record: - OPM.SymWInt(Srec); - IF typ^.BaseTyp = NIL THEN OutStr(notyp) ELSE OutStr(typ^.BaseTyp) END ; - (* BaseTyp should be Notyp, too late to change *) - OPM.SymWInt(typ^.size); OPM.SymWInt(typ^.align); OPM.SymWInt(typ^.n); - nofhdfld := 0; OutFlds(typ^.link, 0, TRUE); - IF nofhdfld > OPM.MaxHdFld THEN OPM.Mark(223, typ^.txtpos) END ; - OutTProcs(typ, typ^.link); OPM.SymWInt(Send) - ELSE - OPM.LogWStr("unhandled case at OPT.OutStr, typ^.comp = "); OPM.LogWNum(typ^.comp, 0); OPM.LogWLn; - END - ELSE OPM.LogWStr("unhandled case at OPT.OutStr, typ^.form = "); OPM.LogWNum(typ^.form, 0); OPM.LogWLn; + | Pointer: OPM.SymWInt(Sptr); OutStr(typ^.BaseTyp) + | ProcTyp: OPM.SymWInt(Spro); OutSign(typ^.BaseTyp, typ^.link) + | Comp: CASE typ^.comp OF + | Array: OPM.SymWInt(Sarr); OutStr(typ^.BaseTyp); OPM.SymWInt(typ^.n) + | DynArr: OPM.SymWInt(Sdarr); OutStr(typ^.BaseTyp) + | Record: OPM.SymWInt(Srec); + IF typ^.BaseTyp = NIL THEN OutStr(notyp) ELSE OutStr(typ^.BaseTyp) END; + (* BaseTyp should be Notyp, too late to change *) + OPM.SymWInt(typ^.size); OPM.SymWInt(typ^.align); OPM.SymWInt(typ^.n); + nofhdfld := 0; OutFlds(typ^.link, 0, TRUE); + IF nofhdfld > OPM.MaxHdFld THEN OPM.Mark(223, typ^.txtpos) END; + OutTProcs(typ, typ^.link); OPM.SymWInt(Send) + ELSE OPM.LogWStr("unhandled case at OutStr, typ^.comp = "); OPM.LogWNum(typ^.comp, 0); OPM.LogWLn; + END + ELSE OPM.LogWStr("unhandled case at OutStr, typ^.form = "); OPM.LogWNum(typ^.form, 0); OPM.LogWLn; END END END OutStr; @@ -992,20 +1025,17 @@ END InStruct; BEGIN f := obj^.typ^.form; OPM.SymWInt(f); CASE f OF - | Bool, Char: - OPM.SymWCh(CHR(obj^.conval^.intval)) - | SInt, Int, LInt(*, Int8, Int16, Int32, Int64*): - OPM.SymWInt(obj^.conval^.intval) - | Set: - OPM.SymWSet(obj^.conval^.setval) - | Real: - rval := SHORT(obj^.conval^.realval); OPM.SymWReal(rval) - | LReal: - OPM.SymWLReal(obj^.conval^.realval) - | String: - OutName(obj^.conval^.ext^) + | Bool, + Char: OPM.SymWCh(CHR(obj^.conval^.intval)) + | SInt, + Int, + LInt: OPM.SymWInt(obj^.conval^.intval) + | Set: OPM.SymWSet(obj^.conval^.setval) + | Real: rval := SHORT(obj^.conval^.realval); OPM.SymWReal(rval) + | LReal: OPM.SymWLReal(obj^.conval^.realval) + | String: OutName(obj^.conval^.ext^) | NilTyp: - ELSE err(127) + ELSE err(127) END END OutConstant; @@ -1018,47 +1048,39 @@ END InStruct; IF obj^.history = removed THEN FPrintErr(obj, 250) ELSIF obj^.vis # internal THEN CASE obj^.history OF - | inserted: FPrintErr(obj, 253) - | same: (* ok *) + | inserted: FPrintErr(obj, 253) + | same: (* ok *) | pbmodified: FPrintErr(obj, 252) | pvmodified: FPrintErr(obj, 251) - ELSE - OPM.LogWStr("unhandled case at OPT.OutObj, obj^.history = "); OPM.LogWNum(obj^.history, 0); OPM.LogWLn; - END ; + ELSE OPM.LogWStr("unhandled case at OutObj, obj^.history = "); OPM.LogWNum(obj^.history, 0); OPM.LogWLn; + END; CASE obj^.mode OF - | Con: - OutConstant(obj); OutName(obj^.name) - | Typ: - IF obj^.typ^.strobj = obj THEN OPM.SymWInt(Stype); OutStr(obj^.typ) - ELSE OPM.SymWInt(Salias); OutStr(obj^.typ); OutName(obj^.name) - END - | Var: - IF obj^.vis = externalR THEN OPM.SymWInt(Srvar) ELSE OPM.SymWInt(Svar) END ; - OutStr(obj^.typ); OutName(obj^.name); - IF (obj^.typ^.strobj = NIL) OR (obj^.typ^.strobj^.name = "") THEN - (* compute fingerprint to avoid structural type equivalence *) - OPM.FPrint(expCtxt.reffp, obj^.typ^.ref) - END - | XProc: - OPM.SymWInt(Sxpro); OutSign(obj^.typ, obj^.link); OutName(obj^.name) - | IProc: - OPM.SymWInt(Sipro); OutSign(obj^.typ, obj^.link); OutName(obj^.name) - | CProc: - OPM.SymWInt(Scpro); OutSign(obj^.typ, obj^.link); ext := obj^.conval^.ext; - j := ORD(ext^[0]); i := 1; OPM.SymWInt(j); - WHILE i <= j DO OPM.SymWCh(ext^[i]); INC(i) END ; - OutName(obj^.name) - ELSE - OPM.LogWStr("unhandled case at OPT.OutObj, obj.mode = "); OPM.LogWNum(obj.mode, 0); OPM.LogWLn; + | Con: OutConstant(obj); OutName(obj^.name) + | Typ: IF obj^.typ^.strobj = obj THEN OPM.SymWInt(Stype); OutStr(obj^.typ) + ELSE OPM.SymWInt(Salias); OutStr(obj^.typ); OutName(obj^.name) + END + | Var: IF obj^.vis = externalR THEN OPM.SymWInt(Srvar) ELSE OPM.SymWInt(Svar) END; + OutStr(obj^.typ); OutName(obj^.name); + IF (obj^.typ^.strobj = NIL) OR (obj^.typ^.strobj^.name = "") THEN + (* compute fingerprint to avoid structural type equivalence *) + OPM.FPrint(expCtxt.reffp, obj^.typ^.ref) + END + | XProc: OPM.SymWInt(Sxpro); OutSign(obj^.typ, obj^.link); OutName(obj^.name) + | IProc: OPM.SymWInt(Sipro); OutSign(obj^.typ, obj^.link); OutName(obj^.name) + | CProc: OPM.SymWInt(Scpro); OutSign(obj^.typ, obj^.link); ext := obj^.conval^.ext; + j := ORD(ext^[0]); i := 1; OPM.SymWInt(j); + WHILE i <= j DO OPM.SymWCh(ext^[i]); INC(i) END; + OutName(obj^.name) + ELSE OPM.LogWStr("unhandled case at OutObj, obj.mode = "); OPM.LogWNum(obj.mode, 0); OPM.LogWLn; END END - END ; + END; OutObj(obj^.right) END END OutObj; PROCEDURE Export*(VAR ext, new: BOOLEAN); - VAR i: INTEGER; nofmod: SHORTINT; done: BOOLEAN; + VAR i: INTEGER; nofmod: SHORTINT; done: BOOLEAN; BEGIN symExtended := FALSE; symNew := FALSE; nofmod := nofGmod; Import("@self", SelfName, done); nofGmod := nofmod; @@ -1068,20 +1090,20 @@ END InStruct; OPM.SymWInt(Smname); OutName(SelfName); expCtxt.reffp := 0; expCtxt.ref := FirstRef(*Comp+1*); expCtxt.nofm := 1; expCtxt.locmno[0] := 0; - i := 1; WHILE i < maxImps DO expCtxt.locmno[i] := -1; INC(i) END ; + i := 1; WHILE i < maxImps DO expCtxt.locmno[i] := -1; INC(i) END; OutObj(topScope^.right); ext := sfpresent & symExtended; new := ~sfpresent OR symNew; - IF OPM.forceNewSym THEN - new := TRUE - END; (* for bootstrapping -- noch *) + IF OPM.forceNewSym THEN + new := TRUE + END; (* for bootstrapping -- noch *) IF OPM.noerr & sfpresent & (impCtxt.reffp # expCtxt.reffp) THEN new := TRUE; IF ~extsf THEN err(155) END - END ; + END; newsf := FALSE; symNew := FALSE; (* because of call to FPrintErr from OPL *) IF ~OPM.noerr OR findpc THEN - OPM.DeleteNewSym - END + OPM.DeleteNewSym + END (* OPM.RegisterNewSym is called in OP2 after writing the object file *) END END @@ -1125,12 +1147,6 @@ BEGIN topScope := NIL; OpenScope(0, NIL); OPM.errpos := 0; (*initialization of module SYSTEM*) EnterTyp("BYTE", Byte, OPM.ByteSize, bytetyp); -(* - EnterTyp("INT8", Int8, OPM.Int8Size, int8typ); - EnterTyp("INT16", Int16, OPM.Int16Size, int16typ); - EnterTyp("INT32", Int32, OPM.Int32Size, int32typ); - EnterTyp("INT64", Int64, OPM.Int64Size, int64typ); -*) EnterTyp("PTR", Pointer, OPM.PointerSize, sysptrtyp); EnterProc("ADR", adrfn); EnterProc("CC", ccfn); @@ -1147,46 +1163,54 @@ BEGIN topScope := NIL; OpenScope(0, NIL); OPM.errpos := 0; syslink := topScope^.right; universe := topScope; topScope^.right := NIL; - EnterTyp("CHAR", Char, OPM.CharSize, chartyp); - EnterTyp("SET", Set, OPM.SetSize, settyp); - EnterTyp("REAL", Real, OPM.RealSize, realtyp); - EnterTyp("INTEGER", Int, OPM.IntSize, inttyp); - EnterTyp("LONGINT", LInt, OPM.LIntSize, linttyp); + EnterTyp("BOOLEAN", Bool, OPM.BoolSize, booltyp); + EnterTyp("CHAR", Char, OPM.CharSize, chartyp); + EnterTyp("SET", Set, OPM.SetSize, settyp); + EnterTyp("REAL", Real, OPM.RealSize, realtyp); + EnterTyp("INTEGER", Int, OPM.IntSize, inttyp); + EnterTyp("LONGINT", LInt, OPM.LIntSize, linttyp); EnterTyp("LONGREAL", LReal, OPM.LRealSize, lrltyp); - EnterTyp("SHORTINT", SInt, OPM.SIntSize, sinttyp); - EnterTyp("BOOLEAN", Bool, OPM.BoolSize, booltyp); + EnterTyp("SHORTINT", SInt, OPM.SIntSize, sinttyp); + EnterBoolConst("FALSE", 0); (* 0 and 1 are compiler internal representation only *) EnterBoolConst("TRUE", 1); - EnterProc("HALT", haltfn); - EnterProc("NEW", newfn); - EnterProc("ABS", absfn); - EnterProc("CAP", capfn); - EnterProc("ORD", ordfn); + + EnterProc("HALT", haltfn); + EnterProc("NEW", newfn); + EnterProc("ABS", absfn); + EnterProc("CAP", capfn); + EnterProc("ORD", ordfn); EnterProc("ENTIER", entierfn); - EnterProc("ODD", oddfn); - EnterProc("MIN", minfn); - EnterProc("MAX", maxfn); - EnterProc("CHR", chrfn); - EnterProc("SHORT", shortfn); - EnterProc("LONG", longfn); - EnterProc("SIZE", sizefn); - EnterProc("INC", incfn); - EnterProc("DEC", decfn); - EnterProc("INCL", inclfn); - EnterProc("EXCL", exclfn); - EnterProc("LEN", lenfn); - EnterProc("COPY", copyfn); - EnterProc("ASH", ashfn); + EnterProc("ODD", oddfn); + EnterProc("MIN", minfn); + EnterProc("MAX", maxfn); + EnterProc("CHR", chrfn); + EnterProc("SHORT", shortfn); + EnterProc("LONG", longfn); + EnterProc("SIZE", sizefn); + EnterProc("INC", incfn); + EnterProc("DEC", decfn); + EnterProc("INCL", inclfn); + EnterProc("EXCL", exclfn); + EnterProc("LEN", lenfn); + EnterProc("COPY", copyfn); + EnterProc("ASH", ashfn); EnterProc("ASSERT", assertfn); - impCtxt.ref[Undef] := undftyp; impCtxt.ref[Byte] := bytetyp; -(* impCtxt.ref[Int8] := int8typ; impCtxt.ref[Int16] := int16typ; - impCtxt.ref[Int32] := int32typ; impCtxt.ref[Int64] := int64typ;*) - impCtxt.ref[Bool] := booltyp; impCtxt.ref[Char] := chartyp; - impCtxt.ref[SInt] := sinttyp; impCtxt.ref[Int] := inttyp; - impCtxt.ref[LInt] := linttyp; impCtxt.ref[Real] := realtyp; - impCtxt.ref[LReal] := lrltyp; impCtxt.ref[Set] := settyp; - impCtxt.ref[String] := stringtyp; impCtxt.ref[NilTyp] := niltyp; - impCtxt.ref[NoTyp] := notyp; impCtxt.ref[Pointer] := sysptrtyp + + impCtxt.ref[Undef] := undftyp; + impCtxt.ref[Byte] := bytetyp; + impCtxt.ref[Bool] := booltyp; + impCtxt.ref[Char] := chartyp; + impCtxt.ref[SInt] := sinttyp; + impCtxt.ref[Int] := inttyp; + impCtxt.ref[LInt] := linttyp; + impCtxt.ref[Real] := realtyp; + impCtxt.ref[LReal] := lrltyp; + impCtxt.ref[Set] := settyp; + impCtxt.ref[String] := stringtyp; + impCtxt.ref[NilTyp] := niltyp; + impCtxt.ref[NoTyp] := notyp; + impCtxt.ref[Pointer] := sysptrtyp END OPT. Objects: @@ -1219,6 +1243,7 @@ Objects: SInt Basic | Int Basic | LInt Basic | + XInt Basic | bits Real Basic | LReal Basic | Set Basic | @@ -1332,4 +1357,3 @@ stat NIL Nreturn proc nextexpr stat (proc = NIL for mod) Nwith ifstat stat stat Ntrap expr stat - diff --git a/src/compiler/OPV.Mod b/src/compiler/OPV.Mod index 702055f9..7a59c1d3 100644 --- a/src/compiler/OPV.Mod +++ b/src/compiler/OPV.Mod @@ -1,6 +1,6 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 - 26.7.2002 jt bug fix in Len: wrong result if called for fixed Array + 26.7.2002 jt bug fix OPS.in Len: wrong result if called for fixed OPT.Array 31.1.2007 jt synchronized with BlackBox version, in particular: various promotion rules changed (long) => (LONGINT), xxxL avoided *) @@ -8,55 +8,6 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 IMPORT OPT, OPC, OPM, OPS; CONST - (* object modes *) - Var = 1; VarPar = 2; Fld = 4; Typ = 5; LProc = 6; XProc = 7; - CProc = 9; IProc = 10; Mod = 11; TProc = 13; - - (* symbol values or ops *) - times = 1; slash = 2; div = 3; mod = 4; - and = 5; plus = 6; minus = 7; or = 8; eql = 9; - neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; - in = 15; is = 16; ash = 17; msk = 18; len = 19; - conv = 20; abs = 21; cap = 22; odd = 23; not = 33; - (*SYSTEM*) - adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; - - (* structure forms *) - Byte = 1; Bool = 2; Char = 3; - SInt = 4; Int = 5; LInt = 6; - Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; - Pointer = 13; ProcTyp = 14; - Comp = 15; - (*Int8 = 7; Int16 = 8; Int32 = 9; Int64 = 10; - Real = 11; LReal = 12; Set = 13; String = 14; NilTyp = 15; NoTyp = 16; - Pointer = 17; ProcTyp = 18; - Comp = 19;*) - (*Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; Pointer = 13; ProcTyp = 14; - Int8 = 15; Int16 = 16; Int32 = 17; Int64 = 18; - Comp = (*15*)19;*) - - (* composite structure forms *) - Array = 2; DynArr = 3; Record = 4; - - (* nodes classes *) - Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; - Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; - Ninittd = 14; Nenter = 18; Nassign = 19; - Nifelse =20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; - Nreturn = 26; Nwith = 27; Ntrap = 28; - - (*function number*) - assign = 0; newfn = 1; incfn = 13; decfn = 14; - inclfn = 15; exclfn = 16; copyfn = 18; assertfn = 32; - - (*SYSTEM function number*) - getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; sysnewfn = 30; movefn = 31; - - (*procedure flags*) - isRedef = 2; - - super = 1; - UndefinedType = 0; (* named type not yet defined *) ProcessingType = 1; (* pointer type is being processed *) PredefinedType = 2; (* for all predefined types *) @@ -91,7 +42,6 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 MaxPrec = 12; ProcTypeVar = 11; (* precedence number when a call is made with a proc type variable *) - internal = 0; TYPE ExitInfo = RECORD level, label: INTEGER END ; @@ -125,14 +75,14 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 IF typ = OPT.undftyp THEN OPM.err(58) ELSIF typ^.size = -1 THEN f := typ^.form; c := typ^.comp; - IF c = Record THEN btyp := typ^.BaseTyp; - IF btyp = NIL THEN offset := 0; base := OPM.RecAlign; + IF c = OPT.Record THEN btyp := typ^.BaseTyp; + IF btyp = NIL THEN offset := 0; base := (*OPM.RecAlign*)OPC.SizeAlignment(OPM.RecSize); ELSE TypSize(btyp); offset := btyp^.size - btyp^.sysflag DIV 100H; base := btyp^.align; END; fld := typ^.link; - WHILE (fld # NIL) & (fld^.mode = Fld) DO + WHILE (fld # NIL) & (fld^.mode = OPT.Fld) DO btyp := fld^.typ; TypSize(btyp); - size := btyp^.size; fbase := OPC.Base(btyp); + size := btyp^.size; fbase := OPC.BaseAlignment(btyp); OPC.Align(offset, fbase); fld^.adr := offset; INC(offset, size); IF fbase > base THEN base := fbase END ; @@ -140,25 +90,25 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 END ; off0 := offset; IF offset = 0 THEN offset := 1 END ; (* 1 byte filler to avoid empty struct *) - IF OPM.RecSize = 0 THEN base := NaturalAlignment(offset, OPM.RecAlign) END ; + IF OPM.RecSize = 0 THEN base := NaturalAlignment(offset, (*OPM.RecAlign*)OPC.SizeAlignment(OPM.RecSize)) END ; OPC.Align(offset, base); IF (typ^.strobj = NIL) & (typ^.align MOD 10000H = 0) THEN INC(recno); INC(base, recno * 10000H) END ; typ^.size := offset; typ^.align := base; (* encode the trailing gap into the symbol table to allow dense packing of extended records *) typ^.sysflag := typ^.sysflag MOD 100H + SHORT((offset - off0)*100H) - ELSIF c = Array THEN + ELSIF c = OPT.Array THEN TypSize(typ^.BaseTyp); typ^.size := typ^.n * typ^.BaseTyp^.size; - ELSIF f = Pointer THEN + ELSIF f = OPT.Pointer THEN typ^.size := OPM.PointerSize; IF typ^.BaseTyp = OPT.undftyp THEN OPM.Mark(128, typ^.n) ELSE TypSize(typ^.BaseTyp) END - ELSIF f = ProcTyp THEN + ELSIF f = OPT.ProcTyp THEN typ^.size := OPM.ProcSize; - ELSIF c = DynArr THEN + ELSIF c = OPT.DynArr THEN btyp := typ^.BaseTyp; TypSize(btyp); - IF btyp^.comp = DynArr THEN typ^.size := btyp^.size + 4 (* describes dim not size *) + IF btyp^.comp = OPT.DynArr THEN typ^.size := btyp^.size + 4 (* describes dim not size *) ELSE typ^.size := 8 END END @@ -181,10 +131,10 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 BEGIN oldPos := OPM.errpos; OPM.errpos := obj^.scope^.adr; typ := obj^.link^.typ; - IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ; + IF typ^.form = OPT.Pointer THEN typ := typ^.BaseTyp END ; OPT.FindField(obj^.name, typ^.BaseTyp, redef); IF redef # NIL THEN obj^.adr := 10000H*(redef^.adr DIV 10000H) (*mthno*); - IF ~(isRedef IN obj^.conval^.setval) THEN OPM.err(119) END + IF ~(OPT.isRedef IN obj^.conval^.setval) THEN OPM.err(119) END ELSE INC(obj^.adr, 10000H*typ^.n); INC(typ^.n) END ; OPM.errpos := oldPos @@ -218,23 +168,23 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 IF obj^.name[0] = "@" THEN obj^.name[0] := "_"; Stamp(obj^.name) END ; (* translate and make unique @for, ... *) obj^.linkadr := UndefinedType; mode := obj^.mode; - IF (mode = Typ) & ((obj^.vis # internal) = exported) THEN + IF (mode = OPT.Typ) & ((obj^.vis # OPT.internal) = exported) THEN typ := obj^.typ; TypSize(obj^.typ); - IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ; - IF typ^.comp = Record THEN TraverseRecord(typ) END - ELSIF mode = TProc THEN GetTProcNum(obj) - ELSIF mode = Var THEN TypSize(obj^.typ) + IF typ^.form = OPT.Pointer THEN typ := typ^.BaseTyp END ; + IF typ^.comp = OPT.Record THEN TraverseRecord(typ) END + ELSIF mode = OPT.TProc THEN GetTProcNum(obj) + ELSIF mode = OPT.Var THEN TypSize(obj^.typ) END ; IF ~exported THEN (* do this only once *) - IF (mode IN {LProc, Typ}) & (obj^.mnolev > 0) THEN Stamp(obj^.name) END ; - IF mode IN {Var, VarPar, Typ} THEN + IF (mode IN {OPT.LProc, OPT.Typ}) & (obj^.mnolev > 0) THEN Stamp(obj^.name) END ; + IF mode IN {OPT.Var, OPT.VarPar, OPT.Typ} THEN obj^.scope := outerScope - ELSIF mode IN {LProc, XProc, TProc, CProc, IProc} THEN + ELSIF mode IN {OPT.LProc, OPT.XProc, OPT.TProc, OPT.CProc, OPT.IProc} THEN IF obj^.conval^.setval = {} THEN OPM.err(129) END ; scope := obj^.scope; scope^.leaf := TRUE; scope^.name := obj^.name; Stamp(scope^.name); - IF mode = CProc THEN obj^.adr := 1 (* c.f. OPC.CProcDefs *) END ; + IF mode = OPT.CProc THEN obj^.adr := 1 (* c.f. OPC.CProcDefs *) END ; IF scope^.mnolev > 1 THEN outerScope^.leaf := FALSE END ; Traverse (obj^.scope^.right, obj^.scope, FALSE) END @@ -250,19 +200,15 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 Traverse(topScope^.right, topScope, TRUE); (* first pass only on exported types and procedures *) Traverse(topScope^.right, topScope, FALSE); (* second pass *) (* mark basic types as predefined, OPC.Ident can avoid qualification*) - OPT.chartyp^.strobj^.linkadr := PredefinedType; - OPT.settyp^.strobj^.linkadr := PredefinedType; - OPT.realtyp^.strobj^.linkadr := PredefinedType; - OPT.inttyp^.strobj^.linkadr := PredefinedType; - OPT.linttyp^.strobj^.linkadr := PredefinedType; - OPT.lrltyp^.strobj^.linkadr := PredefinedType; - OPT.sinttyp^.strobj^.linkadr := PredefinedType; - OPT.booltyp^.strobj^.linkadr := PredefinedType; - OPT.bytetyp^.strobj^.linkadr := PredefinedType; - (*OPT.int8typ^.strobj^.linkadr := PredefinedType; - OPT.int16typ^.strobj^.linkadr := PredefinedType; - OPT.int32typ^.strobj^.linkadr := PredefinedType; - OPT.int64typ^.strobj^.linkadr := PredefinedType;*) + OPT.chartyp^.strobj^.linkadr := PredefinedType; + OPT.settyp^.strobj^.linkadr := PredefinedType; + OPT.realtyp^.strobj^.linkadr := PredefinedType; + OPT.inttyp^.strobj^.linkadr := PredefinedType; + OPT.linttyp^.strobj^.linkadr := PredefinedType; + OPT.lrltyp^.strobj^.linkadr := PredefinedType; + OPT.sinttyp^.strobj^.linkadr := PredefinedType; + OPT.booltyp^.strobj^.linkadr := PredefinedType; + OPT.bytetyp^.strobj^.linkadr := PredefinedType; OPT.sysptrtyp^.strobj^.linkadr := PredefinedType; END AdrAndSize; @@ -271,53 +217,48 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE Precedence (class, subclass, form, comp: INTEGER): INTEGER; BEGIN CASE class OF - Nconst, Nvar, Nfield, Nindex, Nproc, Ncall: - RETURN 10 - | Nguard: IF OPM.typchk IN OPM.opt THEN RETURN 10 ELSE RETURN 9 (*cast*) END - | Nvarpar: - IF comp IN {Array, DynArr} THEN RETURN 10 ELSE RETURN 9 END (* arrays don't need deref *) - | Nderef: - RETURN 9 - | Nmop: - CASE subclass OF - not, minus, adr, val, conv: - RETURN 9 - | is, abs, cap, odd, cc: - RETURN 10 - ELSE - OPM.LogWStr("unhandled case in OPV.Precedence Nmop, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; - END - | Ndop: - CASE subclass OF - times: - IF form = Set THEN RETURN 4 ELSE RETURN 8 END - | slash: - IF form = Set THEN RETURN 3 ELSE RETURN 8 END - | div, mod: - RETURN 10 (* div/mod are replaced by functions *) - | plus: - IF form = Set THEN RETURN 2 ELSE RETURN 7 END - | minus: - IF form = Set THEN RETURN 4 ELSE RETURN 7 END - | lss, leq, gtr, geq: - RETURN 6 - | eql, neq: - RETURN 5 - | and: - RETURN 1 - | or: - RETURN 0 - | len, in, ash, msk, bit, lsh, rot: - RETURN 10 - ELSE - OPM.LogWStr("unhandled case in OPV.Precedence Ndop, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; - END; - | Nupto: - RETURN 10 - | Ntype, Neguard: (* ignored anyway *) - RETURN MaxPrec - ELSE - OPM.LogWStr("unhandled case in OPV.Precedence, class = "); OPM.LogWNum(class, 0); OPM.LogWLn; + | OPT.Nconst, + OPT.Nvar, + OPT.Nfield, + OPT.Nindex, + OPT.Nproc, + OPT.Ncall: RETURN 10 + | OPT.Nguard: IF OPM.typchk IN OPM.opt THEN RETURN 10 ELSE RETURN 9 (*cast*) END + | OPT.Nvarpar: IF comp IN {OPT.Array, OPT.DynArr} THEN RETURN 10 ELSE RETURN 9 END (* arrays don't need deref *) + | OPT.Nderef: RETURN 9 + | OPT.Nmop: CASE subclass OF + | OPS.not, OPS.minus, OPT.adr, OPT.val, OPT.conv: RETURN 9 + | OPS.is, OPT.abs, OPT.cap, OPT.odd, OPT.cc: RETURN 10 + ELSE OPM.LogWStr("unhandled case in OPV.Precedence OPT.Nmop, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; + END + | OPT.Ndop: CASE subclass OF + | OPS.times: IF form = OPT.Set THEN RETURN 4 ELSE RETURN 8 END + | OPS.slash: IF form = OPT.Set THEN RETURN 3 ELSE RETURN 8 END + | OPS.div, + OPS.mod: RETURN 10 (* div/mod are replaced by functions *) + | OPS.plus: IF form = OPT.Set THEN RETURN 2 ELSE RETURN 7 END + | OPS.minus: IF form = OPT.Set THEN RETURN 4 ELSE RETURN 7 END + | OPS.lss, + OPS.leq, + OPS.gtr, + OPS.geq: RETURN 6 + | OPS.eql, + OPS.neq: RETURN 5 + | OPS.and: RETURN 1 + | OPS.or: RETURN 0 + | OPT.len, + OPS.in, + OPT.ash, + OPT.msk, + OPT.bit, + OPT.lsh, + OPT.rot: RETURN 10 + ELSE OPM.LogWStr("unhandled case in OPV.Precedence OPT.Ndop, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; + END; + | OPT.Nupto: RETURN 10 + | OPT.Ntype, + OPT.Neguard: (* ignored anyway *) RETURN MaxPrec + ELSE OPM.LogWStr("unhandled case in OPV.Precedence, class = "); OPM.LogWNum(class, 0); OPM.LogWLn; END; END Precedence; @@ -326,8 +267,8 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE Len(n: OPT.Node; dim: LONGINT); BEGIN - WHILE (n^.class = Nindex) & (n^.typ^.comp = DynArr(*26.7.2002*)) DO INC(dim); n := n^.left END ; - IF (n^.class = Nderef) & (n^.typ^.comp = DynArr) THEN + WHILE (n^.class = OPT.Nindex) & (n^.typ^.comp = OPT.DynArr(*26.7.2002*)) DO INC(dim); n := n^.left END ; + IF (n^.class = OPT.Nderef) & (n^.typ^.comp = OPT.DynArr) THEN design(n^.left, 10); OPM.WriteString("->len["); OPM.WriteInt(dim); OPM.Write("]") ELSE OPC.Len(n^.obj, n^.typ, dim) @@ -336,47 +277,40 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE SideEffects(n: OPT.Node): BOOLEAN; BEGIN - IF n # NIL THEN RETURN (n^.class = Ncall) OR SideEffects(n^.left) OR SideEffects(n^.right) + IF n # NIL THEN RETURN (n^.class = OPT.Ncall) OR SideEffects(n^.left) OR SideEffects(n^.right) ELSE RETURN FALSE END END SideEffects; PROCEDURE Entier(n: OPT.Node; prec: INTEGER); BEGIN - IF n^.typ^.form IN {Real, LReal} THEN + IF n^.typ^.form IN {OPT.Real, OPT.LReal} THEN OPM.WriteString(EntierFunc); expr(n, MinPrec); OPM.Write(CloseParen) ELSE expr(n, prec) END END Entier; - PROCEDURE Convert(n: OPT.Node; form, prec: INTEGER); - VAR from: INTEGER; - BEGIN from := n^.typ^.form; - IF form = Set THEN OPM.WriteString(SetOfFunc); Entier(n, MinPrec); OPM.Write(CloseParen) - ELSIF form = LInt THEN - IF from < LInt THEN OPM.WriteString("(LONGINT)") END ; - Entier(n, 9) - (*ELSIF form = Int64 THEN - IF (from >= SInt) & (from <= LInt) OR (from >= Int8) & (from < Int64) THEN OPM.WriteString("(SYSTEM_INT64)") END; - Entier(n, 9);*) - ELSIF form = Int THEN - IF from < Int THEN OPM.WriteString("(int)"); expr(n, 9) + PROCEDURE SizeCast(size: LONGINT); + BEGIN + IF size <= 4 THEN OPM.WriteString("(int)") + ELSE OPM.WriteString("(SYSTEM_INT64)") + END + END SizeCast; + + PROCEDURE Convert(n: OPT.Node; newtype: OPT.Struct; prec: INTEGER); + VAR from, to: INTEGER; + BEGIN from := n^.typ^.form; to := newtype.form; + IF to = OPT.Set THEN OPM.WriteString(SetOfFunc); Entier(n, MinPrec); OPM.Write(CloseParen) + ELSIF to IN OPT.intSet THEN + IF (newtype.size < n.typ.size) & (OPM.ranchk IN OPM.opt) THEN + OPM.WriteString("__SHORT"); IF SideEffects(n) THEN OPM.Write("F") END; + OPM.Write(OpenParen); Entier(n, MinPrec); OPM.WriteString(Comma); + OPM.WriteInt(OPM.SignedMaximum(newtype.size) + 1); OPM.Write(CloseParen) ELSE - IF OPM.ranchk IN OPM.opt THEN OPM.WriteString("__SHORT"); - IF SideEffects(n) THEN OPM.Write("F") END ; - OPM.Write(OpenParen); Entier(n, MinPrec); - OPM.WriteString(Comma); OPM.WriteInt(OPM.MaxInt + 1); OPM.Write(CloseParen) - ELSE OPM.WriteString("(int)"); Entier(n, 9) - END + IF newtype.size # n.typ.size THEN SizeCast(newtype.size) END; + Entier(n, 9) END - ELSIF form = SInt THEN - IF OPM.ranchk IN OPM.opt THEN OPM.WriteString("__SHORT"); - IF SideEffects(n) THEN OPM.Write("F") END ; - OPM.Write(OpenParen); Entier(n, MinPrec); - OPM.WriteString(Comma); OPM.WriteInt(OPM.MaxSInt + 1); OPM.Write(CloseParen) - ELSE OPM.WriteString("(int)"); Entier(n, 9) - END - ELSIF form = Char THEN + ELSIF to = OPT.Char THEN IF OPM.ranchk IN OPM.opt THEN OPM.WriteString("__CHR"); IF SideEffects(n) THEN OPM.Write("F") END ; OPM.Write(OpenParen); Entier(n, MinPrec); OPM.Write(CloseParen) @@ -388,15 +322,15 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE TypeOf(n: OPT.Node); BEGIN - IF n^.typ^.form = Pointer THEN + IF n^.typ^.form = OPT.Pointer THEN OPM.WriteString(TypeFunc); expr(n, MinPrec); OPM.Write(")") - ELSIF n^.class IN {Nvar, Nindex, Nfield} THEN (* dyn rec type = stat rec type *) + ELSIF n^.class IN {OPT.Nvar, OPT.Nindex, OPT.Nfield} THEN (* dyn rec type = stat rec type *) OPC.Andent(n^.typ); OPM.WriteString(DynTypExt) - ELSIF n^.class = Nderef THEN (* p^ *) + ELSIF n^.class = OPT.Nderef THEN (* p^ *) OPM.WriteString(TypeFunc); expr(n^.left, MinPrec); OPM.Write(")") - ELSIF n^.class = Nguard THEN (* r(T) *) + ELSIF n^.class = OPT.Nguard THEN (* r(T) *) TypeOf(n^.left) (* skip guard *) - ELSIF (n^.class = Nmop) & (n^.subcl = val) THEN + ELSIF (n^.class = OPT.Nmop) & (n^.subcl = OPT.val) THEN (*SYSTEM.VAL(typ, var par rec)*) OPC.TypeOf(n^.left^.obj) ELSE (* var par rec *) @@ -407,7 +341,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE Index(n, d: OPT.Node; prec, dim: INTEGER); BEGIN IF ~inxchk - OR (n^.right^.class = Nconst) & ((n^.right^.conval^.intval = 0) OR (n^.left^.typ^.comp # DynArr)) THEN + OR (n^.right^.class = OPT.Nconst) & ((n^.right^.conval^.intval = 0) OR (n^.left^.typ^.comp # OPT.DynArr)) THEN expr(n^.right, prec) ELSE IF SideEffects(n^.right) THEN OPM.WriteString("__XF(") ELSE OPM.WriteString("__X(") END ; @@ -422,94 +356,84 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 BEGIN comp := n^.typ^.comp; obj := n^.obj; class := n^.class; designPrec := Precedence(class, n^.subcl, n^.typ^.form, comp); - IF (class = Nvar) & (obj^.mnolev > 0) & (obj^.mnolev # OPM.level) & (prec = 10) THEN designPrec := 9 END ; + IF (class = OPT.Nvar) & (obj^.mnolev > 0) & (obj^.mnolev # OPM.level) & (prec = 10) THEN designPrec := 9 END ; IF prec > designPrec THEN OPM.Write(OpenParen) END; IF prec = ProcTypeVar THEN OPM.Write(Deref) END; (* proc var calls must be dereferenced in K&R C *) CASE class OF - Nproc: - OPC.Ident(n^.obj) - | Nvar: - OPC.CompleteIdent(n^.obj) - | Nvarpar: - IF ~(comp IN {Array, DynArr}) THEN OPM.Write(Deref) END; (* deref var parameter *) - OPC.CompleteIdent(n^.obj) - | Nfield: - IF n^.left^.class = Nderef THEN design(n^.left^.left, designPrec); OPM.WriteString("->") - ELSE design(n^.left, designPrec); OPM.Write(".") - END ; - OPC.Ident(n^.obj) - | Nderef: - IF n^.typ^.comp = DynArr THEN design(n^.left, 10); OPM.WriteString("->data") - ELSE OPM.Write(Deref); design(n^.left, designPrec) - END - | Nindex: - d := n^.left; - IF d^.typ^.comp = DynArr THEN dims := 0; - WHILE d^.class = Nindex DO d := d^.left; INC(dims) END ; - IF n^.typ^.comp = DynArr THEN OPM.Write("&") END ; - design(d, designPrec); - OPM.Write(OpenBracket); - IF n^.typ^.comp = DynArr THEN OPM.Write("(") END ; - i := dims; x := n; - WHILE x # d DO (* apply Horner schema *) - IF x^.left # d THEN Index(x, d, 7, i); OPM.WriteString(" + "); Len(d, i); OPM.WriteString(" * ("); DEC(i) - ELSE Index(x, d, MinPrec, i) - END ; - x := x^.left - END ; - FOR i := 1 TO dims DO OPM.Write(")") END ; - IF n^.typ^.comp = DynArr THEN - (* element type is DynArr; finish Horner schema with virtual indices = 0*) - OPM.Write(")"); - WHILE i < (d^.typ^.size - 4) DIV 4 DO - OPM.WriteString(" * "); Len(d, i); - INC(i) - END - END ; - OPM.Write(CloseBracket) - ELSE - design(n^.left, designPrec); - OPM.Write(OpenBracket); - Index(n, n^.left, MinPrec, 0); - OPM.Write(CloseBracket) - END - | Nguard: - typ := n^.typ; obj := n^.left^.obj; - IF OPM.typchk IN OPM.opt THEN - IF typ^.comp = Record THEN OPM.WriteString(GuardRecFunc); - IF obj^.mnolev # OPM.level THEN (*intermediate level var-par record*) - OPM.WriteStringVar(obj^.scope^.name); OPM.WriteString("__curr->"); OPC.Ident(obj) - ELSE (*local var-par record*) - OPC.Ident(obj) - END ; - ELSE (*Pointer*) - IF typ^.BaseTyp^.strobj = NIL THEN OPM.WriteString("__GUARDA(") ELSE OPM.WriteString(GuardPtrFunc) END ; - expr(n^.left, MinPrec); typ := typ^.BaseTyp - END ; - OPM.WriteString(Comma); - OPC.Andent(typ); OPM.WriteString(Comma); - OPM.WriteInt(typ^.extlev); OPM.Write(")") - ELSE - IF typ^.comp = Record THEN (* do not cast record directly, cast pointer to record *) - OPM.WriteString("*("); OPC.Ident(typ^.strobj); OPM.WriteString("*)"); OPC.CompleteIdent(obj) - ELSE (*simply cast pointer*) - OPM.Write("("); OPC.Ident(typ^.strobj); OPM.Write(")"); expr(n^.left, designPrec) - END - END - | Neguard: - IF OPM.typchk IN OPM.opt THEN - IF n^.left^.class = Nvarpar THEN OPM.WriteString("__GUARDEQR("); - OPC.CompleteIdent(n^.left^.obj); OPM.WriteString(Comma); TypeOf(n^.left); - ELSE OPM.WriteString("__GUARDEQP("); expr(n^.left^.left, MinPrec) - END ; (* __GUARDEQx includes deref *) - OPM.WriteString(Comma); OPC.Ident(n^.left^.typ^.strobj); OPM.Write(")") - ELSE - expr(n^.left, MinPrec) (* always lhs of assignment *) - END - | Nmop: - IF n^.subcl = val THEN design(n^.left, prec) END - ELSE - OPM.LogWStr("unhandled case in OPV.design, class = "); OPM.LogWNum(class, 0); OPM.LogWLn; + | OPT.Nproc: OPC.Ident(n^.obj) + | OPT.Nvar: OPC.CompleteIdent(n^.obj) + | OPT.Nvarpar: IF ~(comp IN {OPT.Array, OPT.DynArr}) THEN OPM.Write(Deref) END; (* deref var parameter *) + OPC.CompleteIdent(n^.obj) + | OPT.Nfield: IF n^.left^.class = OPT.Nderef THEN design(n^.left^.left, designPrec); OPM.WriteString("->") + ELSE design(n^.left, designPrec); OPM.Write(".") + END ; + OPC.Ident(n^.obj) + | OPT.Nderef: IF n^.typ^.comp = OPT.DynArr THEN design(n^.left, 10); OPM.WriteString("->data") + ELSE OPM.Write(Deref); design(n^.left, designPrec) + END + | OPT.Nindex: d := n^.left; + IF d^.typ^.comp = OPT.DynArr THEN dims := 0; + WHILE d^.class = OPT.Nindex DO d := d^.left; INC(dims) END ; + IF n^.typ^.comp = OPT.DynArr THEN OPM.Write("&") END ; + design(d, designPrec); + OPM.Write(OpenBracket); + IF n^.typ^.comp = OPT.DynArr THEN OPM.Write("(") END ; + i := dims; x := n; + WHILE x # d DO (* apply Horner schema *) + IF x^.left # d THEN Index(x, d, 7, i); OPM.WriteString(" + "); Len(d, i); OPM.WriteString(" * ("); DEC(i) + ELSE Index(x, d, MinPrec, i) + END ; + x := x^.left + END ; + FOR i := 1 TO dims DO OPM.Write(")") END ; + IF n^.typ^.comp = OPT.DynArr THEN + (* element type is OPT.DynArr; finish Horner schema with virtual indices = 0*) + OPM.Write(")"); + WHILE i < (d^.typ^.size - 4) DIV 4 DO + OPM.WriteString(" * "); Len(d, i); + INC(i) + END + END ; + OPM.Write(CloseBracket) + ELSE + design(n^.left, designPrec); + OPM.Write(OpenBracket); + Index(n, n^.left, MinPrec, 0); + OPM.Write(CloseBracket) + END + | OPT.Nguard: typ := n^.typ; obj := n^.left^.obj; + IF OPM.typchk IN OPM.opt THEN + IF typ^.comp = OPT.Record THEN OPM.WriteString(GuardRecFunc); + IF obj^.mnolev # OPM.level THEN (*intermediate level var-par record*) + OPM.WriteStringVar(obj^.scope^.name); OPM.WriteString("__curr->"); OPC.Ident(obj) + ELSE (*local var-par record*) + OPC.Ident(obj) + END ; + ELSE (*Pointer*) + IF typ^.BaseTyp^.strobj = NIL THEN OPM.WriteString("__GUARDA(") ELSE OPM.WriteString(GuardPtrFunc) END ; + expr(n^.left, MinPrec); typ := typ^.BaseTyp + END ; + OPM.WriteString(Comma); + OPC.Andent(typ); OPM.WriteString(Comma); + OPM.WriteInt(typ^.extlev); OPM.Write(")") + ELSE + IF typ^.comp = OPT.Record THEN (* do not cast record directly, cast pointer to record *) + OPM.WriteString("*("); OPC.Ident(typ^.strobj); OPM.WriteString("*)"); OPC.CompleteIdent(obj) + ELSE (*simply cast pointer*) + OPM.Write("("); OPC.Ident(typ^.strobj); OPM.Write(")"); expr(n^.left, designPrec) + END + END + | OPT.Neguard: IF OPM.typchk IN OPM.opt THEN + IF n^.left^.class = OPT.Nvarpar THEN OPM.WriteString("__GUARDEQR("); + OPC.CompleteIdent(n^.left^.obj); OPM.WriteString(Comma); TypeOf(n^.left); + ELSE OPM.WriteString("__GUARDEQP("); expr(n^.left^.left, MinPrec) + END ; (* __GUARDEQx includes deref *) + OPM.WriteString(Comma); OPC.Ident(n^.left^.typ^.strobj); OPM.Write(")") + ELSE + expr(n^.left, MinPrec) (* always lhs of assignment *) + END + | OPT.Nmop: IF n^.subcl = OPT.val THEN design(n^.left, prec) END + ELSE OPM.LogWStr("unhandled case in OPV.design, class = "); OPM.LogWNum(class, 0); OPM.LogWLn; END ; IF prec > designPrec THEN OPM.Write(CloseParen) END END design; @@ -520,54 +444,52 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 OPM.Write(OpenParen); WHILE n # NIL DO typ := fp^.typ; comp := typ^.comp; form := typ^.form; mode := fp^.mode; prec := MinPrec; - IF (mode = VarPar) & (n^.class = Nmop) & (n^.subcl = val) THEN (* avoid cast in lvalue *) + IF (mode = OPT.VarPar) & (n^.class = OPT.Nmop) & (n^.subcl = OPT.val) THEN (* avoid cast in lvalue *) OPM.Write(OpenParen); OPC.Ident(n^.typ^.strobj); OPM.WriteString("*)"); prec := 10 END ; - IF ~(n^.typ^.comp IN {Array, DynArr}) THEN - IF mode = VarPar THEN + IF ~(n^.typ^.comp IN {OPT.Array, OPT.DynArr}) THEN + IF mode = OPT.VarPar THEN IF ansi & (typ # n^.typ) THEN OPM.WriteString("(void*)") END ; OPM.Write("&"); prec := 9 ELSIF ansi THEN - IF (comp IN {Array, DynArr}) & (n^.class = Nconst) THEN + IF (comp IN {OPT.Array, OPT.DynArr}) & (n^.class = OPT.Nconst) THEN OPM.WriteString("(CHAR*)") (* force to unsigned char *) - ELSIF (form = Pointer) & (typ # n^.typ) & (n^.typ # OPT.niltyp) THEN + ELSIF (form = OPT.Pointer) & (typ # n^.typ) & (n^.typ # OPT.niltyp) THEN OPM.WriteString("(void*)") (* type extension *) END ELSE - IF (form IN {Real, LReal}) & (n^.typ^.form IN {SInt, Int, LInt(*, Int8, Int16, Int32, Int64*)}) THEN (* real promotion *) + IF (form IN {OPT.Real, OPT.LReal}) & (n^.typ^.form IN OPT.intSet) THEN (* real promotion *) OPM.WriteString("(double)"); prec := 9 - ELSIF (form = LInt) & (n^.typ^.form < LInt) THEN (* integral promotion *) + ELSIF (form = OPT.LInt) & (n^.typ^.form < OPT.LInt) THEN (* integral promotion *) OPM.WriteString("(LONGINT)"); prec := 9 - (*ELSIF (form = Int64) & (n^.typ^.form < Int64) THEN - OPM.WriteString("(SYSTEM_INT64)"); prec := 9;*) END END ELSIF ansi THEN (* casting of params should be simplified eventually *) - IF (mode = VarPar) & (typ # n^.typ) & (prec = MinPrec) THEN OPM.WriteString("(void*)") END + IF (mode = OPT.VarPar) & (typ # n^.typ) & (prec = MinPrec) THEN OPM.WriteString("(void*)") END END; - IF (mode = VarPar) & (n^.class = Nmop) & (n^.subcl = val) THEN + IF (mode = OPT.VarPar) & (n^.class = OPT.Nmop) & (n^.subcl = OPT.val) THEN expr(n^.left, prec) (* avoid cast in lvalue *) - ELSIF (form = LInt) & (n^.class = Nconst) - & (n^.conval^.intval <= OPM.MaxInt) & (n^.conval^.intval >= OPM.MinInt) THEN + ELSIF (form = OPT.LInt) & (n^.class = OPT.Nconst) + & (n^.conval^.intval <= OPM.SignedMaximum(OPM.IntSize)) & (n^.conval^.intval >= OPM.SignedMinimum(OPM.IntSize)) THEN OPM.WriteString("((LONGINT)("); expr(n, prec); OPM.WriteString("))"); - ELSE + ELSE expr(n, prec) END; - IF (comp = Record) & (mode = VarPar) THEN + IF (comp = OPT.Record) & (mode = OPT.VarPar) THEN OPM.WriteString(", "); TypeOf(n) - ELSIF comp = DynArr THEN - IF n^.class = Nconst THEN (* ap is string constant *) + ELSIF comp = OPT.DynArr THEN + IF n^.class = OPT.Nconst THEN (* ap is string constant *) OPM.WriteString(Comma); OPM.WriteString("(LONGINT)"); OPM.WriteInt(n^.conval^.intval2) ELSE aptyp := n^.typ; dim := 0; - WHILE (typ^.comp = DynArr) & (typ^.BaseTyp^.form # Byte) DO + WHILE (typ^.comp = OPT.DynArr) & (typ^.BaseTyp^.form # OPT.Byte) DO OPM.WriteString(Comma); Len(n, dim); typ := typ^.BaseTyp; aptyp := aptyp^.BaseTyp; INC(dim) END ; - IF (typ^.comp = DynArr) & (typ^.BaseTyp^.form = Byte) THEN + IF (typ^.comp = OPT.DynArr) & (typ^.BaseTyp^.form = OPT.Byte) THEN OPM.WriteString(Comma); - WHILE aptyp^.comp = DynArr DO + WHILE aptyp^.comp = OPT.DynArr DO Len(n, dim); OPM.WriteString(" * "); INC(dim); aptyp := aptyp^.BaseTyp END ; OPM.WriteString("((LONGINT)("); OPM.WriteInt(aptyp^.size); OPM.WriteString("))"); @@ -583,7 +505,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE SuperProc(n: OPT.Node): OPT.Object; VAR obj: OPT.Object; typ: OPT.Struct; BEGIN typ := n^.right^.typ; (* receiver type *) - IF typ^.form = Pointer THEN typ := typ^.BaseTyp END ; + IF typ^.form = OPT.Pointer THEN typ := typ^.BaseTyp END ; OPT.FindField(n^.left^.obj^.name, typ^.BaseTyp, obj); RETURN obj END SuperProc; @@ -601,189 +523,163 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 class := n^.class; subclass := n^.subcl; form := n^.typ^.form; l := n^.left; r := n^.right; exprPrec := Precedence (class, subclass, form, n^.typ^.comp); - IF (exprPrec <= prec) & (class IN {Nconst, Nupto, Nmop, Ndop, Ncall, Nguard, Neguard}) THEN + IF (exprPrec <= prec) & (class IN {OPT.Nconst, OPT.Nupto, OPT.Nmop, OPT.Ndop, OPT.Ncall, OPT.Nguard, OPT.Neguard}) THEN OPM.Write(OpenParen); END; CASE class OF - Nconst: - OPC.Constant(n^.conval, form) - | Nupto: (* n^.typ = OPT.settyp *) - OPM.WriteString(SetRangeFunc); expr(l, MinPrec); OPM.WriteString(Comma); expr (r, MinPrec); - OPM.Write(CloseParen) - | Nmop: - CASE subclass OF - not: - OPM.Write("!"); expr(l, exprPrec) - | minus: - IF form = Set THEN OPM.Write("~") ELSE OPM.Write("-"); END ; - expr(l, exprPrec) - | is: - typ := n^.obj^.typ; - IF l^.typ^.comp = Record THEN OPM.WriteString(IsFunc); OPC.TypeOf(l^.obj) - ELSE OPM.WriteString(IsPFunc); expr(l, MinPrec); typ := typ^.BaseTyp - END ; - OPM.WriteString(Comma); - OPC.Andent(typ); OPM.WriteString(Comma); - OPM.WriteInt(typ^.extlev); OPM.Write(")") - | conv: - Convert(l, form, exprPrec) - | abs: - IF SideEffects(l) THEN - IF l^.typ^.form < Real THEN - IF l^.typ^.form < LInt THEN OPM.WriteString("(int)") END ; - OPM.WriteString("__ABSF(") - ELSE OPM.WriteString("__ABSFD(") + | OPT.Nconst: OPC.Constant(n^.conval, form) + | OPT.Nupto: (* n^.typ = OPT.settyp *) + OPM.WriteString(SetRangeFunc); expr(l, MinPrec); OPM.WriteString(Comma); expr (r, MinPrec); + OPM.Write(CloseParen) + | OPT.Nmop: + CASE subclass OF + | OPS.not: OPM.Write("!"); expr(l, exprPrec) + | OPS.minus: IF form = OPT.Set THEN OPM.Write("~") ELSE OPM.Write("-") END; + expr(l, exprPrec) + | OPS.is: typ := n^.obj^.typ; + IF l^.typ^.comp = OPT.Record THEN OPM.WriteString(IsFunc); OPC.TypeOf(l^.obj) + ELSE OPM.WriteString(IsPFunc); expr(l, MinPrec); typ := typ^.BaseTyp + END ; + OPM.WriteString(Comma); + OPC.Andent(typ); OPM.WriteString(Comma); + OPM.WriteInt(typ^.extlev); OPM.Write(")") + | OPT.conv: Convert(l, n.typ, exprPrec) + | OPT.abs: IF SideEffects(l) THEN + IF l^.typ^.form < OPT.Real THEN + IF l^.typ^.form < OPT.LInt THEN OPM.WriteString("(int)") END ; + OPM.WriteString("__ABSF(") + ELSE OPM.WriteString("__ABSFD(") + END + ELSE OPM.WriteString("__ABS(") + END ; + expr(l, MinPrec); OPM.Write(CloseParen) + | OPT.cap: OPM.WriteString("__CAP("); expr(l, MinPrec); OPM.Write(CloseParen) + | OPT.odd: OPM.WriteString("__ODD("); expr(l, MinPrec); OPM.Write(CloseParen) + | OPT.adr: OPM.WriteString("(LONGINT)(SYSTEM_ADDRESS)"); (*SYSTEM*) + IF l^.class = OPT.Nvarpar THEN OPC.CompleteIdent(l^.obj) + ELSE + IF (l^.typ^.form # OPT.String) & ~(l^.typ^.comp IN {OPT.Array, OPT.DynArr}) THEN OPM.Write("&") END ; + expr(l, exprPrec) + END + | OPT.val: IF ~(l^.class IN {OPT.Nvar, OPT.Nvarpar, OPT.Nfield, OPT.Nindex}) (*SYSTEM*) + OR (n^.typ^.form IN {OPT.LInt, OPT.Pointer, OPT.Set, OPT.ProcTyp}) + & (l^.typ^.form IN {OPT.LInt, OPT.Pointer, OPT.Set, OPT.ProcTyp}) + & (n^.typ^.size = l^.typ^.size) + THEN + OPM.Write(OpenParen); OPC.Ident(n^.typ^.strobj); OPM.Write(CloseParen); + IF (n^.typ^.form IN {OPT.Pointer, OPT.ProcTyp}) OR (l^.typ^.form IN {OPT.Pointer, OPT.ProcTyp}) THEN + OPM.WriteString("(SYSTEM_ADDRESS)") + END; + expr(l, exprPrec) + ELSE + OPM.WriteString("__VAL("); + OPC.Ident(n^.typ^.strobj); OPM.WriteString(Comma); + expr(l, MinPrec); OPM.Write(CloseParen) + END + ELSE OPM.err(200) END - ELSE OPM.WriteString("__ABS(") - END ; - expr(l, MinPrec); OPM.Write(CloseParen) - | cap: - OPM.WriteString("__CAP("); expr(l, MinPrec); OPM.Write(CloseParen) - | odd: - OPM.WriteString("__ODD("); expr(l, MinPrec); OPM.Write(CloseParen) - | adr: (*SYSTEM*) - OPM.WriteString("(LONGINT)(uintptr_t)"); - IF l^.class = Nvarpar THEN OPC.CompleteIdent(l^.obj) - ELSE - IF (l^.typ^.form # String) & ~(l^.typ^.comp IN {Array, DynArr}) THEN OPM.Write("&") END ; - expr(l, exprPrec) - END - | val: (*SYSTEM*) - IF (n^.typ^.form IN {LInt, Pointer, Set, ProcTyp}) & (l^.typ^.form IN {LInt, Pointer, Set, ProcTyp}) - & (n^.typ^.size = l^.typ^.size) OR ~(l^.class IN {Nvar, Nvarpar, Nfield, Nindex}) THEN - OPM.Write(OpenParen); OPC.Ident(n^.typ^.strobj); OPM.Write(CloseParen); - IF (n^.typ^.form IN {Pointer, ProcTyp}) OR (l^.typ^.form IN {Pointer, ProcTyp}) THEN - OPM.WriteString("(uintptr_t)") - END; - expr(l, exprPrec) - ELSE - IF (n^.typ^.form IN {Pointer, ProcTyp}) OR (l^.typ^.form IN {Pointer, ProcTyp}) THEN - OPM.WriteString("__VALP("); - ELSE - OPM.WriteString("__VAL("); - END; - OPC.Ident(n^.typ^.strobj); OPM.WriteString(Comma); - expr(l, MinPrec); OPM.Write(CloseParen) - END - ELSE OPM.err(200) - END - | Ndop: - CASE subclass OF - len: - Len(l, r^.conval^.intval) - | in, ash, msk, bit, lsh, rot, div, mod: - CASE subclass OF - | in: - OPM.WriteString("__IN(") - | ash: - IF r^.class = Nconst THEN - IF r^.conval^.intval >= 0 THEN OPM.WriteString("__ASHL(") - ELSE OPM.WriteString("__ASHR(") - END - ELSIF SideEffects(r) THEN OPM.WriteString("__ASHF(") - ELSE OPM.WriteString("__ASH(") - END - | msk: - OPM.WriteString("__MASK("); - | bit: - OPM.WriteString("__BIT(") - | lsh: - IF r^.class = Nconst THEN - IF r^.conval^.intval >= 0 THEN OPM.WriteString("__LSHL(") - ELSE OPM.WriteString("__LSHR(") - END - ELSE OPM.WriteString("__LSH(") - END - | rot: - IF r^.class = Nconst THEN - IF r^.conval^.intval >= 0 THEN OPM.WriteString("__ROTL(") - ELSE OPM.WriteString("__ROTR(") - END - ELSE OPM.WriteString("__ROT(") - END - | div: - IF SideEffects(n) THEN - IF form < LInt THEN OPM.WriteString("(int)") END ; - OPM.WriteString("__DIVF(") - ELSE OPM.WriteString("__DIV(") - END - | mod: - IF form < LInt THEN OPM.WriteString("(int)") END ; - IF SideEffects(n) THEN OPM.WriteString("__MODF(") - ELSE OPM.WriteString("__MOD(") - END; - ELSE - OPM.LogWStr("unhandled case in OPV.expr, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; - END ; - expr(l, MinPrec); - OPM.WriteString(Comma); - IF (subclass IN {ash, lsh, rot}) & (r^.class = Nconst) & (r^.conval^.intval < 0) THEN - OPM.WriteInt(-r^.conval^.intval) - ELSE expr(r, MinPrec) - END ; - IF subclass IN {lsh, rot} THEN OPM.WriteString(Comma); OPC.Ident(l^.typ^.strobj) END ; - OPM.Write(CloseParen) - | eql .. geq: - IF l^.typ^.form IN {String, Comp} THEN - OPM.WriteString("__STRCMP("); - expr(l, MinPrec); OPM.WriteString(Comma); expr(r, MinPrec); OPM.Write(CloseParen); - OPC.Cmp(subclass); OPM.Write("0") - ELSE - expr(l, exprPrec); OPC.Cmp(subclass); - typ := l^.typ; - IF (typ^.form = Pointer) & (r^.typ.form # NilTyp) & (r^.typ # typ) & (r^.typ # OPT.sysptrtyp) THEN - OPM.WriteString("(void *) ") - END ; - expr(r, exprPrec) - END - ELSE - IF (subclass = and) OR ((form = Set) & ((subclass = times) OR (subclass = minus))) THEN OPM.Write(OpenParen); END; (* to silence clang warnings; -- noch *) - expr(l, exprPrec); - CASE subclass OF - times: - IF form = Set THEN OPM.WriteString(" & ") - ELSE OPM.WriteString(" * ") + | OPT.Ndop: CASE subclass OF + | OPT.len: Len(l, r^.conval^.intval) + | OPS.in, + OPT.ash, + OPT.msk, + OPT.bit, + OPT.lsh, + OPT.rot, + OPS.div, + OPS.mod: CASE subclass OF + | OPS.in: OPM.WriteString("__IN(") + | OPT.ash: IF r^.class = OPT.Nconst THEN + IF r^.conval^.intval >= 0 THEN OPM.WriteString("__ASHL(") + ELSE OPM.WriteString("__ASHR(") + END + ELSIF SideEffects(r) THEN OPM.WriteString("__ASHF(") + ELSE OPM.WriteString("__ASH(") + END + | OPT.msk: OPM.WriteString("__MASK("); + | OPT.bit: OPM.WriteString("__BIT(") + | OPT.lsh: IF r^.class = OPT.Nconst THEN + IF r^.conval^.intval >= 0 THEN OPM.WriteString("__LSHL(") + ELSE OPM.WriteString("__LSHR(") + END + ELSE OPM.WriteString("__LSH(") + END + | OPT.rot: IF r^.class = OPT.Nconst THEN + IF r^.conval^.intval >= 0 THEN OPM.WriteString("__ROTL(") + ELSE OPM.WriteString("__ROTR(") + END + ELSE OPM.WriteString("__ROT(") + END + | OPS.div: IF SideEffects(n) THEN + IF form < OPT.LInt THEN OPM.WriteString("(int)") END ; + OPM.WriteString("__DIVF(") + ELSE OPM.WriteString("__DIV(") + END + | OPS.mod: IF form < OPT.LInt THEN OPM.WriteString("(int)") END ; + IF SideEffects(n) THEN OPM.WriteString("__MODF(") + ELSE OPM.WriteString("__MOD(") + END; + ELSE OPM.LogWStr("unhandled case in OPV.expr, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; + END ; + expr(l, MinPrec); + OPM.WriteString(Comma); + IF (subclass IN {OPT.ash, OPT.lsh, OPT.rot}) & (r^.class = OPT.Nconst) & (r^.conval^.intval < 0) THEN + OPM.WriteInt(-r^.conval^.intval) + ELSE expr(r, MinPrec) + END ; + IF subclass IN {OPT.lsh, OPT.rot} THEN OPM.WriteString(Comma); OPC.Ident(l^.typ^.strobj) END ; + OPM.Write(CloseParen) + | OPS.eql + .. OPS.geq: IF l^.typ^.form IN {OPT.String, OPT.Comp} THEN + OPM.WriteString("__STRCMP("); + expr(l, MinPrec); OPM.WriteString(Comma); expr(r, MinPrec); OPM.Write(CloseParen); + OPC.Cmp(subclass); OPM.Write("0") + ELSE + expr(l, exprPrec); OPC.Cmp(subclass); + typ := l^.typ; + IF (typ^.form = OPT.Pointer) & (r^.typ.form # OPT.NilTyp) & (r^.typ # typ) & (r^.typ # OPT.sysptrtyp) THEN + OPM.WriteString("(void *) ") + END ; + expr(r, exprPrec) + END + ELSE IF (subclass = OPS.and) OR ((form = OPT.Set) & ((subclass = OPS.times) OR (subclass = OPS.minus))) THEN OPM.Write(OpenParen); END; (* to silence clang warnings; -- noch *) + expr(l, exprPrec); + CASE subclass OF + | OPS.times: IF form = OPT.Set THEN OPM.WriteString(" & ") + ELSE OPM.WriteString(" * ") + END + | OPS.slash: IF form = OPT.Set THEN OPM.WriteString(" ^ ") + ELSE OPM.WriteString(" / "); + IF (r^.obj = NIL) OR (r^.obj^.typ^.form IN OPT.intSet) THEN + OPM.Write(OpenParen); OPC.Ident(n^.typ^.strobj); OPM.Write(CloseParen) + END + END + | OPS.and: OPM.WriteString(" && ") + | OPS.plus: IF form = OPT.Set THEN OPM.WriteString(" | ") + ELSE OPM.WriteString(" + ") + END + | OPS.minus: IF form = OPT.Set THEN OPM.WriteString(" & ~") + ELSE OPM.WriteString(" - ") + END; + | OPS.or: OPM.WriteString(" || "); + ELSE OPM.LogWStr("unhandled case in OPV.expr, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; + END; + expr(r, exprPrec); + IF (subclass = OPS.and) OR ((form = OPT.Set) & ((subclass = OPS.times) OR (subclass = OPS.minus))) THEN OPM.Write(CloseParen) END; (* to silence clang warnings, -- noch*) END - | slash: - IF form = Set THEN OPM.WriteString(" ^ ") - ELSE OPM.WriteString(" / "); - IF (r^.obj = NIL) OR (r^.obj^.typ^.form IN {SInt, Int, LInt(*, Int8, Int16, Int32, Int64*)}) THEN - OPM.Write(OpenParen); OPC.Ident(n^.typ^.strobj); OPM.Write(CloseParen) - END - END - | and: - OPM.WriteString(" && ") - | plus: - IF form = Set THEN OPM.WriteString(" | ") - ELSE OPM.WriteString(" + ") - END - | minus: - IF form = Set THEN OPM.WriteString(" & ~") - ELSE OPM.WriteString(" - ") - END; - | or: - OPM.WriteString(" || "); - ELSE - OPM.LogWStr("unhandled case in OPV.expr, subclass = "); OPM.LogWNum(subclass, 0); OPM.LogWLn; - END; - expr(r, exprPrec); - IF (subclass = and) OR ((form = Set) & ((subclass = times) OR (subclass = minus))) THEN OPM.Write(CloseParen) END; (* to silence clang warnings, -- noch*) - END - | Ncall: - IF (l^.obj # NIL) & (l^.obj^.mode = TProc) THEN - IF l^.subcl = super THEN proc := SuperProc(n) - ELSE OPM.WriteString("__"); proc := OPC.BaseTProc(l^.obj) - END ; - OPC.Ident(proc); - n^.obj := proc^.link - ELSIF l^.class = Nproc THEN design(l, 10) - ELSE design(l, ProcTypeVar) - END ; - ActualPar(r, n^.obj) - ELSE - design(n, prec); (* not exprPrec! *) - END ; - IF (exprPrec <= prec) & (class IN {Nconst, Nupto, Nmop, Ndop, Ncall, Nguard}) THEN + | OPT.Ncall: IF (l^.obj # NIL) & (l^.obj^.mode = OPT.TProc) THEN + IF l^.subcl = OPT.super THEN proc := SuperProc(n) + ELSE OPM.WriteString("__"); proc := OPC.BaseTProc(l^.obj) + END ; + OPC.Ident(proc); + n^.obj := proc^.link + ELSIF l^.class = OPT.Nproc THEN design(l, 10) + ELSE design(l, ProcTypeVar) + END ; + ActualPar(r, n^.obj) + ELSE design(n, prec); (* not exprPrec! *) + END; + IF (exprPrec <= prec) & (class IN {OPT.Nconst, OPT.Nupto, OPT.Nmop, OPT.Ndop, OPT.Ncall, OPT.Nguard}) THEN OPM.Write(CloseParen) END END expr; @@ -792,14 +688,14 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE IfStat(n: OPT.Node; withtrap: BOOLEAN; outerProc: OPT.Object); VAR if: OPT.Node; obj: OPT.Object; typ: OPT.Struct; adr: LONGINT; - BEGIN (* n^.class IN {Nifelse, Nwith} *) + BEGIN (* n^.class IN {OPT.Nifelse, OPT.Nwith} *) if := n^.left; (* name := ""; *) WHILE if # NIL DO OPM.WriteString("if "); expr(if^.left, MaxPrec); (* if *) OPM.Write(Blank); OPC.BegBlk; - IF (n^.class = Nwith) & (if^.left^.left # NIL) THEN (* watch out for const expr *) + IF (n^.class = OPT.Nwith) & (if^.left^.left # NIL) THEN (* watch out for const expr *) obj := if^.left^.left^.obj; typ := obj^.typ; adr := obj^.adr; - IF typ^.comp = Record THEN + IF typ^.comp = OPT.Record THEN (* introduce alias pointer for var records; T1 *name__ = rec; *) OPC.BegStat; OPC.Ident(if^.left^.obj); OPM.WriteString(" *"); OPM.WriteString(obj.name); OPM.WriteString("__ = (void*)"); @@ -865,7 +761,7 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE ImplicitReturn(n: OPT.Node): BOOLEAN; BEGIN - WHILE (n # NIL) & (n.class # Nreturn) DO n := n^.link END ; + WHILE (n # NIL) & (n.class # OPT.Nreturn) DO n := n^.link END ; RETURN n = NIL END ImplicitReturn; @@ -873,22 +769,22 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 VAR typ, base: OPT.Struct; nofdim, nofdyn: INTEGER; BEGIN typ := d^.typ^.BaseTyp; base := typ; nofdim := 0; nofdyn := 0; - WHILE base^.comp = DynArr DO INC(nofdim); INC(nofdyn); base := base^.BaseTyp END ; + WHILE base^.comp = OPT.DynArr DO INC(nofdim); INC(nofdyn); base := base^.BaseTyp END ; design(d, MinPrec); OPM.WriteString(" = __NEWARR("); - WHILE base^.comp = Array DO INC(nofdim); base := base^.BaseTyp END ; - IF (base^.comp = Record) & (OPC.NofPtrs(base) # 0) THEN + WHILE base^.comp = OPT.Array DO INC(nofdim); base := base^.BaseTyp END ; + IF (base^.comp = OPT.Record) & (OPC.NofPtrs(base) # 0) THEN OPC.Ident(base^.strobj); OPM.WriteString(DynTypExt) - ELSIF base^.form = Pointer THEN OPM.WriteString("POINTER__typ") + ELSIF base^.form = OPT.Pointer THEN OPM.WriteString("POINTER__typ") ELSE OPM.WriteString("NIL") END ; OPM.WriteString(", "); OPM.WriteString("((LONGINT)("); OPM.WriteInt(base^.size); OPM.WriteString("))"); - OPM.WriteString(", "); OPM.WriteInt(OPC.Base(base)); (* element alignment *) + OPM.WriteString(", "); OPM.WriteInt(OPC.BaseAlignment(base)); (* element alignment *) OPM.WriteString(", "); OPM.WriteInt(nofdim); (* total number of dimensions = number of additional parameters *) OPM.WriteString(", "); OPM.WriteInt(nofdyn); (* number of dynamic dimensions *) WHILE typ # base DO OPM.WriteString(", "); - IF typ^.comp = DynArr THEN - IF x^.class = Nconst THEN OPM.WriteString("(LONGINT)("); expr(x, MinPrec); OPM.WriteString(")") + IF typ^.comp = OPT.DynArr THEN + IF x^.class = OPT.Nconst THEN OPM.WriteString("(LONGINT)("); expr(x, MinPrec); OPM.WriteString(")") ELSE OPM.WriteString("(LONGINT)"); expr(x, 10) END ; x := x^.link @@ -901,12 +797,12 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 PROCEDURE DefineTDescs(n: OPT.Node); BEGIN - WHILE (n # NIL) & (n^.class = Ninittd) DO OPC.TDescDecl(n^.typ); n := n^.link END + WHILE (n # NIL) & (n^.class = OPT.Ninittd) DO OPC.TDescDecl(n^.typ); n := n^.link END END DefineTDescs; PROCEDURE InitTDescs(n: OPT.Node); BEGIN - WHILE (n # NIL) & (n^.class = Ninittd) DO OPC.InitTDesc(n^.typ); n := n^.link END + WHILE (n # NIL) & (n^.class = OPT.Ninittd) DO OPC.InitTDesc(n^.typ); n := n^.link END END InitTDescs; PROCEDURE stat(n: OPT.Node; outerProc: OPT.Object); @@ -914,162 +810,138 @@ MODULE OPV; (* J. Templ 16.2.95 / 3.7.96 BEGIN WHILE (n # NIL) & OPM.noerr DO OPM.errpos := n^.conval^.intval; - IF n^.class # Ninittd THEN OPC.BegStat; END; + IF n^.class # OPT.Ninittd THEN OPC.BegStat END; CASE n^.class OF - Nenter: - IF n^.obj = NIL THEN (* enter module *) - INC(OPM.level); stat(n^.left, outerProc); DEC(OPM.level); - OPC.GenEnumPtrs(OPT.topScope^.scope); - DefineTDescs(n^.right); OPC.EnterBody; InitTDescs(n^.right); - OPM.WriteString("/* BEGIN */"); OPM.WriteLn; - stat(n^.right, outerProc); OPC.ExitBody - ELSE (* enter proc *) - proc := n^.obj; - OPC.TypeDefs(proc^.scope^.right, 0); - IF ~proc^.scope^.leaf THEN OPC.DefineInter (proc) END ; (* define intermediate procedure scope *) - INC(OPM.level); stat(n^.left, proc); DEC(OPM.level); - OPC.EnterProc(proc); stat(n^.right, proc); - OPC.ExitProc(proc, TRUE, ImplicitReturn(n^.right)); - END - | Ninittd: (* done in enter module *) - | Nassign: - CASE n^.subcl OF - assign: - l := n^.left; r := n^.right; - IF l^.typ^.comp = Array THEN (* includes string assignment but not COPY *) - OPM.WriteString(MoveFunc); - expr(r, MinPrec); OPM.WriteString(Comma); expr(l, MinPrec); OPM.WriteString(Comma); - IF r^.typ = OPT.stringtyp THEN OPM.WriteInt(r^.conval^.intval2) - ELSE OPM.WriteInt(r^.typ^.size) - END ; - OPM.Write(CloseParen) - ELSE - IF (l^.typ^.form = Pointer) & (l^.obj # NIL) & (l^.obj^.adr = 1) & (l^.obj^.mode = Var) THEN - l^.obj^.adr := 0; design(l, MinPrec); l^.obj^.adr := 1; (* avoid cast of WITH-variable *) - IF r^.typ^.form # NilTyp THEN OPM.WriteString(" = (void*)") - ELSE OPM.WriteString(" = ") - END - ELSE - design(l, MinPrec); OPM.WriteString(" = ") - END ; - IF l^.typ = r^.typ THEN expr(r, MinPrec) - ELSIF (l^.typ^.form = Pointer) & (r^.typ^.form # NilTyp) & (l^.typ^.strobj # NIL) THEN - OPM.Write("("); OPC.Ident(l^.typ^.strobj); OPM.Write(")"); expr(r, MinPrec) - ELSIF l^.typ^.comp = Record THEN - OPM.WriteString("*("); OPC.Andent(l^.typ); OPM.WriteString("*)&"); expr(r, 9) - ELSE expr(r, MinPrec) - END - END - | newfn: - IF n^.left^.typ^.BaseTyp^.comp = Record THEN - OPM.WriteString("__NEW("); design(n^.left, MinPrec); OPM.WriteString(", "); - OPC.Andent(n^.left^.typ^.BaseTyp); OPM.WriteString(")") - ELSIF n^.left^.typ^.BaseTyp^.comp IN {Array, DynArr} THEN - NewArr(n^.left, n^.right) - END - | incfn, decfn: - expr(n^.left, MinPrec); OPC.Increment(n^.subcl = decfn); expr(n^.right, MinPrec) - | inclfn, exclfn: - expr(n^.left, MinPrec); OPC.SetInclude(n^.subcl = exclfn); OPM.WriteString(SetOfFunc); expr(n^.right, MinPrec); - OPM.Write(CloseParen) - | copyfn: - OPM.WriteString(CopyFunc); - expr(n^.right, MinPrec); OPM.WriteString(Comma); expr(n^.left, MinPrec); OPM.WriteString(Comma); - Len(n^.left, 0); OPM.Write(CloseParen) - | (*SYSTEM*)movefn: - OPM.WriteString(MoveFunc); - expr(n^.right, MinPrec); OPM.WriteString(Comma); expr(n^.left, MinPrec); OPM.WriteString(Comma); - expr(n^.right^.link, MinPrec); - OPM.Write(CloseParen) - | (*SYSTEM*)getfn: - OPM.WriteString(GetFunc); expr(n^.right, MinPrec); OPM.WriteString(Comma); expr(n^.left, MinPrec); - OPM.WriteString(Comma); OPC.Ident(n^.left^.typ^.strobj); OPM.Write(CloseParen) - | (*SYSTEM*)putfn: - OPM.WriteString(PutFunc); expr(n^.left, MinPrec); OPM.WriteString(Comma); expr(n^.right, MinPrec); - OPM.WriteString(Comma); OPC.Ident(n^.right^.typ^.strobj); OPM.Write(CloseParen) - | (*SYSTEM*)getrfn, putrfn: OPM.err(200) - | (*SYSTEM*)sysnewfn: - OPM.WriteString("__SYSNEW("); - design(n^.left, MinPrec); OPM.WriteString(", "); - expr(n^.right, MinPrec); - OPM.Write(")") - ELSE - OPM.LogWStr("unhandled case in OPV.expr, n^.subcl = "); OPM.LogWNum(n^.subcl, 0); OPM.LogWLn; - END - | Ncall: - IF (n^.left^.obj # NIL) & (n^.left^.obj^.mode = TProc) THEN - IF n^.left^.subcl = super THEN proc := SuperProc(n) - ELSE OPM.WriteString("__"); proc := OPC.BaseTProc(n^.left^.obj) - END ; - OPC.Ident(proc); - n^.obj := proc^.link - ELSIF n^.left^.class = Nproc THEN design(n^.left, 10) - ELSE design(n^.left, ProcTypeVar) - END ; - ActualPar(n^.right, n^.obj) - | Nifelse: - IF n^.subcl # assertfn THEN IfStat(n, FALSE, outerProc) - ELSIF assert THEN OPM.WriteString("__ASSERT("); expr(n^.left^.left^.left, MinPrec); OPM.WriteString(Comma); - OPM.WriteInt(n^.left^.right^.right^.conval^.intval); OPM.Write(CloseParen); OPC.EndStat - END - | Ncase: - INC(exit.level); CaseStat(n, outerProc); DEC(exit.level) - | Nwhile: - INC(exit.level); OPM.WriteString("while "); expr(n^.left, MaxPrec); - OPM.Write(Blank); OPC.BegBlk; stat(n^.right, outerProc); OPC.EndBlk; - DEC(exit.level) - | Nrepeat: - INC(exit.level); OPM.WriteString("do "); OPC.BegBlk; stat(n^.left, outerProc); OPC.EndBlk0; - OPM.WriteString(" while (!"); expr(n^.right, 9); OPM.Write(CloseParen); - DEC(exit.level) - | Nloop: - saved := exit; exit.level := 0; exit.label := -1; - OPM.WriteString("for (;;) "); OPC.BegBlk; stat(n^.left, outerProc); OPC.EndBlk; - IF exit.label # -1 THEN - OPC.BegStat; OPM.WriteString("exit__"); OPM.WriteInt(exit.label); OPM.Write(":"); OPC.EndStat - END ; - exit := saved - | Nexit: - IF exit.level = 0 THEN OPM.WriteString(Break) - ELSE - IF exit.label = -1 THEN exit.label := nofExitLabels; INC(nofExitLabels) END ; - OPM.WriteString("goto exit__"); OPM.WriteInt(exit.label) - END - | Nreturn: - IF OPM.level = 0 THEN - IF mainprog THEN OPM.WriteString("__FINI") ELSE OPM.WriteString("__ENDMOD") END - ELSE - IF n^.left # NIL THEN - (* Make local copy of result before ExitProc deletes dynamic vars *) - OPM.WriteString("_o_result = "); - IF (n^.left^.typ^.form = Pointer) & (n^.obj^.typ # n^.left^.typ) THEN - OPM.WriteString("(void*)"); expr(n^.left, 10) - ELSE - expr(n^.left, MinPrec) - END; - OPM.WriteString(";"); OPM.WriteLn; OPC.BegStat; - OPC.ExitProc(outerProc, FALSE, FALSE); - OPM.WriteString("return _o_result"); - ELSE - OPM.WriteString("return"); - END - END - | Nwith: - IfStat(n, n^.subcl = 0, outerProc) - | Ntrap: - OPC.Halt(n^.right^.conval^.intval) - ELSE - (* this else is necessary cause - it can happen that - n^.class is something which is not handled, - like Nconst (7) - which I actually experienced - when compiling Texts0.Mod on raspberry pi - it generates __CASECHK and cause Halt, - noch *) - OPM.LogWStr("unhandled case in OPV.expr, n^.class = "); OPM.LogWNum(n^.class, 0); OPM.LogWLn; - END ; - IF ~(n^.class IN {Nenter, Ninittd, Nifelse, Nwith, Ncase, Nwhile, Nloop}) THEN OPC.EndStat END ; + | OPT.Nenter: IF n^.obj = NIL THEN (* enter module *) + INC(OPM.level); stat(n^.left, outerProc); DEC(OPM.level); + OPC.GenEnumPtrs(OPT.topScope^.scope); + DefineTDescs(n^.right); OPC.EnterBody; InitTDescs(n^.right); + OPM.WriteString("/* BEGIN */"); OPM.WriteLn; + stat(n^.right, outerProc); OPC.ExitBody + ELSE (* enter proc *) + proc := n^.obj; + OPC.TypeDefs(proc^.scope^.right, 0); + IF ~proc^.scope^.leaf THEN OPC.DefineInter (proc) END ; (* define intermediate procedure scope *) + INC(OPM.level); stat(n^.left, proc); DEC(OPM.level); + OPC.EnterProc(proc); stat(n^.right, proc); + OPC.ExitProc(proc, TRUE, ImplicitReturn(n^.right)); + END + | OPT.Ninittd: (* done in enter module *) + | OPT.Nassign: CASE n^.subcl OF + | OPT.assign: l := n^.left; r := n^.right; + IF l^.typ^.comp = OPT.Array THEN (* includes string assignment but not COPY *) + OPM.WriteString(MoveFunc); + expr(r, MinPrec); OPM.WriteString(Comma); expr(l, MinPrec); OPM.WriteString(Comma); + IF r^.typ = OPT.stringtyp THEN OPM.WriteInt(r^.conval^.intval2) + ELSE OPM.WriteInt(r^.typ^.size) + END ; + OPM.Write(CloseParen) + ELSE + IF (l^.typ^.form = OPT.Pointer) & (l^.obj # NIL) & (l^.obj^.adr = 1) & (l^.obj^.mode = OPT.Var) THEN + l^.obj^.adr := 0; design(l, MinPrec); l^.obj^.adr := 1; (* avoid cast of WITH-variable *) + IF r^.typ^.form # OPT.NilTyp THEN OPM.WriteString(" = (void*)") + ELSE OPM.WriteString(" = ") + END + ELSE + design(l, MinPrec); OPM.WriteString(" = ") + END ; + IF l^.typ = r^.typ THEN expr(r, MinPrec) + ELSIF (l^.typ^.form = OPT.Pointer) & (r^.typ^.form # OPT.NilTyp) & (l^.typ^.strobj # NIL) THEN + OPM.Write("("); OPC.Ident(l^.typ^.strobj); OPM.Write(")"); expr(r, MinPrec) + ELSIF l^.typ^.comp = OPT.Record THEN + OPM.WriteString("*("); OPC.Andent(l^.typ); OPM.WriteString("*)&"); expr(r, 9) + ELSE expr(r, MinPrec) + END + END + | OPT.newfn: IF n^.left^.typ^.BaseTyp^.comp = OPT.Record THEN + OPM.WriteString("__NEW("); design(n^.left, MinPrec); OPM.WriteString(", "); + OPC.Andent(n^.left^.typ^.BaseTyp); OPM.WriteString(")") + ELSIF n^.left^.typ^.BaseTyp^.comp IN {OPT.Array, OPT.DynArr} THEN + NewArr(n^.left, n^.right) + END + | OPT.incfn, + OPT.decfn: expr(n^.left, MinPrec); OPC.Increment(n^.subcl = OPT.decfn); expr(n^.right, MinPrec) + | OPT.inclfn, + OPT.exclfn: expr(n^.left, MinPrec); OPC.SetInclude(n^.subcl = OPT.exclfn); OPM.WriteString(SetOfFunc); expr(n^.right, MinPrec); + OPM.Write(CloseParen) + | OPT.copyfn: OPM.WriteString(CopyFunc); + expr(n^.right, MinPrec); OPM.WriteString(Comma); expr(n^.left, MinPrec); OPM.WriteString(Comma); + Len(n^.left, 0); OPM.Write(CloseParen) + | OPT.movefn: (*SYSTEM*) + OPM.WriteString(MoveFunc); + expr(n^.right, MinPrec); OPM.WriteString(Comma); expr(n^.left, MinPrec); OPM.WriteString(Comma); + expr(n^.right^.link, MinPrec); + OPM.Write(CloseParen) + | OPT.getfn: (*SYSTEM*) + OPM.WriteString(GetFunc); expr(n^.right, MinPrec); OPM.WriteString(Comma); expr(n^.left, MinPrec); + OPM.WriteString(Comma); OPC.Ident(n^.left^.typ^.strobj); OPM.Write(CloseParen) + | OPT.putfn: (*SYSTEM*) + OPM.WriteString(PutFunc); expr(n^.left, MinPrec); OPM.WriteString(Comma); expr(n^.right, MinPrec); + OPM.WriteString(Comma); OPC.Ident(n^.right^.typ^.strobj); OPM.Write(CloseParen) + | OPT.getrfn, (*SYSTEM*) + OPT.putrfn: (*SYSTEM*) OPM.err(200) + | OPT.sysnewfn: (*SYSTEM*) + OPM.WriteString("__SYSNEW("); + design(n^.left, MinPrec); OPM.WriteString(", "); + expr(n^.right, MinPrec); + OPM.Write(")") + ELSE OPM.LogWStr("unhandled case in OPV.expr, n^.subcl = "); OPM.LogWNum(n^.subcl, 0); OPM.LogWLn; + END + | OPT.Ncall: IF (n^.left^.obj # NIL) & (n^.left^.obj^.mode = OPT.TProc) THEN + IF n^.left^.subcl = OPT.super THEN proc := SuperProc(n) + ELSE OPM.WriteString("__"); proc := OPC.BaseTProc(n^.left^.obj) + END ; + OPC.Ident(proc); + n^.obj := proc^.link + ELSIF n^.left^.class = OPT.Nproc THEN design(n^.left, 10) + ELSE design(n^.left, ProcTypeVar) + END ; + ActualPar(n^.right, n^.obj) + | OPT.Nifelse: IF n^.subcl # OPT.assertfn THEN IfStat(n, FALSE, outerProc) + ELSIF assert THEN OPM.WriteString("__ASSERT("); expr(n^.left^.left^.left, MinPrec); OPM.WriteString(Comma); + OPM.WriteInt(n^.left^.right^.right^.conval^.intval); OPM.Write(CloseParen); OPC.EndStat + END + | OPT.Ncase: INC(exit.level); CaseStat(n, outerProc); DEC(exit.level) + | OPT.Nwhile: INC(exit.level); OPM.WriteString("while "); expr(n^.left, MaxPrec); + OPM.Write(Blank); OPC.BegBlk; stat(n^.right, outerProc); OPC.EndBlk; + DEC(exit.level) + | OPT.Nrepeat: INC(exit.level); OPM.WriteString("do "); OPC.BegBlk; stat(n^.left, outerProc); OPC.EndBlk0; + OPM.WriteString(" while (!"); expr(n^.right, 9); OPM.Write(CloseParen); + DEC(exit.level) + | OPT.Nloop: saved := exit; exit.level := 0; exit.label := -1; + OPM.WriteString("for (;;) "); OPC.BegBlk; stat(n^.left, outerProc); OPC.EndBlk; + IF exit.label # -1 THEN + OPC.BegStat; OPM.WriteString("exit__"); OPM.WriteInt(exit.label); OPM.Write(":"); OPC.EndStat + END ; + exit := saved + | OPT.Nexit: IF exit.level = 0 THEN OPM.WriteString(Break) + ELSE + IF exit.label = -1 THEN exit.label := nofExitLabels; INC(nofExitLabels) END ; + OPM.WriteString("goto exit__"); OPM.WriteInt(exit.label) + END + | OPT.Nreturn: IF OPM.level = 0 THEN + IF mainprog THEN OPM.WriteString("__FINI") ELSE OPM.WriteString("__ENDMOD") END + ELSE + IF n^.left # NIL THEN + (* Make local copy of result before ExitProc deletes dynamic vars *) + OPM.WriteString("_o_result = "); + IF (n^.left^.typ^.form = OPT.Pointer) & (n^.obj^.typ # n^.left^.typ) THEN + OPM.WriteString("(void*)"); expr(n^.left, 10) + ELSE + expr(n^.left, MinPrec) + END; + OPM.WriteString(";"); OPM.WriteLn; OPC.BegStat; + OPC.ExitProc(outerProc, FALSE, FALSE); + OPM.WriteString("return _o_result"); + ELSE + OPM.WriteString("return"); + END + END + | OPT.Nwith: IfStat(n, n^.subcl = 0, outerProc) + | OPT.Ntrap: OPC.Halt(n^.right^.conval^.intval) + ELSE OPM.LogWStr("unhandled case in OPV.expr, n^.class = "); OPM.LogWNum(n^.class, 0); OPM.LogWLn; + END; + IF ~(n^.class IN {OPT.Nenter, OPT.Ninittd, OPT.Nifelse, OPT.Nwith, OPT.Ncase, OPT.Nwhile, OPT.Nloop}) THEN OPC.EndStat END ; n := n^.link END END stat; diff --git a/src/compiler/errors.Mod b/src/compiler/errors.Mod index 02d6b84a..1546aa8c 100644 --- a/src/compiler/errors.Mod +++ b/src/compiler/errors.Mod @@ -188,6 +188,7 @@ errors[245] := "guarded pointer variable may be manipulated by non-local operati errors[301] := "implicit type cast"; errors[306] := "inappropriate symbol file ignored"; errors[307] := "no ELSE symbol after CASE statement sequence may lead to trap"; (* new warning, -- noch *) +errors[308] := "SYSTEM.VAL result includes memory past end of source variable"; (* DCWB *) END errors. (* @@ -196,8 +197,8 @@ Run-time Error Messages 0 silent HALT(0) 1..255 HALT(n), cf. SYSTEM_halt -1 assertion failed, cf. SYSTEM_assert - -2 invalid array index - -3 function procedure without RETURN statement + -2 invalid array index + -3 function procedure without RETURN statement -4 invalid case in CASE statement -5 type guard failed -6 implicit type guard in record assignment failed diff --git a/src/system/Files.Mod b/src/system/Files.Mod index 02bc69fc..7aeee5ac 100644 --- a/src/system/Files.Mod +++ b/src/system/Files.Mod @@ -615,9 +615,12 @@ Especially Length would become fairly complex. END ReadLInt; PROCEDURE ReadSet* (VAR R: Rider; VAR x: SET); - VAR b: ARRAY 4 OF CHAR; + (* Reads 32 bits as a SET value (even on 64 bit systems. See Oakwood appendix 1.2.5.4 *) + VAR b: ARRAY 4 OF CHAR; l: LONGINT; BEGIN ReadBytes(R, b, 4); - x := SYSTEM.VAL(SET, ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H) + (* Need to read via a LONGINT to provide correct behaviour for 64 bit sets. *) + l := ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H; + x := SYSTEM.VAL(SET, l) END ReadSet; PROCEDURE ReadReal* (VAR R: Rider; VAR x: REAL); diff --git a/src/system/Heap.Mod b/src/system/Heap.Mod index 73534c46..6395c0a7 100644 --- a/src/system/Heap.Mod +++ b/src/system/Heap.Mod @@ -186,7 +186,7 @@ MODULE Heap; correctly regardless of the size of an address. Specifically on 32 bit address architectures with 64 bit LONGINT, it loads 32 bits and extends it to LONGINT rather than loading 64 bits. *) - PROCEDURE -FetchAddress(pointer: LONGINT): LONGINT "(LONGINT)(uintptr_t)(*((void**)((uintptr_t)pointer)))"; + PROCEDURE -FetchAddress(pointer: LONGINT): LONGINT "(LONGINT)(SYSTEM_ADDRESS)(*((void**)((SYSTEM_ADDRESS)pointer)))"; PROCEDURE ExtendHeap(blksz: LONGINT); VAR size, chnk, j, next: LONGINT; diff --git a/src/system/Platformunix.Mod b/src/system/Platformunix.Mod index 6da2b7d7..1c2da65d 100644 --- a/src/system/Platformunix.Mod +++ b/src/system/Platformunix.Mod @@ -106,10 +106,10 @@ BEGIN RETURN (e = ECONNREFUSED()) OR (e = ECONNABORTED()) (* OS memory allocaton *) -PROCEDURE -allocate(size: LONGINT): LONGINT "(LONGINT)(uintptr_t)((void*)malloc((size_t)size))"; +PROCEDURE -allocate(size: LONGINT): LONGINT "(LONGINT)(SYSTEM_ADDRESS)((void*)malloc((size_t)size))"; PROCEDURE OSAllocate*(size: LONGINT): LONGINT; BEGIN RETURN allocate(size) END OSAllocate; -PROCEDURE -free(address: LONGINT) "free((void*)(uintptr_t)address)"; +PROCEDURE -free(address: LONGINT) "free((void*)(SYSTEM_ADDRESS)address)"; PROCEDURE OSFree*(address: LONGINT); BEGIN free(address) END OSFree; @@ -189,7 +189,7 @@ END ArgPos; (* Signals and traps *) -PROCEDURE -sethandler(s: INTEGER; h: SignalHandler) "SystemSetHandler(s, (uintptr_t)h)"; +PROCEDURE -sethandler(s: INTEGER; h: SignalHandler) "SystemSetHandler(s, (SYSTEM_ADDRESS)h)"; PROCEDURE SetInterruptHandler*(handler: SignalHandler); BEGIN sethandler(2, handler); END SetInterruptHandler; @@ -369,7 +369,7 @@ END Size; PROCEDURE -readfile (fd: LONGINT; p: LONGINT; l: LONGINT): LONGINT -"read(fd, (void*)(uintptr_t)(p), l)"; +"read(fd, (void*)(SYSTEM_ADDRESS)(p), l)"; PROCEDURE Read*(h: FileHandle; p: LONGINT; l: LONGINT; VAR n: LONGINT): ErrorCode; BEGIN @@ -386,7 +386,7 @@ END ReadBuf; PROCEDURE -writefile(fd: LONGINT; p: LONGINT; l: LONGINT): LONGINT -"write(fd, (void*)(uintptr_t)(p), l)"; +"write(fd, (void*)(SYSTEM_ADDRESS)(p), l)"; PROCEDURE Write*(h: FileHandle; p: LONGINT; l: LONGINT): ErrorCode; VAR written: LONGINT; diff --git a/src/system/Platformwindows.Mod b/src/system/Platformwindows.Mod index 0e30e3f9..a97d7da9 100644 --- a/src/system/Platformwindows.Mod +++ b/src/system/Platformwindows.Mod @@ -104,10 +104,10 @@ BEGIN RETURN (e = ECONNREFUSED()) OR (e = ECONNABORTED()) (* OS memory allocaton *) -PROCEDURE -allocate(size: LONGINT): LONGINT "(LONGINT)(uintptr_t)((void*)HeapAlloc(GetProcessHeap(), 0, (size_t)size))"; +PROCEDURE -allocate(size: LONGINT): LONGINT "(LONGINT)(SYSTEM_ADDRESS)((void*)HeapAlloc(GetProcessHeap(), 0, (size_t)size))"; PROCEDURE OSAllocate*(size: LONGINT): LONGINT; BEGIN RETURN allocate(size) END OSAllocate; -PROCEDURE -free(address: LONGINT) "HeapFree(GetProcessHeap(), 0, (void*)(uintptr_t)address)"; +PROCEDURE -free(address: LONGINT) "HeapFree(GetProcessHeap(), 0, (void*)(SYSTEM_ADDRESS)address)"; PROCEDURE OSFree*(address: LONGINT); BEGIN free(address) END OSFree; @@ -200,8 +200,8 @@ END ArgPos; (* Ctrl/c handling *) -PROCEDURE -SetInterruptHandler*(h: SignalHandler) "SystemSetInterruptHandler((uintptr_t)h)"; -PROCEDURE -SetQuitHandler* (h: SignalHandler) "SystemSetQuitHandler((uintptr_t)h)"; +PROCEDURE -SetInterruptHandler*(h: SignalHandler) "SystemSetInterruptHandler((SYSTEM_ADDRESS)h)"; +PROCEDURE -SetQuitHandler* (h: SignalHandler) "SystemSetQuitHandler((SYSTEM_ADDRESS)h)"; PROCEDURE SetBadInstructionHandler*(handler: SignalHandler); BEGIN (* TODO *) END SetBadInstructionHandler; @@ -232,7 +232,7 @@ BEGIN YMDHMStoClock(styear(), stmon(), stmday(), sthour(), stmin(), stsec(), t, d); END GetClock; -PROCEDURE -GetTickCount(): LONGINT "(LONGINT)(uint32_t)GetTickCount()"; +PROCEDURE -GetTickCount(): LONGINT "(LONGINT)(SYSTEM_CARD32)GetTickCount()"; PROCEDURE Time*(): LONGINT; VAR ms: LONGINT; @@ -293,16 +293,16 @@ PROCEDURE Error*(): ErrorCode; BEGIN RETURN err() END Error; (* File system *) -PROCEDURE -invalidHandleValue(): LONGINT "((LONGINT)(uintptr_t)INVALID_HANDLE_VALUE)"; +PROCEDURE -invalidHandleValue(): LONGINT "((LONGINT)(SYSTEM_ADDRESS)INVALID_HANDLE_VALUE)"; PROCEDURE -openrw (n: ARRAY OF CHAR): LONGINT -"(LONGINT)(uintptr_t)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)"; +"(LONGINT)(SYSTEM_ADDRESS)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)"; PROCEDURE -openro (n: ARRAY OF CHAR): LONGINT -"(LONGINT)(uintptr_t)CreateFile((char*)n, GENERIC_READ , FILE_SHARE_READ|FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)"; +"(LONGINT)(SYSTEM_ADDRESS)CreateFile((char*)n, GENERIC_READ , FILE_SHARE_READ|FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)"; PROCEDURE -opennew(n: ARRAY OF CHAR): LONGINT -"(LONGINT)(uintptr_t)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)"; +"(LONGINT)(SYSTEM_ADDRESS)CreateFile((char*)n, GENERIC_READ|GENERIC_WRITE, FILE_SHARE_READ|FILE_SHARE_WRITE, 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)"; @@ -332,7 +332,7 @@ END New; -PROCEDURE -closeHandle(h: FileHandle): INTEGER "(INTEGER)CloseHandle((HANDLE)(uintptr_t)h)"; +PROCEDURE -closeHandle(h: FileHandle): INTEGER "(INTEGER)CloseHandle((HANDLE)(SYSTEM_ADDRESS)h)"; PROCEDURE Close*(h: FileHandle): ErrorCode; BEGIN @@ -342,7 +342,7 @@ END Close; PROCEDURE -byHandleFileInformation "BY_HANDLE_FILE_INFORMATION bhfi"; -PROCEDURE -getFileInformationByHandle(h: FileHandle): INTEGER "(INTEGER)GetFileInformationByHandle((HANDLE)(uintptr_t)h, &bhfi)"; +PROCEDURE -getFileInformationByHandle(h: FileHandle): INTEGER "(INTEGER)GetFileInformationByHandle((HANDLE)(SYSTEM_ADDRESS)h, &bhfi)"; PROCEDURE -bhfiMtimeHigh(): LONGINT "(LONGINT)bhfi.ftLastWriteTime.dwHighDateTime"; PROCEDURE -bhfiMtimeLow(): LONGINT "(LONGINT)bhfi.ftLastWriteTime.dwLowDateTime"; PROCEDURE -bhfiVsn(): LONGINT "(LONGINT)bhfi.dwVolumeSerialNumber"; @@ -401,7 +401,7 @@ END MTimeAsClock; PROCEDURE -largeInteger "LARGE_INTEGER li"; PROCEDURE -liLongint(): LONGINT "(LONGINT)li.QuadPart"; -PROCEDURE -getFileSize(h: FileHandle): INTEGER "(INTEGER)GetFileSizeEx((HANDLE)(uintptr_t)h, &li)"; +PROCEDURE -getFileSize(h: FileHandle): INTEGER "(INTEGER)GetFileSizeEx((HANDLE)(SYSTEM_ADDRESS)h, &li)"; PROCEDURE Size*(h: FileHandle; VAR l: LONGINT): ErrorCode; BEGIN @@ -413,7 +413,7 @@ END Size; PROCEDURE -readfile (fd: LONGINT; p: LONGINT; l: LONGINT; VAR n: LONGINT): INTEGER -"(INTEGER)ReadFile ((HANDLE)(uintptr_t)fd, (void*)(uintptr_t)(p), (DWORD)l, (DWORD*)n, 0)"; +"(INTEGER)ReadFile ((HANDLE)(SYSTEM_ADDRESS)fd, (void*)(SYSTEM_ADDRESS)(p), (DWORD)l, (DWORD*)n, 0)"; PROCEDURE Read*(h: FileHandle; p: LONGINT; l: LONGINT; VAR n: LONGINT): ErrorCode; VAR result: INTEGER; @@ -434,7 +434,7 @@ END ReadBuf; PROCEDURE -writefile(fd: LONGINT; p: LONGINT; l: LONGINT): INTEGER -"(INTEGER)WriteFile((HANDLE)(uintptr_t)fd, (void*)(uintptr_t)(p), (DWORD)l, 0,0)"; +"(INTEGER)WriteFile((HANDLE)(SYSTEM_ADDRESS)fd, (void*)(SYSTEM_ADDRESS)(p), (DWORD)l, 0,0)"; PROCEDURE Write*(h: FileHandle; p: LONGINT; l: LONGINT): ErrorCode; BEGIN @@ -443,7 +443,7 @@ END Write; -PROCEDURE -flushFileBuffers(h: FileHandle): INTEGER "(INTEGER)FlushFileBuffers((HANDLE)(uintptr_t)h)"; +PROCEDURE -flushFileBuffers(h: FileHandle): INTEGER "(INTEGER)FlushFileBuffers((HANDLE)(SYSTEM_ADDRESS)h)"; PROCEDURE Sync*(h: FileHandle): ErrorCode; BEGIN @@ -453,7 +453,7 @@ END Sync; PROCEDURE -setFilePointerEx(h: FileHandle; o: LONGINT; r: INTEGER; VAR rc: INTEGER) -"li.QuadPart=o; *rc = (INTEGER)SetFilePointerEx((HANDLE)(uintptr_t)h, li, 0, (DWORD)r)"; +"li.QuadPart=o; *rc = (INTEGER)SetFilePointerEx((HANDLE)(SYSTEM_ADDRESS)h, li, 0, (DWORD)r)"; PROCEDURE -seekset(): INTEGER "FILE_BEGIN"; PROCEDURE -seekcur(): INTEGER "FILE_CURRENT"; @@ -469,9 +469,9 @@ END Seek; -PROCEDURE -setEndOfFile(h: FileHandle): INTEGER "(INTEGER)SetEndOfFile((HANDLE)(uintptr_t)h)"; +PROCEDURE -setEndOfFile(h: FileHandle): INTEGER "(INTEGER)SetEndOfFile((HANDLE)(SYSTEM_ADDRESS)h)"; PROCEDURE -getFilePos(h: FileHandle; VAR r: LONGINT; VAR rc: INTEGER) -"LARGE_INTEGER liz = {0}; *rc = (INTEGER)SetFilePointerEx((HANDLE)(uintptr_t)h, liz, &li, FILE_CURRENT); *r = (LONGINT)li.QuadPart"; +"LARGE_INTEGER liz = {0}; *rc = (INTEGER)SetFilePointerEx((HANDLE)(SYSTEM_ADDRESS)h, liz, &li, FILE_CURRENT); *r = (LONGINT)li.QuadPart"; PROCEDURE Truncate*(h: FileHandle; limit: LONGINT): ErrorCode; VAR rc: INTEGER; oldpos: LONGINT; @@ -529,8 +529,8 @@ PROCEDURE Exit*(code: INTEGER); BEGIN exit(code) END Exit; -PROCEDURE -errstring(s: ARRAY OF CHAR) 'WriteFile((HANDLE)(uintptr_t)Platform_StdOut, s, s__len-1, 0,0)'; -PROCEDURE -errc (c: CHAR) 'WriteFile((HANDLE)(uintptr_t)Platform_StdOut, &c, 1, 0,0)'; +PROCEDURE -errstring(s: ARRAY OF CHAR) 'WriteFile((HANDLE)(SYSTEM_ADDRESS)Platform_StdOut, s, s__len-1, 0,0)'; +PROCEDURE -errc (c: CHAR) 'WriteFile((HANDLE)(SYSTEM_ADDRESS)Platform_StdOut, &c, 1, 0,0)'; PROCEDURE errch(c: CHAR); BEGIN errc(c) END errch; PROCEDURE errln; BEGIN errch(0DX); errch(0AX) END errln; @@ -589,9 +589,9 @@ PROCEDURE TestLittleEndian; BEGIN i := 1; SYSTEM.GET(SYSTEM.ADR(i), LittleEndian); END TestLittleEndian; -PROCEDURE -getstdinhandle(): FileHandle "(uintptr_t)GetStdHandle(STD_INPUT_HANDLE)"; -PROCEDURE -getstdouthandle(): FileHandle "(uintptr_t)GetStdHandle(STD_OUTPUT_HANDLE)"; -PROCEDURE -getstderrhandle(): FileHandle "(uintptr_t)GetStdHandle(STD_ERROR_HANDLE)"; +PROCEDURE -getstdinhandle(): FileHandle "(SYSTEM_ADDRESS)GetStdHandle(STD_INPUT_HANDLE)"; +PROCEDURE -getstdouthandle(): FileHandle "(SYSTEM_ADDRESS)GetStdHandle(STD_OUTPUT_HANDLE)"; +PROCEDURE -getstderrhandle(): FileHandle "(SYSTEM_ADDRESS)GetStdHandle(STD_ERROR_HANDLE)"; PROCEDURE -getpid(): INTEGER "(INTEGER)GetCurrentProcessId()"; BEGIN diff --git a/src/system/SYSTEM.c b/src/system/SYSTEM.c index 50e91c6d..33511a70 100644 --- a/src/system/SYSTEM.c +++ b/src/system/SYSTEM.c @@ -35,7 +35,7 @@ void SYSTEM_INHERIT(LONGINT *t, LONGINT *t0) void SYSTEM_ENUMP(void *adr, LONGINT n, void (*P)()) { while (n > 0) { - P((LONGINT)(uintptr_t)(*((void**)(adr)))); + P((LONGINT)(SYSTEM_ADDRESS)(*((void**)(adr)))); adr = ((void**)adr) + 1; n--; } @@ -106,7 +106,7 @@ SYSTEM_PTR SYSTEM_NEWARR(LONGINT *typ, LONGINT elemsz, int elemalgn, int nofdim, else if (typ == (LONGINT*)POINTER__typ) { /* element type is a pointer */ x = Heap_NEWBLK(size + nofelems * sizeof(LONGINT)); - p = (LONGINT*)(uintptr_t)x[-1]; + p = (LONGINT*)(SYSTEM_ADDRESS)x[-1]; p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */ while (n <= nofelems) {*p = n*sizeof(LONGINT); p++; n++;} @@ -119,7 +119,7 @@ SYSTEM_PTR SYSTEM_NEWARR(LONGINT *typ, LONGINT elemsz, int elemalgn, int nofdim, while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */ nptr = nofelems * nofptrs; /* total number of pointers */ x = Heap_NEWBLK(size + nptr * sizeof(LONGINT)); - p = (LONGINT*)(uintptr_t)x[- 1]; + p = (LONGINT*)(SYSTEM_ADDRESS)x[- 1]; p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */ p -= nptr - 1; n = 0; off = dataoff; while (n < nofelems) {i = 0; @@ -155,7 +155,7 @@ typedef void (*SystemSignalHandler)(INTEGER); // = Platform_SignalHandler // (Ignore other signals) } - void SystemSetHandler(int s, uintptr_t h) { + void SystemSetHandler(int s, SYSTEM_ADDRESS h) { if (s >= 2 && s <= 4) { int needtosetsystemhandler = handler[s-2] == 0; handler[s-2] = (SystemSignalHandler)h; @@ -194,12 +194,12 @@ typedef void (*SystemSignalHandler)(INTEGER); // = Platform_SignalHandler } } - void SystemSetInterruptHandler(uintptr_t h) { + void SystemSetInterruptHandler(SYSTEM_ADDRESS h) { EnsureConsoleCtrlHandler(); SystemInterruptHandler = (SystemSignalHandler)h; } - void SystemSetQuitHandler(uintptr_t h) { + void SystemSetQuitHandler(SYSTEM_ADDRESS h) { EnsureConsoleCtrlHandler(); SystemQuitHandler = (SystemSignalHandler)h; } diff --git a/src/system/SYSTEM.h b/src/system/SYSTEM.h index 949951ac..6377745e 100644 --- a/src/system/SYSTEM.h +++ b/src/system/SYSTEM.h @@ -1,28 +1,38 @@ #ifndef SYSTEM__h #define SYSTEM__h -#ifndef _WIN32 - - // Building for a Unix/Linux based system - #include // For memcpy ... - #include // For uintptr_t ... - +#if defined(_WIN64) + typedef long long SYSTEM_INT64; + typedef unsigned long long SYSTEM_CARD64; #else - - // Building for Windows platform with either mingw under cygwin, or the MS C compiler - #ifdef _WIN64 - typedef unsigned long long size_t; - typedef unsigned long long uintptr_t; - #else - typedef unsigned int size_t; - typedef unsigned int uintptr_t; - #endif /* _WIN64 */ - - typedef unsigned int uint32_t; - void * __cdecl memcpy(void * dest, const void * source, size_t size); - + typedef long SYSTEM_INT64; + typedef unsigned long SYSTEM_CARD64; #endif +typedef int SYSTEM_INT32; +typedef unsigned int SYSTEM_CARD32; +typedef short int SYSTEM_INT16; +typedef unsigned short int SYSTEM_CARD16; +typedef signed char SYSTEM_INT8; +typedef unsigned char SYSTEM_CARD8; + +#if (__SIZEOF_POINTER__ == 8) || defined(_WIN64) || defined(__LP64__) + #if defined(_WIN64) + typedef unsigned long long size_t; + #else + typedef unsigned long size_t; + #endif +#else + typedef unsigned int size_t; +#endif + +#define SYSTEM_ADDRESS size_t +#define _SIZE_T_DECLARED // For FreeBSD +#define _SIZE_T_DEFINED_ // For OpenBSD + +void *memcpy(void *dest, const void *source, SYSTEM_ADDRESS size); + + // The compiler uses 'import' and 'export' which translate to 'extern' and // nothing respectively. @@ -70,6 +80,7 @@ typedef unsigned char U_SHORTINT; #endif typedef U_LONGINT SET; +typedef U_LONGINT U_SET; // OS Memory allocation interfaces are in PlatformXXX.Mod @@ -96,10 +107,10 @@ extern LONGINT SYSTEM_ENTIER (double x); // Signal handling in SYSTEM.c #ifndef _WIN32 - extern void SystemSetHandler(int s, uintptr_t h); + extern void SystemSetHandler(int s, SYSTEM_ADDRESS h); #else - extern void SystemSetInterruptHandler(uintptr_t h); - extern void SystemSetQuitHandler (uintptr_t h); + extern void SystemSetInterruptHandler(SYSTEM_ADDRESS h); + extern void SystemSetQuitHandler (SYSTEM_ADDRESS h); #endif @@ -122,20 +133,20 @@ static int __str_cmp(CHAR *x, CHAR *y){ #define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d; LONGINT _i=0,_t=n-1; \ while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;} -#define __DUP(x, l, t) x=(void*)memcpy((void*)(uintptr_t)Platform_OSAllocate(l*sizeof(t)),x,l*sizeof(t)) +#define __DUP(x, l, t) x=(void*)memcpy((void*)(SYSTEM_ADDRESS)Platform_OSAllocate(l*sizeof(t)),x,l*sizeof(t)) #define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t)) -#define __DEL(x) Platform_OSFree((LONGINT)(uintptr_t)x) +#define __DEL(x) Platform_OSFree((LONGINT)(SYSTEM_ADDRESS)x) /* SYSTEM ops */ -#define __VAL(t, x) ((t)(x)) -#define __VALP(t, x) ((t)(uintptr_t)(x)) +#define __VAL(t, x) (*(t*)&(x)) -#define __GET(a, x, t) x= *(t*)(uintptr_t)(a) -#define __PUT(a, x, t) *(t*)(uintptr_t)(a)=x + +#define __GET(a, x, t) x= *(t*)(SYSTEM_ADDRESS)(a) +#define __PUT(a, x, t) *(t*)(SYSTEM_ADDRESS)(a)=x #define __LSHL(x, n, t) ((t)((U_##t)(x)<<(n))) #define __LSHR(x, n, t) ((t)((U_##t)(x)>>(n))) @@ -150,7 +161,7 @@ static int __str_cmp(CHAR *x, CHAR *y){ #define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t)) #define __BIT(x, n) (*(U_LONGINT*)(x)>>(n)&1) -#define __MOVE(s, d, n) memcpy((char*)(uintptr_t)(d),(char*)(uintptr_t)(s),n) +#define __MOVE(s, d, n) memcpy((char*)(SYSTEM_ADDRESS)(d),(char*)(SYSTEM_ADDRESS)(s),n) #define __ASHF(x, n) SYSTEM_ASH((LONGINT)(x), (LONGINT)(n)) #define __SHORT(x, y) ((int)((U_LONGINT)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0))) #define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y))) @@ -211,7 +222,7 @@ extern void Heap_INCREF(); extern void Platform_Init(INTEGER argc, LONGINT argv); extern void Heap_FINALL(); -#define __INIT(argc, argv) static void *m; Platform_Init((INTEGER)argc, (LONGINT)(uintptr_t)&argv); +#define __INIT(argc, argv) static void *m; Platform_Init((INTEGER)argc, (LONGINT)(SYSTEM_ADDRESS)&argv); #define __REGMAIN(name, enum) m = Heap_REGMOD((CHAR*)name,enum) #define __FINI Heap_FINALL(); return 0 @@ -232,7 +243,7 @@ extern SYSTEM_PTR Heap_NEWREC (LONGINT tag); extern SYSTEM_PTR SYSTEM_NEWARR(LONGINT*, LONGINT, int, int, int, ...); #define __SYSNEW(p, len) p = Heap_NEWBLK((LONGINT)(len)) -#define __NEW(p, t) p = Heap_NEWREC((LONGINT)(uintptr_t)t##__typ) +#define __NEW(p, t) p = Heap_NEWREC((LONGINT)(SYSTEM_ADDRESS)t##__typ) #define __NEWARR SYSTEM_NEWARR @@ -263,20 +274,20 @@ extern SYSTEM_PTR SYSTEM_NEWARR(LONGINT*, LONGINT, int, int, int, ...); #define __INITYP(t, t0, level) \ t##__typ = (LONGINT*)&t##__desc.blksz; \ memcpy(t##__desc.basep, t0##__typ - __BASEOFF, level*sizeof(LONGINT)); \ - t##__desc.basep[level] = (LONGINT)(uintptr_t)t##__typ; \ - t##__desc.module = (LONGINT)(uintptr_t)m; \ + t##__desc.basep[level] = (LONGINT)(SYSTEM_ADDRESS)t##__typ; \ + t##__desc.module = (LONGINT)(SYSTEM_ADDRESS)m; \ if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \ t##__desc.blksz = (t##__desc.blksz+5*sizeof(LONGINT)-1)/(4*sizeof(LONGINT))*(4*sizeof(LONGINT)); \ - Heap_REGTYP(m, (LONGINT)(uintptr_t)&t##__desc.next); \ + Heap_REGTYP(m, (LONGINT)(SYSTEM_ADDRESS)&t##__desc.next); \ SYSTEM_INHERIT(t##__typ, t0##__typ) -#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(LONGINT)(uintptr_t)typ##__typ) -#define __TYPEOF(p) ((LONGINT*)(uintptr_t)(*(((LONGINT*)(p))-1))) +#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(LONGINT)(SYSTEM_ADDRESS)typ##__typ) +#define __TYPEOF(p) ((LONGINT*)(SYSTEM_ADDRESS)(*(((LONGINT*)(p))-1))) #define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) // Oberon-2 type bound procedures support -#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(LONGINT)(uintptr_t)proc -#define __SEND(typ, num, funtyp, parlist) ((funtyp)((uintptr_t)*(typ-(__TPROC0OFF+num))))parlist +#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(LONGINT)(SYSTEM_ADDRESS)proc +#define __SEND(typ, num, funtyp, parlist) ((funtyp)((SYSTEM_ADDRESS)*(typ-(__TPROC0OFF+num))))parlist diff --git a/src/test/events/clb.Mod b/src/test/events/clb.Mod index 218b82b7..a414cc44 100644 --- a/src/test/events/clb.Mod +++ b/src/test/events/clb.Mod @@ -2,54 +2,43 @@ MODULE clb; IMPORT Console; -TYPE OnSomething = PROCEDURE (x, y : INTEGER); - -PROCEDURE ProcessEvents(x, y : INTEGER; onsomething : OnSomething); +TYPE OnSomething = PROCEDURE (x, y: INTEGER); +PROCEDURE ProcessEvents(x, y: INTEGER; onsomething: OnSomething); BEGIN - -IF onsomething # NIL THEN onsomething(x, y) -ELSE - Console.String("didn't happen"); Console.Ln -END; - + IF onsomething # NIL THEN + onsomething(x, y) + ELSE + Console.String("didn't happen"); Console.Ln + END END ProcessEvents; PROCEDURE OnEvent(x, y : INTEGER); - BEGIN - -Console.String("event happened"); Console.Ln - + Console.String("event happened"); Console.Ln END OnEvent; PROCEDURE OnEvent2(x, y : INTEGER); - BEGIN - -Console.String("happened"); Console.Ln - + Console.String("event 2 happened"); Console.Ln END OnEvent2; PROCEDURE Something; -VAR onsmth : OnSomething; - + VAR onsmth: OnSomething; BEGIN - onsmth := NIL; ProcessEvents(0, 0, onsmth); onsmth := OnEvent; ProcessEvents(0, 0, onsmth); - END Something; BEGIN - Something; -(* -ProcessEvents(0, 0, NIL); -ProcessEvents(0, 0, OnEvent); -ProcessEvents(0, 0, OnEvent2); -*) + Something; + (* + ProcessEvents(0, 0, NIL); + ProcessEvents(0, 0, OnEvent); + ProcessEvents(0, 0, OnEvent2); + *) END clb. diff --git a/src/test/files/testFiles.Mod b/src/test/files/testFiles.Mod index 236a1247..8eaaba8e 100644 --- a/src/test/files/testFiles.Mod +++ b/src/test/files/testFiles.Mod @@ -5,31 +5,24 @@ IMPORT Files, Texts, Console; CONST file="testFiles.Mod"; -VAR +VAR T : Texts.Text; R : Texts.Reader; F : Files.File; ch : CHAR; BEGIN + F := Files.Old (file); + IF F # NIL THEN + NEW(T); + Texts.Open(T, file); + Texts.OpenReader(R, T, 0); + Texts.Read (R, ch); -F := Files.Old (file); -IF F # NIL THEN - NEW(T); - Texts.Open(T, file); - Texts.OpenReader(R, T, 0); - Texts.Read (R, ch); - - WHILE ~R.eot DO - Console.Char(ch); - IF ch = 0DX THEN Console.Char(0AX) END; + WHILE ~R.eot DO + IF ch = 0DX THEN Console.Ln ELSE Console.Char(ch) END; Texts.Read (R, ch); - END; - -ELSE - - Console.String ("cannot open"); Console.Ln; - -END; - - + END; + ELSE + Console.String ("cannot open"); Console.Ln; + END; END testFiles. diff --git a/src/tools/make/configure.c b/src/tools/make/configure.c index 0ec8e6b1..312b3ca5 100644 --- a/src/tools/make/configure.c +++ b/src/tools/make/configure.c @@ -16,6 +16,7 @@ #include "SYSTEM.h" + #ifdef _WIN32 #define strncasecmp _strnicmp #else @@ -406,7 +407,7 @@ void writeConfigurationMod() { fprintf(fd, " installdir* = '%s';\n", installdir); fprintf(fd, " staticLink* = '%s';\n", staticlink); fprintf(fd, "VAR\n"); - fprintf(fd, " versionLong-: ARRAY %d OF CHAR;\n", strnlen(versionstring, 100)+1); + fprintf(fd, " versionLong-: ARRAY %d OF CHAR;\n", (int)strnlen(versionstring, 100)+1); fprintf(fd, "BEGIN\n"); fprintf(fd, " versionLong := '%s';\n", versionstring); fprintf(fd, "END Configuration.\n"); diff --git a/src/tools/make/sourcechanges.sh b/src/tools/make/sourcechanges.sh index b2460d25..08aa873b 100644 --- a/src/tools/make/sourcechanges.sh +++ b/src/tools/make/sourcechanges.sh @@ -14,8 +14,8 @@ changes="0" for f in $1/*; do fn=$(basename $f) - egrep -v "(^/\* voc )|Configuration_|__MOVE.* cmd, |OPM_(IntSize|PointerSize|Alignment) =|Strings_Append.+void\*\)(cmd|OPM_OBERON|extTools_comp)" $f >$fn.old - egrep -v "(^/\* voc )|Configuration_|__MOVE.* cmd, |OPM_(IntSize|PointerSize|Alignment) =|Strings_Append.+void\*\)(cmd|OPM_OBERON|extTools_comp)" $fn >$fn.new + egrep -v "(^/\* voc +)|Configuration_|__MOVE.* cmd, |OPM_(IntSize|PointerSize|Alignment) =|Strings_Append.+void\*\)(cmd|OPM_OBERON|extTools_comp)" $f >$fn.old + egrep -v "(^/\* voc +)|Configuration_|__MOVE.* cmd, |OPM_(IntSize|PointerSize|Alignment) =|Strings_Append.+void\*\)(cmd|OPM_OBERON|extTools_comp)" $fn >$fn.new if ! diff -U 2 -b $fn.old $fn.new >$fn.diff; then echo "" echo ""