diff --git a/bootstrap/unix-44/Compiler.c b/bootstrap/unix-44/Compiler.c index 6444021c..1b3b14f1 100644 --- a/bootstrap/unix-44/Compiler.c +++ b/bootstrap/unix-44/Compiler.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspamSf */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspamSf */ #define INTEGER int16 #define LONGINT int32 @@ -32,7 +32,7 @@ void Compiler_Module (BOOLEAN *done) { BOOLEAN ext, new; OPT_Node p = NIL; - OPP_Module(&p, OPM_opt); + OPP_Module(&p, OPM_Options); if (OPM_noerr) { OPV_Init(); OPT_InitRecno(); @@ -43,22 +43,22 @@ void Compiler_Module (BOOLEAN *done) OPC_Init(); OPV_Module(p); if (OPM_noerr) { - if ((__IN(10, OPM_opt, 32) && __STRCMP(OPM_modName, "SYSTEM") != 0)) { + if ((__IN(10, OPM_Options, 32) && __STRCMP(OPM_modName, "SYSTEM") != 0)) { OPM_DeleteNewSym(); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"32m", 4); } OPM_LogWStr((CHAR*)" Main program.", 16); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } } else { if (new) { - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"32m", 4); } OPM_LogWStr((CHAR*)" New symbol file.", 19); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } OPM_RegisterNewSym(); @@ -115,17 +115,17 @@ void Compiler_Translate (void) OPM_LogWLn(); Platform_Exit(1); } - if (!__IN(13, OPM_opt, 32)) { - if (__IN(14, OPM_opt, 32)) { + if (!__IN(13, OPM_Options, 32)) { + if (__IN(14, OPM_Options, 32)) { extTools_Assemble(OPM_modName, 32); } else { - if (!__IN(10, OPM_opt, 32)) { + if (!__IN(10, OPM_Options, 32)) { extTools_Assemble(OPM_modName, 32); Strings_Append((CHAR*)" ", 2, (void*)modulesobj, 2048); Strings_Append(OPM_modName, 32, (void*)modulesobj, 2048); Strings_Append((CHAR*)".o", 3, (void*)modulesobj, 2048); } else { - extTools_LinkMain((void*)OPM_modName, 32, __IN(15, OPM_opt, 32), modulesobj, 2048); + extTools_LinkMain((void*)OPM_modName, 32, __IN(15, OPM_Options, 32), modulesobj, 2048); } } } diff --git a/bootstrap/unix-44/Configuration.c b/bootstrap/unix-44/Configuration.c index 28528f64..85c8cf89 100644 --- a/bootstrap/unix-44/Configuration.c +++ b/bootstrap/unix-44/Configuration.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -18,6 +18,6 @@ export void *Configuration__init(void) __DEFMOD; __REGMOD("Configuration", 0); /* BEGIN */ - __MOVE("1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8.", Configuration_versionLong, 75); + __MOVE("1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8.", Configuration_versionLong, 75); __ENDMOD; } diff --git a/bootstrap/unix-44/Configuration.h b/bootstrap/unix-44/Configuration.h index d9030dbe..a365d693 100644 --- a/bootstrap/unix-44/Configuration.h +++ b/bootstrap/unix-44/Configuration.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Configuration__h #define Configuration__h diff --git a/bootstrap/unix-44/Console.c b/bootstrap/unix-44/Console.c index 5bf17489..c2089f05 100644 --- a/bootstrap/unix-44/Console.c +++ b/bootstrap/unix-44/Console.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-44/Console.h b/bootstrap/unix-44/Console.h index 4eb27c8b..08f4e38e 100644 --- a/bootstrap/unix-44/Console.h +++ b/bootstrap/unix-44/Console.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Console__h #define Console__h diff --git a/bootstrap/unix-44/Files.c b/bootstrap/unix-44/Files.c index 6f5eb201..4800d53c 100644 --- a/bootstrap/unix-44/Files.c +++ b/bootstrap/unix-44/Files.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-44/Files.h b/bootstrap/unix-44/Files.h index c75a1073..55e5fa16 100644 --- a/bootstrap/unix-44/Files.h +++ b/bootstrap/unix-44/Files.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #ifndef Files__h #define Files__h diff --git a/bootstrap/unix-44/Heap.c b/bootstrap/unix-44/Heap.c index 945fbff7..1f66b283 100644 --- a/bootstrap/unix-44/Heap.c +++ b/bootstrap/unix-44/Heap.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-44/Heap.h b/bootstrap/unix-44/Heap.h index eccb5d85..9e9400e1 100644 --- a/bootstrap/unix-44/Heap.h +++ b/bootstrap/unix-44/Heap.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ #ifndef Heap__h #define Heap__h diff --git a/bootstrap/unix-44/Modules.c b/bootstrap/unix-44/Modules.c index a87d0732..f165488e 100644 --- a/bootstrap/unix-44/Modules.c +++ b/bootstrap/unix-44/Modules.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-44/Modules.h b/bootstrap/unix-44/Modules.h index 93e2105b..a2ceebdf 100644 --- a/bootstrap/unix-44/Modules.h +++ b/bootstrap/unix-44/Modules.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Modules__h #define Modules__h diff --git a/bootstrap/unix-44/OPB.c b/bootstrap/unix-44/OPB.c index d211135a..e370e621 100644 --- a/bootstrap/unix-44/OPB.c +++ b/bootstrap/unix-44/OPB.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -1541,28 +1541,9 @@ static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) OPT_Struct y = NIL; int16 f, g; OPT_Struct p = NIL, q = NIL; - if (__IN(18, OPM_opt, 32)) { - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"PROCEDURE CheckAssign", 22); - OPM_LogWLn(); - } y = ynode->typ; f = x->form; g = y->form; - if (__IN(18, OPM_opt, 32)) { - OPM_LogWStr((CHAR*)"y.form = ", 10); - OPM_LogWNum(y->form, 0); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"f = ", 5); - OPM_LogWNum(f, 0); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"g = ", 5); - OPM_LogWNum(g, 0); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"ynode.typ.syze = ", 18); - OPM_LogWNum(ynode->typ->size, 0); - OPM_LogWLn(); - } if (ynode->class == 8 || (ynode->class == 9 && f != 12)) { OPB_err(126); } @@ -2367,7 +2348,7 @@ static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpa atyp = atyp->BaseTyp; if ((fvarpar && ftyp == OPT_bytetyp)) { if (!__IN(f, 0x0c, 32) || !((__IN(atyp->form, 0x1e, 32) && atyp->size == 1))) { - if (__IN(18, OPM_opt, 32)) { + if (__IN(18, OPM_Options, 32)) { OPB_err(-301); } } diff --git a/bootstrap/unix-44/OPB.h b/bootstrap/unix-44/OPB.h index 97860bfc..8c0fd594 100644 --- a/bootstrap/unix-44/OPB.h +++ b/bootstrap/unix-44/OPB.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPB__h #define OPB__h diff --git a/bootstrap/unix-44/OPC.c b/bootstrap/unix-44/OPC.c index e4c0eb06..4c9ae495 100644 --- a/bootstrap/unix-44/OPC.c +++ b/bootstrap/unix-44/OPC.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -989,7 +989,7 @@ static void OPC_IdentList (OPT_Object obj, int16 vis) OPC_Ident(obj); OPM_WriteString((CHAR*)"__typ", 6); base = NIL; - } else if ((((((__IN(5, OPM_opt, 32) && vis == 0)) && obj->mnolev > 0)) && obj->typ->form == 11)) { + } else if ((((((__IN(5, OPM_Options, 32) && vis == 0)) && obj->mnolev > 0)) && obj->typ->form == 11)) { OPM_WriteString((CHAR*)" = NIL", 7); } } @@ -1153,7 +1153,7 @@ static void OPC_GenHeaderMsg (void) OPM_Write(' '); i = 0; while (i <= 31) { - if (__IN(i, OPM_glbopt, 32)) { + if (__IN(i, OPM_Options, 32)) { switch (i) { case 0: OPM_Write('x'); @@ -1355,7 +1355,7 @@ void OPC_EnterBody (void) { OPM_WriteLn(); OPM_WriteString((CHAR*)"export ", 8); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"int main(int argc, char **argv)", 32); OPM_WriteLn(); } else { @@ -1366,20 +1366,20 @@ void OPC_EnterBody (void) } OPC_BegBlk(); OPC_BegStat(); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__INIT(argc, argv)", 19); } else { OPM_WriteString((CHAR*)"__DEFMOD", 9); } OPC_EndStat(); - if ((__IN(10, OPM_opt, 32) && 0)) { + if ((__IN(10, OPM_Options, 32) && 0)) { OPC_BegStat(); OPM_WriteString((CHAR*)"/*don`t do it!*/ printf(\"DEMO VERSION: DO NOT USE THIS PROGRAM FOR ANY COMMERCIAL PURPOSE\\n\")", 94); OPC_EndStat(); } OPC_InitImports(OPT_topScope->right); OPC_BegStat(); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__REGMAIN(\"", 12); } else { OPM_WriteString((CHAR*)"__REGMOD(\"", 11); @@ -1399,7 +1399,7 @@ void OPC_EnterBody (void) void OPC_ExitBody (void) { OPC_BegStat(); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__FINI;", 8); } else { OPM_WriteString((CHAR*)"__ENDMOD;", 10); diff --git a/bootstrap/unix-44/OPC.h b/bootstrap/unix-44/OPC.h index 3325aded..e681f43d 100644 --- a/bootstrap/unix-44/OPC.h +++ b/bootstrap/unix-44/OPC.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPC__h #define OPC__h diff --git a/bootstrap/unix-44/OPM.c b/bootstrap/unix-44/OPM.c index 7234f518..534a5c0d 100644 --- a/bootstrap/unix-44/OPM.c +++ b/bootstrap/unix-44/OPM.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -19,7 +19,14 @@ typedef static CHAR OPM_SourceFileName[256]; -export int16 OPM_AddressSize, OPM_Alignment, OPM_SetSize, OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_MaxSet; +static CHAR OPM_GlobalModel[10]; +export CHAR OPM_Model[10]; +static int16 OPM_GlobalAddressSize; +export int16 OPM_AddressSize; +static int16 OPM_GlobalAlignment; +export int16 OPM_Alignment; +export SET OPM_GlobalOptions, OPM_Options; +export int16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize, OPM_MaxSet; export int64 OPM_MaxIndex; export LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; export BOOLEAN OPM_noerr; @@ -27,7 +34,6 @@ export int32 OPM_curpos, OPM_errpos, OPM_breakpc; export int16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; export CHAR OPM_modName[32]; export CHAR OPM_objname[64]; -export SET OPM_opt, OPM_glbopt; static int32 OPM_ErrorLineStartPos, OPM_ErrorLineLimitPos, OPM_ErrorLineNumber, OPM_lasterrpos; static Texts_Reader OPM_inR; static Texts_Text OPM_Log; @@ -36,8 +42,7 @@ static Files_Rider OPM_oldSF, OPM_newSF; static Files_Rider OPM_R[3]; static Files_File OPM_oldSFile, OPM_newSFile, OPM_HFile, OPM_BFile, OPM_HIFile; static int16 OPM_S; -static CHAR OPM_OBERON[1024]; -static CHAR OPM_MODULES[1024]; +export CHAR OPM_ResourceDir[1024]; static void OPM_Append (Files_Rider *R, address *R__typ, Files_File F); @@ -50,8 +55,6 @@ export void OPM_FPrintReal (int32 *fp, REAL real); export void OPM_FPrintSet (int32 *fp, SET set); static void OPM_FindLine (Files_File f, Files_Rider *r, address *r__typ, int64 pos); export void OPM_Get (CHAR *ch); -static void OPM_GetProperties (void); -static void OPM_GetProperty (Texts_Scanner *S, address *S__typ, CHAR *name, LONGINT name__len, int16 *size, int16 *align); export void OPM_Init (BOOLEAN *done, CHAR *mname, LONGINT mname__len); export void OPM_InitOptions (void); export int16 OPM_Integer (int64 n); @@ -68,7 +71,7 @@ export void OPM_OldSym (CHAR *modName, LONGINT modName__len, BOOLEAN *done); export void OPM_OpenFiles (CHAR *moduleName, LONGINT moduleName__len); export BOOLEAN OPM_OpenPar (void); export void OPM_RegisterNewSym (void); -static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt); +static void OPM_ScanOptions (CHAR *s, LONGINT s__len); static void OPM_ShowLine (int64 pos); export int64 OPM_SignedMaximum (int32 bytecount); export int64 OPM_SignedMinimum (int32 bytecount); @@ -93,10 +96,8 @@ 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 (int16 n); -static int32 OPM_minusop (int32 i); -static int32 OPM_power0 (int32 i, int32 j); -#define OPM_GetAlignment(a) struct {char c; long long l;} s; *a = (char*)&s.l - (char*)&s +#define OPM_GetAlignment(a) struct {char c; long long l;} _s; *a = (char*)&_s.l - (char*)&_s void OPM_LogW (CHAR ch) { @@ -120,6 +121,23 @@ void OPM_LogWLn (void) Console_Ln(); } +int64 OPM_SignedMaximum (int32 bytecount) +{ + int64 _o_result; + int64 result; + result = 1; + result = __LSH(result, __ASHL(bytecount, 3) - 1, 64); + _o_result = result - 1; + return _o_result; +} + +int64 OPM_SignedMinimum (int32 bytecount) +{ + int64 _o_result; + _o_result = -OPM_SignedMaximum(bytecount) - 1; + return _o_result; +} + int32 OPM_Longint (int64 n) { int32 _o_result; @@ -134,7 +152,7 @@ int16 OPM_Integer (int64 n) return _o_result; } -static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) +static void OPM_ScanOptions (CHAR *s, LONGINT s__len) { int16 i; __DUP(s, s__len, CHAR); @@ -142,75 +160,57 @@ static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) while (s[__X(i, s__len)] != 0x00) { switch (s[__X(i, s__len)]) { case 'p': - *opt = *opt ^ 0x20; + OPM_Options = OPM_Options ^ 0x20; break; case 'a': - *opt = *opt ^ 0x80; + OPM_Options = OPM_Options ^ 0x80; break; case 'r': - *opt = *opt ^ 0x04; + OPM_Options = OPM_Options ^ 0x04; break; case 't': - *opt = *opt ^ 0x08; + OPM_Options = OPM_Options ^ 0x08; break; case 'x': - *opt = *opt ^ 0x01; + OPM_Options = OPM_Options ^ 0x01; break; case 'e': - *opt = *opt ^ 0x0200; + OPM_Options = OPM_Options ^ 0x0200; break; case 's': - *opt = *opt ^ 0x10; + OPM_Options = OPM_Options ^ 0x10; break; case 'F': - *opt = *opt ^ 0x020000; + OPM_Options = OPM_Options ^ 0x020000; break; case 'm': - *opt = *opt ^ 0x0400; + OPM_Options = OPM_Options ^ 0x0400; break; case 'M': - *opt = *opt ^ 0x8000; + OPM_Options = OPM_Options ^ 0x8000; break; case 'S': - *opt = *opt ^ 0x2000; + OPM_Options = OPM_Options ^ 0x2000; break; case 'c': - *opt = *opt ^ 0x4000; + OPM_Options = OPM_Options ^ 0x4000; break; case 'f': - *opt = *opt ^ 0x010000; + OPM_Options = OPM_Options ^ 0x010000; break; case 'V': - *opt = *opt ^ 0x040000; + OPM_Options = OPM_Options ^ 0x040000; break; case 'O': if (i + 1 >= Strings_Length(s, s__len)) { OPM_LogWStr((CHAR*)"-O option requires following size model character.", 51); OPM_LogWLn(); } else { - switch (s[__X(i + 1, s__len)]) { - case '2': - OPM_ShortintSize = 1; - OPM_IntegerSize = 2; - OPM_LongintSize = 4; - OPM_SetSize = 4; - break; - case 'V': - OPM_ShortintSize = 1; - OPM_IntegerSize = 4; - OPM_LongintSize = 8; - OPM_SetSize = 8; - break; - case 'C': - OPM_ShortintSize = 2; - OPM_IntegerSize = 4; - OPM_LongintSize = 8; - OPM_SetSize = 8; - break; - default: - OPM_LogWStr((CHAR*)"Unrecognised size model character following -O.", 48); - OPM_LogWLn(); - break; + OPM_Model[0] = s[__X(i + 1, s__len)]; + OPM_Model[1] = 0x00; + if ((((OPM_Model[0] != '2' && OPM_Model[0] != 'C')) && OPM_Model[0] != 'V')) { + OPM_LogWStr((CHAR*)"Unrecognised size model character following -O.", 48); + OPM_LogWLn(); } i += 1; } @@ -358,39 +358,119 @@ BOOLEAN OPM_OpenPar (void) _o_result = 0; return _o_result; } else { + OPM_AddressSize = 4; + OPM_GetAlignment(&OPM_Alignment); + __MOVE("2", OPM_Model, 2); + OPM_Options = 0xa9; OPM_S = 1; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); - OPM_glbopt = 0xa9; while (s[0] == '-') { - OPM_ScanOptions(s, 256, &OPM_glbopt); + OPM_ScanOptions(s, 256); OPM_S += 1; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); } + OPM_GlobalAddressSize = OPM_AddressSize; + OPM_GlobalAlignment = OPM_Alignment; + __COPY(OPM_Model, OPM_GlobalModel, 10); + OPM_GlobalOptions = OPM_Options; _o_result = 1; return _o_result; } __RETCHK; } +static void OPM_VerboseListSizes (void) +{ + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Type Size", 15); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"SHORTINT ", 12); + OPM_LogWNum(OPM_ShortintSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"INTEGER ", 12); + OPM_LogWNum(OPM_IntegerSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"LONGINT ", 12); + OPM_LogWNum(OPM_LongintSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"SET ", 12); + OPM_LogWNum(OPM_SetSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"ADDRESS ", 12); + OPM_LogWNum(OPM_AddressSize, 4); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Alignment: ", 12); + OPM_LogWNum(OPM_Alignment, 4); + OPM_LogWLn(); +} + void OPM_InitOptions (void) { CHAR s[256]; - OPM_opt = OPM_glbopt; + CHAR searchpath[1024], modules[1024]; + CHAR MODULES[1024]; + OPM_Options = OPM_GlobalOptions; + __COPY(OPM_GlobalModel, OPM_Model, 10); + OPM_Alignment = OPM_GlobalAlignment; + OPM_AddressSize = OPM_GlobalAddressSize; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); while (s[0] == '-') { - OPM_ScanOptions(s, 256, &OPM_opt); + OPM_ScanOptions(s, 256); OPM_S += 1; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); } - if (__IN(15, OPM_opt, 32)) { - OPM_glbopt |= __SETOF(10,32); - OPM_opt |= __SETOF(10,32); + if (__IN(15, OPM_Options, 32)) { + OPM_Options |= __SETOF(10,32); } - OPM_GetProperties(); + OPM_MaxIndex = OPM_SignedMaximum(OPM_AddressSize); + switch (OPM_Model[0]) { + case '2': + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + case 'C': + OPM_ShortintSize = 2; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 8; + break; + case 'V': + OPM_ShortintSize = 1; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 8; + break; + default: + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + } + OPM_MaxSet = __ASHL(OPM_SetSize, 3) - 1; + if (__IN(18, OPM_Options, 32)) { + OPM_VerboseListSizes(); + } + OPM_ResourceDir[0] = 0x00; + Strings_Append((CHAR*)"/", 2, (void*)OPM_ResourceDir, 1024); + Strings_Append(OPM_Model, 10, (void*)OPM_ResourceDir, 1024); + modules[0] = 0x00; + Platform_GetEnv((CHAR*)"MODULES", 8, (void*)modules, 1024); + __MOVE(".", searchpath, 2); + Platform_GetEnv((CHAR*)"OBERON", 7, (void*)searchpath, 1024); + Strings_Append((CHAR*)";.;", 4, (void*)searchpath, 1024); + Strings_Append(modules, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)";", 2, (void*)searchpath, 1024); + Strings_Append(OPM_ResourceDir, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)"/sym;", 6, (void*)searchpath, 1024); + Files_SetSearchPath(searchpath, 1024); } void OPM_Init (BOOLEAN *done, CHAR *mname, LONGINT mname__len) @@ -474,20 +554,20 @@ static void OPM_LogErrMsg (int16 n) int16 i; CHAR buf[1024]; if (n >= 0) { - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"31m", 4); } OPM_LogWStr((CHAR*)" err ", 7); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } } else { - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"35m", 4); } OPM_LogWStr((CHAR*)" warning ", 11); n = -n; - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } } @@ -560,11 +640,11 @@ static void OPM_ShowLine (int64 pos) OPM_LogW(' '); i -= 1; } - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"32m", 4); } OPM_LogW('^'); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } Files_Close(f); @@ -654,106 +734,6 @@ void OPM_FPrintLReal (int32 *fp, LONGREAL lr) OPM_FPrint(&*fp, h); } -static void OPM_GetProperty (Texts_Scanner *S, address *S__typ, CHAR *name, LONGINT name__len, int16 *size, int16 *align) -{ - __DUP(name, name__len, CHAR); - if (((*S).class == 1 && __STRCMP((*S).s, name) == 0)) { - Texts_Scan(&*S, S__typ); - if ((*S).class == 3) { - *size = (int16)(*S).i; - Texts_Scan(&*S, S__typ); - } else { - OPM_Mark(-157, -1); - } - if ((*S).class == 3) { - *align = (int16)(*S).i; - Texts_Scan(&*S, S__typ); - } else { - OPM_Mark(-157, -1); - } - } else { - OPM_Mark(-157, -1); - } - __DEL(name); -} - -static int32 OPM_minusop (int32 i) -{ - int32 _o_result; - _o_result = -i; - return _o_result; -} - -static int32 OPM_power0 (int32 i, int32 j) -{ - int32 _o_result; - int32 k, p; - k = 1; - p = i; - do { - p = p * i; - k += 1; - } while (!(k == j)); - _o_result = p; - return _o_result; -} - -static void OPM_VerboseListSizes (void) -{ - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Type Size", 17); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"SHORTINT ", 14); - OPM_LogWNum(OPM_ShortintSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"INTEGER ", 14); - OPM_LogWNum(OPM_IntegerSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"LONGINT ", 14); - OPM_LogWNum(OPM_LongintSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"SET ", 14); - OPM_LogWNum(OPM_SetSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"ADDRESS ", 14); - OPM_LogWNum(OPM_AddressSize, 4); - OPM_LogWLn(); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Alignment: ", 12); - OPM_LogWNum(OPM_Alignment, 4); - OPM_LogWLn(); -} - -int64 OPM_SignedMaximum (int32 bytecount) -{ - int64 _o_result; - int64 result; - result = 1; - result = __LSH(result, __ASHL(bytecount, 3) - 1, 64); - _o_result = result - 1; - return _o_result; -} - -int64 OPM_SignedMinimum (int32 bytecount) -{ - int64 _o_result; - _o_result = -OPM_SignedMaximum(bytecount) - 1; - return _o_result; -} - -static void OPM_GetProperties (void) -{ - OPM_MaxReal = 3.40282346000000e+038; - OPM_MaxLReal = 1.79769296342094e+308; - OPM_MinReal = -OPM_MaxReal; - OPM_MinLReal = -OPM_MaxLReal; - OPM_MaxSet = __ASHL(OPM_SetSize, 3) - 1; - OPM_MaxIndex = OPM_SignedMaximum(OPM_AddressSize); - if (__IN(18, OPM_opt, 32)) { - OPM_VerboseListSizes(); - } -} - void OPM_SymRCh (CHAR *ch) { Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&*ch); @@ -848,7 +828,7 @@ void OPM_SymWLReal (LONGREAL lr) void OPM_RegisterNewSym (void) { - if (__STRCMP(OPM_modName, "SYSTEM") != 0 || __IN(10, OPM_opt, 32)) { + if (__STRCMP(OPM_modName, "SYSTEM") != 0 || __IN(10, OPM_Options, 32)) { Files_Register(OPM_newSFile); } } @@ -1047,10 +1027,10 @@ void OPM_CloseFiles (void) } if (OPM_noerr) { if (__STRCMP(OPM_modName, "SYSTEM") == 0) { - if (!__IN(10, OPM_opt, 32)) { + if (!__IN(10, OPM_Options, 32)) { Files_Register(OPM_BFile); } - } else if (!__IN(10, OPM_opt, 32)) { + } else if (!__IN(10, OPM_Options, 32)) { OPM_Append(&OPM_R[2], Files_Rider__typ, OPM_HFile); Files_Register(OPM_HIFile); Files_Register(OPM_BFile); @@ -1110,22 +1090,10 @@ export void *OPM__init(void) __REGCMD("RegisterNewSym", OPM_RegisterNewSym); __REGCMD("WriteLn", OPM_WriteLn); /* BEGIN */ + OPM_MaxReal = 3.40282346000000e+038; + OPM_MaxLReal = 1.79769296342094e+308; + OPM_MinReal = -OPM_MaxReal; + OPM_MinLReal = -OPM_MaxLReal; Texts_OpenWriter(&OPM_W, Texts_Writer__typ); - OPM_MODULES[0] = 0x00; - Platform_GetEnv((CHAR*)"MODULES", 8, (void*)OPM_MODULES, 1024); - __MOVE(".", OPM_OBERON, 2); - Platform_GetEnv((CHAR*)"OBERON", 7, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)";.;", 4, (void*)OPM_OBERON, 1024); - Strings_Append(OPM_MODULES, 1024, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)";", 2, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)"", 1, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)"/sym;", 6, (void*)OPM_OBERON, 1024); - Files_SetSearchPath(OPM_OBERON, 1024); - OPM_AddressSize = 4; - OPM_GetAlignment(&OPM_Alignment); - OPM_ShortintSize = 1; - OPM_IntegerSize = 2; - OPM_LongintSize = 4; - OPM_SetSize = 4; __ENDMOD; } diff --git a/bootstrap/unix-44/OPM.h b/bootstrap/unix-44/OPM.h index e249edd5..933ef1b5 100644 --- a/bootstrap/unix-44/OPM.h +++ b/bootstrap/unix-44/OPM.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPM__h #define OPM__h @@ -6,7 +6,10 @@ #include "SYSTEM.h" -import int16 OPM_AddressSize, OPM_Alignment, OPM_SetSize, OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_MaxSet; +import CHAR OPM_Model[10]; +import int16 OPM_AddressSize, OPM_Alignment; +import SET OPM_GlobalOptions, OPM_Options; +import int16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize, OPM_MaxSet; import int64 OPM_MaxIndex; import LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; import BOOLEAN OPM_noerr; @@ -14,7 +17,7 @@ import int32 OPM_curpos, OPM_errpos, OPM_breakpc; import int16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; import CHAR OPM_modName[32]; import CHAR OPM_objname[64]; -import SET OPM_opt, OPM_glbopt; +import CHAR OPM_ResourceDir[1024]; import void OPM_CloseFiles (void); diff --git a/bootstrap/unix-44/OPP.c b/bootstrap/unix-44/OPP.c index 1e5c6674..010efab1 100644 --- a/bootstrap/unix-44/OPP.c +++ b/bootstrap/unix-44/OPP.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-44/OPP.h b/bootstrap/unix-44/OPP.h index 3b9acd86..373d8daa 100644 --- a/bootstrap/unix-44/OPP.h +++ b/bootstrap/unix-44/OPP.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPP__h #define OPP__h diff --git a/bootstrap/unix-44/OPS.c b/bootstrap/unix-44/OPS.c index ee182741..f8ed61bf 100644 --- a/bootstrap/unix-44/OPS.c +++ b/bootstrap/unix-44/OPS.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-44/OPS.h b/bootstrap/unix-44/OPS.h index 1514d9eb..1f02668b 100644 --- a/bootstrap/unix-44/OPS.h +++ b/bootstrap/unix-44/OPS.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #ifndef OPS__h #define OPS__h diff --git a/bootstrap/unix-44/OPT.c b/bootstrap/unix-44/OPT.c index c1b4cb67..7efc4cc4 100644 --- a/bootstrap/unix-44/OPT.c +++ b/bootstrap/unix-44/OPT.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -1867,7 +1867,7 @@ void OPT_Export (BOOLEAN *ext, BOOLEAN *new) } OPT_OutObj(OPT_topScope->right); *ext = (OPT_sfpresent && OPT_symExtended); - *new = (!OPT_sfpresent || OPT_symNew) || __IN(17, OPM_opt, 32); + *new = (!OPT_sfpresent || OPT_symNew) || __IN(17, OPM_Options, 32); if ((((OPM_noerr && OPT_sfpresent)) && OPT_impCtxt.reffp != OPT_expCtxt.reffp)) { *new = 1; if (!OPT_extsf) { diff --git a/bootstrap/unix-44/OPT.h b/bootstrap/unix-44/OPT.h index d4f953ba..202c8278 100644 --- a/bootstrap/unix-44/OPT.h +++ b/bootstrap/unix-44/OPT.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPT__h #define OPT__h diff --git a/bootstrap/unix-44/OPV.c b/bootstrap/unix-44/OPV.c index a70a40bf..ff99f665 100644 --- a/bootstrap/unix-44/OPV.c +++ b/bootstrap/unix-44/OPV.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -211,7 +211,7 @@ static int16 OPV_Precedence (int16 class, int16 subclass, int16 form, int16 comp return _o_result; break; case 5: - if (__IN(3, OPM_opt, 32)) { + if (__IN(3, OPM_Options, 32)) { _o_result = 10; return _o_result; } else { @@ -397,7 +397,7 @@ static void OPV_Convert (OPT_Node n, OPT_Struct newtype, int16 prec) OPM_WriteInt(__ASHL(newtype->size, 3)); OPM_Write(')'); } else if (to == 4) { - if ((newtype->size < n->typ->size && __IN(2, OPM_opt, 32))) { + if ((newtype->size < n->typ->size && __IN(2, OPM_Options, 32))) { OPM_WriteString((CHAR*)"__SHORT", 8); if (OPV_SideEffects(n)) { OPM_Write('F'); @@ -412,7 +412,7 @@ static void OPV_Convert (OPT_Node n, OPT_Struct newtype, int16 prec) OPV_Entier(n, 9); } } else if (to == 3) { - if (__IN(2, OPM_opt, 32)) { + if (__IN(2, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__CHR", 6); if (OPV_SideEffects(n)) { OPM_Write('F'); @@ -453,7 +453,7 @@ static void OPV_TypeOf (OPT_Node n) static void OPV_Index (OPT_Node n, OPT_Node d, int16 prec, int16 dim) { - if (!__IN(0, OPM_opt, 32) || (n->right->class == 7 && (n->right->conval->intval == 0 || n->left->typ->comp != 3))) { + if (!__IN(0, OPM_Options, 32) || (n->right->class == 7 && (n->right->conval->intval == 0 || n->left->typ->comp != 3))) { OPV_expr(n->right, prec); } else { if (OPV_SideEffects(n->right)) { @@ -575,7 +575,7 @@ static void OPV_design (OPT_Node n, int16 prec) case 5: typ = n->typ; obj = n->left->obj; - if (__IN(3, OPM_opt, 32)) { + if (__IN(3, OPM_Options, 32)) { if (typ->comp == 4) { OPM_WriteString((CHAR*)"__GUARDR(", 10); if ((int16)obj->mnolev != OPM_level) { @@ -614,7 +614,7 @@ static void OPV_design (OPT_Node n, int16 prec) } break; case 6: - if (__IN(3, OPM_opt, 32)) { + if (__IN(3, OPM_Options, 32)) { if (n->left->class == 1) { OPM_WriteString((CHAR*)"__GUARDEQR(", 12); OPC_CompleteIdent(n->left->obj); @@ -1442,7 +1442,7 @@ static void OPV_stat (OPT_Node n, OPT_Object outerProc) case 20: if (n->subcl != 32) { OPV_IfStat(n, 0, outerProc); - } else if (__IN(7, OPM_opt, 32)) { + } else if (__IN(7, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__ASSERT(", 10); OPV_expr(n->left->left->left, -1); OPM_WriteString((CHAR*)", ", 3); @@ -1508,7 +1508,7 @@ static void OPV_stat (OPT_Node n, OPT_Object outerProc) break; case 26: if (OPM_level == 0) { - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__FINI", 7); } else { OPM_WriteString((CHAR*)"__ENDMOD", 9); @@ -1553,7 +1553,7 @@ static void OPV_stat (OPT_Node n, OPT_Object outerProc) void OPV_Module (OPT_Node prog) { - if (!__IN(10, OPM_opt, 32)) { + if (!__IN(10, OPM_Options, 32)) { OPC_GenHdr(prog->right); OPC_GenHdrIncludes(); } diff --git a/bootstrap/unix-44/OPV.h b/bootstrap/unix-44/OPV.h index 0a9135f5..a44fb5b5 100644 --- a/bootstrap/unix-44/OPV.h +++ b/bootstrap/unix-44/OPV.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPV__h #define OPV__h diff --git a/bootstrap/unix-44/Platform.c b/bootstrap/unix-44/Platform.c index ef0c0dbe..18c66534 100644 --- a/bootstrap/unix-44/Platform.c +++ b/bootstrap/unix-44/Platform.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -65,6 +65,7 @@ export int16 Platform_Identify (int32 h, Platform_FileIdentity *identity, addres export int16 Platform_IdentifyByName (CHAR *n, LONGINT n__len, Platform_FileIdentity *identity, address *identity__typ); export BOOLEAN Platform_Inaccessible (int16 e); export void Platform_Init (int16 argc, int32 argvadr); +export BOOLEAN Platform_Interrupted (int16 e); export void Platform_MTimeAsClock (Platform_FileIdentity i, int32 *t, int32 *d); export int16 Platform_New (CHAR *n, LONGINT n__len, int32 *h); export BOOLEAN Platform_NoSuchDirectory (int16 e); @@ -115,6 +116,7 @@ export BOOLEAN Platform_getEnv (CHAR *var, LONGINT var__len, CHAR *val, LONGINT #define Platform_ECONNABORTED() ECONNABORTED #define Platform_ECONNREFUSED() ECONNREFUSED #define Platform_EHOSTUNREACH() EHOSTUNREACH +#define Platform_EINTR() EINTR #define Platform_EMFILE() EMFILE #define Platform_ENETUNREACH() ENETUNREACH #define Platform_ENFILE() ENFILE @@ -218,6 +220,13 @@ BOOLEAN Platform_ConnectionFailed (int16 e) return _o_result; } +BOOLEAN Platform_Interrupted (int16 e) +{ + BOOLEAN _o_result; + _o_result = e == Platform_EINTR(); + return _o_result; +} + int32 Platform_OSAllocate (int32 size) { int32 _o_result; @@ -618,13 +627,11 @@ int16 Platform_Chdir (CHAR *n, LONGINT n__len) { int16 _o_result; int16 r; - r = Platform_chdir(n, n__len); - Platform_getcwd((void*)Platform_CWD, 256); - if (r < 0) { - _o_result = Platform_err(); + if ((Platform_chdir(n, n__len) >= 0 && Platform_getcwd((void*)Platform_CWD, 256) != NIL)) { + _o_result = 0; return _o_result; } else { - _o_result = 0; + _o_result = Platform_err(); return _o_result; } __RETCHK; @@ -784,9 +791,10 @@ export void *Platform__init(void) Platform_HaltHandler = NIL; Platform_TimeStart = 0; Platform_TimeStart = Platform_Time(); - Platform_CWD[0] = 0x00; - Platform_getcwd((void*)Platform_CWD, 256); Platform_PID = Platform_getpid(); + if (Platform_getcwd((void*)Platform_CWD, 256) == NIL) { + Platform_CWD[0] = 0x00; + } Platform_SeekSet = Platform_seekset(); Platform_SeekCur = Platform_seekcur(); Platform_SeekEnd = Platform_seekend(); diff --git a/bootstrap/unix-44/Platform.h b/bootstrap/unix-44/Platform.h index 986a65ef..158cb341 100644 --- a/bootstrap/unix-44/Platform.h +++ b/bootstrap/unix-44/Platform.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Platform__h #define Platform__h @@ -50,6 +50,7 @@ import int16 Platform_Identify (int32 h, Platform_FileIdentity *identity, addres import int16 Platform_IdentifyByName (CHAR *n, LONGINT n__len, Platform_FileIdentity *identity, address *identity__typ); import BOOLEAN Platform_Inaccessible (int16 e); import void Platform_Init (int16 argc, int32 argvadr); +import BOOLEAN Platform_Interrupted (int16 e); import void Platform_MTimeAsClock (Platform_FileIdentity i, int32 *t, int32 *d); import int16 Platform_New (CHAR *n, LONGINT n__len, int32 *h); import BOOLEAN Platform_NoSuchDirectory (int16 e); diff --git a/bootstrap/unix-44/Reals.c b/bootstrap/unix-44/Reals.c index e75d35ff..57e22100 100644 --- a/bootstrap/unix-44/Reals.c +++ b/bootstrap/unix-44/Reals.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-44/Reals.h b/bootstrap/unix-44/Reals.h index 8a42b39b..f3404dda 100644 --- a/bootstrap/unix-44/Reals.h +++ b/bootstrap/unix-44/Reals.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Reals__h #define Reals__h diff --git a/bootstrap/unix-44/Strings.c b/bootstrap/unix-44/Strings.c index 9f9562db..bcf3cb9b 100644 --- a/bootstrap/unix-44/Strings.c +++ b/bootstrap/unix-44/Strings.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-44/Strings.h b/bootstrap/unix-44/Strings.h index da213d81..9418692a 100644 --- a/bootstrap/unix-44/Strings.h +++ b/bootstrap/unix-44/Strings.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Strings__h #define Strings__h diff --git a/bootstrap/unix-44/Texts.c b/bootstrap/unix-44/Texts.c index 9d981ce0..efc9fd98 100644 --- a/bootstrap/unix-44/Texts.c +++ b/bootstrap/unix-44/Texts.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-44/Texts.h b/bootstrap/unix-44/Texts.h index 1faae4d6..e402259d 100644 --- a/bootstrap/unix-44/Texts.h +++ b/bootstrap/unix-44/Texts.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Texts__h #define Texts__h diff --git a/bootstrap/unix-44/errors.c b/bootstrap/unix-44/errors.c index 34e6fae3..ba890a17 100644 --- a/bootstrap/unix-44/errors.c +++ b/bootstrap/unix-44/errors.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-44/errors.h b/bootstrap/unix-44/errors.h index ce275b8c..d8124792 100644 --- a/bootstrap/unix-44/errors.h +++ b/bootstrap/unix-44/errors.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef errors__h #define errors__h diff --git a/bootstrap/unix-44/extTools.c b/bootstrap/unix-44/extTools.c index fd7974da..76fdc084 100644 --- a/bootstrap/unix-44/extTools.c +++ b/bootstrap/unix-44/extTools.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -12,10 +12,11 @@ #include "Strings.h" -static CHAR extTools_compilationOptions[1023], extTools_CFLAGS[1023]; +static CHAR extTools_CFLAGS[1023]; export void extTools_Assemble (CHAR *moduleName, LONGINT moduleName__len); +static void extTools_InitialiseCompilerCommand (CHAR *s, LONGINT s__len); export void extTools_LinkMain (CHAR *moduleName, LONGINT moduleName__len, BOOLEAN statically, CHAR *additionalopts, LONGINT additionalopts__len); static void extTools_execute (CHAR *title, LONGINT title__len, CHAR *cmd, LONGINT cmd__len); @@ -25,7 +26,7 @@ static void extTools_execute (CHAR *title, LONGINT title__len, CHAR *cmd, LONGIN int16 r, status, exitcode; __DUP(title, title__len, CHAR); __DUP(cmd, cmd__len, CHAR); - if (__IN(18, OPM_opt, 32)) { + if (__IN(18, OPM_Options, 32)) { Console_String(title, title__len); Console_String(cmd, cmd__len); Console_Ln(); @@ -60,12 +61,22 @@ static void extTools_execute (CHAR *title, LONGINT title__len, CHAR *cmd, LONGIN __DEL(cmd); } +static void extTools_InitialiseCompilerCommand (CHAR *s, LONGINT s__len) +{ + __COPY("gcc -g -O1", s, s__len); + Strings_Append((CHAR*)" -I \"", 6, (void*)s, s__len); + Strings_Append(OPM_ResourceDir, 1024, (void*)s, s__len); + Strings_Append((CHAR*)"/include\" ", 11, (void*)s, s__len); + Platform_GetEnv((CHAR*)"CFLAGS", 7, (void*)extTools_CFLAGS, 1023); + Strings_Append(extTools_CFLAGS, 1023, (void*)s, s__len); + Strings_Append((CHAR*)" ", 2, (void*)s, s__len); +} + void extTools_Assemble (CHAR *moduleName, LONGINT moduleName__len) { CHAR cmd[1023]; __DUP(moduleName, moduleName__len, CHAR); - __MOVE("gcc -g -O1", cmd, 11); - Strings_Append(extTools_compilationOptions, 1023, (void*)cmd, 1023); + extTools_InitialiseCompilerCommand((void*)cmd, 1023); Strings_Append((CHAR*)"-c ", 4, (void*)cmd, 1023); Strings_Append(moduleName, moduleName__len, (void*)cmd, 1023); Strings_Append((CHAR*)".c", 3, (void*)cmd, 1023); @@ -77,9 +88,7 @@ void extTools_LinkMain (CHAR *moduleName, LONGINT moduleName__len, BOOLEAN stati { CHAR cmd[1023]; __DUP(additionalopts, additionalopts__len, CHAR); - __MOVE("gcc -g -O1", cmd, 11); - Strings_Append((CHAR*)" ", 2, (void*)cmd, 1023); - Strings_Append(extTools_compilationOptions, 1023, (void*)cmd, 1023); + extTools_InitialiseCompilerCommand((void*)cmd, 1023); Strings_Append(moduleName, moduleName__len, (void*)cmd, 1023); Strings_Append((CHAR*)".c ", 4, (void*)cmd, 1023); Strings_Append(additionalopts, additionalopts__len, (void*)cmd, 1023); @@ -92,6 +101,7 @@ void extTools_LinkMain (CHAR *moduleName, LONGINT moduleName__len, BOOLEAN stati Strings_Append((CHAR*)"", 1, (void*)cmd, 1023); Strings_Append((CHAR*)"/lib\"", 6, (void*)cmd, 1023); Strings_Append((CHAR*)" -l voc", 8, (void*)cmd, 1023); + Strings_Append(OPM_Model, 10, (void*)cmd, 1023); extTools_execute((CHAR*)"Assemble and link: ", 20, cmd, 1023); __DEL(additionalopts); } @@ -107,11 +117,5 @@ export void *extTools__init(void) __MODULE_IMPORT(Strings); __REGMOD("extTools", 0); /* BEGIN */ - Strings_Append((CHAR*)" -I \"", 6, (void*)extTools_compilationOptions, 1023); - Strings_Append((CHAR*)"", 1, (void*)extTools_compilationOptions, 1023); - Strings_Append((CHAR*)"/include\" ", 11, (void*)extTools_compilationOptions, 1023); - Platform_GetEnv((CHAR*)"CFLAGS", 7, (void*)extTools_CFLAGS, 1023); - Strings_Append(extTools_CFLAGS, 1023, (void*)extTools_compilationOptions, 1023); - Strings_Append((CHAR*)" ", 2, (void*)extTools_compilationOptions, 1023); __ENDMOD; } diff --git a/bootstrap/unix-44/extTools.h b/bootstrap/unix-44/extTools.h index f87adfac..bb5be954 100644 --- a/bootstrap/unix-44/extTools.h +++ b/bootstrap/unix-44/extTools.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef extTools__h #define extTools__h diff --git a/bootstrap/unix-44/vt100.c b/bootstrap/unix-44/vt100.c index ca56f466..c44586d2 100644 --- a/bootstrap/unix-44/vt100.c +++ b/bootstrap/unix-44/vt100.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-44/vt100.h b/bootstrap/unix-44/vt100.h index f5b8588f..c9a01a7c 100644 --- a/bootstrap/unix-44/vt100.h +++ b/bootstrap/unix-44/vt100.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef vt100__h #define vt100__h diff --git a/bootstrap/unix-48/Compiler.c b/bootstrap/unix-48/Compiler.c index 6444021c..1b3b14f1 100644 --- a/bootstrap/unix-48/Compiler.c +++ b/bootstrap/unix-48/Compiler.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspamSf */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspamSf */ #define INTEGER int16 #define LONGINT int32 @@ -32,7 +32,7 @@ void Compiler_Module (BOOLEAN *done) { BOOLEAN ext, new; OPT_Node p = NIL; - OPP_Module(&p, OPM_opt); + OPP_Module(&p, OPM_Options); if (OPM_noerr) { OPV_Init(); OPT_InitRecno(); @@ -43,22 +43,22 @@ void Compiler_Module (BOOLEAN *done) OPC_Init(); OPV_Module(p); if (OPM_noerr) { - if ((__IN(10, OPM_opt, 32) && __STRCMP(OPM_modName, "SYSTEM") != 0)) { + if ((__IN(10, OPM_Options, 32) && __STRCMP(OPM_modName, "SYSTEM") != 0)) { OPM_DeleteNewSym(); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"32m", 4); } OPM_LogWStr((CHAR*)" Main program.", 16); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } } else { if (new) { - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"32m", 4); } OPM_LogWStr((CHAR*)" New symbol file.", 19); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } OPM_RegisterNewSym(); @@ -115,17 +115,17 @@ void Compiler_Translate (void) OPM_LogWLn(); Platform_Exit(1); } - if (!__IN(13, OPM_opt, 32)) { - if (__IN(14, OPM_opt, 32)) { + if (!__IN(13, OPM_Options, 32)) { + if (__IN(14, OPM_Options, 32)) { extTools_Assemble(OPM_modName, 32); } else { - if (!__IN(10, OPM_opt, 32)) { + if (!__IN(10, OPM_Options, 32)) { extTools_Assemble(OPM_modName, 32); Strings_Append((CHAR*)" ", 2, (void*)modulesobj, 2048); Strings_Append(OPM_modName, 32, (void*)modulesobj, 2048); Strings_Append((CHAR*)".o", 3, (void*)modulesobj, 2048); } else { - extTools_LinkMain((void*)OPM_modName, 32, __IN(15, OPM_opt, 32), modulesobj, 2048); + extTools_LinkMain((void*)OPM_modName, 32, __IN(15, OPM_Options, 32), modulesobj, 2048); } } } diff --git a/bootstrap/unix-48/Configuration.c b/bootstrap/unix-48/Configuration.c index 28528f64..85c8cf89 100644 --- a/bootstrap/unix-48/Configuration.c +++ b/bootstrap/unix-48/Configuration.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -18,6 +18,6 @@ export void *Configuration__init(void) __DEFMOD; __REGMOD("Configuration", 0); /* BEGIN */ - __MOVE("1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8.", Configuration_versionLong, 75); + __MOVE("1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8.", Configuration_versionLong, 75); __ENDMOD; } diff --git a/bootstrap/unix-48/Configuration.h b/bootstrap/unix-48/Configuration.h index d9030dbe..a365d693 100644 --- a/bootstrap/unix-48/Configuration.h +++ b/bootstrap/unix-48/Configuration.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Configuration__h #define Configuration__h diff --git a/bootstrap/unix-48/Console.c b/bootstrap/unix-48/Console.c index 5bf17489..c2089f05 100644 --- a/bootstrap/unix-48/Console.c +++ b/bootstrap/unix-48/Console.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-48/Console.h b/bootstrap/unix-48/Console.h index 4eb27c8b..08f4e38e 100644 --- a/bootstrap/unix-48/Console.h +++ b/bootstrap/unix-48/Console.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Console__h #define Console__h diff --git a/bootstrap/unix-48/Files.c b/bootstrap/unix-48/Files.c index 6f5eb201..4800d53c 100644 --- a/bootstrap/unix-48/Files.c +++ b/bootstrap/unix-48/Files.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-48/Files.h b/bootstrap/unix-48/Files.h index c75a1073..55e5fa16 100644 --- a/bootstrap/unix-48/Files.h +++ b/bootstrap/unix-48/Files.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #ifndef Files__h #define Files__h diff --git a/bootstrap/unix-48/Heap.c b/bootstrap/unix-48/Heap.c index 945fbff7..1f66b283 100644 --- a/bootstrap/unix-48/Heap.c +++ b/bootstrap/unix-48/Heap.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-48/Heap.h b/bootstrap/unix-48/Heap.h index eccb5d85..9e9400e1 100644 --- a/bootstrap/unix-48/Heap.h +++ b/bootstrap/unix-48/Heap.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ #ifndef Heap__h #define Heap__h diff --git a/bootstrap/unix-48/Modules.c b/bootstrap/unix-48/Modules.c index a87d0732..f165488e 100644 --- a/bootstrap/unix-48/Modules.c +++ b/bootstrap/unix-48/Modules.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-48/Modules.h b/bootstrap/unix-48/Modules.h index 93e2105b..a2ceebdf 100644 --- a/bootstrap/unix-48/Modules.h +++ b/bootstrap/unix-48/Modules.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Modules__h #define Modules__h diff --git a/bootstrap/unix-48/OPB.c b/bootstrap/unix-48/OPB.c index d211135a..e370e621 100644 --- a/bootstrap/unix-48/OPB.c +++ b/bootstrap/unix-48/OPB.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -1541,28 +1541,9 @@ static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) OPT_Struct y = NIL; int16 f, g; OPT_Struct p = NIL, q = NIL; - if (__IN(18, OPM_opt, 32)) { - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"PROCEDURE CheckAssign", 22); - OPM_LogWLn(); - } y = ynode->typ; f = x->form; g = y->form; - if (__IN(18, OPM_opt, 32)) { - OPM_LogWStr((CHAR*)"y.form = ", 10); - OPM_LogWNum(y->form, 0); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"f = ", 5); - OPM_LogWNum(f, 0); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"g = ", 5); - OPM_LogWNum(g, 0); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"ynode.typ.syze = ", 18); - OPM_LogWNum(ynode->typ->size, 0); - OPM_LogWLn(); - } if (ynode->class == 8 || (ynode->class == 9 && f != 12)) { OPB_err(126); } @@ -2367,7 +2348,7 @@ static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpa atyp = atyp->BaseTyp; if ((fvarpar && ftyp == OPT_bytetyp)) { if (!__IN(f, 0x0c, 32) || !((__IN(atyp->form, 0x1e, 32) && atyp->size == 1))) { - if (__IN(18, OPM_opt, 32)) { + if (__IN(18, OPM_Options, 32)) { OPB_err(-301); } } diff --git a/bootstrap/unix-48/OPB.h b/bootstrap/unix-48/OPB.h index 97860bfc..8c0fd594 100644 --- a/bootstrap/unix-48/OPB.h +++ b/bootstrap/unix-48/OPB.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPB__h #define OPB__h diff --git a/bootstrap/unix-48/OPC.c b/bootstrap/unix-48/OPC.c index e4c0eb06..4c9ae495 100644 --- a/bootstrap/unix-48/OPC.c +++ b/bootstrap/unix-48/OPC.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -989,7 +989,7 @@ static void OPC_IdentList (OPT_Object obj, int16 vis) OPC_Ident(obj); OPM_WriteString((CHAR*)"__typ", 6); base = NIL; - } else if ((((((__IN(5, OPM_opt, 32) && vis == 0)) && obj->mnolev > 0)) && obj->typ->form == 11)) { + } else if ((((((__IN(5, OPM_Options, 32) && vis == 0)) && obj->mnolev > 0)) && obj->typ->form == 11)) { OPM_WriteString((CHAR*)" = NIL", 7); } } @@ -1153,7 +1153,7 @@ static void OPC_GenHeaderMsg (void) OPM_Write(' '); i = 0; while (i <= 31) { - if (__IN(i, OPM_glbopt, 32)) { + if (__IN(i, OPM_Options, 32)) { switch (i) { case 0: OPM_Write('x'); @@ -1355,7 +1355,7 @@ void OPC_EnterBody (void) { OPM_WriteLn(); OPM_WriteString((CHAR*)"export ", 8); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"int main(int argc, char **argv)", 32); OPM_WriteLn(); } else { @@ -1366,20 +1366,20 @@ void OPC_EnterBody (void) } OPC_BegBlk(); OPC_BegStat(); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__INIT(argc, argv)", 19); } else { OPM_WriteString((CHAR*)"__DEFMOD", 9); } OPC_EndStat(); - if ((__IN(10, OPM_opt, 32) && 0)) { + if ((__IN(10, OPM_Options, 32) && 0)) { OPC_BegStat(); OPM_WriteString((CHAR*)"/*don`t do it!*/ printf(\"DEMO VERSION: DO NOT USE THIS PROGRAM FOR ANY COMMERCIAL PURPOSE\\n\")", 94); OPC_EndStat(); } OPC_InitImports(OPT_topScope->right); OPC_BegStat(); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__REGMAIN(\"", 12); } else { OPM_WriteString((CHAR*)"__REGMOD(\"", 11); @@ -1399,7 +1399,7 @@ void OPC_EnterBody (void) void OPC_ExitBody (void) { OPC_BegStat(); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__FINI;", 8); } else { OPM_WriteString((CHAR*)"__ENDMOD;", 10); diff --git a/bootstrap/unix-48/OPC.h b/bootstrap/unix-48/OPC.h index 3325aded..e681f43d 100644 --- a/bootstrap/unix-48/OPC.h +++ b/bootstrap/unix-48/OPC.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPC__h #define OPC__h diff --git a/bootstrap/unix-48/OPM.c b/bootstrap/unix-48/OPM.c index 7234f518..534a5c0d 100644 --- a/bootstrap/unix-48/OPM.c +++ b/bootstrap/unix-48/OPM.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -19,7 +19,14 @@ typedef static CHAR OPM_SourceFileName[256]; -export int16 OPM_AddressSize, OPM_Alignment, OPM_SetSize, OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_MaxSet; +static CHAR OPM_GlobalModel[10]; +export CHAR OPM_Model[10]; +static int16 OPM_GlobalAddressSize; +export int16 OPM_AddressSize; +static int16 OPM_GlobalAlignment; +export int16 OPM_Alignment; +export SET OPM_GlobalOptions, OPM_Options; +export int16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize, OPM_MaxSet; export int64 OPM_MaxIndex; export LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; export BOOLEAN OPM_noerr; @@ -27,7 +34,6 @@ export int32 OPM_curpos, OPM_errpos, OPM_breakpc; export int16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; export CHAR OPM_modName[32]; export CHAR OPM_objname[64]; -export SET OPM_opt, OPM_glbopt; static int32 OPM_ErrorLineStartPos, OPM_ErrorLineLimitPos, OPM_ErrorLineNumber, OPM_lasterrpos; static Texts_Reader OPM_inR; static Texts_Text OPM_Log; @@ -36,8 +42,7 @@ static Files_Rider OPM_oldSF, OPM_newSF; static Files_Rider OPM_R[3]; static Files_File OPM_oldSFile, OPM_newSFile, OPM_HFile, OPM_BFile, OPM_HIFile; static int16 OPM_S; -static CHAR OPM_OBERON[1024]; -static CHAR OPM_MODULES[1024]; +export CHAR OPM_ResourceDir[1024]; static void OPM_Append (Files_Rider *R, address *R__typ, Files_File F); @@ -50,8 +55,6 @@ export void OPM_FPrintReal (int32 *fp, REAL real); export void OPM_FPrintSet (int32 *fp, SET set); static void OPM_FindLine (Files_File f, Files_Rider *r, address *r__typ, int64 pos); export void OPM_Get (CHAR *ch); -static void OPM_GetProperties (void); -static void OPM_GetProperty (Texts_Scanner *S, address *S__typ, CHAR *name, LONGINT name__len, int16 *size, int16 *align); export void OPM_Init (BOOLEAN *done, CHAR *mname, LONGINT mname__len); export void OPM_InitOptions (void); export int16 OPM_Integer (int64 n); @@ -68,7 +71,7 @@ export void OPM_OldSym (CHAR *modName, LONGINT modName__len, BOOLEAN *done); export void OPM_OpenFiles (CHAR *moduleName, LONGINT moduleName__len); export BOOLEAN OPM_OpenPar (void); export void OPM_RegisterNewSym (void); -static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt); +static void OPM_ScanOptions (CHAR *s, LONGINT s__len); static void OPM_ShowLine (int64 pos); export int64 OPM_SignedMaximum (int32 bytecount); export int64 OPM_SignedMinimum (int32 bytecount); @@ -93,10 +96,8 @@ 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 (int16 n); -static int32 OPM_minusop (int32 i); -static int32 OPM_power0 (int32 i, int32 j); -#define OPM_GetAlignment(a) struct {char c; long long l;} s; *a = (char*)&s.l - (char*)&s +#define OPM_GetAlignment(a) struct {char c; long long l;} _s; *a = (char*)&_s.l - (char*)&_s void OPM_LogW (CHAR ch) { @@ -120,6 +121,23 @@ void OPM_LogWLn (void) Console_Ln(); } +int64 OPM_SignedMaximum (int32 bytecount) +{ + int64 _o_result; + int64 result; + result = 1; + result = __LSH(result, __ASHL(bytecount, 3) - 1, 64); + _o_result = result - 1; + return _o_result; +} + +int64 OPM_SignedMinimum (int32 bytecount) +{ + int64 _o_result; + _o_result = -OPM_SignedMaximum(bytecount) - 1; + return _o_result; +} + int32 OPM_Longint (int64 n) { int32 _o_result; @@ -134,7 +152,7 @@ int16 OPM_Integer (int64 n) return _o_result; } -static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) +static void OPM_ScanOptions (CHAR *s, LONGINT s__len) { int16 i; __DUP(s, s__len, CHAR); @@ -142,75 +160,57 @@ static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) while (s[__X(i, s__len)] != 0x00) { switch (s[__X(i, s__len)]) { case 'p': - *opt = *opt ^ 0x20; + OPM_Options = OPM_Options ^ 0x20; break; case 'a': - *opt = *opt ^ 0x80; + OPM_Options = OPM_Options ^ 0x80; break; case 'r': - *opt = *opt ^ 0x04; + OPM_Options = OPM_Options ^ 0x04; break; case 't': - *opt = *opt ^ 0x08; + OPM_Options = OPM_Options ^ 0x08; break; case 'x': - *opt = *opt ^ 0x01; + OPM_Options = OPM_Options ^ 0x01; break; case 'e': - *opt = *opt ^ 0x0200; + OPM_Options = OPM_Options ^ 0x0200; break; case 's': - *opt = *opt ^ 0x10; + OPM_Options = OPM_Options ^ 0x10; break; case 'F': - *opt = *opt ^ 0x020000; + OPM_Options = OPM_Options ^ 0x020000; break; case 'm': - *opt = *opt ^ 0x0400; + OPM_Options = OPM_Options ^ 0x0400; break; case 'M': - *opt = *opt ^ 0x8000; + OPM_Options = OPM_Options ^ 0x8000; break; case 'S': - *opt = *opt ^ 0x2000; + OPM_Options = OPM_Options ^ 0x2000; break; case 'c': - *opt = *opt ^ 0x4000; + OPM_Options = OPM_Options ^ 0x4000; break; case 'f': - *opt = *opt ^ 0x010000; + OPM_Options = OPM_Options ^ 0x010000; break; case 'V': - *opt = *opt ^ 0x040000; + OPM_Options = OPM_Options ^ 0x040000; break; case 'O': if (i + 1 >= Strings_Length(s, s__len)) { OPM_LogWStr((CHAR*)"-O option requires following size model character.", 51); OPM_LogWLn(); } else { - switch (s[__X(i + 1, s__len)]) { - case '2': - OPM_ShortintSize = 1; - OPM_IntegerSize = 2; - OPM_LongintSize = 4; - OPM_SetSize = 4; - break; - case 'V': - OPM_ShortintSize = 1; - OPM_IntegerSize = 4; - OPM_LongintSize = 8; - OPM_SetSize = 8; - break; - case 'C': - OPM_ShortintSize = 2; - OPM_IntegerSize = 4; - OPM_LongintSize = 8; - OPM_SetSize = 8; - break; - default: - OPM_LogWStr((CHAR*)"Unrecognised size model character following -O.", 48); - OPM_LogWLn(); - break; + OPM_Model[0] = s[__X(i + 1, s__len)]; + OPM_Model[1] = 0x00; + if ((((OPM_Model[0] != '2' && OPM_Model[0] != 'C')) && OPM_Model[0] != 'V')) { + OPM_LogWStr((CHAR*)"Unrecognised size model character following -O.", 48); + OPM_LogWLn(); } i += 1; } @@ -358,39 +358,119 @@ BOOLEAN OPM_OpenPar (void) _o_result = 0; return _o_result; } else { + OPM_AddressSize = 4; + OPM_GetAlignment(&OPM_Alignment); + __MOVE("2", OPM_Model, 2); + OPM_Options = 0xa9; OPM_S = 1; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); - OPM_glbopt = 0xa9; while (s[0] == '-') { - OPM_ScanOptions(s, 256, &OPM_glbopt); + OPM_ScanOptions(s, 256); OPM_S += 1; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); } + OPM_GlobalAddressSize = OPM_AddressSize; + OPM_GlobalAlignment = OPM_Alignment; + __COPY(OPM_Model, OPM_GlobalModel, 10); + OPM_GlobalOptions = OPM_Options; _o_result = 1; return _o_result; } __RETCHK; } +static void OPM_VerboseListSizes (void) +{ + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Type Size", 15); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"SHORTINT ", 12); + OPM_LogWNum(OPM_ShortintSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"INTEGER ", 12); + OPM_LogWNum(OPM_IntegerSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"LONGINT ", 12); + OPM_LogWNum(OPM_LongintSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"SET ", 12); + OPM_LogWNum(OPM_SetSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"ADDRESS ", 12); + OPM_LogWNum(OPM_AddressSize, 4); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Alignment: ", 12); + OPM_LogWNum(OPM_Alignment, 4); + OPM_LogWLn(); +} + void OPM_InitOptions (void) { CHAR s[256]; - OPM_opt = OPM_glbopt; + CHAR searchpath[1024], modules[1024]; + CHAR MODULES[1024]; + OPM_Options = OPM_GlobalOptions; + __COPY(OPM_GlobalModel, OPM_Model, 10); + OPM_Alignment = OPM_GlobalAlignment; + OPM_AddressSize = OPM_GlobalAddressSize; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); while (s[0] == '-') { - OPM_ScanOptions(s, 256, &OPM_opt); + OPM_ScanOptions(s, 256); OPM_S += 1; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); } - if (__IN(15, OPM_opt, 32)) { - OPM_glbopt |= __SETOF(10,32); - OPM_opt |= __SETOF(10,32); + if (__IN(15, OPM_Options, 32)) { + OPM_Options |= __SETOF(10,32); } - OPM_GetProperties(); + OPM_MaxIndex = OPM_SignedMaximum(OPM_AddressSize); + switch (OPM_Model[0]) { + case '2': + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + case 'C': + OPM_ShortintSize = 2; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 8; + break; + case 'V': + OPM_ShortintSize = 1; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 8; + break; + default: + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + } + OPM_MaxSet = __ASHL(OPM_SetSize, 3) - 1; + if (__IN(18, OPM_Options, 32)) { + OPM_VerboseListSizes(); + } + OPM_ResourceDir[0] = 0x00; + Strings_Append((CHAR*)"/", 2, (void*)OPM_ResourceDir, 1024); + Strings_Append(OPM_Model, 10, (void*)OPM_ResourceDir, 1024); + modules[0] = 0x00; + Platform_GetEnv((CHAR*)"MODULES", 8, (void*)modules, 1024); + __MOVE(".", searchpath, 2); + Platform_GetEnv((CHAR*)"OBERON", 7, (void*)searchpath, 1024); + Strings_Append((CHAR*)";.;", 4, (void*)searchpath, 1024); + Strings_Append(modules, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)";", 2, (void*)searchpath, 1024); + Strings_Append(OPM_ResourceDir, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)"/sym;", 6, (void*)searchpath, 1024); + Files_SetSearchPath(searchpath, 1024); } void OPM_Init (BOOLEAN *done, CHAR *mname, LONGINT mname__len) @@ -474,20 +554,20 @@ static void OPM_LogErrMsg (int16 n) int16 i; CHAR buf[1024]; if (n >= 0) { - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"31m", 4); } OPM_LogWStr((CHAR*)" err ", 7); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } } else { - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"35m", 4); } OPM_LogWStr((CHAR*)" warning ", 11); n = -n; - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } } @@ -560,11 +640,11 @@ static void OPM_ShowLine (int64 pos) OPM_LogW(' '); i -= 1; } - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"32m", 4); } OPM_LogW('^'); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } Files_Close(f); @@ -654,106 +734,6 @@ void OPM_FPrintLReal (int32 *fp, LONGREAL lr) OPM_FPrint(&*fp, h); } -static void OPM_GetProperty (Texts_Scanner *S, address *S__typ, CHAR *name, LONGINT name__len, int16 *size, int16 *align) -{ - __DUP(name, name__len, CHAR); - if (((*S).class == 1 && __STRCMP((*S).s, name) == 0)) { - Texts_Scan(&*S, S__typ); - if ((*S).class == 3) { - *size = (int16)(*S).i; - Texts_Scan(&*S, S__typ); - } else { - OPM_Mark(-157, -1); - } - if ((*S).class == 3) { - *align = (int16)(*S).i; - Texts_Scan(&*S, S__typ); - } else { - OPM_Mark(-157, -1); - } - } else { - OPM_Mark(-157, -1); - } - __DEL(name); -} - -static int32 OPM_minusop (int32 i) -{ - int32 _o_result; - _o_result = -i; - return _o_result; -} - -static int32 OPM_power0 (int32 i, int32 j) -{ - int32 _o_result; - int32 k, p; - k = 1; - p = i; - do { - p = p * i; - k += 1; - } while (!(k == j)); - _o_result = p; - return _o_result; -} - -static void OPM_VerboseListSizes (void) -{ - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Type Size", 17); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"SHORTINT ", 14); - OPM_LogWNum(OPM_ShortintSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"INTEGER ", 14); - OPM_LogWNum(OPM_IntegerSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"LONGINT ", 14); - OPM_LogWNum(OPM_LongintSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"SET ", 14); - OPM_LogWNum(OPM_SetSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"ADDRESS ", 14); - OPM_LogWNum(OPM_AddressSize, 4); - OPM_LogWLn(); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Alignment: ", 12); - OPM_LogWNum(OPM_Alignment, 4); - OPM_LogWLn(); -} - -int64 OPM_SignedMaximum (int32 bytecount) -{ - int64 _o_result; - int64 result; - result = 1; - result = __LSH(result, __ASHL(bytecount, 3) - 1, 64); - _o_result = result - 1; - return _o_result; -} - -int64 OPM_SignedMinimum (int32 bytecount) -{ - int64 _o_result; - _o_result = -OPM_SignedMaximum(bytecount) - 1; - return _o_result; -} - -static void OPM_GetProperties (void) -{ - OPM_MaxReal = 3.40282346000000e+038; - OPM_MaxLReal = 1.79769296342094e+308; - OPM_MinReal = -OPM_MaxReal; - OPM_MinLReal = -OPM_MaxLReal; - OPM_MaxSet = __ASHL(OPM_SetSize, 3) - 1; - OPM_MaxIndex = OPM_SignedMaximum(OPM_AddressSize); - if (__IN(18, OPM_opt, 32)) { - OPM_VerboseListSizes(); - } -} - void OPM_SymRCh (CHAR *ch) { Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&*ch); @@ -848,7 +828,7 @@ void OPM_SymWLReal (LONGREAL lr) void OPM_RegisterNewSym (void) { - if (__STRCMP(OPM_modName, "SYSTEM") != 0 || __IN(10, OPM_opt, 32)) { + if (__STRCMP(OPM_modName, "SYSTEM") != 0 || __IN(10, OPM_Options, 32)) { Files_Register(OPM_newSFile); } } @@ -1047,10 +1027,10 @@ void OPM_CloseFiles (void) } if (OPM_noerr) { if (__STRCMP(OPM_modName, "SYSTEM") == 0) { - if (!__IN(10, OPM_opt, 32)) { + if (!__IN(10, OPM_Options, 32)) { Files_Register(OPM_BFile); } - } else if (!__IN(10, OPM_opt, 32)) { + } else if (!__IN(10, OPM_Options, 32)) { OPM_Append(&OPM_R[2], Files_Rider__typ, OPM_HFile); Files_Register(OPM_HIFile); Files_Register(OPM_BFile); @@ -1110,22 +1090,10 @@ export void *OPM__init(void) __REGCMD("RegisterNewSym", OPM_RegisterNewSym); __REGCMD("WriteLn", OPM_WriteLn); /* BEGIN */ + OPM_MaxReal = 3.40282346000000e+038; + OPM_MaxLReal = 1.79769296342094e+308; + OPM_MinReal = -OPM_MaxReal; + OPM_MinLReal = -OPM_MaxLReal; Texts_OpenWriter(&OPM_W, Texts_Writer__typ); - OPM_MODULES[0] = 0x00; - Platform_GetEnv((CHAR*)"MODULES", 8, (void*)OPM_MODULES, 1024); - __MOVE(".", OPM_OBERON, 2); - Platform_GetEnv((CHAR*)"OBERON", 7, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)";.;", 4, (void*)OPM_OBERON, 1024); - Strings_Append(OPM_MODULES, 1024, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)";", 2, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)"", 1, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)"/sym;", 6, (void*)OPM_OBERON, 1024); - Files_SetSearchPath(OPM_OBERON, 1024); - OPM_AddressSize = 4; - OPM_GetAlignment(&OPM_Alignment); - OPM_ShortintSize = 1; - OPM_IntegerSize = 2; - OPM_LongintSize = 4; - OPM_SetSize = 4; __ENDMOD; } diff --git a/bootstrap/unix-48/OPM.h b/bootstrap/unix-48/OPM.h index e249edd5..933ef1b5 100644 --- a/bootstrap/unix-48/OPM.h +++ b/bootstrap/unix-48/OPM.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPM__h #define OPM__h @@ -6,7 +6,10 @@ #include "SYSTEM.h" -import int16 OPM_AddressSize, OPM_Alignment, OPM_SetSize, OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_MaxSet; +import CHAR OPM_Model[10]; +import int16 OPM_AddressSize, OPM_Alignment; +import SET OPM_GlobalOptions, OPM_Options; +import int16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize, OPM_MaxSet; import int64 OPM_MaxIndex; import LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; import BOOLEAN OPM_noerr; @@ -14,7 +17,7 @@ import int32 OPM_curpos, OPM_errpos, OPM_breakpc; import int16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; import CHAR OPM_modName[32]; import CHAR OPM_objname[64]; -import SET OPM_opt, OPM_glbopt; +import CHAR OPM_ResourceDir[1024]; import void OPM_CloseFiles (void); diff --git a/bootstrap/unix-48/OPP.c b/bootstrap/unix-48/OPP.c index 1e5c6674..010efab1 100644 --- a/bootstrap/unix-48/OPP.c +++ b/bootstrap/unix-48/OPP.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-48/OPP.h b/bootstrap/unix-48/OPP.h index 3b9acd86..373d8daa 100644 --- a/bootstrap/unix-48/OPP.h +++ b/bootstrap/unix-48/OPP.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPP__h #define OPP__h diff --git a/bootstrap/unix-48/OPS.c b/bootstrap/unix-48/OPS.c index ee182741..f8ed61bf 100644 --- a/bootstrap/unix-48/OPS.c +++ b/bootstrap/unix-48/OPS.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-48/OPS.h b/bootstrap/unix-48/OPS.h index 1514d9eb..1f02668b 100644 --- a/bootstrap/unix-48/OPS.h +++ b/bootstrap/unix-48/OPS.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #ifndef OPS__h #define OPS__h diff --git a/bootstrap/unix-48/OPT.c b/bootstrap/unix-48/OPT.c index 0a1f8f54..3f54ed72 100644 --- a/bootstrap/unix-48/OPT.c +++ b/bootstrap/unix-48/OPT.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -1867,7 +1867,7 @@ void OPT_Export (BOOLEAN *ext, BOOLEAN *new) } OPT_OutObj(OPT_topScope->right); *ext = (OPT_sfpresent && OPT_symExtended); - *new = (!OPT_sfpresent || OPT_symNew) || __IN(17, OPM_opt, 32); + *new = (!OPT_sfpresent || OPT_symNew) || __IN(17, OPM_Options, 32); if ((((OPM_noerr && OPT_sfpresent)) && OPT_impCtxt.reffp != OPT_expCtxt.reffp)) { *new = 1; if (!OPT_extsf) { diff --git a/bootstrap/unix-48/OPT.h b/bootstrap/unix-48/OPT.h index d4f953ba..202c8278 100644 --- a/bootstrap/unix-48/OPT.h +++ b/bootstrap/unix-48/OPT.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPT__h #define OPT__h diff --git a/bootstrap/unix-48/OPV.c b/bootstrap/unix-48/OPV.c index a70a40bf..ff99f665 100644 --- a/bootstrap/unix-48/OPV.c +++ b/bootstrap/unix-48/OPV.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -211,7 +211,7 @@ static int16 OPV_Precedence (int16 class, int16 subclass, int16 form, int16 comp return _o_result; break; case 5: - if (__IN(3, OPM_opt, 32)) { + if (__IN(3, OPM_Options, 32)) { _o_result = 10; return _o_result; } else { @@ -397,7 +397,7 @@ static void OPV_Convert (OPT_Node n, OPT_Struct newtype, int16 prec) OPM_WriteInt(__ASHL(newtype->size, 3)); OPM_Write(')'); } else if (to == 4) { - if ((newtype->size < n->typ->size && __IN(2, OPM_opt, 32))) { + if ((newtype->size < n->typ->size && __IN(2, OPM_Options, 32))) { OPM_WriteString((CHAR*)"__SHORT", 8); if (OPV_SideEffects(n)) { OPM_Write('F'); @@ -412,7 +412,7 @@ static void OPV_Convert (OPT_Node n, OPT_Struct newtype, int16 prec) OPV_Entier(n, 9); } } else if (to == 3) { - if (__IN(2, OPM_opt, 32)) { + if (__IN(2, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__CHR", 6); if (OPV_SideEffects(n)) { OPM_Write('F'); @@ -453,7 +453,7 @@ static void OPV_TypeOf (OPT_Node n) static void OPV_Index (OPT_Node n, OPT_Node d, int16 prec, int16 dim) { - if (!__IN(0, OPM_opt, 32) || (n->right->class == 7 && (n->right->conval->intval == 0 || n->left->typ->comp != 3))) { + if (!__IN(0, OPM_Options, 32) || (n->right->class == 7 && (n->right->conval->intval == 0 || n->left->typ->comp != 3))) { OPV_expr(n->right, prec); } else { if (OPV_SideEffects(n->right)) { @@ -575,7 +575,7 @@ static void OPV_design (OPT_Node n, int16 prec) case 5: typ = n->typ; obj = n->left->obj; - if (__IN(3, OPM_opt, 32)) { + if (__IN(3, OPM_Options, 32)) { if (typ->comp == 4) { OPM_WriteString((CHAR*)"__GUARDR(", 10); if ((int16)obj->mnolev != OPM_level) { @@ -614,7 +614,7 @@ static void OPV_design (OPT_Node n, int16 prec) } break; case 6: - if (__IN(3, OPM_opt, 32)) { + if (__IN(3, OPM_Options, 32)) { if (n->left->class == 1) { OPM_WriteString((CHAR*)"__GUARDEQR(", 12); OPC_CompleteIdent(n->left->obj); @@ -1442,7 +1442,7 @@ static void OPV_stat (OPT_Node n, OPT_Object outerProc) case 20: if (n->subcl != 32) { OPV_IfStat(n, 0, outerProc); - } else if (__IN(7, OPM_opt, 32)) { + } else if (__IN(7, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__ASSERT(", 10); OPV_expr(n->left->left->left, -1); OPM_WriteString((CHAR*)", ", 3); @@ -1508,7 +1508,7 @@ static void OPV_stat (OPT_Node n, OPT_Object outerProc) break; case 26: if (OPM_level == 0) { - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__FINI", 7); } else { OPM_WriteString((CHAR*)"__ENDMOD", 9); @@ -1553,7 +1553,7 @@ static void OPV_stat (OPT_Node n, OPT_Object outerProc) void OPV_Module (OPT_Node prog) { - if (!__IN(10, OPM_opt, 32)) { + if (!__IN(10, OPM_Options, 32)) { OPC_GenHdr(prog->right); OPC_GenHdrIncludes(); } diff --git a/bootstrap/unix-48/OPV.h b/bootstrap/unix-48/OPV.h index 0a9135f5..a44fb5b5 100644 --- a/bootstrap/unix-48/OPV.h +++ b/bootstrap/unix-48/OPV.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPV__h #define OPV__h diff --git a/bootstrap/unix-48/Platform.c b/bootstrap/unix-48/Platform.c index ef0c0dbe..18c66534 100644 --- a/bootstrap/unix-48/Platform.c +++ b/bootstrap/unix-48/Platform.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -65,6 +65,7 @@ export int16 Platform_Identify (int32 h, Platform_FileIdentity *identity, addres export int16 Platform_IdentifyByName (CHAR *n, LONGINT n__len, Platform_FileIdentity *identity, address *identity__typ); export BOOLEAN Platform_Inaccessible (int16 e); export void Platform_Init (int16 argc, int32 argvadr); +export BOOLEAN Platform_Interrupted (int16 e); export void Platform_MTimeAsClock (Platform_FileIdentity i, int32 *t, int32 *d); export int16 Platform_New (CHAR *n, LONGINT n__len, int32 *h); export BOOLEAN Platform_NoSuchDirectory (int16 e); @@ -115,6 +116,7 @@ export BOOLEAN Platform_getEnv (CHAR *var, LONGINT var__len, CHAR *val, LONGINT #define Platform_ECONNABORTED() ECONNABORTED #define Platform_ECONNREFUSED() ECONNREFUSED #define Platform_EHOSTUNREACH() EHOSTUNREACH +#define Platform_EINTR() EINTR #define Platform_EMFILE() EMFILE #define Platform_ENETUNREACH() ENETUNREACH #define Platform_ENFILE() ENFILE @@ -218,6 +220,13 @@ BOOLEAN Platform_ConnectionFailed (int16 e) return _o_result; } +BOOLEAN Platform_Interrupted (int16 e) +{ + BOOLEAN _o_result; + _o_result = e == Platform_EINTR(); + return _o_result; +} + int32 Platform_OSAllocate (int32 size) { int32 _o_result; @@ -618,13 +627,11 @@ int16 Platform_Chdir (CHAR *n, LONGINT n__len) { int16 _o_result; int16 r; - r = Platform_chdir(n, n__len); - Platform_getcwd((void*)Platform_CWD, 256); - if (r < 0) { - _o_result = Platform_err(); + if ((Platform_chdir(n, n__len) >= 0 && Platform_getcwd((void*)Platform_CWD, 256) != NIL)) { + _o_result = 0; return _o_result; } else { - _o_result = 0; + _o_result = Platform_err(); return _o_result; } __RETCHK; @@ -784,9 +791,10 @@ export void *Platform__init(void) Platform_HaltHandler = NIL; Platform_TimeStart = 0; Platform_TimeStart = Platform_Time(); - Platform_CWD[0] = 0x00; - Platform_getcwd((void*)Platform_CWD, 256); Platform_PID = Platform_getpid(); + if (Platform_getcwd((void*)Platform_CWD, 256) == NIL) { + Platform_CWD[0] = 0x00; + } Platform_SeekSet = Platform_seekset(); Platform_SeekCur = Platform_seekcur(); Platform_SeekEnd = Platform_seekend(); diff --git a/bootstrap/unix-48/Platform.h b/bootstrap/unix-48/Platform.h index 986a65ef..158cb341 100644 --- a/bootstrap/unix-48/Platform.h +++ b/bootstrap/unix-48/Platform.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Platform__h #define Platform__h @@ -50,6 +50,7 @@ import int16 Platform_Identify (int32 h, Platform_FileIdentity *identity, addres import int16 Platform_IdentifyByName (CHAR *n, LONGINT n__len, Platform_FileIdentity *identity, address *identity__typ); import BOOLEAN Platform_Inaccessible (int16 e); import void Platform_Init (int16 argc, int32 argvadr); +import BOOLEAN Platform_Interrupted (int16 e); import void Platform_MTimeAsClock (Platform_FileIdentity i, int32 *t, int32 *d); import int16 Platform_New (CHAR *n, LONGINT n__len, int32 *h); import BOOLEAN Platform_NoSuchDirectory (int16 e); diff --git a/bootstrap/unix-48/Reals.c b/bootstrap/unix-48/Reals.c index e75d35ff..57e22100 100644 --- a/bootstrap/unix-48/Reals.c +++ b/bootstrap/unix-48/Reals.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-48/Reals.h b/bootstrap/unix-48/Reals.h index 8a42b39b..f3404dda 100644 --- a/bootstrap/unix-48/Reals.h +++ b/bootstrap/unix-48/Reals.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Reals__h #define Reals__h diff --git a/bootstrap/unix-48/Strings.c b/bootstrap/unix-48/Strings.c index 9f9562db..bcf3cb9b 100644 --- a/bootstrap/unix-48/Strings.c +++ b/bootstrap/unix-48/Strings.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-48/Strings.h b/bootstrap/unix-48/Strings.h index da213d81..9418692a 100644 --- a/bootstrap/unix-48/Strings.h +++ b/bootstrap/unix-48/Strings.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Strings__h #define Strings__h diff --git a/bootstrap/unix-48/Texts.c b/bootstrap/unix-48/Texts.c index ab510cdb..28f099a4 100644 --- a/bootstrap/unix-48/Texts.c +++ b/bootstrap/unix-48/Texts.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-48/Texts.h b/bootstrap/unix-48/Texts.h index 64e78861..0afd65f7 100644 --- a/bootstrap/unix-48/Texts.h +++ b/bootstrap/unix-48/Texts.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Texts__h #define Texts__h diff --git a/bootstrap/unix-48/errors.c b/bootstrap/unix-48/errors.c index 34e6fae3..ba890a17 100644 --- a/bootstrap/unix-48/errors.c +++ b/bootstrap/unix-48/errors.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-48/errors.h b/bootstrap/unix-48/errors.h index ce275b8c..d8124792 100644 --- a/bootstrap/unix-48/errors.h +++ b/bootstrap/unix-48/errors.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef errors__h #define errors__h diff --git a/bootstrap/unix-48/extTools.c b/bootstrap/unix-48/extTools.c index fd7974da..76fdc084 100644 --- a/bootstrap/unix-48/extTools.c +++ b/bootstrap/unix-48/extTools.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -12,10 +12,11 @@ #include "Strings.h" -static CHAR extTools_compilationOptions[1023], extTools_CFLAGS[1023]; +static CHAR extTools_CFLAGS[1023]; export void extTools_Assemble (CHAR *moduleName, LONGINT moduleName__len); +static void extTools_InitialiseCompilerCommand (CHAR *s, LONGINT s__len); export void extTools_LinkMain (CHAR *moduleName, LONGINT moduleName__len, BOOLEAN statically, CHAR *additionalopts, LONGINT additionalopts__len); static void extTools_execute (CHAR *title, LONGINT title__len, CHAR *cmd, LONGINT cmd__len); @@ -25,7 +26,7 @@ static void extTools_execute (CHAR *title, LONGINT title__len, CHAR *cmd, LONGIN int16 r, status, exitcode; __DUP(title, title__len, CHAR); __DUP(cmd, cmd__len, CHAR); - if (__IN(18, OPM_opt, 32)) { + if (__IN(18, OPM_Options, 32)) { Console_String(title, title__len); Console_String(cmd, cmd__len); Console_Ln(); @@ -60,12 +61,22 @@ static void extTools_execute (CHAR *title, LONGINT title__len, CHAR *cmd, LONGIN __DEL(cmd); } +static void extTools_InitialiseCompilerCommand (CHAR *s, LONGINT s__len) +{ + __COPY("gcc -g -O1", s, s__len); + Strings_Append((CHAR*)" -I \"", 6, (void*)s, s__len); + Strings_Append(OPM_ResourceDir, 1024, (void*)s, s__len); + Strings_Append((CHAR*)"/include\" ", 11, (void*)s, s__len); + Platform_GetEnv((CHAR*)"CFLAGS", 7, (void*)extTools_CFLAGS, 1023); + Strings_Append(extTools_CFLAGS, 1023, (void*)s, s__len); + Strings_Append((CHAR*)" ", 2, (void*)s, s__len); +} + void extTools_Assemble (CHAR *moduleName, LONGINT moduleName__len) { CHAR cmd[1023]; __DUP(moduleName, moduleName__len, CHAR); - __MOVE("gcc -g -O1", cmd, 11); - Strings_Append(extTools_compilationOptions, 1023, (void*)cmd, 1023); + extTools_InitialiseCompilerCommand((void*)cmd, 1023); Strings_Append((CHAR*)"-c ", 4, (void*)cmd, 1023); Strings_Append(moduleName, moduleName__len, (void*)cmd, 1023); Strings_Append((CHAR*)".c", 3, (void*)cmd, 1023); @@ -77,9 +88,7 @@ void extTools_LinkMain (CHAR *moduleName, LONGINT moduleName__len, BOOLEAN stati { CHAR cmd[1023]; __DUP(additionalopts, additionalopts__len, CHAR); - __MOVE("gcc -g -O1", cmd, 11); - Strings_Append((CHAR*)" ", 2, (void*)cmd, 1023); - Strings_Append(extTools_compilationOptions, 1023, (void*)cmd, 1023); + extTools_InitialiseCompilerCommand((void*)cmd, 1023); Strings_Append(moduleName, moduleName__len, (void*)cmd, 1023); Strings_Append((CHAR*)".c ", 4, (void*)cmd, 1023); Strings_Append(additionalopts, additionalopts__len, (void*)cmd, 1023); @@ -92,6 +101,7 @@ void extTools_LinkMain (CHAR *moduleName, LONGINT moduleName__len, BOOLEAN stati Strings_Append((CHAR*)"", 1, (void*)cmd, 1023); Strings_Append((CHAR*)"/lib\"", 6, (void*)cmd, 1023); Strings_Append((CHAR*)" -l voc", 8, (void*)cmd, 1023); + Strings_Append(OPM_Model, 10, (void*)cmd, 1023); extTools_execute((CHAR*)"Assemble and link: ", 20, cmd, 1023); __DEL(additionalopts); } @@ -107,11 +117,5 @@ export void *extTools__init(void) __MODULE_IMPORT(Strings); __REGMOD("extTools", 0); /* BEGIN */ - Strings_Append((CHAR*)" -I \"", 6, (void*)extTools_compilationOptions, 1023); - Strings_Append((CHAR*)"", 1, (void*)extTools_compilationOptions, 1023); - Strings_Append((CHAR*)"/include\" ", 11, (void*)extTools_compilationOptions, 1023); - Platform_GetEnv((CHAR*)"CFLAGS", 7, (void*)extTools_CFLAGS, 1023); - Strings_Append(extTools_CFLAGS, 1023, (void*)extTools_compilationOptions, 1023); - Strings_Append((CHAR*)" ", 2, (void*)extTools_compilationOptions, 1023); __ENDMOD; } diff --git a/bootstrap/unix-48/extTools.h b/bootstrap/unix-48/extTools.h index f87adfac..bb5be954 100644 --- a/bootstrap/unix-48/extTools.h +++ b/bootstrap/unix-48/extTools.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef extTools__h #define extTools__h diff --git a/bootstrap/unix-48/vt100.c b/bootstrap/unix-48/vt100.c index ca56f466..c44586d2 100644 --- a/bootstrap/unix-48/vt100.c +++ b/bootstrap/unix-48/vt100.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-48/vt100.h b/bootstrap/unix-48/vt100.h index f5b8588f..c9a01a7c 100644 --- a/bootstrap/unix-48/vt100.h +++ b/bootstrap/unix-48/vt100.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef vt100__h #define vt100__h diff --git a/bootstrap/unix-88/Compiler.c b/bootstrap/unix-88/Compiler.c index 6444021c..1b3b14f1 100644 --- a/bootstrap/unix-88/Compiler.c +++ b/bootstrap/unix-88/Compiler.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspamSf */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspamSf */ #define INTEGER int16 #define LONGINT int32 @@ -32,7 +32,7 @@ void Compiler_Module (BOOLEAN *done) { BOOLEAN ext, new; OPT_Node p = NIL; - OPP_Module(&p, OPM_opt); + OPP_Module(&p, OPM_Options); if (OPM_noerr) { OPV_Init(); OPT_InitRecno(); @@ -43,22 +43,22 @@ void Compiler_Module (BOOLEAN *done) OPC_Init(); OPV_Module(p); if (OPM_noerr) { - if ((__IN(10, OPM_opt, 32) && __STRCMP(OPM_modName, "SYSTEM") != 0)) { + if ((__IN(10, OPM_Options, 32) && __STRCMP(OPM_modName, "SYSTEM") != 0)) { OPM_DeleteNewSym(); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"32m", 4); } OPM_LogWStr((CHAR*)" Main program.", 16); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } } else { if (new) { - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"32m", 4); } OPM_LogWStr((CHAR*)" New symbol file.", 19); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } OPM_RegisterNewSym(); @@ -115,17 +115,17 @@ void Compiler_Translate (void) OPM_LogWLn(); Platform_Exit(1); } - if (!__IN(13, OPM_opt, 32)) { - if (__IN(14, OPM_opt, 32)) { + if (!__IN(13, OPM_Options, 32)) { + if (__IN(14, OPM_Options, 32)) { extTools_Assemble(OPM_modName, 32); } else { - if (!__IN(10, OPM_opt, 32)) { + if (!__IN(10, OPM_Options, 32)) { extTools_Assemble(OPM_modName, 32); Strings_Append((CHAR*)" ", 2, (void*)modulesobj, 2048); Strings_Append(OPM_modName, 32, (void*)modulesobj, 2048); Strings_Append((CHAR*)".o", 3, (void*)modulesobj, 2048); } else { - extTools_LinkMain((void*)OPM_modName, 32, __IN(15, OPM_opt, 32), modulesobj, 2048); + extTools_LinkMain((void*)OPM_modName, 32, __IN(15, OPM_Options, 32), modulesobj, 2048); } } } diff --git a/bootstrap/unix-88/Configuration.c b/bootstrap/unix-88/Configuration.c index 28528f64..85c8cf89 100644 --- a/bootstrap/unix-88/Configuration.c +++ b/bootstrap/unix-88/Configuration.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -18,6 +18,6 @@ export void *Configuration__init(void) __DEFMOD; __REGMOD("Configuration", 0); /* BEGIN */ - __MOVE("1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8.", Configuration_versionLong, 75); + __MOVE("1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8.", Configuration_versionLong, 75); __ENDMOD; } diff --git a/bootstrap/unix-88/Configuration.h b/bootstrap/unix-88/Configuration.h index d9030dbe..a365d693 100644 --- a/bootstrap/unix-88/Configuration.h +++ b/bootstrap/unix-88/Configuration.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Configuration__h #define Configuration__h diff --git a/bootstrap/unix-88/Console.c b/bootstrap/unix-88/Console.c index 5bf17489..c2089f05 100644 --- a/bootstrap/unix-88/Console.c +++ b/bootstrap/unix-88/Console.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-88/Console.h b/bootstrap/unix-88/Console.h index 4eb27c8b..08f4e38e 100644 --- a/bootstrap/unix-88/Console.h +++ b/bootstrap/unix-88/Console.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Console__h #define Console__h diff --git a/bootstrap/unix-88/Files.c b/bootstrap/unix-88/Files.c index 5b82978c..efa49511 100644 --- a/bootstrap/unix-88/Files.c +++ b/bootstrap/unix-88/Files.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-88/Files.h b/bootstrap/unix-88/Files.h index 75495244..5aebf125 100644 --- a/bootstrap/unix-88/Files.h +++ b/bootstrap/unix-88/Files.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #ifndef Files__h #define Files__h diff --git a/bootstrap/unix-88/Heap.c b/bootstrap/unix-88/Heap.c index ca208a31..71ad15a1 100644 --- a/bootstrap/unix-88/Heap.c +++ b/bootstrap/unix-88/Heap.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-88/Heap.h b/bootstrap/unix-88/Heap.h index 3fcd0b28..0cd62e2b 100644 --- a/bootstrap/unix-88/Heap.h +++ b/bootstrap/unix-88/Heap.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ #ifndef Heap__h #define Heap__h diff --git a/bootstrap/unix-88/Modules.c b/bootstrap/unix-88/Modules.c index e3ff56bd..0e05b5aa 100644 --- a/bootstrap/unix-88/Modules.c +++ b/bootstrap/unix-88/Modules.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-88/Modules.h b/bootstrap/unix-88/Modules.h index 93e2105b..a2ceebdf 100644 --- a/bootstrap/unix-88/Modules.h +++ b/bootstrap/unix-88/Modules.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Modules__h #define Modules__h diff --git a/bootstrap/unix-88/OPB.c b/bootstrap/unix-88/OPB.c index d211135a..e370e621 100644 --- a/bootstrap/unix-88/OPB.c +++ b/bootstrap/unix-88/OPB.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -1541,28 +1541,9 @@ static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) OPT_Struct y = NIL; int16 f, g; OPT_Struct p = NIL, q = NIL; - if (__IN(18, OPM_opt, 32)) { - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"PROCEDURE CheckAssign", 22); - OPM_LogWLn(); - } y = ynode->typ; f = x->form; g = y->form; - if (__IN(18, OPM_opt, 32)) { - OPM_LogWStr((CHAR*)"y.form = ", 10); - OPM_LogWNum(y->form, 0); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"f = ", 5); - OPM_LogWNum(f, 0); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"g = ", 5); - OPM_LogWNum(g, 0); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"ynode.typ.syze = ", 18); - OPM_LogWNum(ynode->typ->size, 0); - OPM_LogWLn(); - } if (ynode->class == 8 || (ynode->class == 9 && f != 12)) { OPB_err(126); } @@ -2367,7 +2348,7 @@ static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpa atyp = atyp->BaseTyp; if ((fvarpar && ftyp == OPT_bytetyp)) { if (!__IN(f, 0x0c, 32) || !((__IN(atyp->form, 0x1e, 32) && atyp->size == 1))) { - if (__IN(18, OPM_opt, 32)) { + if (__IN(18, OPM_Options, 32)) { OPB_err(-301); } } diff --git a/bootstrap/unix-88/OPB.h b/bootstrap/unix-88/OPB.h index 97860bfc..8c0fd594 100644 --- a/bootstrap/unix-88/OPB.h +++ b/bootstrap/unix-88/OPB.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPB__h #define OPB__h diff --git a/bootstrap/unix-88/OPC.c b/bootstrap/unix-88/OPC.c index e4c0eb06..4c9ae495 100644 --- a/bootstrap/unix-88/OPC.c +++ b/bootstrap/unix-88/OPC.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -989,7 +989,7 @@ static void OPC_IdentList (OPT_Object obj, int16 vis) OPC_Ident(obj); OPM_WriteString((CHAR*)"__typ", 6); base = NIL; - } else if ((((((__IN(5, OPM_opt, 32) && vis == 0)) && obj->mnolev > 0)) && obj->typ->form == 11)) { + } else if ((((((__IN(5, OPM_Options, 32) && vis == 0)) && obj->mnolev > 0)) && obj->typ->form == 11)) { OPM_WriteString((CHAR*)" = NIL", 7); } } @@ -1153,7 +1153,7 @@ static void OPC_GenHeaderMsg (void) OPM_Write(' '); i = 0; while (i <= 31) { - if (__IN(i, OPM_glbopt, 32)) { + if (__IN(i, OPM_Options, 32)) { switch (i) { case 0: OPM_Write('x'); @@ -1355,7 +1355,7 @@ void OPC_EnterBody (void) { OPM_WriteLn(); OPM_WriteString((CHAR*)"export ", 8); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"int main(int argc, char **argv)", 32); OPM_WriteLn(); } else { @@ -1366,20 +1366,20 @@ void OPC_EnterBody (void) } OPC_BegBlk(); OPC_BegStat(); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__INIT(argc, argv)", 19); } else { OPM_WriteString((CHAR*)"__DEFMOD", 9); } OPC_EndStat(); - if ((__IN(10, OPM_opt, 32) && 0)) { + if ((__IN(10, OPM_Options, 32) && 0)) { OPC_BegStat(); OPM_WriteString((CHAR*)"/*don`t do it!*/ printf(\"DEMO VERSION: DO NOT USE THIS PROGRAM FOR ANY COMMERCIAL PURPOSE\\n\")", 94); OPC_EndStat(); } OPC_InitImports(OPT_topScope->right); OPC_BegStat(); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__REGMAIN(\"", 12); } else { OPM_WriteString((CHAR*)"__REGMOD(\"", 11); @@ -1399,7 +1399,7 @@ void OPC_EnterBody (void) void OPC_ExitBody (void) { OPC_BegStat(); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__FINI;", 8); } else { OPM_WriteString((CHAR*)"__ENDMOD;", 10); diff --git a/bootstrap/unix-88/OPC.h b/bootstrap/unix-88/OPC.h index 3325aded..e681f43d 100644 --- a/bootstrap/unix-88/OPC.h +++ b/bootstrap/unix-88/OPC.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPC__h #define OPC__h diff --git a/bootstrap/unix-88/OPM.c b/bootstrap/unix-88/OPM.c index 4710b95f..297ade25 100644 --- a/bootstrap/unix-88/OPM.c +++ b/bootstrap/unix-88/OPM.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -19,7 +19,14 @@ typedef static CHAR OPM_SourceFileName[256]; -export int16 OPM_AddressSize, OPM_Alignment, OPM_SetSize, OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_MaxSet; +static CHAR OPM_GlobalModel[10]; +export CHAR OPM_Model[10]; +static int16 OPM_GlobalAddressSize; +export int16 OPM_AddressSize; +static int16 OPM_GlobalAlignment; +export int16 OPM_Alignment; +export SET OPM_GlobalOptions, OPM_Options; +export int16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize, OPM_MaxSet; export int64 OPM_MaxIndex; export LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; export BOOLEAN OPM_noerr; @@ -27,7 +34,6 @@ export int32 OPM_curpos, OPM_errpos, OPM_breakpc; export int16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; export CHAR OPM_modName[32]; export CHAR OPM_objname[64]; -export SET OPM_opt, OPM_glbopt; static int32 OPM_ErrorLineStartPos, OPM_ErrorLineLimitPos, OPM_ErrorLineNumber, OPM_lasterrpos; static Texts_Reader OPM_inR; static Texts_Text OPM_Log; @@ -36,8 +42,7 @@ static Files_Rider OPM_oldSF, OPM_newSF; static Files_Rider OPM_R[3]; static Files_File OPM_oldSFile, OPM_newSFile, OPM_HFile, OPM_BFile, OPM_HIFile; static int16 OPM_S; -static CHAR OPM_OBERON[1024]; -static CHAR OPM_MODULES[1024]; +export CHAR OPM_ResourceDir[1024]; static void OPM_Append (Files_Rider *R, address *R__typ, Files_File F); @@ -50,8 +55,6 @@ export void OPM_FPrintReal (int32 *fp, REAL real); export void OPM_FPrintSet (int32 *fp, SET set); static void OPM_FindLine (Files_File f, Files_Rider *r, address *r__typ, int64 pos); export void OPM_Get (CHAR *ch); -static void OPM_GetProperties (void); -static void OPM_GetProperty (Texts_Scanner *S, address *S__typ, CHAR *name, LONGINT name__len, int16 *size, int16 *align); export void OPM_Init (BOOLEAN *done, CHAR *mname, LONGINT mname__len); export void OPM_InitOptions (void); export int16 OPM_Integer (int64 n); @@ -68,7 +71,7 @@ export void OPM_OldSym (CHAR *modName, LONGINT modName__len, BOOLEAN *done); export void OPM_OpenFiles (CHAR *moduleName, LONGINT moduleName__len); export BOOLEAN OPM_OpenPar (void); export void OPM_RegisterNewSym (void); -static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt); +static void OPM_ScanOptions (CHAR *s, LONGINT s__len); static void OPM_ShowLine (int64 pos); export int64 OPM_SignedMaximum (int32 bytecount); export int64 OPM_SignedMinimum (int32 bytecount); @@ -93,10 +96,8 @@ 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 (int16 n); -static int32 OPM_minusop (int32 i); -static int32 OPM_power0 (int32 i, int32 j); -#define OPM_GetAlignment(a) struct {char c; long long l;} s; *a = (char*)&s.l - (char*)&s +#define OPM_GetAlignment(a) struct {char c; long long l;} _s; *a = (char*)&_s.l - (char*)&_s void OPM_LogW (CHAR ch) { @@ -120,6 +121,23 @@ void OPM_LogWLn (void) Console_Ln(); } +int64 OPM_SignedMaximum (int32 bytecount) +{ + int64 _o_result; + int64 result; + result = 1; + result = __LSH(result, __ASHL(bytecount, 3) - 1, 64); + _o_result = result - 1; + return _o_result; +} + +int64 OPM_SignedMinimum (int32 bytecount) +{ + int64 _o_result; + _o_result = -OPM_SignedMaximum(bytecount) - 1; + return _o_result; +} + int32 OPM_Longint (int64 n) { int32 _o_result; @@ -134,7 +152,7 @@ int16 OPM_Integer (int64 n) return _o_result; } -static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) +static void OPM_ScanOptions (CHAR *s, LONGINT s__len) { int16 i; __DUP(s, s__len, CHAR); @@ -142,75 +160,57 @@ static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) while (s[__X(i, s__len)] != 0x00) { switch (s[__X(i, s__len)]) { case 'p': - *opt = *opt ^ 0x20; + OPM_Options = OPM_Options ^ 0x20; break; case 'a': - *opt = *opt ^ 0x80; + OPM_Options = OPM_Options ^ 0x80; break; case 'r': - *opt = *opt ^ 0x04; + OPM_Options = OPM_Options ^ 0x04; break; case 't': - *opt = *opt ^ 0x08; + OPM_Options = OPM_Options ^ 0x08; break; case 'x': - *opt = *opt ^ 0x01; + OPM_Options = OPM_Options ^ 0x01; break; case 'e': - *opt = *opt ^ 0x0200; + OPM_Options = OPM_Options ^ 0x0200; break; case 's': - *opt = *opt ^ 0x10; + OPM_Options = OPM_Options ^ 0x10; break; case 'F': - *opt = *opt ^ 0x020000; + OPM_Options = OPM_Options ^ 0x020000; break; case 'm': - *opt = *opt ^ 0x0400; + OPM_Options = OPM_Options ^ 0x0400; break; case 'M': - *opt = *opt ^ 0x8000; + OPM_Options = OPM_Options ^ 0x8000; break; case 'S': - *opt = *opt ^ 0x2000; + OPM_Options = OPM_Options ^ 0x2000; break; case 'c': - *opt = *opt ^ 0x4000; + OPM_Options = OPM_Options ^ 0x4000; break; case 'f': - *opt = *opt ^ 0x010000; + OPM_Options = OPM_Options ^ 0x010000; break; case 'V': - *opt = *opt ^ 0x040000; + OPM_Options = OPM_Options ^ 0x040000; break; case 'O': if (i + 1 >= Strings_Length(s, s__len)) { OPM_LogWStr((CHAR*)"-O option requires following size model character.", 51); OPM_LogWLn(); } else { - switch (s[__X(i + 1, s__len)]) { - case '2': - OPM_ShortintSize = 1; - OPM_IntegerSize = 2; - OPM_LongintSize = 4; - OPM_SetSize = 4; - break; - case 'V': - OPM_ShortintSize = 1; - OPM_IntegerSize = 4; - OPM_LongintSize = 8; - OPM_SetSize = 8; - break; - case 'C': - OPM_ShortintSize = 2; - OPM_IntegerSize = 4; - OPM_LongintSize = 8; - OPM_SetSize = 8; - break; - default: - OPM_LogWStr((CHAR*)"Unrecognised size model character following -O.", 48); - OPM_LogWLn(); - break; + OPM_Model[0] = s[__X(i + 1, s__len)]; + OPM_Model[1] = 0x00; + if ((((OPM_Model[0] != '2' && OPM_Model[0] != 'C')) && OPM_Model[0] != 'V')) { + OPM_LogWStr((CHAR*)"Unrecognised size model character following -O.", 48); + OPM_LogWLn(); } i += 1; } @@ -358,39 +358,119 @@ BOOLEAN OPM_OpenPar (void) _o_result = 0; return _o_result; } else { + OPM_AddressSize = 8; + OPM_GetAlignment(&OPM_Alignment); + __MOVE("2", OPM_Model, 2); + OPM_Options = 0xa9; OPM_S = 1; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); - OPM_glbopt = 0xa9; while (s[0] == '-') { - OPM_ScanOptions(s, 256, &OPM_glbopt); + OPM_ScanOptions(s, 256); OPM_S += 1; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); } + OPM_GlobalAddressSize = OPM_AddressSize; + OPM_GlobalAlignment = OPM_Alignment; + __COPY(OPM_Model, OPM_GlobalModel, 10); + OPM_GlobalOptions = OPM_Options; _o_result = 1; return _o_result; } __RETCHK; } +static void OPM_VerboseListSizes (void) +{ + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Type Size", 15); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"SHORTINT ", 12); + OPM_LogWNum(OPM_ShortintSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"INTEGER ", 12); + OPM_LogWNum(OPM_IntegerSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"LONGINT ", 12); + OPM_LogWNum(OPM_LongintSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"SET ", 12); + OPM_LogWNum(OPM_SetSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"ADDRESS ", 12); + OPM_LogWNum(OPM_AddressSize, 4); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Alignment: ", 12); + OPM_LogWNum(OPM_Alignment, 4); + OPM_LogWLn(); +} + void OPM_InitOptions (void) { CHAR s[256]; - OPM_opt = OPM_glbopt; + CHAR searchpath[1024], modules[1024]; + CHAR MODULES[1024]; + OPM_Options = OPM_GlobalOptions; + __COPY(OPM_GlobalModel, OPM_Model, 10); + OPM_Alignment = OPM_GlobalAlignment; + OPM_AddressSize = OPM_GlobalAddressSize; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); while (s[0] == '-') { - OPM_ScanOptions(s, 256, &OPM_opt); + OPM_ScanOptions(s, 256); OPM_S += 1; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); } - if (__IN(15, OPM_opt, 32)) { - OPM_glbopt |= __SETOF(10,32); - OPM_opt |= __SETOF(10,32); + if (__IN(15, OPM_Options, 32)) { + OPM_Options |= __SETOF(10,32); } - OPM_GetProperties(); + OPM_MaxIndex = OPM_SignedMaximum(OPM_AddressSize); + switch (OPM_Model[0]) { + case '2': + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + case 'C': + OPM_ShortintSize = 2; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 8; + break; + case 'V': + OPM_ShortintSize = 1; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 8; + break; + default: + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + } + OPM_MaxSet = __ASHL(OPM_SetSize, 3) - 1; + if (__IN(18, OPM_Options, 32)) { + OPM_VerboseListSizes(); + } + OPM_ResourceDir[0] = 0x00; + Strings_Append((CHAR*)"/", 2, (void*)OPM_ResourceDir, 1024); + Strings_Append(OPM_Model, 10, (void*)OPM_ResourceDir, 1024); + modules[0] = 0x00; + Platform_GetEnv((CHAR*)"MODULES", 8, (void*)modules, 1024); + __MOVE(".", searchpath, 2); + Platform_GetEnv((CHAR*)"OBERON", 7, (void*)searchpath, 1024); + Strings_Append((CHAR*)";.;", 4, (void*)searchpath, 1024); + Strings_Append(modules, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)";", 2, (void*)searchpath, 1024); + Strings_Append(OPM_ResourceDir, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)"/sym;", 6, (void*)searchpath, 1024); + Files_SetSearchPath(searchpath, 1024); } void OPM_Init (BOOLEAN *done, CHAR *mname, LONGINT mname__len) @@ -474,20 +554,20 @@ static void OPM_LogErrMsg (int16 n) int16 i; CHAR buf[1024]; if (n >= 0) { - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"31m", 4); } OPM_LogWStr((CHAR*)" err ", 7); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } } else { - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"35m", 4); } OPM_LogWStr((CHAR*)" warning ", 11); n = -n; - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } } @@ -560,11 +640,11 @@ static void OPM_ShowLine (int64 pos) OPM_LogW(' '); i -= 1; } - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"32m", 4); } OPM_LogW('^'); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } Files_Close(f); @@ -654,106 +734,6 @@ void OPM_FPrintLReal (int32 *fp, LONGREAL lr) OPM_FPrint(&*fp, h); } -static void OPM_GetProperty (Texts_Scanner *S, address *S__typ, CHAR *name, LONGINT name__len, int16 *size, int16 *align) -{ - __DUP(name, name__len, CHAR); - if (((*S).class == 1 && __STRCMP((*S).s, name) == 0)) { - Texts_Scan(&*S, S__typ); - if ((*S).class == 3) { - *size = (int16)(*S).i; - Texts_Scan(&*S, S__typ); - } else { - OPM_Mark(-157, -1); - } - if ((*S).class == 3) { - *align = (int16)(*S).i; - Texts_Scan(&*S, S__typ); - } else { - OPM_Mark(-157, -1); - } - } else { - OPM_Mark(-157, -1); - } - __DEL(name); -} - -static int32 OPM_minusop (int32 i) -{ - int32 _o_result; - _o_result = -i; - return _o_result; -} - -static int32 OPM_power0 (int32 i, int32 j) -{ - int32 _o_result; - int32 k, p; - k = 1; - p = i; - do { - p = p * i; - k += 1; - } while (!(k == j)); - _o_result = p; - return _o_result; -} - -static void OPM_VerboseListSizes (void) -{ - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Type Size", 17); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"SHORTINT ", 14); - OPM_LogWNum(OPM_ShortintSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"INTEGER ", 14); - OPM_LogWNum(OPM_IntegerSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"LONGINT ", 14); - OPM_LogWNum(OPM_LongintSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"SET ", 14); - OPM_LogWNum(OPM_SetSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"ADDRESS ", 14); - OPM_LogWNum(OPM_AddressSize, 4); - OPM_LogWLn(); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Alignment: ", 12); - OPM_LogWNum(OPM_Alignment, 4); - OPM_LogWLn(); -} - -int64 OPM_SignedMaximum (int32 bytecount) -{ - int64 _o_result; - int64 result; - result = 1; - result = __LSH(result, __ASHL(bytecount, 3) - 1, 64); - _o_result = result - 1; - return _o_result; -} - -int64 OPM_SignedMinimum (int32 bytecount) -{ - int64 _o_result; - _o_result = -OPM_SignedMaximum(bytecount) - 1; - return _o_result; -} - -static void OPM_GetProperties (void) -{ - OPM_MaxReal = 3.40282346000000e+038; - OPM_MaxLReal = 1.79769296342094e+308; - OPM_MinReal = -OPM_MaxReal; - OPM_MinLReal = -OPM_MaxLReal; - OPM_MaxSet = __ASHL(OPM_SetSize, 3) - 1; - OPM_MaxIndex = OPM_SignedMaximum(OPM_AddressSize); - if (__IN(18, OPM_opt, 32)) { - OPM_VerboseListSizes(); - } -} - void OPM_SymRCh (CHAR *ch) { Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&*ch); @@ -848,7 +828,7 @@ void OPM_SymWLReal (LONGREAL lr) void OPM_RegisterNewSym (void) { - if (__STRCMP(OPM_modName, "SYSTEM") != 0 || __IN(10, OPM_opt, 32)) { + if (__STRCMP(OPM_modName, "SYSTEM") != 0 || __IN(10, OPM_Options, 32)) { Files_Register(OPM_newSFile); } } @@ -1047,10 +1027,10 @@ void OPM_CloseFiles (void) } if (OPM_noerr) { if (__STRCMP(OPM_modName, "SYSTEM") == 0) { - if (!__IN(10, OPM_opt, 32)) { + if (!__IN(10, OPM_Options, 32)) { Files_Register(OPM_BFile); } - } else if (!__IN(10, OPM_opt, 32)) { + } else if (!__IN(10, OPM_Options, 32)) { OPM_Append(&OPM_R[2], Files_Rider__typ, OPM_HFile); Files_Register(OPM_HIFile); Files_Register(OPM_BFile); @@ -1110,22 +1090,10 @@ export void *OPM__init(void) __REGCMD("RegisterNewSym", OPM_RegisterNewSym); __REGCMD("WriteLn", OPM_WriteLn); /* BEGIN */ + OPM_MaxReal = 3.40282346000000e+038; + OPM_MaxLReal = 1.79769296342094e+308; + OPM_MinReal = -OPM_MaxReal; + OPM_MinLReal = -OPM_MaxLReal; Texts_OpenWriter(&OPM_W, Texts_Writer__typ); - OPM_MODULES[0] = 0x00; - Platform_GetEnv((CHAR*)"MODULES", 8, (void*)OPM_MODULES, 1024); - __MOVE(".", OPM_OBERON, 2); - Platform_GetEnv((CHAR*)"OBERON", 7, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)";.;", 4, (void*)OPM_OBERON, 1024); - Strings_Append(OPM_MODULES, 1024, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)";", 2, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)"", 1, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)"/sym;", 6, (void*)OPM_OBERON, 1024); - Files_SetSearchPath(OPM_OBERON, 1024); - OPM_AddressSize = 8; - OPM_GetAlignment(&OPM_Alignment); - OPM_ShortintSize = 1; - OPM_IntegerSize = 2; - OPM_LongintSize = 4; - OPM_SetSize = 4; __ENDMOD; } diff --git a/bootstrap/unix-88/OPM.h b/bootstrap/unix-88/OPM.h index e249edd5..933ef1b5 100644 --- a/bootstrap/unix-88/OPM.h +++ b/bootstrap/unix-88/OPM.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPM__h #define OPM__h @@ -6,7 +6,10 @@ #include "SYSTEM.h" -import int16 OPM_AddressSize, OPM_Alignment, OPM_SetSize, OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_MaxSet; +import CHAR OPM_Model[10]; +import int16 OPM_AddressSize, OPM_Alignment; +import SET OPM_GlobalOptions, OPM_Options; +import int16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize, OPM_MaxSet; import int64 OPM_MaxIndex; import LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; import BOOLEAN OPM_noerr; @@ -14,7 +17,7 @@ import int32 OPM_curpos, OPM_errpos, OPM_breakpc; import int16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; import CHAR OPM_modName[32]; import CHAR OPM_objname[64]; -import SET OPM_opt, OPM_glbopt; +import CHAR OPM_ResourceDir[1024]; import void OPM_CloseFiles (void); diff --git a/bootstrap/unix-88/OPP.c b/bootstrap/unix-88/OPP.c index f6a8dfc5..c9986e20 100644 --- a/bootstrap/unix-88/OPP.c +++ b/bootstrap/unix-88/OPP.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-88/OPP.h b/bootstrap/unix-88/OPP.h index 3b9acd86..373d8daa 100644 --- a/bootstrap/unix-88/OPP.h +++ b/bootstrap/unix-88/OPP.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPP__h #define OPP__h diff --git a/bootstrap/unix-88/OPS.c b/bootstrap/unix-88/OPS.c index ee182741..f8ed61bf 100644 --- a/bootstrap/unix-88/OPS.c +++ b/bootstrap/unix-88/OPS.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-88/OPS.h b/bootstrap/unix-88/OPS.h index 1514d9eb..1f02668b 100644 --- a/bootstrap/unix-88/OPS.h +++ b/bootstrap/unix-88/OPS.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #ifndef OPS__h #define OPS__h diff --git a/bootstrap/unix-88/OPT.c b/bootstrap/unix-88/OPT.c index ad18ebdb..b0a12a18 100644 --- a/bootstrap/unix-88/OPT.c +++ b/bootstrap/unix-88/OPT.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -1867,7 +1867,7 @@ void OPT_Export (BOOLEAN *ext, BOOLEAN *new) } OPT_OutObj(OPT_topScope->right); *ext = (OPT_sfpresent && OPT_symExtended); - *new = (!OPT_sfpresent || OPT_symNew) || __IN(17, OPM_opt, 32); + *new = (!OPT_sfpresent || OPT_symNew) || __IN(17, OPM_Options, 32); if ((((OPM_noerr && OPT_sfpresent)) && OPT_impCtxt.reffp != OPT_expCtxt.reffp)) { *new = 1; if (!OPT_extsf) { diff --git a/bootstrap/unix-88/OPT.h b/bootstrap/unix-88/OPT.h index d4f953ba..202c8278 100644 --- a/bootstrap/unix-88/OPT.h +++ b/bootstrap/unix-88/OPT.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPT__h #define OPT__h diff --git a/bootstrap/unix-88/OPV.c b/bootstrap/unix-88/OPV.c index 09f3d249..07fa214f 100644 --- a/bootstrap/unix-88/OPV.c +++ b/bootstrap/unix-88/OPV.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -211,7 +211,7 @@ static int16 OPV_Precedence (int16 class, int16 subclass, int16 form, int16 comp return _o_result; break; case 5: - if (__IN(3, OPM_opt, 32)) { + if (__IN(3, OPM_Options, 32)) { _o_result = 10; return _o_result; } else { @@ -397,7 +397,7 @@ static void OPV_Convert (OPT_Node n, OPT_Struct newtype, int16 prec) OPM_WriteInt(__ASHL(newtype->size, 3)); OPM_Write(')'); } else if (to == 4) { - if ((newtype->size < n->typ->size && __IN(2, OPM_opt, 32))) { + if ((newtype->size < n->typ->size && __IN(2, OPM_Options, 32))) { OPM_WriteString((CHAR*)"__SHORT", 8); if (OPV_SideEffects(n)) { OPM_Write('F'); @@ -412,7 +412,7 @@ static void OPV_Convert (OPT_Node n, OPT_Struct newtype, int16 prec) OPV_Entier(n, 9); } } else if (to == 3) { - if (__IN(2, OPM_opt, 32)) { + if (__IN(2, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__CHR", 6); if (OPV_SideEffects(n)) { OPM_Write('F'); @@ -453,7 +453,7 @@ static void OPV_TypeOf (OPT_Node n) static void OPV_Index (OPT_Node n, OPT_Node d, int16 prec, int16 dim) { - if (!__IN(0, OPM_opt, 32) || (n->right->class == 7 && (n->right->conval->intval == 0 || n->left->typ->comp != 3))) { + if (!__IN(0, OPM_Options, 32) || (n->right->class == 7 && (n->right->conval->intval == 0 || n->left->typ->comp != 3))) { OPV_expr(n->right, prec); } else { if (OPV_SideEffects(n->right)) { @@ -575,7 +575,7 @@ static void OPV_design (OPT_Node n, int16 prec) case 5: typ = n->typ; obj = n->left->obj; - if (__IN(3, OPM_opt, 32)) { + if (__IN(3, OPM_Options, 32)) { if (typ->comp == 4) { OPM_WriteString((CHAR*)"__GUARDR(", 10); if ((int16)obj->mnolev != OPM_level) { @@ -614,7 +614,7 @@ static void OPV_design (OPT_Node n, int16 prec) } break; case 6: - if (__IN(3, OPM_opt, 32)) { + if (__IN(3, OPM_Options, 32)) { if (n->left->class == 1) { OPM_WriteString((CHAR*)"__GUARDEQR(", 12); OPC_CompleteIdent(n->left->obj); @@ -1442,7 +1442,7 @@ static void OPV_stat (OPT_Node n, OPT_Object outerProc) case 20: if (n->subcl != 32) { OPV_IfStat(n, 0, outerProc); - } else if (__IN(7, OPM_opt, 32)) { + } else if (__IN(7, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__ASSERT(", 10); OPV_expr(n->left->left->left, -1); OPM_WriteString((CHAR*)", ", 3); @@ -1508,7 +1508,7 @@ static void OPV_stat (OPT_Node n, OPT_Object outerProc) break; case 26: if (OPM_level == 0) { - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__FINI", 7); } else { OPM_WriteString((CHAR*)"__ENDMOD", 9); @@ -1553,7 +1553,7 @@ static void OPV_stat (OPT_Node n, OPT_Object outerProc) void OPV_Module (OPT_Node prog) { - if (!__IN(10, OPM_opt, 32)) { + if (!__IN(10, OPM_Options, 32)) { OPC_GenHdr(prog->right); OPC_GenHdrIncludes(); } diff --git a/bootstrap/unix-88/OPV.h b/bootstrap/unix-88/OPV.h index 0a9135f5..a44fb5b5 100644 --- a/bootstrap/unix-88/OPV.h +++ b/bootstrap/unix-88/OPV.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPV__h #define OPV__h diff --git a/bootstrap/unix-88/Platform.c b/bootstrap/unix-88/Platform.c index 5bad2591..26dc3ce5 100644 --- a/bootstrap/unix-88/Platform.c +++ b/bootstrap/unix-88/Platform.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -65,6 +65,7 @@ export int16 Platform_Identify (int32 h, Platform_FileIdentity *identity, addres export int16 Platform_IdentifyByName (CHAR *n, LONGINT n__len, Platform_FileIdentity *identity, address *identity__typ); export BOOLEAN Platform_Inaccessible (int16 e); export void Platform_Init (int16 argc, int64 argvadr); +export BOOLEAN Platform_Interrupted (int16 e); export void Platform_MTimeAsClock (Platform_FileIdentity i, int32 *t, int32 *d); export int16 Platform_New (CHAR *n, LONGINT n__len, int32 *h); export BOOLEAN Platform_NoSuchDirectory (int16 e); @@ -115,6 +116,7 @@ export BOOLEAN Platform_getEnv (CHAR *var, LONGINT var__len, CHAR *val, LONGINT #define Platform_ECONNABORTED() ECONNABORTED #define Platform_ECONNREFUSED() ECONNREFUSED #define Platform_EHOSTUNREACH() EHOSTUNREACH +#define Platform_EINTR() EINTR #define Platform_EMFILE() EMFILE #define Platform_ENETUNREACH() ENETUNREACH #define Platform_ENFILE() ENFILE @@ -218,6 +220,13 @@ BOOLEAN Platform_ConnectionFailed (int16 e) return _o_result; } +BOOLEAN Platform_Interrupted (int16 e) +{ + BOOLEAN _o_result; + _o_result = e == Platform_EINTR(); + return _o_result; +} + int64 Platform_OSAllocate (int64 size) { int64 _o_result; @@ -618,13 +627,11 @@ int16 Platform_Chdir (CHAR *n, LONGINT n__len) { int16 _o_result; int16 r; - r = Platform_chdir(n, n__len); - Platform_getcwd((void*)Platform_CWD, 256); - if (r < 0) { - _o_result = Platform_err(); + if ((Platform_chdir(n, n__len) >= 0 && Platform_getcwd((void*)Platform_CWD, 256) != NIL)) { + _o_result = 0; return _o_result; } else { - _o_result = 0; + _o_result = Platform_err(); return _o_result; } __RETCHK; @@ -784,9 +791,10 @@ export void *Platform__init(void) Platform_HaltHandler = NIL; Platform_TimeStart = 0; Platform_TimeStart = Platform_Time(); - Platform_CWD[0] = 0x00; - Platform_getcwd((void*)Platform_CWD, 256); Platform_PID = Platform_getpid(); + if (Platform_getcwd((void*)Platform_CWD, 256) == NIL) { + Platform_CWD[0] = 0x00; + } Platform_SeekSet = Platform_seekset(); Platform_SeekCur = Platform_seekcur(); Platform_SeekEnd = Platform_seekend(); diff --git a/bootstrap/unix-88/Platform.h b/bootstrap/unix-88/Platform.h index 2402b996..c9b53f3c 100644 --- a/bootstrap/unix-88/Platform.h +++ b/bootstrap/unix-88/Platform.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Platform__h #define Platform__h @@ -50,6 +50,7 @@ import int16 Platform_Identify (int32 h, Platform_FileIdentity *identity, addres import int16 Platform_IdentifyByName (CHAR *n, LONGINT n__len, Platform_FileIdentity *identity, address *identity__typ); import BOOLEAN Platform_Inaccessible (int16 e); import void Platform_Init (int16 argc, int64 argvadr); +import BOOLEAN Platform_Interrupted (int16 e); import void Platform_MTimeAsClock (Platform_FileIdentity i, int32 *t, int32 *d); import int16 Platform_New (CHAR *n, LONGINT n__len, int32 *h); import BOOLEAN Platform_NoSuchDirectory (int16 e); diff --git a/bootstrap/unix-88/Reals.c b/bootstrap/unix-88/Reals.c index e75d35ff..57e22100 100644 --- a/bootstrap/unix-88/Reals.c +++ b/bootstrap/unix-88/Reals.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-88/Reals.h b/bootstrap/unix-88/Reals.h index 8a42b39b..f3404dda 100644 --- a/bootstrap/unix-88/Reals.h +++ b/bootstrap/unix-88/Reals.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Reals__h #define Reals__h diff --git a/bootstrap/unix-88/Strings.c b/bootstrap/unix-88/Strings.c index 9f9562db..bcf3cb9b 100644 --- a/bootstrap/unix-88/Strings.c +++ b/bootstrap/unix-88/Strings.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-88/Strings.h b/bootstrap/unix-88/Strings.h index da213d81..9418692a 100644 --- a/bootstrap/unix-88/Strings.h +++ b/bootstrap/unix-88/Strings.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Strings__h #define Strings__h diff --git a/bootstrap/unix-88/Texts.c b/bootstrap/unix-88/Texts.c index 2590cb27..a71cf72a 100644 --- a/bootstrap/unix-88/Texts.c +++ b/bootstrap/unix-88/Texts.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-88/Texts.h b/bootstrap/unix-88/Texts.h index 7800b252..47f1e428 100644 --- a/bootstrap/unix-88/Texts.h +++ b/bootstrap/unix-88/Texts.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Texts__h #define Texts__h diff --git a/bootstrap/unix-88/errors.c b/bootstrap/unix-88/errors.c index 34e6fae3..ba890a17 100644 --- a/bootstrap/unix-88/errors.c +++ b/bootstrap/unix-88/errors.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-88/errors.h b/bootstrap/unix-88/errors.h index ce275b8c..d8124792 100644 --- a/bootstrap/unix-88/errors.h +++ b/bootstrap/unix-88/errors.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef errors__h #define errors__h diff --git a/bootstrap/unix-88/extTools.c b/bootstrap/unix-88/extTools.c index fd7974da..76fdc084 100644 --- a/bootstrap/unix-88/extTools.c +++ b/bootstrap/unix-88/extTools.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -12,10 +12,11 @@ #include "Strings.h" -static CHAR extTools_compilationOptions[1023], extTools_CFLAGS[1023]; +static CHAR extTools_CFLAGS[1023]; export void extTools_Assemble (CHAR *moduleName, LONGINT moduleName__len); +static void extTools_InitialiseCompilerCommand (CHAR *s, LONGINT s__len); export void extTools_LinkMain (CHAR *moduleName, LONGINT moduleName__len, BOOLEAN statically, CHAR *additionalopts, LONGINT additionalopts__len); static void extTools_execute (CHAR *title, LONGINT title__len, CHAR *cmd, LONGINT cmd__len); @@ -25,7 +26,7 @@ static void extTools_execute (CHAR *title, LONGINT title__len, CHAR *cmd, LONGIN int16 r, status, exitcode; __DUP(title, title__len, CHAR); __DUP(cmd, cmd__len, CHAR); - if (__IN(18, OPM_opt, 32)) { + if (__IN(18, OPM_Options, 32)) { Console_String(title, title__len); Console_String(cmd, cmd__len); Console_Ln(); @@ -60,12 +61,22 @@ static void extTools_execute (CHAR *title, LONGINT title__len, CHAR *cmd, LONGIN __DEL(cmd); } +static void extTools_InitialiseCompilerCommand (CHAR *s, LONGINT s__len) +{ + __COPY("gcc -g -O1", s, s__len); + Strings_Append((CHAR*)" -I \"", 6, (void*)s, s__len); + Strings_Append(OPM_ResourceDir, 1024, (void*)s, s__len); + Strings_Append((CHAR*)"/include\" ", 11, (void*)s, s__len); + Platform_GetEnv((CHAR*)"CFLAGS", 7, (void*)extTools_CFLAGS, 1023); + Strings_Append(extTools_CFLAGS, 1023, (void*)s, s__len); + Strings_Append((CHAR*)" ", 2, (void*)s, s__len); +} + void extTools_Assemble (CHAR *moduleName, LONGINT moduleName__len) { CHAR cmd[1023]; __DUP(moduleName, moduleName__len, CHAR); - __MOVE("gcc -g -O1", cmd, 11); - Strings_Append(extTools_compilationOptions, 1023, (void*)cmd, 1023); + extTools_InitialiseCompilerCommand((void*)cmd, 1023); Strings_Append((CHAR*)"-c ", 4, (void*)cmd, 1023); Strings_Append(moduleName, moduleName__len, (void*)cmd, 1023); Strings_Append((CHAR*)".c", 3, (void*)cmd, 1023); @@ -77,9 +88,7 @@ void extTools_LinkMain (CHAR *moduleName, LONGINT moduleName__len, BOOLEAN stati { CHAR cmd[1023]; __DUP(additionalopts, additionalopts__len, CHAR); - __MOVE("gcc -g -O1", cmd, 11); - Strings_Append((CHAR*)" ", 2, (void*)cmd, 1023); - Strings_Append(extTools_compilationOptions, 1023, (void*)cmd, 1023); + extTools_InitialiseCompilerCommand((void*)cmd, 1023); Strings_Append(moduleName, moduleName__len, (void*)cmd, 1023); Strings_Append((CHAR*)".c ", 4, (void*)cmd, 1023); Strings_Append(additionalopts, additionalopts__len, (void*)cmd, 1023); @@ -92,6 +101,7 @@ void extTools_LinkMain (CHAR *moduleName, LONGINT moduleName__len, BOOLEAN stati Strings_Append((CHAR*)"", 1, (void*)cmd, 1023); Strings_Append((CHAR*)"/lib\"", 6, (void*)cmd, 1023); Strings_Append((CHAR*)" -l voc", 8, (void*)cmd, 1023); + Strings_Append(OPM_Model, 10, (void*)cmd, 1023); extTools_execute((CHAR*)"Assemble and link: ", 20, cmd, 1023); __DEL(additionalopts); } @@ -107,11 +117,5 @@ export void *extTools__init(void) __MODULE_IMPORT(Strings); __REGMOD("extTools", 0); /* BEGIN */ - Strings_Append((CHAR*)" -I \"", 6, (void*)extTools_compilationOptions, 1023); - Strings_Append((CHAR*)"", 1, (void*)extTools_compilationOptions, 1023); - Strings_Append((CHAR*)"/include\" ", 11, (void*)extTools_compilationOptions, 1023); - Platform_GetEnv((CHAR*)"CFLAGS", 7, (void*)extTools_CFLAGS, 1023); - Strings_Append(extTools_CFLAGS, 1023, (void*)extTools_compilationOptions, 1023); - Strings_Append((CHAR*)" ", 2, (void*)extTools_compilationOptions, 1023); __ENDMOD; } diff --git a/bootstrap/unix-88/extTools.h b/bootstrap/unix-88/extTools.h index f87adfac..bb5be954 100644 --- a/bootstrap/unix-88/extTools.h +++ b/bootstrap/unix-88/extTools.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef extTools__h #define extTools__h diff --git a/bootstrap/unix-88/vt100.c b/bootstrap/unix-88/vt100.c index ca56f466..c44586d2 100644 --- a/bootstrap/unix-88/vt100.c +++ b/bootstrap/unix-88/vt100.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/unix-88/vt100.h b/bootstrap/unix-88/vt100.h index f5b8588f..c9a01a7c 100644 --- a/bootstrap/unix-88/vt100.h +++ b/bootstrap/unix-88/vt100.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef vt100__h #define vt100__h diff --git a/bootstrap/windows-48/Compiler.c b/bootstrap/windows-48/Compiler.c index 6444021c..1b3b14f1 100644 --- a/bootstrap/windows-48/Compiler.c +++ b/bootstrap/windows-48/Compiler.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspamSf */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspamSf */ #define INTEGER int16 #define LONGINT int32 @@ -32,7 +32,7 @@ void Compiler_Module (BOOLEAN *done) { BOOLEAN ext, new; OPT_Node p = NIL; - OPP_Module(&p, OPM_opt); + OPP_Module(&p, OPM_Options); if (OPM_noerr) { OPV_Init(); OPT_InitRecno(); @@ -43,22 +43,22 @@ void Compiler_Module (BOOLEAN *done) OPC_Init(); OPV_Module(p); if (OPM_noerr) { - if ((__IN(10, OPM_opt, 32) && __STRCMP(OPM_modName, "SYSTEM") != 0)) { + if ((__IN(10, OPM_Options, 32) && __STRCMP(OPM_modName, "SYSTEM") != 0)) { OPM_DeleteNewSym(); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"32m", 4); } OPM_LogWStr((CHAR*)" Main program.", 16); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } } else { if (new) { - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"32m", 4); } OPM_LogWStr((CHAR*)" New symbol file.", 19); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } OPM_RegisterNewSym(); @@ -115,17 +115,17 @@ void Compiler_Translate (void) OPM_LogWLn(); Platform_Exit(1); } - if (!__IN(13, OPM_opt, 32)) { - if (__IN(14, OPM_opt, 32)) { + if (!__IN(13, OPM_Options, 32)) { + if (__IN(14, OPM_Options, 32)) { extTools_Assemble(OPM_modName, 32); } else { - if (!__IN(10, OPM_opt, 32)) { + if (!__IN(10, OPM_Options, 32)) { extTools_Assemble(OPM_modName, 32); Strings_Append((CHAR*)" ", 2, (void*)modulesobj, 2048); Strings_Append(OPM_modName, 32, (void*)modulesobj, 2048); Strings_Append((CHAR*)".o", 3, (void*)modulesobj, 2048); } else { - extTools_LinkMain((void*)OPM_modName, 32, __IN(15, OPM_opt, 32), modulesobj, 2048); + extTools_LinkMain((void*)OPM_modName, 32, __IN(15, OPM_Options, 32), modulesobj, 2048); } } } diff --git a/bootstrap/windows-48/Configuration.c b/bootstrap/windows-48/Configuration.c index 28528f64..85c8cf89 100644 --- a/bootstrap/windows-48/Configuration.c +++ b/bootstrap/windows-48/Configuration.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -18,6 +18,6 @@ export void *Configuration__init(void) __DEFMOD; __REGMOD("Configuration", 0); /* BEGIN */ - __MOVE("1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8.", Configuration_versionLong, 75); + __MOVE("1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8.", Configuration_versionLong, 75); __ENDMOD; } diff --git a/bootstrap/windows-48/Configuration.h b/bootstrap/windows-48/Configuration.h index d9030dbe..a365d693 100644 --- a/bootstrap/windows-48/Configuration.h +++ b/bootstrap/windows-48/Configuration.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Configuration__h #define Configuration__h diff --git a/bootstrap/windows-48/Console.c b/bootstrap/windows-48/Console.c index 11937ee4..7d63057e 100644 --- a/bootstrap/windows-48/Console.c +++ b/bootstrap/windows-48/Console.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-48/Console.h b/bootstrap/windows-48/Console.h index 4eb27c8b..08f4e38e 100644 --- a/bootstrap/windows-48/Console.h +++ b/bootstrap/windows-48/Console.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Console__h #define Console__h diff --git a/bootstrap/windows-48/Files.c b/bootstrap/windows-48/Files.c index 7c1ea1bd..ef927317 100644 --- a/bootstrap/windows-48/Files.c +++ b/bootstrap/windows-48/Files.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-48/Files.h b/bootstrap/windows-48/Files.h index a7de696c..8d274283 100644 --- a/bootstrap/windows-48/Files.h +++ b/bootstrap/windows-48/Files.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #ifndef Files__h #define Files__h diff --git a/bootstrap/windows-48/Heap.c b/bootstrap/windows-48/Heap.c index 945fbff7..1f66b283 100644 --- a/bootstrap/windows-48/Heap.c +++ b/bootstrap/windows-48/Heap.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-48/Heap.h b/bootstrap/windows-48/Heap.h index eccb5d85..9e9400e1 100644 --- a/bootstrap/windows-48/Heap.h +++ b/bootstrap/windows-48/Heap.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ #ifndef Heap__h #define Heap__h diff --git a/bootstrap/windows-48/Modules.c b/bootstrap/windows-48/Modules.c index a87d0732..f165488e 100644 --- a/bootstrap/windows-48/Modules.c +++ b/bootstrap/windows-48/Modules.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-48/Modules.h b/bootstrap/windows-48/Modules.h index 93e2105b..a2ceebdf 100644 --- a/bootstrap/windows-48/Modules.h +++ b/bootstrap/windows-48/Modules.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Modules__h #define Modules__h diff --git a/bootstrap/windows-48/OPB.c b/bootstrap/windows-48/OPB.c index d211135a..e370e621 100644 --- a/bootstrap/windows-48/OPB.c +++ b/bootstrap/windows-48/OPB.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -1541,28 +1541,9 @@ static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) OPT_Struct y = NIL; int16 f, g; OPT_Struct p = NIL, q = NIL; - if (__IN(18, OPM_opt, 32)) { - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"PROCEDURE CheckAssign", 22); - OPM_LogWLn(); - } y = ynode->typ; f = x->form; g = y->form; - if (__IN(18, OPM_opt, 32)) { - OPM_LogWStr((CHAR*)"y.form = ", 10); - OPM_LogWNum(y->form, 0); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"f = ", 5); - OPM_LogWNum(f, 0); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"g = ", 5); - OPM_LogWNum(g, 0); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"ynode.typ.syze = ", 18); - OPM_LogWNum(ynode->typ->size, 0); - OPM_LogWLn(); - } if (ynode->class == 8 || (ynode->class == 9 && f != 12)) { OPB_err(126); } @@ -2367,7 +2348,7 @@ static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpa atyp = atyp->BaseTyp; if ((fvarpar && ftyp == OPT_bytetyp)) { if (!__IN(f, 0x0c, 32) || !((__IN(atyp->form, 0x1e, 32) && atyp->size == 1))) { - if (__IN(18, OPM_opt, 32)) { + if (__IN(18, OPM_Options, 32)) { OPB_err(-301); } } diff --git a/bootstrap/windows-48/OPB.h b/bootstrap/windows-48/OPB.h index 97860bfc..8c0fd594 100644 --- a/bootstrap/windows-48/OPB.h +++ b/bootstrap/windows-48/OPB.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPB__h #define OPB__h diff --git a/bootstrap/windows-48/OPC.c b/bootstrap/windows-48/OPC.c index e4c0eb06..4c9ae495 100644 --- a/bootstrap/windows-48/OPC.c +++ b/bootstrap/windows-48/OPC.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -989,7 +989,7 @@ static void OPC_IdentList (OPT_Object obj, int16 vis) OPC_Ident(obj); OPM_WriteString((CHAR*)"__typ", 6); base = NIL; - } else if ((((((__IN(5, OPM_opt, 32) && vis == 0)) && obj->mnolev > 0)) && obj->typ->form == 11)) { + } else if ((((((__IN(5, OPM_Options, 32) && vis == 0)) && obj->mnolev > 0)) && obj->typ->form == 11)) { OPM_WriteString((CHAR*)" = NIL", 7); } } @@ -1153,7 +1153,7 @@ static void OPC_GenHeaderMsg (void) OPM_Write(' '); i = 0; while (i <= 31) { - if (__IN(i, OPM_glbopt, 32)) { + if (__IN(i, OPM_Options, 32)) { switch (i) { case 0: OPM_Write('x'); @@ -1355,7 +1355,7 @@ void OPC_EnterBody (void) { OPM_WriteLn(); OPM_WriteString((CHAR*)"export ", 8); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"int main(int argc, char **argv)", 32); OPM_WriteLn(); } else { @@ -1366,20 +1366,20 @@ void OPC_EnterBody (void) } OPC_BegBlk(); OPC_BegStat(); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__INIT(argc, argv)", 19); } else { OPM_WriteString((CHAR*)"__DEFMOD", 9); } OPC_EndStat(); - if ((__IN(10, OPM_opt, 32) && 0)) { + if ((__IN(10, OPM_Options, 32) && 0)) { OPC_BegStat(); OPM_WriteString((CHAR*)"/*don`t do it!*/ printf(\"DEMO VERSION: DO NOT USE THIS PROGRAM FOR ANY COMMERCIAL PURPOSE\\n\")", 94); OPC_EndStat(); } OPC_InitImports(OPT_topScope->right); OPC_BegStat(); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__REGMAIN(\"", 12); } else { OPM_WriteString((CHAR*)"__REGMOD(\"", 11); @@ -1399,7 +1399,7 @@ void OPC_EnterBody (void) void OPC_ExitBody (void) { OPC_BegStat(); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__FINI;", 8); } else { OPM_WriteString((CHAR*)"__ENDMOD;", 10); diff --git a/bootstrap/windows-48/OPC.h b/bootstrap/windows-48/OPC.h index 3325aded..e681f43d 100644 --- a/bootstrap/windows-48/OPC.h +++ b/bootstrap/windows-48/OPC.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPC__h #define OPC__h diff --git a/bootstrap/windows-48/OPM.c b/bootstrap/windows-48/OPM.c index 7234f518..534a5c0d 100644 --- a/bootstrap/windows-48/OPM.c +++ b/bootstrap/windows-48/OPM.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -19,7 +19,14 @@ typedef static CHAR OPM_SourceFileName[256]; -export int16 OPM_AddressSize, OPM_Alignment, OPM_SetSize, OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_MaxSet; +static CHAR OPM_GlobalModel[10]; +export CHAR OPM_Model[10]; +static int16 OPM_GlobalAddressSize; +export int16 OPM_AddressSize; +static int16 OPM_GlobalAlignment; +export int16 OPM_Alignment; +export SET OPM_GlobalOptions, OPM_Options; +export int16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize, OPM_MaxSet; export int64 OPM_MaxIndex; export LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; export BOOLEAN OPM_noerr; @@ -27,7 +34,6 @@ export int32 OPM_curpos, OPM_errpos, OPM_breakpc; export int16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; export CHAR OPM_modName[32]; export CHAR OPM_objname[64]; -export SET OPM_opt, OPM_glbopt; static int32 OPM_ErrorLineStartPos, OPM_ErrorLineLimitPos, OPM_ErrorLineNumber, OPM_lasterrpos; static Texts_Reader OPM_inR; static Texts_Text OPM_Log; @@ -36,8 +42,7 @@ static Files_Rider OPM_oldSF, OPM_newSF; static Files_Rider OPM_R[3]; static Files_File OPM_oldSFile, OPM_newSFile, OPM_HFile, OPM_BFile, OPM_HIFile; static int16 OPM_S; -static CHAR OPM_OBERON[1024]; -static CHAR OPM_MODULES[1024]; +export CHAR OPM_ResourceDir[1024]; static void OPM_Append (Files_Rider *R, address *R__typ, Files_File F); @@ -50,8 +55,6 @@ export void OPM_FPrintReal (int32 *fp, REAL real); export void OPM_FPrintSet (int32 *fp, SET set); static void OPM_FindLine (Files_File f, Files_Rider *r, address *r__typ, int64 pos); export void OPM_Get (CHAR *ch); -static void OPM_GetProperties (void); -static void OPM_GetProperty (Texts_Scanner *S, address *S__typ, CHAR *name, LONGINT name__len, int16 *size, int16 *align); export void OPM_Init (BOOLEAN *done, CHAR *mname, LONGINT mname__len); export void OPM_InitOptions (void); export int16 OPM_Integer (int64 n); @@ -68,7 +71,7 @@ export void OPM_OldSym (CHAR *modName, LONGINT modName__len, BOOLEAN *done); export void OPM_OpenFiles (CHAR *moduleName, LONGINT moduleName__len); export BOOLEAN OPM_OpenPar (void); export void OPM_RegisterNewSym (void); -static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt); +static void OPM_ScanOptions (CHAR *s, LONGINT s__len); static void OPM_ShowLine (int64 pos); export int64 OPM_SignedMaximum (int32 bytecount); export int64 OPM_SignedMinimum (int32 bytecount); @@ -93,10 +96,8 @@ 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 (int16 n); -static int32 OPM_minusop (int32 i); -static int32 OPM_power0 (int32 i, int32 j); -#define OPM_GetAlignment(a) struct {char c; long long l;} s; *a = (char*)&s.l - (char*)&s +#define OPM_GetAlignment(a) struct {char c; long long l;} _s; *a = (char*)&_s.l - (char*)&_s void OPM_LogW (CHAR ch) { @@ -120,6 +121,23 @@ void OPM_LogWLn (void) Console_Ln(); } +int64 OPM_SignedMaximum (int32 bytecount) +{ + int64 _o_result; + int64 result; + result = 1; + result = __LSH(result, __ASHL(bytecount, 3) - 1, 64); + _o_result = result - 1; + return _o_result; +} + +int64 OPM_SignedMinimum (int32 bytecount) +{ + int64 _o_result; + _o_result = -OPM_SignedMaximum(bytecount) - 1; + return _o_result; +} + int32 OPM_Longint (int64 n) { int32 _o_result; @@ -134,7 +152,7 @@ int16 OPM_Integer (int64 n) return _o_result; } -static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) +static void OPM_ScanOptions (CHAR *s, LONGINT s__len) { int16 i; __DUP(s, s__len, CHAR); @@ -142,75 +160,57 @@ static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) while (s[__X(i, s__len)] != 0x00) { switch (s[__X(i, s__len)]) { case 'p': - *opt = *opt ^ 0x20; + OPM_Options = OPM_Options ^ 0x20; break; case 'a': - *opt = *opt ^ 0x80; + OPM_Options = OPM_Options ^ 0x80; break; case 'r': - *opt = *opt ^ 0x04; + OPM_Options = OPM_Options ^ 0x04; break; case 't': - *opt = *opt ^ 0x08; + OPM_Options = OPM_Options ^ 0x08; break; case 'x': - *opt = *opt ^ 0x01; + OPM_Options = OPM_Options ^ 0x01; break; case 'e': - *opt = *opt ^ 0x0200; + OPM_Options = OPM_Options ^ 0x0200; break; case 's': - *opt = *opt ^ 0x10; + OPM_Options = OPM_Options ^ 0x10; break; case 'F': - *opt = *opt ^ 0x020000; + OPM_Options = OPM_Options ^ 0x020000; break; case 'm': - *opt = *opt ^ 0x0400; + OPM_Options = OPM_Options ^ 0x0400; break; case 'M': - *opt = *opt ^ 0x8000; + OPM_Options = OPM_Options ^ 0x8000; break; case 'S': - *opt = *opt ^ 0x2000; + OPM_Options = OPM_Options ^ 0x2000; break; case 'c': - *opt = *opt ^ 0x4000; + OPM_Options = OPM_Options ^ 0x4000; break; case 'f': - *opt = *opt ^ 0x010000; + OPM_Options = OPM_Options ^ 0x010000; break; case 'V': - *opt = *opt ^ 0x040000; + OPM_Options = OPM_Options ^ 0x040000; break; case 'O': if (i + 1 >= Strings_Length(s, s__len)) { OPM_LogWStr((CHAR*)"-O option requires following size model character.", 51); OPM_LogWLn(); } else { - switch (s[__X(i + 1, s__len)]) { - case '2': - OPM_ShortintSize = 1; - OPM_IntegerSize = 2; - OPM_LongintSize = 4; - OPM_SetSize = 4; - break; - case 'V': - OPM_ShortintSize = 1; - OPM_IntegerSize = 4; - OPM_LongintSize = 8; - OPM_SetSize = 8; - break; - case 'C': - OPM_ShortintSize = 2; - OPM_IntegerSize = 4; - OPM_LongintSize = 8; - OPM_SetSize = 8; - break; - default: - OPM_LogWStr((CHAR*)"Unrecognised size model character following -O.", 48); - OPM_LogWLn(); - break; + OPM_Model[0] = s[__X(i + 1, s__len)]; + OPM_Model[1] = 0x00; + if ((((OPM_Model[0] != '2' && OPM_Model[0] != 'C')) && OPM_Model[0] != 'V')) { + OPM_LogWStr((CHAR*)"Unrecognised size model character following -O.", 48); + OPM_LogWLn(); } i += 1; } @@ -358,39 +358,119 @@ BOOLEAN OPM_OpenPar (void) _o_result = 0; return _o_result; } else { + OPM_AddressSize = 4; + OPM_GetAlignment(&OPM_Alignment); + __MOVE("2", OPM_Model, 2); + OPM_Options = 0xa9; OPM_S = 1; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); - OPM_glbopt = 0xa9; while (s[0] == '-') { - OPM_ScanOptions(s, 256, &OPM_glbopt); + OPM_ScanOptions(s, 256); OPM_S += 1; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); } + OPM_GlobalAddressSize = OPM_AddressSize; + OPM_GlobalAlignment = OPM_Alignment; + __COPY(OPM_Model, OPM_GlobalModel, 10); + OPM_GlobalOptions = OPM_Options; _o_result = 1; return _o_result; } __RETCHK; } +static void OPM_VerboseListSizes (void) +{ + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Type Size", 15); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"SHORTINT ", 12); + OPM_LogWNum(OPM_ShortintSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"INTEGER ", 12); + OPM_LogWNum(OPM_IntegerSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"LONGINT ", 12); + OPM_LogWNum(OPM_LongintSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"SET ", 12); + OPM_LogWNum(OPM_SetSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"ADDRESS ", 12); + OPM_LogWNum(OPM_AddressSize, 4); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Alignment: ", 12); + OPM_LogWNum(OPM_Alignment, 4); + OPM_LogWLn(); +} + void OPM_InitOptions (void) { CHAR s[256]; - OPM_opt = OPM_glbopt; + CHAR searchpath[1024], modules[1024]; + CHAR MODULES[1024]; + OPM_Options = OPM_GlobalOptions; + __COPY(OPM_GlobalModel, OPM_Model, 10); + OPM_Alignment = OPM_GlobalAlignment; + OPM_AddressSize = OPM_GlobalAddressSize; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); while (s[0] == '-') { - OPM_ScanOptions(s, 256, &OPM_opt); + OPM_ScanOptions(s, 256); OPM_S += 1; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); } - if (__IN(15, OPM_opt, 32)) { - OPM_glbopt |= __SETOF(10,32); - OPM_opt |= __SETOF(10,32); + if (__IN(15, OPM_Options, 32)) { + OPM_Options |= __SETOF(10,32); } - OPM_GetProperties(); + OPM_MaxIndex = OPM_SignedMaximum(OPM_AddressSize); + switch (OPM_Model[0]) { + case '2': + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + case 'C': + OPM_ShortintSize = 2; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 8; + break; + case 'V': + OPM_ShortintSize = 1; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 8; + break; + default: + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + } + OPM_MaxSet = __ASHL(OPM_SetSize, 3) - 1; + if (__IN(18, OPM_Options, 32)) { + OPM_VerboseListSizes(); + } + OPM_ResourceDir[0] = 0x00; + Strings_Append((CHAR*)"/", 2, (void*)OPM_ResourceDir, 1024); + Strings_Append(OPM_Model, 10, (void*)OPM_ResourceDir, 1024); + modules[0] = 0x00; + Platform_GetEnv((CHAR*)"MODULES", 8, (void*)modules, 1024); + __MOVE(".", searchpath, 2); + Platform_GetEnv((CHAR*)"OBERON", 7, (void*)searchpath, 1024); + Strings_Append((CHAR*)";.;", 4, (void*)searchpath, 1024); + Strings_Append(modules, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)";", 2, (void*)searchpath, 1024); + Strings_Append(OPM_ResourceDir, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)"/sym;", 6, (void*)searchpath, 1024); + Files_SetSearchPath(searchpath, 1024); } void OPM_Init (BOOLEAN *done, CHAR *mname, LONGINT mname__len) @@ -474,20 +554,20 @@ static void OPM_LogErrMsg (int16 n) int16 i; CHAR buf[1024]; if (n >= 0) { - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"31m", 4); } OPM_LogWStr((CHAR*)" err ", 7); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } } else { - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"35m", 4); } OPM_LogWStr((CHAR*)" warning ", 11); n = -n; - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } } @@ -560,11 +640,11 @@ static void OPM_ShowLine (int64 pos) OPM_LogW(' '); i -= 1; } - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"32m", 4); } OPM_LogW('^'); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } Files_Close(f); @@ -654,106 +734,6 @@ void OPM_FPrintLReal (int32 *fp, LONGREAL lr) OPM_FPrint(&*fp, h); } -static void OPM_GetProperty (Texts_Scanner *S, address *S__typ, CHAR *name, LONGINT name__len, int16 *size, int16 *align) -{ - __DUP(name, name__len, CHAR); - if (((*S).class == 1 && __STRCMP((*S).s, name) == 0)) { - Texts_Scan(&*S, S__typ); - if ((*S).class == 3) { - *size = (int16)(*S).i; - Texts_Scan(&*S, S__typ); - } else { - OPM_Mark(-157, -1); - } - if ((*S).class == 3) { - *align = (int16)(*S).i; - Texts_Scan(&*S, S__typ); - } else { - OPM_Mark(-157, -1); - } - } else { - OPM_Mark(-157, -1); - } - __DEL(name); -} - -static int32 OPM_minusop (int32 i) -{ - int32 _o_result; - _o_result = -i; - return _o_result; -} - -static int32 OPM_power0 (int32 i, int32 j) -{ - int32 _o_result; - int32 k, p; - k = 1; - p = i; - do { - p = p * i; - k += 1; - } while (!(k == j)); - _o_result = p; - return _o_result; -} - -static void OPM_VerboseListSizes (void) -{ - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Type Size", 17); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"SHORTINT ", 14); - OPM_LogWNum(OPM_ShortintSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"INTEGER ", 14); - OPM_LogWNum(OPM_IntegerSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"LONGINT ", 14); - OPM_LogWNum(OPM_LongintSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"SET ", 14); - OPM_LogWNum(OPM_SetSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"ADDRESS ", 14); - OPM_LogWNum(OPM_AddressSize, 4); - OPM_LogWLn(); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Alignment: ", 12); - OPM_LogWNum(OPM_Alignment, 4); - OPM_LogWLn(); -} - -int64 OPM_SignedMaximum (int32 bytecount) -{ - int64 _o_result; - int64 result; - result = 1; - result = __LSH(result, __ASHL(bytecount, 3) - 1, 64); - _o_result = result - 1; - return _o_result; -} - -int64 OPM_SignedMinimum (int32 bytecount) -{ - int64 _o_result; - _o_result = -OPM_SignedMaximum(bytecount) - 1; - return _o_result; -} - -static void OPM_GetProperties (void) -{ - OPM_MaxReal = 3.40282346000000e+038; - OPM_MaxLReal = 1.79769296342094e+308; - OPM_MinReal = -OPM_MaxReal; - OPM_MinLReal = -OPM_MaxLReal; - OPM_MaxSet = __ASHL(OPM_SetSize, 3) - 1; - OPM_MaxIndex = OPM_SignedMaximum(OPM_AddressSize); - if (__IN(18, OPM_opt, 32)) { - OPM_VerboseListSizes(); - } -} - void OPM_SymRCh (CHAR *ch) { Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&*ch); @@ -848,7 +828,7 @@ void OPM_SymWLReal (LONGREAL lr) void OPM_RegisterNewSym (void) { - if (__STRCMP(OPM_modName, "SYSTEM") != 0 || __IN(10, OPM_opt, 32)) { + if (__STRCMP(OPM_modName, "SYSTEM") != 0 || __IN(10, OPM_Options, 32)) { Files_Register(OPM_newSFile); } } @@ -1047,10 +1027,10 @@ void OPM_CloseFiles (void) } if (OPM_noerr) { if (__STRCMP(OPM_modName, "SYSTEM") == 0) { - if (!__IN(10, OPM_opt, 32)) { + if (!__IN(10, OPM_Options, 32)) { Files_Register(OPM_BFile); } - } else if (!__IN(10, OPM_opt, 32)) { + } else if (!__IN(10, OPM_Options, 32)) { OPM_Append(&OPM_R[2], Files_Rider__typ, OPM_HFile); Files_Register(OPM_HIFile); Files_Register(OPM_BFile); @@ -1110,22 +1090,10 @@ export void *OPM__init(void) __REGCMD("RegisterNewSym", OPM_RegisterNewSym); __REGCMD("WriteLn", OPM_WriteLn); /* BEGIN */ + OPM_MaxReal = 3.40282346000000e+038; + OPM_MaxLReal = 1.79769296342094e+308; + OPM_MinReal = -OPM_MaxReal; + OPM_MinLReal = -OPM_MaxLReal; Texts_OpenWriter(&OPM_W, Texts_Writer__typ); - OPM_MODULES[0] = 0x00; - Platform_GetEnv((CHAR*)"MODULES", 8, (void*)OPM_MODULES, 1024); - __MOVE(".", OPM_OBERON, 2); - Platform_GetEnv((CHAR*)"OBERON", 7, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)";.;", 4, (void*)OPM_OBERON, 1024); - Strings_Append(OPM_MODULES, 1024, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)";", 2, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)"", 1, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)"/sym;", 6, (void*)OPM_OBERON, 1024); - Files_SetSearchPath(OPM_OBERON, 1024); - OPM_AddressSize = 4; - OPM_GetAlignment(&OPM_Alignment); - OPM_ShortintSize = 1; - OPM_IntegerSize = 2; - OPM_LongintSize = 4; - OPM_SetSize = 4; __ENDMOD; } diff --git a/bootstrap/windows-48/OPM.h b/bootstrap/windows-48/OPM.h index e249edd5..933ef1b5 100644 --- a/bootstrap/windows-48/OPM.h +++ b/bootstrap/windows-48/OPM.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPM__h #define OPM__h @@ -6,7 +6,10 @@ #include "SYSTEM.h" -import int16 OPM_AddressSize, OPM_Alignment, OPM_SetSize, OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_MaxSet; +import CHAR OPM_Model[10]; +import int16 OPM_AddressSize, OPM_Alignment; +import SET OPM_GlobalOptions, OPM_Options; +import int16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize, OPM_MaxSet; import int64 OPM_MaxIndex; import LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; import BOOLEAN OPM_noerr; @@ -14,7 +17,7 @@ import int32 OPM_curpos, OPM_errpos, OPM_breakpc; import int16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; import CHAR OPM_modName[32]; import CHAR OPM_objname[64]; -import SET OPM_opt, OPM_glbopt; +import CHAR OPM_ResourceDir[1024]; import void OPM_CloseFiles (void); diff --git a/bootstrap/windows-48/OPP.c b/bootstrap/windows-48/OPP.c index 1e5c6674..010efab1 100644 --- a/bootstrap/windows-48/OPP.c +++ b/bootstrap/windows-48/OPP.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-48/OPP.h b/bootstrap/windows-48/OPP.h index 3b9acd86..373d8daa 100644 --- a/bootstrap/windows-48/OPP.h +++ b/bootstrap/windows-48/OPP.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPP__h #define OPP__h diff --git a/bootstrap/windows-48/OPS.c b/bootstrap/windows-48/OPS.c index ee182741..f8ed61bf 100644 --- a/bootstrap/windows-48/OPS.c +++ b/bootstrap/windows-48/OPS.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-48/OPS.h b/bootstrap/windows-48/OPS.h index 1514d9eb..1f02668b 100644 --- a/bootstrap/windows-48/OPS.h +++ b/bootstrap/windows-48/OPS.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #ifndef OPS__h #define OPS__h diff --git a/bootstrap/windows-48/OPT.c b/bootstrap/windows-48/OPT.c index 0a1f8f54..3f54ed72 100644 --- a/bootstrap/windows-48/OPT.c +++ b/bootstrap/windows-48/OPT.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -1867,7 +1867,7 @@ void OPT_Export (BOOLEAN *ext, BOOLEAN *new) } OPT_OutObj(OPT_topScope->right); *ext = (OPT_sfpresent && OPT_symExtended); - *new = (!OPT_sfpresent || OPT_symNew) || __IN(17, OPM_opt, 32); + *new = (!OPT_sfpresent || OPT_symNew) || __IN(17, OPM_Options, 32); if ((((OPM_noerr && OPT_sfpresent)) && OPT_impCtxt.reffp != OPT_expCtxt.reffp)) { *new = 1; if (!OPT_extsf) { diff --git a/bootstrap/windows-48/OPT.h b/bootstrap/windows-48/OPT.h index d4f953ba..202c8278 100644 --- a/bootstrap/windows-48/OPT.h +++ b/bootstrap/windows-48/OPT.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPT__h #define OPT__h diff --git a/bootstrap/windows-48/OPV.c b/bootstrap/windows-48/OPV.c index a70a40bf..ff99f665 100644 --- a/bootstrap/windows-48/OPV.c +++ b/bootstrap/windows-48/OPV.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -211,7 +211,7 @@ static int16 OPV_Precedence (int16 class, int16 subclass, int16 form, int16 comp return _o_result; break; case 5: - if (__IN(3, OPM_opt, 32)) { + if (__IN(3, OPM_Options, 32)) { _o_result = 10; return _o_result; } else { @@ -397,7 +397,7 @@ static void OPV_Convert (OPT_Node n, OPT_Struct newtype, int16 prec) OPM_WriteInt(__ASHL(newtype->size, 3)); OPM_Write(')'); } else if (to == 4) { - if ((newtype->size < n->typ->size && __IN(2, OPM_opt, 32))) { + if ((newtype->size < n->typ->size && __IN(2, OPM_Options, 32))) { OPM_WriteString((CHAR*)"__SHORT", 8); if (OPV_SideEffects(n)) { OPM_Write('F'); @@ -412,7 +412,7 @@ static void OPV_Convert (OPT_Node n, OPT_Struct newtype, int16 prec) OPV_Entier(n, 9); } } else if (to == 3) { - if (__IN(2, OPM_opt, 32)) { + if (__IN(2, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__CHR", 6); if (OPV_SideEffects(n)) { OPM_Write('F'); @@ -453,7 +453,7 @@ static void OPV_TypeOf (OPT_Node n) static void OPV_Index (OPT_Node n, OPT_Node d, int16 prec, int16 dim) { - if (!__IN(0, OPM_opt, 32) || (n->right->class == 7 && (n->right->conval->intval == 0 || n->left->typ->comp != 3))) { + if (!__IN(0, OPM_Options, 32) || (n->right->class == 7 && (n->right->conval->intval == 0 || n->left->typ->comp != 3))) { OPV_expr(n->right, prec); } else { if (OPV_SideEffects(n->right)) { @@ -575,7 +575,7 @@ static void OPV_design (OPT_Node n, int16 prec) case 5: typ = n->typ; obj = n->left->obj; - if (__IN(3, OPM_opt, 32)) { + if (__IN(3, OPM_Options, 32)) { if (typ->comp == 4) { OPM_WriteString((CHAR*)"__GUARDR(", 10); if ((int16)obj->mnolev != OPM_level) { @@ -614,7 +614,7 @@ static void OPV_design (OPT_Node n, int16 prec) } break; case 6: - if (__IN(3, OPM_opt, 32)) { + if (__IN(3, OPM_Options, 32)) { if (n->left->class == 1) { OPM_WriteString((CHAR*)"__GUARDEQR(", 12); OPC_CompleteIdent(n->left->obj); @@ -1442,7 +1442,7 @@ static void OPV_stat (OPT_Node n, OPT_Object outerProc) case 20: if (n->subcl != 32) { OPV_IfStat(n, 0, outerProc); - } else if (__IN(7, OPM_opt, 32)) { + } else if (__IN(7, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__ASSERT(", 10); OPV_expr(n->left->left->left, -1); OPM_WriteString((CHAR*)", ", 3); @@ -1508,7 +1508,7 @@ static void OPV_stat (OPT_Node n, OPT_Object outerProc) break; case 26: if (OPM_level == 0) { - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__FINI", 7); } else { OPM_WriteString((CHAR*)"__ENDMOD", 9); @@ -1553,7 +1553,7 @@ static void OPV_stat (OPT_Node n, OPT_Object outerProc) void OPV_Module (OPT_Node prog) { - if (!__IN(10, OPM_opt, 32)) { + if (!__IN(10, OPM_Options, 32)) { OPC_GenHdr(prog->right); OPC_GenHdrIncludes(); } diff --git a/bootstrap/windows-48/OPV.h b/bootstrap/windows-48/OPV.h index 0a9135f5..a44fb5b5 100644 --- a/bootstrap/windows-48/OPV.h +++ b/bootstrap/windows-48/OPV.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPV__h #define OPV__h diff --git a/bootstrap/windows-48/Platform.c b/bootstrap/windows-48/Platform.c index 51a62ed7..41a1da42 100644 --- a/bootstrap/windows-48/Platform.c +++ b/bootstrap/windows-48/Platform.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -67,6 +67,7 @@ export int16 Platform_Identify (int32 h, Platform_FileIdentity *identity, addres export int16 Platform_IdentifyByName (CHAR *n, LONGINT n__len, Platform_FileIdentity *identity, address *identity__typ); export BOOLEAN Platform_Inaccessible (int16 e); export void Platform_Init (int16 argc, int32 argvadr); +export BOOLEAN Platform_Interrupted (int16 e); export void Platform_MTimeAsClock (Platform_FileIdentity i, int32 *t, int32 *d); export int16 Platform_New (CHAR *n, LONGINT n__len, int32 *h); export BOOLEAN Platform_NoSuchDirectory (int16 e); @@ -104,6 +105,7 @@ export BOOLEAN Platform_getEnv (CHAR *var, LONGINT var__len, CHAR *val, LONGINT #define Platform_ECONNABORTED() WSAECONNABORTED #define Platform_ECONNREFUSED() WSAECONNREFUSED #define Platform_EHOSTUNREACH() WSAEHOSTUNREACH +#define Platform_EINTR() WSAEINTR #define Platform_ENETUNREACH() WSAENETUNREACH #define Platform_ERRORACCESSDENIED() ERROR_ACCESS_DENIED #define Platform_ERRORFILENOTFOUND() ERROR_FILE_NOT_FOUND @@ -230,6 +232,13 @@ BOOLEAN Platform_ConnectionFailed (int16 e) return _o_result; } +BOOLEAN Platform_Interrupted (int16 e) +{ + BOOLEAN _o_result; + _o_result = e == Platform_EINTR(); + return _o_result; +} + int32 Platform_OSAllocate (int32 size) { int32 _o_result; diff --git a/bootstrap/windows-48/Platform.h b/bootstrap/windows-48/Platform.h index fff5ea74..7917d958 100644 --- a/bootstrap/windows-48/Platform.h +++ b/bootstrap/windows-48/Platform.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Platform__h #define Platform__h @@ -51,6 +51,7 @@ import int16 Platform_Identify (int32 h, Platform_FileIdentity *identity, addres import int16 Platform_IdentifyByName (CHAR *n, LONGINT n__len, Platform_FileIdentity *identity, address *identity__typ); import BOOLEAN Platform_Inaccessible (int16 e); import void Platform_Init (int16 argc, int32 argvadr); +import BOOLEAN Platform_Interrupted (int16 e); import void Platform_MTimeAsClock (Platform_FileIdentity i, int32 *t, int32 *d); import int16 Platform_New (CHAR *n, LONGINT n__len, int32 *h); import BOOLEAN Platform_NoSuchDirectory (int16 e); diff --git a/bootstrap/windows-48/Reals.c b/bootstrap/windows-48/Reals.c index e75d35ff..57e22100 100644 --- a/bootstrap/windows-48/Reals.c +++ b/bootstrap/windows-48/Reals.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-48/Reals.h b/bootstrap/windows-48/Reals.h index 8a42b39b..f3404dda 100644 --- a/bootstrap/windows-48/Reals.h +++ b/bootstrap/windows-48/Reals.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Reals__h #define Reals__h diff --git a/bootstrap/windows-48/Strings.c b/bootstrap/windows-48/Strings.c index 9f9562db..bcf3cb9b 100644 --- a/bootstrap/windows-48/Strings.c +++ b/bootstrap/windows-48/Strings.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-48/Strings.h b/bootstrap/windows-48/Strings.h index da213d81..9418692a 100644 --- a/bootstrap/windows-48/Strings.h +++ b/bootstrap/windows-48/Strings.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Strings__h #define Strings__h diff --git a/bootstrap/windows-48/Texts.c b/bootstrap/windows-48/Texts.c index ab510cdb..28f099a4 100644 --- a/bootstrap/windows-48/Texts.c +++ b/bootstrap/windows-48/Texts.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-48/Texts.h b/bootstrap/windows-48/Texts.h index 64e78861..0afd65f7 100644 --- a/bootstrap/windows-48/Texts.h +++ b/bootstrap/windows-48/Texts.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Texts__h #define Texts__h diff --git a/bootstrap/windows-48/errors.c b/bootstrap/windows-48/errors.c index 34e6fae3..ba890a17 100644 --- a/bootstrap/windows-48/errors.c +++ b/bootstrap/windows-48/errors.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-48/errors.h b/bootstrap/windows-48/errors.h index ce275b8c..d8124792 100644 --- a/bootstrap/windows-48/errors.h +++ b/bootstrap/windows-48/errors.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef errors__h #define errors__h diff --git a/bootstrap/windows-48/extTools.c b/bootstrap/windows-48/extTools.c index fd7974da..76fdc084 100644 --- a/bootstrap/windows-48/extTools.c +++ b/bootstrap/windows-48/extTools.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -12,10 +12,11 @@ #include "Strings.h" -static CHAR extTools_compilationOptions[1023], extTools_CFLAGS[1023]; +static CHAR extTools_CFLAGS[1023]; export void extTools_Assemble (CHAR *moduleName, LONGINT moduleName__len); +static void extTools_InitialiseCompilerCommand (CHAR *s, LONGINT s__len); export void extTools_LinkMain (CHAR *moduleName, LONGINT moduleName__len, BOOLEAN statically, CHAR *additionalopts, LONGINT additionalopts__len); static void extTools_execute (CHAR *title, LONGINT title__len, CHAR *cmd, LONGINT cmd__len); @@ -25,7 +26,7 @@ static void extTools_execute (CHAR *title, LONGINT title__len, CHAR *cmd, LONGIN int16 r, status, exitcode; __DUP(title, title__len, CHAR); __DUP(cmd, cmd__len, CHAR); - if (__IN(18, OPM_opt, 32)) { + if (__IN(18, OPM_Options, 32)) { Console_String(title, title__len); Console_String(cmd, cmd__len); Console_Ln(); @@ -60,12 +61,22 @@ static void extTools_execute (CHAR *title, LONGINT title__len, CHAR *cmd, LONGIN __DEL(cmd); } +static void extTools_InitialiseCompilerCommand (CHAR *s, LONGINT s__len) +{ + __COPY("gcc -g -O1", s, s__len); + Strings_Append((CHAR*)" -I \"", 6, (void*)s, s__len); + Strings_Append(OPM_ResourceDir, 1024, (void*)s, s__len); + Strings_Append((CHAR*)"/include\" ", 11, (void*)s, s__len); + Platform_GetEnv((CHAR*)"CFLAGS", 7, (void*)extTools_CFLAGS, 1023); + Strings_Append(extTools_CFLAGS, 1023, (void*)s, s__len); + Strings_Append((CHAR*)" ", 2, (void*)s, s__len); +} + void extTools_Assemble (CHAR *moduleName, LONGINT moduleName__len) { CHAR cmd[1023]; __DUP(moduleName, moduleName__len, CHAR); - __MOVE("gcc -g -O1", cmd, 11); - Strings_Append(extTools_compilationOptions, 1023, (void*)cmd, 1023); + extTools_InitialiseCompilerCommand((void*)cmd, 1023); Strings_Append((CHAR*)"-c ", 4, (void*)cmd, 1023); Strings_Append(moduleName, moduleName__len, (void*)cmd, 1023); Strings_Append((CHAR*)".c", 3, (void*)cmd, 1023); @@ -77,9 +88,7 @@ void extTools_LinkMain (CHAR *moduleName, LONGINT moduleName__len, BOOLEAN stati { CHAR cmd[1023]; __DUP(additionalopts, additionalopts__len, CHAR); - __MOVE("gcc -g -O1", cmd, 11); - Strings_Append((CHAR*)" ", 2, (void*)cmd, 1023); - Strings_Append(extTools_compilationOptions, 1023, (void*)cmd, 1023); + extTools_InitialiseCompilerCommand((void*)cmd, 1023); Strings_Append(moduleName, moduleName__len, (void*)cmd, 1023); Strings_Append((CHAR*)".c ", 4, (void*)cmd, 1023); Strings_Append(additionalopts, additionalopts__len, (void*)cmd, 1023); @@ -92,6 +101,7 @@ void extTools_LinkMain (CHAR *moduleName, LONGINT moduleName__len, BOOLEAN stati Strings_Append((CHAR*)"", 1, (void*)cmd, 1023); Strings_Append((CHAR*)"/lib\"", 6, (void*)cmd, 1023); Strings_Append((CHAR*)" -l voc", 8, (void*)cmd, 1023); + Strings_Append(OPM_Model, 10, (void*)cmd, 1023); extTools_execute((CHAR*)"Assemble and link: ", 20, cmd, 1023); __DEL(additionalopts); } @@ -107,11 +117,5 @@ export void *extTools__init(void) __MODULE_IMPORT(Strings); __REGMOD("extTools", 0); /* BEGIN */ - Strings_Append((CHAR*)" -I \"", 6, (void*)extTools_compilationOptions, 1023); - Strings_Append((CHAR*)"", 1, (void*)extTools_compilationOptions, 1023); - Strings_Append((CHAR*)"/include\" ", 11, (void*)extTools_compilationOptions, 1023); - Platform_GetEnv((CHAR*)"CFLAGS", 7, (void*)extTools_CFLAGS, 1023); - Strings_Append(extTools_CFLAGS, 1023, (void*)extTools_compilationOptions, 1023); - Strings_Append((CHAR*)" ", 2, (void*)extTools_compilationOptions, 1023); __ENDMOD; } diff --git a/bootstrap/windows-48/extTools.h b/bootstrap/windows-48/extTools.h index f87adfac..bb5be954 100644 --- a/bootstrap/windows-48/extTools.h +++ b/bootstrap/windows-48/extTools.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef extTools__h #define extTools__h diff --git a/bootstrap/windows-48/vt100.c b/bootstrap/windows-48/vt100.c index ca56f466..c44586d2 100644 --- a/bootstrap/windows-48/vt100.c +++ b/bootstrap/windows-48/vt100.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-48/vt100.h b/bootstrap/windows-48/vt100.h index f5b8588f..c9a01a7c 100644 --- a/bootstrap/windows-48/vt100.h +++ b/bootstrap/windows-48/vt100.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef vt100__h #define vt100__h diff --git a/bootstrap/windows-88/Compiler.c b/bootstrap/windows-88/Compiler.c index 6444021c..1b3b14f1 100644 --- a/bootstrap/windows-88/Compiler.c +++ b/bootstrap/windows-88/Compiler.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspamSf */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspamSf */ #define INTEGER int16 #define LONGINT int32 @@ -32,7 +32,7 @@ void Compiler_Module (BOOLEAN *done) { BOOLEAN ext, new; OPT_Node p = NIL; - OPP_Module(&p, OPM_opt); + OPP_Module(&p, OPM_Options); if (OPM_noerr) { OPV_Init(); OPT_InitRecno(); @@ -43,22 +43,22 @@ void Compiler_Module (BOOLEAN *done) OPC_Init(); OPV_Module(p); if (OPM_noerr) { - if ((__IN(10, OPM_opt, 32) && __STRCMP(OPM_modName, "SYSTEM") != 0)) { + if ((__IN(10, OPM_Options, 32) && __STRCMP(OPM_modName, "SYSTEM") != 0)) { OPM_DeleteNewSym(); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"32m", 4); } OPM_LogWStr((CHAR*)" Main program.", 16); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } } else { if (new) { - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"32m", 4); } OPM_LogWStr((CHAR*)" New symbol file.", 19); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } OPM_RegisterNewSym(); @@ -115,17 +115,17 @@ void Compiler_Translate (void) OPM_LogWLn(); Platform_Exit(1); } - if (!__IN(13, OPM_opt, 32)) { - if (__IN(14, OPM_opt, 32)) { + if (!__IN(13, OPM_Options, 32)) { + if (__IN(14, OPM_Options, 32)) { extTools_Assemble(OPM_modName, 32); } else { - if (!__IN(10, OPM_opt, 32)) { + if (!__IN(10, OPM_Options, 32)) { extTools_Assemble(OPM_modName, 32); Strings_Append((CHAR*)" ", 2, (void*)modulesobj, 2048); Strings_Append(OPM_modName, 32, (void*)modulesobj, 2048); Strings_Append((CHAR*)".o", 3, (void*)modulesobj, 2048); } else { - extTools_LinkMain((void*)OPM_modName, 32, __IN(15, OPM_opt, 32), modulesobj, 2048); + extTools_LinkMain((void*)OPM_modName, 32, __IN(15, OPM_Options, 32), modulesobj, 2048); } } } diff --git a/bootstrap/windows-88/Configuration.c b/bootstrap/windows-88/Configuration.c index 28528f64..85c8cf89 100644 --- a/bootstrap/windows-88/Configuration.c +++ b/bootstrap/windows-88/Configuration.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -18,6 +18,6 @@ export void *Configuration__init(void) __DEFMOD; __REGMOD("Configuration", 0); /* BEGIN */ - __MOVE("1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8.", Configuration_versionLong, 75); + __MOVE("1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8.", Configuration_versionLong, 75); __ENDMOD; } diff --git a/bootstrap/windows-88/Configuration.h b/bootstrap/windows-88/Configuration.h index d9030dbe..a365d693 100644 --- a/bootstrap/windows-88/Configuration.h +++ b/bootstrap/windows-88/Configuration.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Configuration__h #define Configuration__h diff --git a/bootstrap/windows-88/Console.c b/bootstrap/windows-88/Console.c index 11937ee4..7d63057e 100644 --- a/bootstrap/windows-88/Console.c +++ b/bootstrap/windows-88/Console.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-88/Console.h b/bootstrap/windows-88/Console.h index 4eb27c8b..08f4e38e 100644 --- a/bootstrap/windows-88/Console.h +++ b/bootstrap/windows-88/Console.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Console__h #define Console__h diff --git a/bootstrap/windows-88/Files.c b/bootstrap/windows-88/Files.c index 7d407820..72ef67df 100644 --- a/bootstrap/windows-88/Files.c +++ b/bootstrap/windows-88/Files.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-88/Files.h b/bootstrap/windows-88/Files.h index 1391c541..668d8ebf 100644 --- a/bootstrap/windows-88/Files.h +++ b/bootstrap/windows-88/Files.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #ifndef Files__h #define Files__h diff --git a/bootstrap/windows-88/Heap.c b/bootstrap/windows-88/Heap.c index ca208a31..71ad15a1 100644 --- a/bootstrap/windows-88/Heap.c +++ b/bootstrap/windows-88/Heap.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-88/Heap.h b/bootstrap/windows-88/Heap.h index 3fcd0b28..0cd62e2b 100644 --- a/bootstrap/windows-88/Heap.h +++ b/bootstrap/windows-88/Heap.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tsSfF */ #ifndef Heap__h #define Heap__h diff --git a/bootstrap/windows-88/Modules.c b/bootstrap/windows-88/Modules.c index e3ff56bd..0e05b5aa 100644 --- a/bootstrap/windows-88/Modules.c +++ b/bootstrap/windows-88/Modules.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-88/Modules.h b/bootstrap/windows-88/Modules.h index 93e2105b..a2ceebdf 100644 --- a/bootstrap/windows-88/Modules.h +++ b/bootstrap/windows-88/Modules.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Modules__h #define Modules__h diff --git a/bootstrap/windows-88/OPB.c b/bootstrap/windows-88/OPB.c index d211135a..e370e621 100644 --- a/bootstrap/windows-88/OPB.c +++ b/bootstrap/windows-88/OPB.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -1541,28 +1541,9 @@ static void OPB_CheckAssign (OPT_Struct x, OPT_Node ynode) OPT_Struct y = NIL; int16 f, g; OPT_Struct p = NIL, q = NIL; - if (__IN(18, OPM_opt, 32)) { - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"PROCEDURE CheckAssign", 22); - OPM_LogWLn(); - } y = ynode->typ; f = x->form; g = y->form; - if (__IN(18, OPM_opt, 32)) { - OPM_LogWStr((CHAR*)"y.form = ", 10); - OPM_LogWNum(y->form, 0); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"f = ", 5); - OPM_LogWNum(f, 0); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"g = ", 5); - OPM_LogWNum(g, 0); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"ynode.typ.syze = ", 18); - OPM_LogWNum(ynode->typ->size, 0); - OPM_LogWLn(); - } if (ynode->class == 8 || (ynode->class == 9 && f != 12)) { OPB_err(126); } @@ -2367,7 +2348,7 @@ static void OPB_DynArrParCheck (OPT_Struct ftyp, OPT_Struct atyp, BOOLEAN fvarpa atyp = atyp->BaseTyp; if ((fvarpar && ftyp == OPT_bytetyp)) { if (!__IN(f, 0x0c, 32) || !((__IN(atyp->form, 0x1e, 32) && atyp->size == 1))) { - if (__IN(18, OPM_opt, 32)) { + if (__IN(18, OPM_Options, 32)) { OPB_err(-301); } } diff --git a/bootstrap/windows-88/OPB.h b/bootstrap/windows-88/OPB.h index 97860bfc..8c0fd594 100644 --- a/bootstrap/windows-88/OPB.h +++ b/bootstrap/windows-88/OPB.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPB__h #define OPB__h diff --git a/bootstrap/windows-88/OPC.c b/bootstrap/windows-88/OPC.c index e4c0eb06..4c9ae495 100644 --- a/bootstrap/windows-88/OPC.c +++ b/bootstrap/windows-88/OPC.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -989,7 +989,7 @@ static void OPC_IdentList (OPT_Object obj, int16 vis) OPC_Ident(obj); OPM_WriteString((CHAR*)"__typ", 6); base = NIL; - } else if ((((((__IN(5, OPM_opt, 32) && vis == 0)) && obj->mnolev > 0)) && obj->typ->form == 11)) { + } else if ((((((__IN(5, OPM_Options, 32) && vis == 0)) && obj->mnolev > 0)) && obj->typ->form == 11)) { OPM_WriteString((CHAR*)" = NIL", 7); } } @@ -1153,7 +1153,7 @@ static void OPC_GenHeaderMsg (void) OPM_Write(' '); i = 0; while (i <= 31) { - if (__IN(i, OPM_glbopt, 32)) { + if (__IN(i, OPM_Options, 32)) { switch (i) { case 0: OPM_Write('x'); @@ -1355,7 +1355,7 @@ void OPC_EnterBody (void) { OPM_WriteLn(); OPM_WriteString((CHAR*)"export ", 8); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"int main(int argc, char **argv)", 32); OPM_WriteLn(); } else { @@ -1366,20 +1366,20 @@ void OPC_EnterBody (void) } OPC_BegBlk(); OPC_BegStat(); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__INIT(argc, argv)", 19); } else { OPM_WriteString((CHAR*)"__DEFMOD", 9); } OPC_EndStat(); - if ((__IN(10, OPM_opt, 32) && 0)) { + if ((__IN(10, OPM_Options, 32) && 0)) { OPC_BegStat(); OPM_WriteString((CHAR*)"/*don`t do it!*/ printf(\"DEMO VERSION: DO NOT USE THIS PROGRAM FOR ANY COMMERCIAL PURPOSE\\n\")", 94); OPC_EndStat(); } OPC_InitImports(OPT_topScope->right); OPC_BegStat(); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__REGMAIN(\"", 12); } else { OPM_WriteString((CHAR*)"__REGMOD(\"", 11); @@ -1399,7 +1399,7 @@ void OPC_EnterBody (void) void OPC_ExitBody (void) { OPC_BegStat(); - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__FINI;", 8); } else { OPM_WriteString((CHAR*)"__ENDMOD;", 10); diff --git a/bootstrap/windows-88/OPC.h b/bootstrap/windows-88/OPC.h index 3325aded..e681f43d 100644 --- a/bootstrap/windows-88/OPC.h +++ b/bootstrap/windows-88/OPC.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPC__h #define OPC__h diff --git a/bootstrap/windows-88/OPM.c b/bootstrap/windows-88/OPM.c index 4710b95f..297ade25 100644 --- a/bootstrap/windows-88/OPM.c +++ b/bootstrap/windows-88/OPM.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -19,7 +19,14 @@ typedef static CHAR OPM_SourceFileName[256]; -export int16 OPM_AddressSize, OPM_Alignment, OPM_SetSize, OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_MaxSet; +static CHAR OPM_GlobalModel[10]; +export CHAR OPM_Model[10]; +static int16 OPM_GlobalAddressSize; +export int16 OPM_AddressSize; +static int16 OPM_GlobalAlignment; +export int16 OPM_Alignment; +export SET OPM_GlobalOptions, OPM_Options; +export int16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize, OPM_MaxSet; export int64 OPM_MaxIndex; export LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; export BOOLEAN OPM_noerr; @@ -27,7 +34,6 @@ export int32 OPM_curpos, OPM_errpos, OPM_breakpc; export int16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; export CHAR OPM_modName[32]; export CHAR OPM_objname[64]; -export SET OPM_opt, OPM_glbopt; static int32 OPM_ErrorLineStartPos, OPM_ErrorLineLimitPos, OPM_ErrorLineNumber, OPM_lasterrpos; static Texts_Reader OPM_inR; static Texts_Text OPM_Log; @@ -36,8 +42,7 @@ static Files_Rider OPM_oldSF, OPM_newSF; static Files_Rider OPM_R[3]; static Files_File OPM_oldSFile, OPM_newSFile, OPM_HFile, OPM_BFile, OPM_HIFile; static int16 OPM_S; -static CHAR OPM_OBERON[1024]; -static CHAR OPM_MODULES[1024]; +export CHAR OPM_ResourceDir[1024]; static void OPM_Append (Files_Rider *R, address *R__typ, Files_File F); @@ -50,8 +55,6 @@ export void OPM_FPrintReal (int32 *fp, REAL real); export void OPM_FPrintSet (int32 *fp, SET set); static void OPM_FindLine (Files_File f, Files_Rider *r, address *r__typ, int64 pos); export void OPM_Get (CHAR *ch); -static void OPM_GetProperties (void); -static void OPM_GetProperty (Texts_Scanner *S, address *S__typ, CHAR *name, LONGINT name__len, int16 *size, int16 *align); export void OPM_Init (BOOLEAN *done, CHAR *mname, LONGINT mname__len); export void OPM_InitOptions (void); export int16 OPM_Integer (int64 n); @@ -68,7 +71,7 @@ export void OPM_OldSym (CHAR *modName, LONGINT modName__len, BOOLEAN *done); export void OPM_OpenFiles (CHAR *moduleName, LONGINT moduleName__len); export BOOLEAN OPM_OpenPar (void); export void OPM_RegisterNewSym (void); -static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt); +static void OPM_ScanOptions (CHAR *s, LONGINT s__len); static void OPM_ShowLine (int64 pos); export int64 OPM_SignedMaximum (int32 bytecount); export int64 OPM_SignedMinimum (int32 bytecount); @@ -93,10 +96,8 @@ 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 (int16 n); -static int32 OPM_minusop (int32 i); -static int32 OPM_power0 (int32 i, int32 j); -#define OPM_GetAlignment(a) struct {char c; long long l;} s; *a = (char*)&s.l - (char*)&s +#define OPM_GetAlignment(a) struct {char c; long long l;} _s; *a = (char*)&_s.l - (char*)&_s void OPM_LogW (CHAR ch) { @@ -120,6 +121,23 @@ void OPM_LogWLn (void) Console_Ln(); } +int64 OPM_SignedMaximum (int32 bytecount) +{ + int64 _o_result; + int64 result; + result = 1; + result = __LSH(result, __ASHL(bytecount, 3) - 1, 64); + _o_result = result - 1; + return _o_result; +} + +int64 OPM_SignedMinimum (int32 bytecount) +{ + int64 _o_result; + _o_result = -OPM_SignedMaximum(bytecount) - 1; + return _o_result; +} + int32 OPM_Longint (int64 n) { int32 _o_result; @@ -134,7 +152,7 @@ int16 OPM_Integer (int64 n) return _o_result; } -static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) +static void OPM_ScanOptions (CHAR *s, LONGINT s__len) { int16 i; __DUP(s, s__len, CHAR); @@ -142,75 +160,57 @@ static void OPM_ScanOptions (CHAR *s, LONGINT s__len, SET *opt) while (s[__X(i, s__len)] != 0x00) { switch (s[__X(i, s__len)]) { case 'p': - *opt = *opt ^ 0x20; + OPM_Options = OPM_Options ^ 0x20; break; case 'a': - *opt = *opt ^ 0x80; + OPM_Options = OPM_Options ^ 0x80; break; case 'r': - *opt = *opt ^ 0x04; + OPM_Options = OPM_Options ^ 0x04; break; case 't': - *opt = *opt ^ 0x08; + OPM_Options = OPM_Options ^ 0x08; break; case 'x': - *opt = *opt ^ 0x01; + OPM_Options = OPM_Options ^ 0x01; break; case 'e': - *opt = *opt ^ 0x0200; + OPM_Options = OPM_Options ^ 0x0200; break; case 's': - *opt = *opt ^ 0x10; + OPM_Options = OPM_Options ^ 0x10; break; case 'F': - *opt = *opt ^ 0x020000; + OPM_Options = OPM_Options ^ 0x020000; break; case 'm': - *opt = *opt ^ 0x0400; + OPM_Options = OPM_Options ^ 0x0400; break; case 'M': - *opt = *opt ^ 0x8000; + OPM_Options = OPM_Options ^ 0x8000; break; case 'S': - *opt = *opt ^ 0x2000; + OPM_Options = OPM_Options ^ 0x2000; break; case 'c': - *opt = *opt ^ 0x4000; + OPM_Options = OPM_Options ^ 0x4000; break; case 'f': - *opt = *opt ^ 0x010000; + OPM_Options = OPM_Options ^ 0x010000; break; case 'V': - *opt = *opt ^ 0x040000; + OPM_Options = OPM_Options ^ 0x040000; break; case 'O': if (i + 1 >= Strings_Length(s, s__len)) { OPM_LogWStr((CHAR*)"-O option requires following size model character.", 51); OPM_LogWLn(); } else { - switch (s[__X(i + 1, s__len)]) { - case '2': - OPM_ShortintSize = 1; - OPM_IntegerSize = 2; - OPM_LongintSize = 4; - OPM_SetSize = 4; - break; - case 'V': - OPM_ShortintSize = 1; - OPM_IntegerSize = 4; - OPM_LongintSize = 8; - OPM_SetSize = 8; - break; - case 'C': - OPM_ShortintSize = 2; - OPM_IntegerSize = 4; - OPM_LongintSize = 8; - OPM_SetSize = 8; - break; - default: - OPM_LogWStr((CHAR*)"Unrecognised size model character following -O.", 48); - OPM_LogWLn(); - break; + OPM_Model[0] = s[__X(i + 1, s__len)]; + OPM_Model[1] = 0x00; + if ((((OPM_Model[0] != '2' && OPM_Model[0] != 'C')) && OPM_Model[0] != 'V')) { + OPM_LogWStr((CHAR*)"Unrecognised size model character following -O.", 48); + OPM_LogWLn(); } i += 1; } @@ -358,39 +358,119 @@ BOOLEAN OPM_OpenPar (void) _o_result = 0; return _o_result; } else { + OPM_AddressSize = 8; + OPM_GetAlignment(&OPM_Alignment); + __MOVE("2", OPM_Model, 2); + OPM_Options = 0xa9; OPM_S = 1; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); - OPM_glbopt = 0xa9; while (s[0] == '-') { - OPM_ScanOptions(s, 256, &OPM_glbopt); + OPM_ScanOptions(s, 256); OPM_S += 1; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); } + OPM_GlobalAddressSize = OPM_AddressSize; + OPM_GlobalAlignment = OPM_Alignment; + __COPY(OPM_Model, OPM_GlobalModel, 10); + OPM_GlobalOptions = OPM_Options; _o_result = 1; return _o_result; } __RETCHK; } +static void OPM_VerboseListSizes (void) +{ + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Type Size", 15); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"SHORTINT ", 12); + OPM_LogWNum(OPM_ShortintSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"INTEGER ", 12); + OPM_LogWNum(OPM_IntegerSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"LONGINT ", 12); + OPM_LogWNum(OPM_LongintSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"SET ", 12); + OPM_LogWNum(OPM_SetSize, 4); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"ADDRESS ", 12); + OPM_LogWNum(OPM_AddressSize, 4); + OPM_LogWLn(); + OPM_LogWLn(); + OPM_LogWStr((CHAR*)"Alignment: ", 12); + OPM_LogWNum(OPM_Alignment, 4); + OPM_LogWLn(); +} + void OPM_InitOptions (void) { CHAR s[256]; - OPM_opt = OPM_glbopt; + CHAR searchpath[1024], modules[1024]; + CHAR MODULES[1024]; + OPM_Options = OPM_GlobalOptions; + __COPY(OPM_GlobalModel, OPM_Model, 10); + OPM_Alignment = OPM_GlobalAlignment; + OPM_AddressSize = OPM_GlobalAddressSize; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); while (s[0] == '-') { - OPM_ScanOptions(s, 256, &OPM_opt); + OPM_ScanOptions(s, 256); OPM_S += 1; s[0] = 0x00; Platform_GetArg(OPM_S, (void*)s, 256); } - if (__IN(15, OPM_opt, 32)) { - OPM_glbopt |= __SETOF(10,32); - OPM_opt |= __SETOF(10,32); + if (__IN(15, OPM_Options, 32)) { + OPM_Options |= __SETOF(10,32); } - OPM_GetProperties(); + OPM_MaxIndex = OPM_SignedMaximum(OPM_AddressSize); + switch (OPM_Model[0]) { + case '2': + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + case 'C': + OPM_ShortintSize = 2; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 8; + break; + case 'V': + OPM_ShortintSize = 1; + OPM_IntegerSize = 4; + OPM_LongintSize = 8; + OPM_SetSize = 8; + break; + default: + OPM_ShortintSize = 1; + OPM_IntegerSize = 2; + OPM_LongintSize = 4; + OPM_SetSize = 4; + break; + } + OPM_MaxSet = __ASHL(OPM_SetSize, 3) - 1; + if (__IN(18, OPM_Options, 32)) { + OPM_VerboseListSizes(); + } + OPM_ResourceDir[0] = 0x00; + Strings_Append((CHAR*)"/", 2, (void*)OPM_ResourceDir, 1024); + Strings_Append(OPM_Model, 10, (void*)OPM_ResourceDir, 1024); + modules[0] = 0x00; + Platform_GetEnv((CHAR*)"MODULES", 8, (void*)modules, 1024); + __MOVE(".", searchpath, 2); + Platform_GetEnv((CHAR*)"OBERON", 7, (void*)searchpath, 1024); + Strings_Append((CHAR*)";.;", 4, (void*)searchpath, 1024); + Strings_Append(modules, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)";", 2, (void*)searchpath, 1024); + Strings_Append(OPM_ResourceDir, 1024, (void*)searchpath, 1024); + Strings_Append((CHAR*)"/sym;", 6, (void*)searchpath, 1024); + Files_SetSearchPath(searchpath, 1024); } void OPM_Init (BOOLEAN *done, CHAR *mname, LONGINT mname__len) @@ -474,20 +554,20 @@ static void OPM_LogErrMsg (int16 n) int16 i; CHAR buf[1024]; if (n >= 0) { - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"31m", 4); } OPM_LogWStr((CHAR*)" err ", 7); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } } else { - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"35m", 4); } OPM_LogWStr((CHAR*)" warning ", 11); n = -n; - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } } @@ -560,11 +640,11 @@ static void OPM_ShowLine (int64 pos) OPM_LogW(' '); i -= 1; } - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"32m", 4); } OPM_LogW('^'); - if (!__IN(16, OPM_opt, 32)) { + if (!__IN(16, OPM_Options, 32)) { vt100_SetAttr((CHAR*)"0m", 3); } Files_Close(f); @@ -654,106 +734,6 @@ void OPM_FPrintLReal (int32 *fp, LONGREAL lr) OPM_FPrint(&*fp, h); } -static void OPM_GetProperty (Texts_Scanner *S, address *S__typ, CHAR *name, LONGINT name__len, int16 *size, int16 *align) -{ - __DUP(name, name__len, CHAR); - if (((*S).class == 1 && __STRCMP((*S).s, name) == 0)) { - Texts_Scan(&*S, S__typ); - if ((*S).class == 3) { - *size = (int16)(*S).i; - Texts_Scan(&*S, S__typ); - } else { - OPM_Mark(-157, -1); - } - if ((*S).class == 3) { - *align = (int16)(*S).i; - Texts_Scan(&*S, S__typ); - } else { - OPM_Mark(-157, -1); - } - } else { - OPM_Mark(-157, -1); - } - __DEL(name); -} - -static int32 OPM_minusop (int32 i) -{ - int32 _o_result; - _o_result = -i; - return _o_result; -} - -static int32 OPM_power0 (int32 i, int32 j) -{ - int32 _o_result; - int32 k, p; - k = 1; - p = i; - do { - p = p * i; - k += 1; - } while (!(k == j)); - _o_result = p; - return _o_result; -} - -static void OPM_VerboseListSizes (void) -{ - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Type Size", 17); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"SHORTINT ", 14); - OPM_LogWNum(OPM_ShortintSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"INTEGER ", 14); - OPM_LogWNum(OPM_IntegerSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"LONGINT ", 14); - OPM_LogWNum(OPM_LongintSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"SET ", 14); - OPM_LogWNum(OPM_SetSize, 4); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"ADDRESS ", 14); - OPM_LogWNum(OPM_AddressSize, 4); - OPM_LogWLn(); - OPM_LogWLn(); - OPM_LogWStr((CHAR*)"Alignment: ", 12); - OPM_LogWNum(OPM_Alignment, 4); - OPM_LogWLn(); -} - -int64 OPM_SignedMaximum (int32 bytecount) -{ - int64 _o_result; - int64 result; - result = 1; - result = __LSH(result, __ASHL(bytecount, 3) - 1, 64); - _o_result = result - 1; - return _o_result; -} - -int64 OPM_SignedMinimum (int32 bytecount) -{ - int64 _o_result; - _o_result = -OPM_SignedMaximum(bytecount) - 1; - return _o_result; -} - -static void OPM_GetProperties (void) -{ - OPM_MaxReal = 3.40282346000000e+038; - OPM_MaxLReal = 1.79769296342094e+308; - OPM_MinReal = -OPM_MaxReal; - OPM_MinLReal = -OPM_MaxLReal; - OPM_MaxSet = __ASHL(OPM_SetSize, 3) - 1; - OPM_MaxIndex = OPM_SignedMaximum(OPM_AddressSize); - if (__IN(18, OPM_opt, 32)) { - OPM_VerboseListSizes(); - } -} - void OPM_SymRCh (CHAR *ch) { Files_Read(&OPM_oldSF, Files_Rider__typ, (void*)&*ch); @@ -848,7 +828,7 @@ void OPM_SymWLReal (LONGREAL lr) void OPM_RegisterNewSym (void) { - if (__STRCMP(OPM_modName, "SYSTEM") != 0 || __IN(10, OPM_opt, 32)) { + if (__STRCMP(OPM_modName, "SYSTEM") != 0 || __IN(10, OPM_Options, 32)) { Files_Register(OPM_newSFile); } } @@ -1047,10 +1027,10 @@ void OPM_CloseFiles (void) } if (OPM_noerr) { if (__STRCMP(OPM_modName, "SYSTEM") == 0) { - if (!__IN(10, OPM_opt, 32)) { + if (!__IN(10, OPM_Options, 32)) { Files_Register(OPM_BFile); } - } else if (!__IN(10, OPM_opt, 32)) { + } else if (!__IN(10, OPM_Options, 32)) { OPM_Append(&OPM_R[2], Files_Rider__typ, OPM_HFile); Files_Register(OPM_HIFile); Files_Register(OPM_BFile); @@ -1110,22 +1090,10 @@ export void *OPM__init(void) __REGCMD("RegisterNewSym", OPM_RegisterNewSym); __REGCMD("WriteLn", OPM_WriteLn); /* BEGIN */ + OPM_MaxReal = 3.40282346000000e+038; + OPM_MaxLReal = 1.79769296342094e+308; + OPM_MinReal = -OPM_MaxReal; + OPM_MinLReal = -OPM_MaxLReal; Texts_OpenWriter(&OPM_W, Texts_Writer__typ); - OPM_MODULES[0] = 0x00; - Platform_GetEnv((CHAR*)"MODULES", 8, (void*)OPM_MODULES, 1024); - __MOVE(".", OPM_OBERON, 2); - Platform_GetEnv((CHAR*)"OBERON", 7, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)";.;", 4, (void*)OPM_OBERON, 1024); - Strings_Append(OPM_MODULES, 1024, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)";", 2, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)"", 1, (void*)OPM_OBERON, 1024); - Strings_Append((CHAR*)"/sym;", 6, (void*)OPM_OBERON, 1024); - Files_SetSearchPath(OPM_OBERON, 1024); - OPM_AddressSize = 8; - OPM_GetAlignment(&OPM_Alignment); - OPM_ShortintSize = 1; - OPM_IntegerSize = 2; - OPM_LongintSize = 4; - OPM_SetSize = 4; __ENDMOD; } diff --git a/bootstrap/windows-88/OPM.h b/bootstrap/windows-88/OPM.h index e249edd5..933ef1b5 100644 --- a/bootstrap/windows-88/OPM.h +++ b/bootstrap/windows-88/OPM.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPM__h #define OPM__h @@ -6,7 +6,10 @@ #include "SYSTEM.h" -import int16 OPM_AddressSize, OPM_Alignment, OPM_SetSize, OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_MaxSet; +import CHAR OPM_Model[10]; +import int16 OPM_AddressSize, OPM_Alignment; +import SET OPM_GlobalOptions, OPM_Options; +import int16 OPM_ShortintSize, OPM_IntegerSize, OPM_LongintSize, OPM_SetSize, OPM_MaxSet; import int64 OPM_MaxIndex; import LONGREAL OPM_MinReal, OPM_MaxReal, OPM_MinLReal, OPM_MaxLReal; import BOOLEAN OPM_noerr; @@ -14,7 +17,7 @@ import int32 OPM_curpos, OPM_errpos, OPM_breakpc; import int16 OPM_currFile, OPM_level, OPM_pc, OPM_entno; import CHAR OPM_modName[32]; import CHAR OPM_objname[64]; -import SET OPM_opt, OPM_glbopt; +import CHAR OPM_ResourceDir[1024]; import void OPM_CloseFiles (void); diff --git a/bootstrap/windows-88/OPP.c b/bootstrap/windows-88/OPP.c index f6a8dfc5..c9986e20 100644 --- a/bootstrap/windows-88/OPP.c +++ b/bootstrap/windows-88/OPP.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-88/OPP.h b/bootstrap/windows-88/OPP.h index 3b9acd86..373d8daa 100644 --- a/bootstrap/windows-88/OPP.h +++ b/bootstrap/windows-88/OPP.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPP__h #define OPP__h diff --git a/bootstrap/windows-88/OPS.c b/bootstrap/windows-88/OPS.c index ee182741..f8ed61bf 100644 --- a/bootstrap/windows-88/OPS.c +++ b/bootstrap/windows-88/OPS.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-88/OPS.h b/bootstrap/windows-88/OPS.h index 1514d9eb..1f02668b 100644 --- a/bootstrap/windows-88/OPS.h +++ b/bootstrap/windows-88/OPS.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. tspaSfF */ #ifndef OPS__h #define OPS__h diff --git a/bootstrap/windows-88/OPT.c b/bootstrap/windows-88/OPT.c index ad18ebdb..b0a12a18 100644 --- a/bootstrap/windows-88/OPT.c +++ b/bootstrap/windows-88/OPT.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -1867,7 +1867,7 @@ void OPT_Export (BOOLEAN *ext, BOOLEAN *new) } OPT_OutObj(OPT_topScope->right); *ext = (OPT_sfpresent && OPT_symExtended); - *new = (!OPT_sfpresent || OPT_symNew) || __IN(17, OPM_opt, 32); + *new = (!OPT_sfpresent || OPT_symNew) || __IN(17, OPM_Options, 32); if ((((OPM_noerr && OPT_sfpresent)) && OPT_impCtxt.reffp != OPT_expCtxt.reffp)) { *new = 1; if (!OPT_extsf) { diff --git a/bootstrap/windows-88/OPT.h b/bootstrap/windows-88/OPT.h index d4f953ba..202c8278 100644 --- a/bootstrap/windows-88/OPT.h +++ b/bootstrap/windows-88/OPT.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPT__h #define OPT__h diff --git a/bootstrap/windows-88/OPV.c b/bootstrap/windows-88/OPV.c index 09f3d249..07fa214f 100644 --- a/bootstrap/windows-88/OPV.c +++ b/bootstrap/windows-88/OPV.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -211,7 +211,7 @@ static int16 OPV_Precedence (int16 class, int16 subclass, int16 form, int16 comp return _o_result; break; case 5: - if (__IN(3, OPM_opt, 32)) { + if (__IN(3, OPM_Options, 32)) { _o_result = 10; return _o_result; } else { @@ -397,7 +397,7 @@ static void OPV_Convert (OPT_Node n, OPT_Struct newtype, int16 prec) OPM_WriteInt(__ASHL(newtype->size, 3)); OPM_Write(')'); } else if (to == 4) { - if ((newtype->size < n->typ->size && __IN(2, OPM_opt, 32))) { + if ((newtype->size < n->typ->size && __IN(2, OPM_Options, 32))) { OPM_WriteString((CHAR*)"__SHORT", 8); if (OPV_SideEffects(n)) { OPM_Write('F'); @@ -412,7 +412,7 @@ static void OPV_Convert (OPT_Node n, OPT_Struct newtype, int16 prec) OPV_Entier(n, 9); } } else if (to == 3) { - if (__IN(2, OPM_opt, 32)) { + if (__IN(2, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__CHR", 6); if (OPV_SideEffects(n)) { OPM_Write('F'); @@ -453,7 +453,7 @@ static void OPV_TypeOf (OPT_Node n) static void OPV_Index (OPT_Node n, OPT_Node d, int16 prec, int16 dim) { - if (!__IN(0, OPM_opt, 32) || (n->right->class == 7 && (n->right->conval->intval == 0 || n->left->typ->comp != 3))) { + if (!__IN(0, OPM_Options, 32) || (n->right->class == 7 && (n->right->conval->intval == 0 || n->left->typ->comp != 3))) { OPV_expr(n->right, prec); } else { if (OPV_SideEffects(n->right)) { @@ -575,7 +575,7 @@ static void OPV_design (OPT_Node n, int16 prec) case 5: typ = n->typ; obj = n->left->obj; - if (__IN(3, OPM_opt, 32)) { + if (__IN(3, OPM_Options, 32)) { if (typ->comp == 4) { OPM_WriteString((CHAR*)"__GUARDR(", 10); if ((int16)obj->mnolev != OPM_level) { @@ -614,7 +614,7 @@ static void OPV_design (OPT_Node n, int16 prec) } break; case 6: - if (__IN(3, OPM_opt, 32)) { + if (__IN(3, OPM_Options, 32)) { if (n->left->class == 1) { OPM_WriteString((CHAR*)"__GUARDEQR(", 12); OPC_CompleteIdent(n->left->obj); @@ -1442,7 +1442,7 @@ static void OPV_stat (OPT_Node n, OPT_Object outerProc) case 20: if (n->subcl != 32) { OPV_IfStat(n, 0, outerProc); - } else if (__IN(7, OPM_opt, 32)) { + } else if (__IN(7, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__ASSERT(", 10); OPV_expr(n->left->left->left, -1); OPM_WriteString((CHAR*)", ", 3); @@ -1508,7 +1508,7 @@ static void OPV_stat (OPT_Node n, OPT_Object outerProc) break; case 26: if (OPM_level == 0) { - if (__IN(10, OPM_opt, 32)) { + if (__IN(10, OPM_Options, 32)) { OPM_WriteString((CHAR*)"__FINI", 7); } else { OPM_WriteString((CHAR*)"__ENDMOD", 9); @@ -1553,7 +1553,7 @@ static void OPV_stat (OPT_Node n, OPT_Object outerProc) void OPV_Module (OPT_Node prog) { - if (!__IN(10, OPM_opt, 32)) { + if (!__IN(10, OPM_Options, 32)) { OPC_GenHdr(prog->right); OPC_GenHdrIncludes(); } diff --git a/bootstrap/windows-88/OPV.h b/bootstrap/windows-88/OPV.h index 0a9135f5..a44fb5b5 100644 --- a/bootstrap/windows-88/OPV.h +++ b/bootstrap/windows-88/OPV.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef OPV__h #define OPV__h diff --git a/bootstrap/windows-88/Platform.c b/bootstrap/windows-88/Platform.c index c0accb85..95dd629a 100644 --- a/bootstrap/windows-88/Platform.c +++ b/bootstrap/windows-88/Platform.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -67,6 +67,7 @@ export int16 Platform_Identify (int32 h, Platform_FileIdentity *identity, addres export int16 Platform_IdentifyByName (CHAR *n, LONGINT n__len, Platform_FileIdentity *identity, address *identity__typ); export BOOLEAN Platform_Inaccessible (int16 e); export void Platform_Init (int16 argc, int64 argvadr); +export BOOLEAN Platform_Interrupted (int16 e); export void Platform_MTimeAsClock (Platform_FileIdentity i, int32 *t, int32 *d); export int16 Platform_New (CHAR *n, LONGINT n__len, int32 *h); export BOOLEAN Platform_NoSuchDirectory (int16 e); @@ -104,6 +105,7 @@ export BOOLEAN Platform_getEnv (CHAR *var, LONGINT var__len, CHAR *val, LONGINT #define Platform_ECONNABORTED() WSAECONNABORTED #define Platform_ECONNREFUSED() WSAECONNREFUSED #define Platform_EHOSTUNREACH() WSAEHOSTUNREACH +#define Platform_EINTR() WSAEINTR #define Platform_ENETUNREACH() WSAENETUNREACH #define Platform_ERRORACCESSDENIED() ERROR_ACCESS_DENIED #define Platform_ERRORFILENOTFOUND() ERROR_FILE_NOT_FOUND @@ -230,6 +232,13 @@ BOOLEAN Platform_ConnectionFailed (int16 e) return _o_result; } +BOOLEAN Platform_Interrupted (int16 e) +{ + BOOLEAN _o_result; + _o_result = e == Platform_EINTR(); + return _o_result; +} + int64 Platform_OSAllocate (int64 size) { int64 _o_result; diff --git a/bootstrap/windows-88/Platform.h b/bootstrap/windows-88/Platform.h index dcdb5e82..b99b4747 100644 --- a/bootstrap/windows-88/Platform.h +++ b/bootstrap/windows-88/Platform.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Platform__h #define Platform__h @@ -51,6 +51,7 @@ import int16 Platform_Identify (int32 h, Platform_FileIdentity *identity, addres import int16 Platform_IdentifyByName (CHAR *n, LONGINT n__len, Platform_FileIdentity *identity, address *identity__typ); import BOOLEAN Platform_Inaccessible (int16 e); import void Platform_Init (int16 argc, int64 argvadr); +import BOOLEAN Platform_Interrupted (int16 e); import void Platform_MTimeAsClock (Platform_FileIdentity i, int32 *t, int32 *d); import int16 Platform_New (CHAR *n, LONGINT n__len, int32 *h); import BOOLEAN Platform_NoSuchDirectory (int16 e); diff --git a/bootstrap/windows-88/Reals.c b/bootstrap/windows-88/Reals.c index e75d35ff..57e22100 100644 --- a/bootstrap/windows-88/Reals.c +++ b/bootstrap/windows-88/Reals.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-88/Reals.h b/bootstrap/windows-88/Reals.h index 8a42b39b..f3404dda 100644 --- a/bootstrap/windows-88/Reals.h +++ b/bootstrap/windows-88/Reals.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Reals__h #define Reals__h diff --git a/bootstrap/windows-88/Strings.c b/bootstrap/windows-88/Strings.c index 9f9562db..bcf3cb9b 100644 --- a/bootstrap/windows-88/Strings.c +++ b/bootstrap/windows-88/Strings.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-88/Strings.h b/bootstrap/windows-88/Strings.h index da213d81..9418692a 100644 --- a/bootstrap/windows-88/Strings.h +++ b/bootstrap/windows-88/Strings.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Strings__h #define Strings__h diff --git a/bootstrap/windows-88/Texts.c b/bootstrap/windows-88/Texts.c index 2590cb27..a71cf72a 100644 --- a/bootstrap/windows-88/Texts.c +++ b/bootstrap/windows-88/Texts.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-88/Texts.h b/bootstrap/windows-88/Texts.h index 7800b252..47f1e428 100644 --- a/bootstrap/windows-88/Texts.h +++ b/bootstrap/windows-88/Texts.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef Texts__h #define Texts__h diff --git a/bootstrap/windows-88/errors.c b/bootstrap/windows-88/errors.c index 34e6fae3..ba890a17 100644 --- a/bootstrap/windows-88/errors.c +++ b/bootstrap/windows-88/errors.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-88/errors.h b/bootstrap/windows-88/errors.h index ce275b8c..d8124792 100644 --- a/bootstrap/windows-88/errors.h +++ b/bootstrap/windows-88/errors.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef errors__h #define errors__h diff --git a/bootstrap/windows-88/extTools.c b/bootstrap/windows-88/extTools.c index fd7974da..76fdc084 100644 --- a/bootstrap/windows-88/extTools.c +++ b/bootstrap/windows-88/extTools.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 @@ -12,10 +12,11 @@ #include "Strings.h" -static CHAR extTools_compilationOptions[1023], extTools_CFLAGS[1023]; +static CHAR extTools_CFLAGS[1023]; export void extTools_Assemble (CHAR *moduleName, LONGINT moduleName__len); +static void extTools_InitialiseCompilerCommand (CHAR *s, LONGINT s__len); export void extTools_LinkMain (CHAR *moduleName, LONGINT moduleName__len, BOOLEAN statically, CHAR *additionalopts, LONGINT additionalopts__len); static void extTools_execute (CHAR *title, LONGINT title__len, CHAR *cmd, LONGINT cmd__len); @@ -25,7 +26,7 @@ static void extTools_execute (CHAR *title, LONGINT title__len, CHAR *cmd, LONGIN int16 r, status, exitcode; __DUP(title, title__len, CHAR); __DUP(cmd, cmd__len, CHAR); - if (__IN(18, OPM_opt, 32)) { + if (__IN(18, OPM_Options, 32)) { Console_String(title, title__len); Console_String(cmd, cmd__len); Console_Ln(); @@ -60,12 +61,22 @@ static void extTools_execute (CHAR *title, LONGINT title__len, CHAR *cmd, LONGIN __DEL(cmd); } +static void extTools_InitialiseCompilerCommand (CHAR *s, LONGINT s__len) +{ + __COPY("gcc -g -O1", s, s__len); + Strings_Append((CHAR*)" -I \"", 6, (void*)s, s__len); + Strings_Append(OPM_ResourceDir, 1024, (void*)s, s__len); + Strings_Append((CHAR*)"/include\" ", 11, (void*)s, s__len); + Platform_GetEnv((CHAR*)"CFLAGS", 7, (void*)extTools_CFLAGS, 1023); + Strings_Append(extTools_CFLAGS, 1023, (void*)s, s__len); + Strings_Append((CHAR*)" ", 2, (void*)s, s__len); +} + void extTools_Assemble (CHAR *moduleName, LONGINT moduleName__len) { CHAR cmd[1023]; __DUP(moduleName, moduleName__len, CHAR); - __MOVE("gcc -g -O1", cmd, 11); - Strings_Append(extTools_compilationOptions, 1023, (void*)cmd, 1023); + extTools_InitialiseCompilerCommand((void*)cmd, 1023); Strings_Append((CHAR*)"-c ", 4, (void*)cmd, 1023); Strings_Append(moduleName, moduleName__len, (void*)cmd, 1023); Strings_Append((CHAR*)".c", 3, (void*)cmd, 1023); @@ -77,9 +88,7 @@ void extTools_LinkMain (CHAR *moduleName, LONGINT moduleName__len, BOOLEAN stati { CHAR cmd[1023]; __DUP(additionalopts, additionalopts__len, CHAR); - __MOVE("gcc -g -O1", cmd, 11); - Strings_Append((CHAR*)" ", 2, (void*)cmd, 1023); - Strings_Append(extTools_compilationOptions, 1023, (void*)cmd, 1023); + extTools_InitialiseCompilerCommand((void*)cmd, 1023); Strings_Append(moduleName, moduleName__len, (void*)cmd, 1023); Strings_Append((CHAR*)".c ", 4, (void*)cmd, 1023); Strings_Append(additionalopts, additionalopts__len, (void*)cmd, 1023); @@ -92,6 +101,7 @@ void extTools_LinkMain (CHAR *moduleName, LONGINT moduleName__len, BOOLEAN stati Strings_Append((CHAR*)"", 1, (void*)cmd, 1023); Strings_Append((CHAR*)"/lib\"", 6, (void*)cmd, 1023); Strings_Append((CHAR*)" -l voc", 8, (void*)cmd, 1023); + Strings_Append(OPM_Model, 10, (void*)cmd, 1023); extTools_execute((CHAR*)"Assemble and link: ", 20, cmd, 1023); __DEL(additionalopts); } @@ -107,11 +117,5 @@ export void *extTools__init(void) __MODULE_IMPORT(Strings); __REGMOD("extTools", 0); /* BEGIN */ - Strings_Append((CHAR*)" -I \"", 6, (void*)extTools_compilationOptions, 1023); - Strings_Append((CHAR*)"", 1, (void*)extTools_compilationOptions, 1023); - Strings_Append((CHAR*)"/include\" ", 11, (void*)extTools_compilationOptions, 1023); - Platform_GetEnv((CHAR*)"CFLAGS", 7, (void*)extTools_CFLAGS, 1023); - Strings_Append(extTools_CFLAGS, 1023, (void*)extTools_compilationOptions, 1023); - Strings_Append((CHAR*)" ", 2, (void*)extTools_compilationOptions, 1023); __ENDMOD; } diff --git a/bootstrap/windows-88/extTools.h b/bootstrap/windows-88/extTools.h index f87adfac..bb5be954 100644 --- a/bootstrap/windows-88/extTools.h +++ b/bootstrap/windows-88/extTools.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef extTools__h #define extTools__h diff --git a/bootstrap/windows-88/vt100.c b/bootstrap/windows-88/vt100.c index ca56f466..c44586d2 100644 --- a/bootstrap/windows-88/vt100.c +++ b/bootstrap/windows-88/vt100.c @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #define INTEGER int16 #define LONGINT int32 diff --git a/bootstrap/windows-88/vt100.h b/bootstrap/windows-88/vt100.h index f5b8588f..c9a01a7c 100644 --- a/bootstrap/windows-88/vt100.h +++ b/bootstrap/windows-88/vt100.h @@ -1,4 +1,4 @@ -/* voc 1.95 [2016/09/24]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ +/* voc 1.95 [2016/09/26]. Bootstrapping compiler for address size 8, alignment 8. xtspaSfF */ #ifndef vt100__h #define vt100__h diff --git a/makefile b/makefile index 893e59bc..df72a78b 100644 --- a/makefile +++ b/makefile @@ -190,29 +190,29 @@ browsercmd: configuration # library: build all directories under src/library library: configuration - @make -f src/tools/make/oberon.mk -s library + @make -f src/tools/make/oberon.mk -s library MODEL=2 # Individual library components v4: configuration - @make -f src/tools/make/oberon.mk -s v4 + @make -f src/tools/make/oberon.mk -s v4 MODEL=2 ooc2: configuration - @make -f src/tools/make/oberon.mk -s ooc2 + @make -f src/tools/make/oberon.mk -s ooc2 MODEL=2 ooc: configuration - @make -f src/tools/make/oberon.mk -s ooc + @make -f src/tools/make/oberon.mk -s ooc MODEL=2 ulm: configuration - @make -f src/tools/make/oberon.mk -s ulm + @make -f src/tools/make/oberon.mk -s ulm MODEL=2 pow32: configuration - @make -f src/tools/make/oberon.mk -s pow32 + @make -f src/tools/make/oberon.mk -s pow32 MODEL=2 misc: configuration - @make -f src/tools/make/oberon.mk -s misc + @make -f src/tools/make/oberon.mk -s misc MODEL=2 s3: configuration - @make -f src/tools/make/oberon.mk -s s3 + @make -f src/tools/make/oberon.mk -s s3 MODEL=2 @@ -247,8 +247,8 @@ planned-binary-change: # built then run 'make revertbootstrap' first. bootstrap: bootstrapconfiguration @make -f src/tools/make/oberon.mk -s clean - @make -f src/tools/make/oberon.mk -s translate - @make -f src/tools/make/oberon.mk -s assemble + @make -f src/tools/make/oberon.mk -s translate MODEL=2 + @make -f src/tools/make/oberon.mk -s assemble MODEL=2 rm -rf bootstrap/* make -f src/tools/make/oberon.mk -s translate MODEL=2 INTSIZE=2 ADRSIZE=4 ALIGNMENT=4 PLATFORM=unix BUILDDIR=bootstrap/unix-44 && rm bootstrap/unix-44/*.sym make -f src/tools/make/oberon.mk -s translate MODEL=2 INTSIZE=2 ADRSIZE=4 ALIGNMENT=8 PLATFORM=unix BUILDDIR=bootstrap/unix-48 && rm bootstrap/unix-48/*.sym diff --git a/src/library/ooc/oocLRealMath.Mod b/src/library/ooc/oocLRealMath.Mod index 3da0cf96..552f8c20 100644 --- a/src/library/ooc/oocLRealMath.Mod +++ b/src/library/ooc/oocLRealMath.Mod @@ -1,42 +1,42 @@ MODULE oocLRealMath; (* - LRealMath - Target independent mathematical functions for LONGREAL + LRealMath - Target independent mathematical functions for LONGREAL (IEEE double-precision) numbers. - + Numerical approximations are taken from "Software Manual for the Elementary Functions" by Cody & Waite and "Computer Approximations" - by Hart et al. - + by Hart et al. + Copyright (C) 1996-1998 Michael Griebling - + This module is free software; you can redistribute it and/or modify - it under the terms of the GNU Lesser General Public License as + it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. - + This module is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. - + You should have received a copy of the GNU Lesser General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *) -IMPORT l := oocLowLReal, m := oocRealMath; - +IMPORT l := oocLowLReal, m := oocRealMath, SYSTEM; + CONST pi* = 3.1415926535897932384626433832795028841972D0; exp1* = 2.7182818284590452353602874713526624977572D0; - ZERO=0.0D0; ONE=1.0D0; HALF=0.5D0; TWO=2.0D0; (* local constants *) - + ZERO=0.0D0; ONE=1.0D0; HALF=0.5D0; TWO=2.0D0; (* local constants *) + (* internally-used constants *) huge=l.large; (* largest number this package accepts *) - miny=l.small; (* smallest number this package accepts *) + miny=l.small; (* smallest number this package accepts *) sqrtHalf=0.70710678118654752440D0; Limit=1.0536712D-8; (* 2**(-MantBits/2) *) eps=5.5511151D-17; (* 2**(-MantBits-1) *) @@ -44,30 +44,30 @@ CONST piByTwo=1.57079632679489661923D0; lnv=0.6931610107421875D0; (* should be exact *) vbytwo=0.13830277879601902638D-4; (* used in sinh/cosh *) - ln2Inv=1.44269504088896340735992468100189213D0; - + ln2Inv=1.44269504088896340735992468100189213D0; + (* error/exception codes *) - NoError*=m.NoError; IllegalRoot*=m.IllegalRoot; IllegalLog*=m.IllegalLog; Overflow*=m.Overflow; - IllegalPower*=m.IllegalPower; IllegalLogBase*=m.IllegalLogBase; IllegalTrig*=m.IllegalTrig; - IllegalInvTrig*=m.IllegalInvTrig; HypInvTrigClipped*=m.HypInvTrigClipped; + NoError*=m.NoError; IllegalRoot*=m.IllegalRoot; IllegalLog*=m.IllegalLog; Overflow*=m.Overflow; + IllegalPower*=m.IllegalPower; IllegalLogBase*=m.IllegalLogBase; IllegalTrig*=m.IllegalTrig; + IllegalInvTrig*=m.IllegalInvTrig; HypInvTrigClipped*=m.HypInvTrigClipped; IllegalHypInvTrig*=m.IllegalHypInvTrig; LossOfAccuracy*=m.LossOfAccuracy; - + VAR a1: ARRAY 18 OF LONGREAL; (* lookup table for power function *) - a2: ARRAY 9 OF LONGREAL; (* lookup table for power function *) - em: LONGREAL; (* largest number such that 1+epsilon > 1.0 *) + a2: ARRAY 9 OF LONGREAL; (* lookup table for power function *) + em: LONGREAL; (* largest number such that 1+epsilon > 1.0 *) LnInfinity: LONGREAL; (* natural log of infinity *) LnSmall: LONGREAL; (* natural log of very small number *) SqrtInfinity: LONGREAL; (* square root of infinity *) TanhMax: LONGREAL; (* maximum Tanh value *) t: LONGREAL; (* internal variables *) - + (* internally used support routines *) PROCEDURE SinCos (x, y, sign: LONGREAL): LONGREAL; CONST ymax=210828714; (* ENTIER(pi*2**(MantBits/2)) *) - c1=3.1416015625D0; + c1=3.1416015625D0; c2=-8.908910206761537356617D-6; r1=-0.16666666666666665052D+0; r2= 0.83333333333331650314D-2; @@ -77,24 +77,24 @@ PROCEDURE SinCos (x, y, sign: LONGREAL): LONGREAL; r6= 0.16058936490371589114D-9; r7=-0.76429178068910467734D-12; r8= 0.27204790957888846175D-14; - VAR - n: LONGINT; xn, f, x1, g: LONGREAL; + VAR + n: LONGINT; xn, f, x1, g: LONGREAL; BEGIN IF y>=ymax THEN l.ErrorHandler(LossOfAccuracy); RETURN ZERO END; - + (* determine the reduced number *) n:=ENTIER(y*piInv+HALF); xn:=n; IF ODD(n) THEN sign:=-sign END; x:=ABS(x); IF x#y THEN xn:=xn-HALF END; - + (* fractional part of reduced number *) x1:=ENTIER(x); f:=((x1-xn*c1)+(x-x1))-xn*c2; - + (* Pre: |f| <= pi/2 *) IF ABS(f)= 0 *) - CONST + CONST P0=0.41731; P1=0.59016; - VAR - xMant, yEst, z: LONGREAL; xExp: INTEGER; + VAR + xMant, yEst, z: LONGREAL; xExp: INTEGER; BEGIN (* optimize zeros and check for illegal negative roots *) IF x=ZERO THEN RETURN ZERO END; IF x=ZERO THEN n:=SHORT(ENTIER(ln2Inv*x+HALF)) ELSE n:=SHORT(ENTIER(ln2Inv*x-HALF)) END; xn:=n; g:=(x-xn*c1)-xn*c2; - + (* Calculate exp(g)/2 from "Software Manual for the Elementary Functions" *) z:=g*g; p:=((P2*z+P1)*z+P0)*g; q:=(Q2*z+Q1)*z+HALF; RETURN l.scale(HALF+p/(q-p), n+1) END exp; - + PROCEDURE ln*(x: LONGREAL): LONGREAL; (* Returns the natural logarithm of x for x > 0 *) CONST @@ -175,27 +175,27 @@ PROCEDURE ln*(x: LONGREAL): LONGREAL; BEGIN (* ensure illegal inputs are trapped and handled *) IF x<=ZERO THEN l.ErrorHandler(IllegalLog); RETURN -huge END; - + (* reduce the range of the input *) f:=l.fraction(x)*HALF; n:=l.exponent(x)+1; IF f>sqrtHalf THEN zn:=(f-HALF)-HALF; zd:=f*HALF+HALF - ELSE zn:=f-HALF; zd:=zn*HALF+HALF; DEC(n) + ELSE zn:=f-HALF; zd:=zn*HALF+HALF; DEC(n) END; - + (* evaluate rational approximation from "Software Manual for the Elementary Functions" *) z:=zn/zd; w:=z*z; q:=((w+Q2)*w+Q1)*w+Q0; p:=w*((P2*w+P1)*w+P0); r:=z+z*(p/q); - + (* scale the output *) - xn:=n; + xn:=n; RETURN (xn*c2+r)+xn*c1 END ln; - + (* The angle in all trigonometric functions is measured in radians *) - + PROCEDURE sin* (x: LONGREAL): LONGREAL; BEGIN - IF x 0 *) - CONST - P1=0.83333333333333211405D-1; P2=0.12500000000503799174D-1; - P3=0.22321421285924258967D-2; P4=0.43445775672163119635D-3; - K=0.44269504088896340736D0; - Q1=0.69314718055994529629D+0; Q2=0.24022650695909537056D+0; + CONST + P1=0.83333333333333211405D-1; P2=0.12500000000503799174D-1; + P3=0.22321421285924258967D-2; P4=0.43445775672163119635D-3; + K=0.44269504088896340736D0; + Q1=0.69314718055994529629D+0; Q2=0.24022650695909537056D+0; Q3=0.55504108664085595326D-1; Q4=0.96181290595172416964D-2; Q5=0.13333541313585784703D-2; Q6=0.15400290440989764601D-3; Q7=0.14928852680595608186D-4; OneOver16=0.0625D0; XMAX=16*l.expoMax-1; (*XMIN=16*l.expoMin+1;*) XMIN=-16351; (* noch *) - VAR z, g, R, v, u2, u1, w1, w2, y1, y2, w: LONGREAL; m, p, i: INTEGER; mp, pp, iw1: LONGINT; + VAR z, g, R, v, u2, u1, w1, w2, y1, y2, w: LONGREAL; m, p, i: INTEGER; mp, pp, iw1: LONGINT; BEGIN (* handle all possible error conditions *) IF ABS(exponent)ZERO THEN RETURN ZERO ELSE l.ErrorHandler(Overflow); RETURN -huge END END; - + (* extract the exponent of base to m and clear exponent of base in g *) g:=l.fraction(base)*HALF; m:=l.exponent(base)+1; - + (* determine p table offset with an unrolled binary search *) p:=1; IF g<=a1[9] THEN p:=9 END; IF g<=a1[p+4] THEN INC(p, 4) END; IF g<=a1[p+2] THEN INC(p, 2) END; - + (* compute scaled z so that |z| <= 0.044 *) z:=((g-a1[p+1])-a2[(p+1) DIV 2])/(g+a1[p+1]); z:=z+z; (* approximation for log2(z) from "Software Manual for the Elementary Functions" *) - v:=z*z; R:=(((P4*v+P3)*v+P2)*v+P1)*v*z; R:=R+K*R; u2:=(R+z*K)+z; u1:=(m*16-p)*OneOver16; - + v:=z*z; R:=(((P4*v+P3)*v+P2)*v+P1)*v*z; R:=R+K*R; u2:=(R+z*K)+z; u1:=(m*16-p)*OneOver16; + (* generate w with extra precision calculations *) y1:=ENTIER(16*exponent)*OneOver16; y2:=exponent-y1; w:=u2*exponent+u1*y2; w1:=ENTIER(16*w)*OneOver16; w2:=w-w1; w:=w1+u1*y1; @@ -283,14 +283,14 @@ BEGIN IF iw1>XMAX THEN l.ErrorHandler(Overflow); RETURN huge ELSIF iw1ZERO THEN INC(iw1); w2:=w2-OneOver16 END; IF iw1<0 THEN i:=0 ELSE i:=1 END; - mp:=div(iw1, 16)+i; pp:=16*mp-iw1; - z:=((((((Q7*w2+Q6)*w2+Q5)*w2+Q4)*w2+Q3)*w2+Q2)*w2+Q1)*w2; z:=a1[pp+1]+a1[pp+1]*z; + mp:=div(iw1, 16)+i; pp:=16*mp-iw1; + z:=((((((Q7*w2+Q6)*w2+Q5)*w2+Q4)*w2+Q3)*w2+Q2)*w2+Q1)*w2; z:=a1[pp+1]+a1[pp+1]*z; RETURN l.scale(z, SHORT(mp)) END power; - + PROCEDURE round*(x: LONGREAL): LONGINT; (* Returns the value of x rounded to the nearest integer *) BEGIN @@ -298,7 +298,7 @@ BEGIN ELSE RETURN ENTIER(x+HALF) END END round; - + PROCEDURE IsRMathException*(): BOOLEAN; (* Returns TRUE if the current coroutine is in the exceptional execution state because of the raising of the RealMath exception; otherwise returns FALSE. @@ -307,15 +307,15 @@ BEGIN RETURN FALSE END IsRMathException; - -(* + +(* Following routines are provided as extensions to the ISO standard. They are either used as the basis of other functions or provide - useful functions which are not part of the ISO standard. + useful functions which are not part of the ISO standard. *) PROCEDURE log* (x, base: LONGREAL): LONGREAL; -(* log(x,base) is the logarithm of x base b. All positive arguments are +(* log(x,base) is the logarithm of x base b. All positive arguments are allowed but base > 0 and base # 1. *) BEGIN (* log(x, base) = log2(x) / log2(base) *) @@ -324,9 +324,9 @@ BEGIN END END log; -PROCEDURE ipower* (x: LONGREAL; base: INTEGER): LONGREAL; +PROCEDURE ipower* (x: LONGREAL; base: INTEGER): LONGREAL; (* ipower(x, base) returns the x to the integer power base where base*Log2(x) < Log2(Max) *) - VAR y: LONGREAL; neg: BOOLEAN; Exp: LONGINT; + VAR y: LONGREAL; neg: BOOLEAN; Exp: LONGINT; PROCEDURE Adjust(xadj: LONGREAL): LONGREAL; BEGIN @@ -336,17 +336,17 @@ PROCEDURE ipower* (x: LONGREAL; base: INTEGER): LONGREAL; BEGIN (* handle all possible error conditions *) IF base=0 THEN RETURN ONE (* x**0 = 1 *) - ELSIF ABS(x)0 THEN RETURN ZERO ELSE l.ErrorHandler(Overflow); RETURN Adjust(huge) END END; (* trap potential overflows and underflows *) - Exp:=(l.exponent(x)+1)*base; y:=LnInfinity*ln2Inv; + Exp:=(l.exponent(x)+1)*base; y:=LnInfinity*ln2Inv; IF Exp>y THEN l.ErrorHandler(Overflow); RETURN Adjust(huge) ELSIF Exp<-y THEN RETURN ZERO - END; - - (* compute x**base using an optimised algorithm from Knuth, slightly + END; + + (* compute x**base using an optimised algorithm from Knuth, slightly altered : p442, The Art Of Computer Programming, Vol 2 *) y:=ONE; IF base<0 THEN neg:=TRUE; base := -base ELSE neg:= FALSE END; LOOP @@ -355,19 +355,19 @@ BEGIN x:=x*x; END; IF neg THEN RETURN ONE/y ELSE RETURN y END -END ipower; +END ipower; PROCEDURE sincos* (x: LONGREAL; VAR Sin, Cos: LONGREAL); (* More efficient sin/cos implementation if both values are needed. *) BEGIN Sin:=sin(x); Cos:=sqrt(ONE-Sin*Sin) -END sincos; +END sincos; PROCEDURE arctan2* (xn, xd: LONGREAL): LONGREAL; -(* arctan2(xn,xd) is the quadrant-correct arc tangent atan(xn/xd). If the +(* arctan2(xn,xd) is the quadrant-correct arc tangent atan(xn/xd). If the denominator xd is zero, then the numerator xn must not be zero. All arguments are legal except xn = xd = 0. *) - CONST + CONST P0=0.216062307897242551884D+3; P1=0.3226620700132512059245D+3; P2=0.13270239816397674701D+3; P3=0.1288838303415727934D+2; Q0=0.2160623078972426128957D+3; Q1=0.3946828393122829592162D+3; @@ -387,15 +387,15 @@ BEGIN IF ABS(xn)>ABS(xd) THEN z:=ABS(xd/xn); Quadrant:=2 ELSE z:=ABS(xn/xd); Quadrant:=0 END; - + (* further reduce range to within 0 to 2-sqrt(3) *) IF z>TWO-Sqrt3 THEN z:=(z*Sqrt3-ONE)/(Sqrt3+z); INC(Quadrant) END; - + (* approximation from "Computer Approximations" table ARCTN 5075 *) IF ABS(z)1 THEN atan:=-atan END; CASE Quadrant OF @@ -405,20 +405,20 @@ BEGIN | ELSE (* angle is correct *) END END; - + (* map negative xds into the correct quadrant *) IF xdLnInfinity THEN (* handle exp overflows *) y:=y-lnv; - IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow); + IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow); IF x>ZERO THEN RETURN huge ELSE RETURN -huge END ELSE f:=exp(y); f:=f+f*vbytwo (* don't change to f(1+vbytwo) *) END ELSE f:=exp(y); f:=(f-ONE/f)*HALF END; - - (* reach here when 1 < ABS(x) < LnInfinity-lnv+0.69 *) - IF x>ZERO THEN RETURN f ELSE RETURN -f END + + (* reach here when 1 < ABS(x) < LnInfinity-lnv+0.69 *) + IF x>ZERO THEN RETURN f ELSE RETURN -f END END sinh; - + PROCEDURE cosh* (x: LONGREAL): LONGREAL; (* cosh(x) is the hyperbolic cosine of x. The argument x must not be so large - that exp(|x|) overflows. *) + that exp(|x|) overflows. *) VAR y, f: LONGREAL; BEGIN y:=ABS(x); IF y>LnInfinity THEN (* handle exp overflows *) y:=y-lnv; - IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow); + IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow); IF x>ZERO THEN RETURN huge ELSE RETURN -huge END ELSE f:=exp(y); RETURN f+f*vbytwo (* don't change to f(1+vbytwo) *) END ELSE f:=exp(y); RETURN (f+ONE/f)*HALF END END cosh; - + PROCEDURE tanh* (x: LONGREAL): LONGREAL; (* tanh(x) is the hyperbolic tangent of x. All arguments are legal. *) - CONST - P0=-0.16134119023996228053D+4; P1=-0.99225929672236083313D+2; P2=-0.96437492777225469787D+0; + CONST + P0=-0.16134119023996228053D+4; P1=-0.99225929672236083313D+2; P2=-0.96437492777225469787D+0; Q0= 0.48402357071988688686D+4; Q1= 0.22337720718962312926D+4; Q2= 0.11274474380534949335D+3; - ln3over2=0.54930614433405484570D0; + ln3over2=0.54930614433405484570D0; BIG=19.06154747D0; (* (ln(2)+(t+1)*ln(B))/2 where t=mantissa bits, B=base *) VAR f, t: LONGREAL; BEGIN f:=ABS(x); @@ -487,7 +487,7 @@ BEGIN END arcsinh; PROCEDURE arccosh* (x: LONGREAL): LONGREAL; -(* arccosh(x) is the arc hyperbolic cosine of x. All arguments greater than +(* arccosh(x) is the arc hyperbolic cosine of x. All arguments greater than or equal to 1 are legal. *) BEGIN IF x*) - a1[ 1]:=ONE; - a1[ 2]:=ToLONGREAL(3FEEA4AFH, 0A2A490DAH); - a1[ 3]:=ToLONGREAL(3FED5818H, 0DCFBA487H); - a1[ 4]:=ToLONGREAL(3FEC199BH, 0DD85529CH); - a1[ 5]:=ToLONGREAL(3FEAE89FH, 0995AD3ADH); - a1[ 6]:=ToLONGREAL(3FE9C491H, 082A3F090H); - a1[ 7]:=ToLONGREAL(3FE8ACE5H, 0422AA0DBH); - a1[ 8]:=ToLONGREAL(3FE7A114H, 073EB0186H); - a1[ 9]:=ToLONGREAL(3FE6A09EH, 0667F3BCCH); - a1[10]:=ToLONGREAL(3FE5AB07H, 0DD485429H); - a1[11]:=ToLONGREAL(3FE4BFDAH, 0D5362A27H); - a1[12]:=ToLONGREAL(3FE3DEA6H, 04C123422H); - a1[13]:=ToLONGREAL(3FE306FEH, 00A31B715H); - a1[14]:=ToLONGREAL(3FE2387AH, 06E756238H); - a1[15]:=ToLONGREAL(3FE172B8H, 03C7D517AH); - a1[16]:=ToLONGREAL(3FE0B558H, 06CF9890FH); - a1[17]:=HALF; + a1[ 1] := ONE; + a1[ 2] := ToLONGREAL(3FEEA4AFA2A490DAH); (* ToLONGREAL(3FEEA4AFH, 0A2A490DAH); *) + a1[ 3] := ToLONGREAL(3FED5818DCFBA487H); (* ToLONGREAL(3FED5818H, 0DCFBA487H); *) + a1[ 4] := ToLONGREAL(3FEC199BDD85529CH); (* ToLONGREAL(3FEC199BH, 0DD85529CH); *) + a1[ 5] := ToLONGREAL(3FEAE89F995AD3ADH); (* ToLONGREAL(3FEAE89FH, 0995AD3ADH); *) + a1[ 6] := ToLONGREAL(3FE9C49182A3F090H); (* ToLONGREAL(3FE9C491H, 082A3F090H); *) + a1[ 7] := ToLONGREAL(3FE8ACE5422AA0DBH); (* ToLONGREAL(3FE8ACE5H, 0422AA0DBH); *) + a1[ 8] := ToLONGREAL(3FE7A11473EB0186H); (* ToLONGREAL(3FE7A114H, 073EB0186H); *) + a1[ 9] := ToLONGREAL(3FE6A09E667F3BCCH); (* ToLONGREAL(3FE6A09EH, 0667F3BCCH); *) + a1[10] := ToLONGREAL(3FE5AB07DD485429H); (* ToLONGREAL(3FE5AB07H, 0DD485429H); *) + a1[11] := ToLONGREAL(3FE4BFDAD5362A27H); (* ToLONGREAL(3FE4BFDAH, 0D5362A27H); *) + a1[12] := ToLONGREAL(3FE3DEA64C123422H); (* ToLONGREAL(3FE3DEA6H, 04C123422H); *) + a1[13] := ToLONGREAL(3FE306FE0A31B715H); (* ToLONGREAL(3FE306FEH, 00A31B715H); *) + a1[14] := ToLONGREAL(3FE2387A6E756238H); (* ToLONGREAL(3FE2387AH, 06E756238H); *) + a1[15] := ToLONGREAL(3FE172B83C7D517AH); (* ToLONGREAL(3FE172B8H, 03C7D517AH); *) + a1[16] := ToLONGREAL(3FE0B5586CF9890FH); (* ToLONGREAL(3FE0B558H, 06CF9890FH); *) + a1[17] := HALF; (* a2[i]=2**[(1-2i)/16] - a1[2i]; delta resolution *) - a2[1]:=ToLONGREAL(3C90B1EEH, 074320000H); - a2[2]:=ToLONGREAL(3C711065H, 089500000H); - a2[3]:=ToLONGREAL(3C6C7C46H, 0B0700000H); - a2[4]:=ToLONGREAL(3C9AFAA2H, 0047F0000H); - a2[5]:=ToLONGREAL(3C86324CH, 005460000H); - a2[6]:=ToLONGREAL(3C7ADA09H, 011F00000H); - a2[7]:=ToLONGREAL(3C89B07EH, 0B6C80000H); - a2[8]:=ToLONGREAL(3C88A62EH, 04ADC0000H); - + a2[1] := ToLONGREAL(3C90B1EE74320000H); (* ToLONGREAL(3C90B1EEH, 074320000H); *) + a2[2] := ToLONGREAL(3C71106589500000H); (* ToLONGREAL(3C711065H, 089500000H); *) + a2[3] := ToLONGREAL(3C6C7C46B0700000H); (* ToLONGREAL(3C6C7C46H, 0B0700000H); *) + a2[4] := ToLONGREAL(3C9AFAA2047F0000H); (* ToLONGREAL(3C9AFAA2H, 0047F0000H); *) + a2[5] := ToLONGREAL(3C86324C05460000H); (* ToLONGREAL(3C86324CH, 005460000H); *) + a2[6] := ToLONGREAL(3C7ADA0911F00000H); (* ToLONGREAL(3C7ADA09H, 011F00000H); *) + a2[7] := ToLONGREAL(3C89B07EB6C80000H); (* ToLONGREAL(3C89B07EH, 0B6C80000H); *) + a2[8] := ToLONGREAL(3C88A62E4ADC0000H); (* ToLONGREAL(3C88A62EH, 04ADC0000H); *) + (* reenable compiler warnings *) (*<* POP *>*) END oocLRealMath. diff --git a/src/library/ooc/oocLowReal.Mod b/src/library/ooc/oocLowReal.Mod index 83ae8e32..7319794f 100644 --- a/src/library/ooc/oocLowReal.Mod +++ b/src/library/ooc/oocLowReal.Mod @@ -216,7 +216,7 @@ BEGIN IF x 0) DO + IF Streams.ReadByte(in1, b1) & Streams.ReadByte(in2, b2) THEN + res := XorByte(b1, b2); + IF ~Streams.WriteByte(out, res) THEN + RETURN FALSE + END; ELSE - wholeStream := FALSE; + RETURN wholeStream END; - WHILE wholeStream OR (length > 0) DO - IF Streams.ReadByte(in1, b1) & Streams.ReadByte(in2, b2) THEN - res := XorByte(b1, b2); - IF ~Streams.WriteByte(out, res) THEN - RETURN FALSE - END; - ELSE - RETURN wholeStream - END; - DEC(length); - END; - RETURN TRUE - END XorStream; + DEC(length); + END; + RETURN TRUE + END XorStream; END ulmCipherOps. diff --git a/src/library/ulm/ulmCiphers.Mod b/src/library/ulm/ulmCiphers.Mod index bc881c83..95d66aa8 100644 --- a/src/library/ulm/ulmCiphers.Mod +++ b/src/library/ulm/ulmCiphers.Mod @@ -29,15 +29,15 @@ (* abstraction for the use of ciphers and cryptographic methods *) MODULE ulmCiphers; -IMPORT Objects := ulmObjects, PersistentObjects := ulmPersistentObjects, PersistentDisciplines := ulmPersistentDisciplines, Services := ulmServices, +IMPORT Objects := ulmObjects, PersistentObjects := ulmPersistentObjects, PersistentDisciplines := ulmPersistentDisciplines, Services := ulmServices, Streams := ulmStreams, Write := ulmWrite; TYPE Cipher* = POINTER TO CipherRec; -TYPE - CryptProc* = PROCEDURE (in: Streams.Stream; key: Cipher; - length: INTEGER; out: Streams.Stream) : BOOLEAN; +TYPE + CryptProc* = PROCEDURE (in: Streams.Stream; key: Cipher; + length: INTEGER; out: Streams.Stream) : BOOLEAN; TYPE Interface* = POINTER TO InterfaceRec; @@ -48,7 +48,7 @@ TYPE END; TYPE - CipherRec* = RECORD + CipherRec* = RECORD (PersistentDisciplines.ObjectRec) (* private *) if : Interface @@ -64,31 +64,31 @@ BEGIN key.if := if; END Init; -PROCEDURE Encrypt*(in: Streams.Stream; key: Cipher; - out: Streams.Stream) : BOOLEAN; +PROCEDURE Encrypt*(in: Streams.Stream; key: Cipher; + out: Streams.Stream) : BOOLEAN; BEGIN RETURN key.if.encrypt(in, key, -1, out); END Encrypt; -PROCEDURE Decrypt*(in: Streams.Stream; key: Cipher; - out: Streams.Stream) : BOOLEAN; +PROCEDURE Decrypt*(in: Streams.Stream; key: Cipher; + out: Streams.Stream) : BOOLEAN; BEGIN RETURN key.if.decrypt(in, key, -1, out); END Decrypt; -PROCEDURE EncryptPart*(in: Streams.Stream; key: Cipher; - length: INTEGER; out: Streams.Stream) : BOOLEAN; +PROCEDURE EncryptPart*(in: Streams.Stream; key: Cipher; + length: INTEGER; out: Streams.Stream) : BOOLEAN; BEGIN RETURN key.if.encrypt(in, key, length, out); END EncryptPart; -PROCEDURE DecryptPart*(in: Streams.Stream; key: Cipher; - length: INTEGER; out: Streams.Stream) : BOOLEAN; +PROCEDURE DecryptPart*(in: Streams.Stream; key: Cipher; + length: INTEGER; out: Streams.Stream) : BOOLEAN; BEGIN RETURN key.if.decrypt(in, key, length, out); END DecryptPart; BEGIN - PersistentObjects.RegisterType(cipherType, "Ciphers.Cipher", + PersistentObjects.RegisterType(cipherType, "Ciphers.Cipher", "PersistentDisciplines.Object", NIL); END ulmCiphers. diff --git a/src/library/ulm/ulmDisciplines.Mod b/src/library/ulm/ulmDisciplines.Mod index 913f7c03..d96617a6 100644 --- a/src/library/ulm/ulmDisciplines.Mod +++ b/src/library/ulm/ulmDisciplines.Mod @@ -1,140 +1,140 @@ (* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Disciplines.om,v 1.1 1994/02/22 20:07:03 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Disciplines.om,v $ - Revision 1.1 1994/02/22 20:07:03 borchert - Initial revision + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Disciplines.om,v 1.1 1994/02/22 20:07:03 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Disciplines.om,v $ + Revision 1.1 1994/02/22 20:07:03 borchert + Initial revision - ---------------------------------------------------------------------------- - AFB 5/91 - ---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- + AFB 5/91 + ---------------------------------------------------------------------------- *) MODULE ulmDisciplines; - (* Disciplines allows to attach additional data structures to - abstract datatypes like Streams; - these added data structures permit to parametrize operations - which are provided by other modules (e.g. Read or Write for Streams) - *) + (* Disciplines allows to attach additional data structures to + abstract datatypes like Streams; + these added data structures permit to parametrize operations + which are provided by other modules (e.g. Read or Write for Streams) + *) - IMPORT Objects := ulmObjects; + IMPORT Objects := ulmObjects; - TYPE - Identifier* = LONGINT; + TYPE + Identifier* = LONGINT; - Discipline* = POINTER TO DisciplineRec; - DisciplineRec* = - RECORD - (Objects.ObjectRec) - id*: Identifier; (* should be unique for all types of disciplines *) - END; - - DisciplineList = POINTER TO DisciplineListRec; - DisciplineListRec = - RECORD - discipline: Discipline; - id: Identifier; (* copied from discipline.id *) - next: DisciplineList; - END; - - Object* = POINTER TO ObjectRec; - ObjectRec* = - RECORD - (Objects.ObjectRec) - (* private part *) - list: DisciplineList; (* set of disciplines *) - END; - - VAR - unique: Identifier; - - PROCEDURE Unique*() : Identifier; - (* returns a unique identifier; - this procedure should be called during initialization by - all modules defining a discipline type - *) - BEGIN - INC(unique); - RETURN unique - END Unique; - - PROCEDURE Remove*(object: Object; id: Identifier); - (* remove the discipline with the given id from object, if it exists *) - VAR - prev, dl: DisciplineList; - BEGIN - prev := NIL; - dl := object.list; - WHILE (dl # NIL) & (dl.id # id) DO - prev := dl; dl := dl.next; + Discipline* = POINTER TO DisciplineRec; + DisciplineRec* = + RECORD + (Objects.ObjectRec) + id*: Identifier; (* should be unique for all types of disciplines *) END; - IF dl # NIL THEN - IF prev = NIL THEN - object.list := dl.next; - ELSE - prev.next := dl.next; - END; - END; - END Remove; - PROCEDURE Add*(object: Object; discipline: Discipline); - (* adds a new discipline to the given object; - if already a discipline with the same identifier exist - it is deleted first - *) - VAR - dl: DisciplineList; - BEGIN - dl := object.list; - WHILE (dl # NIL) & (dl.id # discipline.id) DO - dl := dl.next; + DisciplineList = POINTER TO DisciplineListRec; + DisciplineListRec = + RECORD + discipline: Discipline; + id: Identifier; (* copied from discipline.id *) + next: DisciplineList; END; - IF dl = NIL THEN - NEW(dl); - dl.id := discipline.id; - dl.next := object.list; - object.list := dl; - END; - dl.discipline := discipline; - END Add; - PROCEDURE Seek*(object: Object; id: Identifier; - VAR discipline: Discipline) : BOOLEAN; - (* returns TRUE if a discipline with the given id is found *) - VAR - dl: DisciplineList; - BEGIN - dl := object.list; - WHILE (dl # NIL) & (dl.id # id) DO - dl := dl.next; + Object* = POINTER TO ObjectRec; + ObjectRec* = + RECORD + (Objects.ObjectRec) + (* private part *) + list: DisciplineList; (* set of disciplines *) END; - IF dl # NIL THEN - discipline := dl.discipline; + + VAR + unique: Identifier; + + PROCEDURE Unique*() : Identifier; + (* returns a unique identifier; + this procedure should be called during initialization by + all modules defining a discipline type + *) + BEGIN + INC(unique); + RETURN unique + END Unique; + + PROCEDURE Remove*(object: Object; id: Identifier); + (* remove the discipline with the given id from object, if it exists *) + VAR + prev, dl: DisciplineList; + BEGIN + prev := NIL; + dl := object.list; + WHILE (dl # NIL) & (dl.id # id) DO + prev := dl; dl := dl.next; + END; + IF dl # NIL THEN + IF prev = NIL THEN + object.list := dl.next; ELSE - discipline := NIL; + prev.next := dl.next; END; - RETURN discipline # NIL - END Seek; + END; + END Remove; + + PROCEDURE Add*(object: Object; discipline: Discipline); + (* adds a new discipline to the given object; + if already a discipline with the same identifier exist + it is deleted first + *) + VAR + dl: DisciplineList; + BEGIN + dl := object.list; + WHILE (dl # NIL) & (dl.id # discipline.id) DO + dl := dl.next; + END; + IF dl = NIL THEN + NEW(dl); + dl.id := discipline.id; + dl.next := object.list; + object.list := dl; + END; + dl.discipline := discipline; + END Add; + + PROCEDURE Seek*(object: Object; id: Identifier; + VAR discipline: Discipline) : BOOLEAN; + (* returns TRUE if a discipline with the given id is found *) + VAR + dl: DisciplineList; + BEGIN + dl := object.list; + WHILE (dl # NIL) & (dl.id # id) DO + dl := dl.next; + END; + IF dl # NIL THEN + discipline := dl.discipline; + ELSE + discipline := NIL; + END; + RETURN discipline # NIL + END Seek; BEGIN - unique := 0; + unique := 0; END ulmDisciplines. diff --git a/src/library/ulm/ulmErrors.Mod b/src/library/ulm/ulmErrors.Mod index edb1cb6f..7336bca2 100644 --- a/src/library/ulm/ulmErrors.Mod +++ b/src/library/ulm/ulmErrors.Mod @@ -1,158 +1,161 @@ (* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Errors.om,v 1.2 1994/07/18 14:16:33 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Errors.om,v $ - Revision 1.2 1994/07/18 14:16:33 borchert - unused variables of Write (ch & index) removed + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Errors.om,v 1.2 1994/07/18 14:16:33 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Errors.om,v $ + Revision 1.2 1994/07/18 14:16:33 borchert + unused variables of Write (ch & index) removed - Revision 1.1 1994/02/22 20:07:15 borchert - Initial revision + Revision 1.1 1994/02/22 20:07:15 borchert + Initial revision - ---------------------------------------------------------------------------- - AFB 11/91 - ---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- + AFB 11/91 + ---------------------------------------------------------------------------- *) MODULE ulmErrors; - (* translate events to errors *) + (* translate events to errors *) - IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, RelatedEvents := ulmRelatedEvents, Streams := ulmStreams, Strings := ulmStrings, - SYS := SYSTEM; + IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, RelatedEvents := ulmRelatedEvents, Streams := ulmStreams, Strings := ulmStrings, + SYS := SYSTEM; - CONST - (* Kind = (debug, message, warning, error, fatal, bug) *) - debug* = 0; - message* = 1; - warning* = 2; - error* = 3; - fatal* = 4; - bug* = 5; - nkinds* = 6; - TYPE - Kind* = SHORTINT; (* debug..bug *) - VAR - kindText*: ARRAY nkinds OF ARRAY 12 OF CHAR; + CONST + (* Kind = (debug, message, warning, error, fatal, bug) *) + debug* = 0; + message* = 1; + warning* = 2; + error* = 3; + fatal* = 4; + bug* = 5; + nkinds* = 6; + TYPE + Kind* = SHORTINT; (* debug..bug *) + VAR + kindText*: ARRAY nkinds OF ARRAY 12 OF CHAR; - TYPE - Handler* = PROCEDURE (event: Events.Event; kind: Kind); - HandlerSet* = POINTER TO HandlerSetRec; - HandlerSetRec* = - RECORD - (Disciplines.ObjectRec) - (* private components *) - handlerSet: SET; (* set of installed handlers *) - handler: ARRAY nkinds OF Handler; - END; - - (* ========== write discipline ========================================= *) - TYPE - WriteProcedure* = PROCEDURE (s: Streams.Stream; event: Events.Event); - WriteDiscipline = POINTER TO WriteDisciplineRec; - WriteDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - write: WriteProcedure; - END; - VAR - writeDiscId: Disciplines.Identifier; - - (* ========== handler discipline ======================================= *) - TYPE - HandlerDiscipline = POINTER TO HandlerDisciplineRec; - HandlerDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - hs: HandlerSet; - kind: Kind; - END; - VAR - handlerDiscId: Disciplines.Identifier; - - VAR - null*: HandlerSet; (* empty handler set *) - - PROCEDURE CreateHandlerSet*(VAR hs: HandlerSet); - BEGIN - NEW(hs); hs.handlerSet := {}; - END CreateHandlerSet; - - PROCEDURE InstallHandler*(hs: HandlerSet; kind: Kind; handler: Handler); - BEGIN - hs.handler[kind] := handler; - INCL(hs.handlerSet, kind); - END InstallHandler; - - PROCEDURE AssignWriteProcedure*(eventType: Events.EventType; - write: WriteProcedure); - VAR - writeDiscipline: WriteDiscipline; - BEGIN - NEW(writeDiscipline); - writeDiscipline.id := writeDiscId; - writeDiscipline.write := write; - Disciplines.Add(eventType, writeDiscipline); - END AssignWriteProcedure; - - PROCEDURE Write*(s: Streams.Stream; event: Events.Event); - VAR - writeDiscipline: WriteDiscipline; - BEGIN - IF Disciplines.Seek(event.type, writeDiscId, SYS.VAL(Disciplines.Discipline, writeDiscipline)) THEN - writeDiscipline.write(s, event); - ELSE - IF ~Streams.WritePart(s, event.message, 0, - Strings.Len(event.message)) THEN - END; + TYPE + Handler* = PROCEDURE (event: Events.Event; kind: Kind); + HandlerSet* = POINTER TO HandlerSetRec; + HandlerSetRec* = + RECORD + (Disciplines.ObjectRec) + (* private components *) + handlerSet: SET; (* set of installed handlers *) + handler: ARRAY nkinds OF Handler; END; - END Write; - PROCEDURE GeneralEventHandler(event: Events.Event); - VAR - disc: HandlerDiscipline; - BEGIN - IF Disciplines.Seek(event.type, handlerDiscId, SYS.VAL(Disciplines.Discipline, disc)) & - (disc.kind IN disc.hs.handlerSet) THEN - disc.hs.handler[disc.kind](event, disc.kind); + (* ========== write discipline ========================================= *) + TYPE + WriteProcedure* = PROCEDURE (s: Streams.Stream; event: Events.Event); + WriteDiscipline = POINTER TO WriteDisciplineRec; + WriteDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + write: WriteProcedure; END; - END GeneralEventHandler; + VAR + writeDiscId: Disciplines.Identifier; - PROCEDURE CatchEvent*(hs: HandlerSet; kind: Kind; type: Events.EventType); - VAR - handlerDiscipline: HandlerDiscipline; - BEGIN - NEW(handlerDiscipline); handlerDiscipline.id := handlerDiscId; - handlerDiscipline.hs := hs; handlerDiscipline.kind := kind; - Disciplines.Add(type, handlerDiscipline); - Events.Handler(type, GeneralEventHandler); - END CatchEvent; + (* ========== handler discipline ======================================= *) + TYPE + HandlerDiscipline = POINTER TO HandlerDisciplineRec; + HandlerDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + hs: HandlerSet; + kind: Kind; + END; + VAR + handlerDiscId: Disciplines.Identifier; + + VAR + null*: HandlerSet; (* empty handler set *) + + PROCEDURE CreateHandlerSet*(VAR hs: HandlerSet); + BEGIN + NEW(hs); hs.handlerSet := {}; + END CreateHandlerSet; + + PROCEDURE InstallHandler*(hs: HandlerSet; kind: Kind; handler: Handler); + BEGIN + hs.handler[kind] := handler; + INCL(hs.handlerSet, kind); + END InstallHandler; + + PROCEDURE AssignWriteProcedure*(eventType: Events.EventType; + write: WriteProcedure); + VAR + writeDiscipline: WriteDiscipline; + BEGIN + NEW(writeDiscipline); + writeDiscipline.id := writeDiscId; + writeDiscipline.write := write; + Disciplines.Add(eventType, writeDiscipline); + END AssignWriteProcedure; + + PROCEDURE Write*(s: Streams.Stream; event: Events.Event); + VAR + writeDiscipline: Disciplines.Discipline; + BEGIN + IF Disciplines.Seek(event.type, writeDiscId, writeDiscipline) THEN + writeDiscipline(WriteDiscipline).write(s, event); + ELSE + IF ~Streams.WritePart(s, event.message, 0, + Strings.Len(event.message)) THEN + END; + END; + END Write; + + PROCEDURE GeneralEventHandler(event: Events.Event); + VAR + disc: Disciplines.Discipline; + hdisc: HandlerDiscipline; + BEGIN + IF Disciplines.Seek(event.type, handlerDiscId, disc) THEN + hdisc := disc(HandlerDiscipline); + IF hdisc.kind IN hdisc.hs.handlerSet THEN + hdisc.hs.handler[hdisc.kind](event, hdisc.kind) + END + END; + END GeneralEventHandler; + + PROCEDURE CatchEvent*(hs: HandlerSet; kind: Kind; type: Events.EventType); + VAR + handlerDiscipline: HandlerDiscipline; + BEGIN + NEW(handlerDiscipline); handlerDiscipline.id := handlerDiscId; + handlerDiscipline.hs := hs; handlerDiscipline.kind := kind; + Disciplines.Add(type, handlerDiscipline); + Events.Handler(type, GeneralEventHandler); + END CatchEvent; BEGIN - writeDiscId := Disciplines.Unique(); - handlerDiscId := Disciplines.Unique(); - CreateHandlerSet(null); - kindText[debug] := "debug"; - kindText[message] := "message"; - kindText[warning] := "warning"; - kindText[error] := "error"; - kindText[fatal] := "fatal"; - kindText[bug] := "bug"; + writeDiscId := Disciplines.Unique(); + handlerDiscId := Disciplines.Unique(); + CreateHandlerSet(null); + kindText[debug] := "debug"; + kindText[message] := "message"; + kindText[warning] := "warning"; + kindText[error] := "error"; + kindText[fatal] := "fatal"; + kindText[bug] := "bug"; END ulmErrors. diff --git a/src/library/ulm/ulmEvents.Mod b/src/library/ulm/ulmEvents.Mod index 6016f8b0..52695762 100644 --- a/src/library/ulm/ulmEvents.Mod +++ b/src/library/ulm/ulmEvents.Mod @@ -46,88 +46,88 @@ MODULE ulmEvents; CONST (* possibilities on receipt of an event: *) - default* = 0; (* causes abortion *) - ignore* = 1; (* ignore event *) - funcs* = 2; (* call associated event handlers *) + default* = 0; (* causes abortion *) + ignore* = 1; (* ignore event *) + funcs* = 2; (* call associated event handlers *) TYPE - Reaction* = INTEGER; (* one of default, ignore, or funcs *) + Reaction* = INTEGER; (* one of default, ignore, or funcs *) Message* = ARRAY 80 OF CHAR; Event* = POINTER TO EventRec; EventRec* = - RECORD - (Objects.ObjectRec) - type*: EventType; - message*: Message; - (* private part *) - next: Event; (* queue *) - END; + RECORD + (Objects.ObjectRec) + type*: EventType; + message*: Message; + (* private part *) + next: Event; (* queue *) + END; EventHandler = PROCEDURE (event: Event); (* event managers are needed if there is any action necessary - on changing the kind of reaction + on changing the kind of reaction *) EventManager = PROCEDURE (type: EventType; reaction: Reaction); Priority = INTEGER; (* must be non-negative *) (* every event with reaction `funcs' has a handler list; - the list is in calling order which is reverse to - the order of `Handler'-calls + the list is in calling order which is reverse to + the order of `Handler'-calls *) HandlerList = POINTER TO HandlerRec; HandlerRec* = - RECORD - (Objects.ObjectRec) - handler*: EventHandler; - next*: HandlerList; - END; + RECORD + (Objects.ObjectRec) + handler*: EventHandler; + next*: HandlerList; + END; SaveList = POINTER TO SaveRec; SaveRec = - RECORD - reaction: Reaction; - handlers: HandlerList; - next: SaveList; - END; + RECORD + reaction: Reaction; + handlers: HandlerList; + next: SaveList; + END; EventTypeRec* = - RECORD - (Services.ObjectRec) - (* private components *) - handlers: HandlerList; - priority: Priority; - reaction: Reaction; - manager: EventManager; - savelist: SaveList; - END; + RECORD + (Services.ObjectRec) + (* private components *) + handlers: HandlerList; + priority: Priority; + reaction: Reaction; + manager: EventManager; + savelist: SaveList; + END; Queue = POINTER TO QueueRec; QueueRec = - RECORD - priority: INTEGER; (* queue for this priority *) - head, tail: Event; - next: Queue; (* queue with lower priority *) - END; + RECORD + priority: INTEGER; (* queue for this priority *) + head, tail: Event; + next: Queue; (* queue with lower priority *) + END; VAR eventTypeType: Services.Type; - + CONST - priotabsize = 256; (* size of a priority table *) - maxnestlevel = 1024; (* of Raise-calls (avoids endless recursion) *) + priotabsize = 256; (* size of a priority table *) + maxnestlevel = 1024; (* of Raise-calls (avoids endless recursion) *) TYPE (* in some cases coroutines uses local priority systems *) PrioritySystem* = POINTER TO PrioritySystemRec; PrioritySystemRec* = - RECORD - (Objects.ObjectRec) - (* private part *) - currentPriority: Priority; - priotab: ARRAY priotabsize OF Priority; - priotop: INTEGER; - overflow: INTEGER; (* of priority table *) - END; + RECORD + (Objects.ObjectRec) + (* private part *) + currentPriority: Priority; + priotab: ARRAY priotabsize OF Priority; + priotop: INTEGER; + overflow: INTEGER; (* of priority table *) + END; CONST priorityViolation* = 0; (* priority violation (EnterPriority *) @@ -139,10 +139,10 @@ MODULE ulmEvents; TYPE ErrorEvent* = POINTER TO ErrorEventRec; ErrorEventRec* = - RECORD - (EventRec) - errorcode*: SHORTINT; - END; + RECORD + (EventRec) + errorcode*: SHORTINT; + END; VAR errormsg*: ARRAY errorcodes OF Message; @@ -151,10 +151,10 @@ MODULE ulmEvents; VAR (* private part *) abort, log, queueHandler: EventHandler; - nestlevel: INTEGER; (* of Raise calls *) + nestlevel: INTEGER; (* of Raise calls *) queue: Queue; - lock: BOOLEAN; (* lock critical operations *) - psys: PrioritySystem; (* current priority system *) + lock: BOOLEAN; (* lock critical operations *) + psys: PrioritySystem; (* current priority system *) PROCEDURE ^ Define*(VAR type: EventType); PROCEDURE ^ SetPriority*(type: EventType; priority: Priority); @@ -164,13 +164,13 @@ MODULE ulmEvents; BEGIN Define(error); SetPriority(error, Priorities.liberrors); errormsg[priorityViolation] := - "priority violation (Events.EnterPriority)"; + "priority violation (Events.EnterPriority)"; errormsg[unbalancedExitPriority] := - "unbalanced call of Events.ExitPriority"; + "unbalanced call of Events.ExitPriority"; errormsg[unbalancedRestoreReaction] := - "unbalanced call of Events.RestoreReaction"; + "unbalanced call of Events.RestoreReaction"; errormsg[negPriority] := - "negative priority given to Events.SetPriority"; + "negative priority given to Events.SetPriority"; END InitErrorHandling; PROCEDURE Error(code: SHORTINT); @@ -187,7 +187,7 @@ MODULE ulmEvents; PROCEDURE Init*(type: EventType); VAR - stype: Services.Type; + stype: Services.Type; BEGIN Services.GetType(type, stype); ASSERT(stype # NIL); type.handlers := NIL; @@ -199,8 +199,8 @@ MODULE ulmEvents; PROCEDURE Define*(VAR type: EventType); (* definition of a new event; - an unique event number is returned; - the reaction on receipt of `type' is defined to be `default' + an unique event number is returned; + the reaction on receipt of `type' is defined to be `default' *) BEGIN NEW(type); @@ -218,9 +218,9 @@ MODULE ulmEvents; (* (re-)defines the priority of an event *) BEGIN IF priority <= 0 THEN - Error(negPriority); + Error(negPriority); ELSE - type.priority := priority; + type.priority := priority; END; END SetPriority; @@ -238,42 +238,42 @@ MODULE ulmEvents; PROCEDURE Handler*(type: EventType; handler: EventHandler); (* add `handler' to the list of handlers for event `type' *) VAR - newhandler: HandlerList; + newhandler: HandlerList; BEGIN NEW(newhandler); newhandler.handler := handler; newhandler.next := type.handlers; type.handlers := newhandler; IF type.reaction # funcs THEN - type.reaction := funcs; type.manager(type, funcs); + type.reaction := funcs; type.manager(type, funcs); END; END Handler; PROCEDURE RemoveHandlers*(type: EventType); (* remove list of handlers for event `type'; - implies default reaction (abortion) on - receipt of `type' + implies default reaction (abortion) on + receipt of `type' *) BEGIN type.handlers := NIL; IF type.reaction # default THEN - type.reaction := default; type.manager(type, default); + type.reaction := default; type.manager(type, default); END; END RemoveHandlers; PROCEDURE Ignore*(type: EventType); (* implies RemoveHandlers(type) and causes receipt - of `type' to be ignored + of `type' to be ignored *) BEGIN type.handlers := NIL; IF type.reaction # ignore THEN - type.reaction := ignore; type.manager(type, ignore); + type.reaction := ignore; type.manager(type, ignore); END; END Ignore; PROCEDURE GetHandlers*(type: EventType; handlers: HandlerList); (* returns the list of handlers in `handlers'; - the reaction of `type' must be `funcs' + the reaction of `type' must be `funcs' *) BEGIN handlers := type.handlers; @@ -281,8 +281,8 @@ MODULE ulmEvents; PROCEDURE Log*(loghandler: EventHandler); (* call `loghandler' for every event; - subsequent calls of `Log' replace the loghandler; - the loghandler is not called on default and ignore + subsequent calls of `Log' replace the loghandler; + the loghandler is not called on default and ignore *) BEGIN log := loghandler; @@ -311,8 +311,8 @@ MODULE ulmEvents; PROCEDURE QueueHandler*(handler: EventHandler); (* setup an alternative handler of events - that cannot be processed now because - of their unsufficient priority + that cannot be processed now because + of their unsufficient priority *) VAR b : BOOLEAN; (* noch *) tmphandler : EventHandler; @@ -345,93 +345,93 @@ MODULE ulmEvents; PROCEDURE WorkupQueue; VAR - ptr: Event; + ptr: Event; BEGIN WHILE (queue # NIL) & (queue.priority > psys.currentPriority) DO - IF SYS.TAS(lock) THEN RETURN END; - ptr := queue.head; queue := queue.next; - lock := FALSE; - WHILE ptr # NIL DO - CallHandlers(ptr); - ptr := ptr.next; - END; + IF SYS.TAS(lock) THEN RETURN END; + ptr := queue.head; queue := queue.next; + lock := FALSE; + WHILE ptr # NIL DO + CallHandlers(ptr); + ptr := ptr.next; + END; END; END WorkupQueue; PROCEDURE CallHandlers(event: Event); VAR - ptr: HandlerList; - oldPriority: Priority; + ptr: HandlerList; + oldPriority: Priority; BEGIN CASE event.type.reaction OF | default: abort(event); | ignore: | funcs: oldPriority := psys.currentPriority; - psys.currentPriority := event.type.priority; - log(event); - ptr := event.type.handlers; - WHILE ptr # NIL DO - ptr.handler(event); - ptr := ptr.next; - END; - psys.currentPriority := oldPriority; + psys.currentPriority := event.type.priority; + log(event); + ptr := event.type.handlers; + WHILE ptr # NIL DO + ptr.handler(event); + ptr := ptr.next; + END; + psys.currentPriority := oldPriority; ELSE (* Explicitly ignore unhandled even type reactions *) END; END CallHandlers; PROCEDURE Raise*(event: Event); (* call all event handlers (in reverse order) - associated with event.type; - abort if there are none; - some system events may abort in another way - (i.e. they do not cause the abortion handler to be called) + associated with event.type; + abort if there are none; + some system events may abort in another way + (i.e. they do not cause the abortion handler to be called) *) VAR - priority: Priority; + priority: Priority; PROCEDURE AddToQueue(event: Event); - VAR - prev, ptr: Queue; + VAR + prev, ptr: Queue; BEGIN - event.next := NIL; - ptr := queue; prev := NIL; - WHILE (ptr # NIL) & (ptr.priority > priority) DO - prev := ptr; - ptr := ptr.next; - END; - IF (ptr # NIL) & (ptr.priority = priority) THEN - ptr.tail.next := event; - ptr.tail := event; - ELSE - NEW(ptr); - ptr.priority := priority; - ptr.head := event; ptr.tail := event; - IF prev = NIL THEN - ptr.next := queue; - queue := ptr; - ELSE - ptr.next := prev.next; - prev.next := ptr; - END; - END; + event.next := NIL; + ptr := queue; prev := NIL; + WHILE (ptr # NIL) & (ptr.priority > priority) DO + prev := ptr; + ptr := ptr.next; + END; + IF (ptr # NIL) & (ptr.priority = priority) THEN + ptr.tail.next := event; + ptr.tail := event; + ELSE + NEW(ptr); + ptr.priority := priority; + ptr.head := event; ptr.tail := event; + IF prev = NIL THEN + ptr.next := queue; + queue := ptr; + ELSE + ptr.next := prev.next; + prev.next := ptr; + END; + END; END AddToQueue; BEGIN (* Raise *) INC(nestlevel); IF nestlevel >= maxnestlevel THEN - abort(event); + abort(event); ELSE - IF event.type.reaction # ignore THEN - priority := event.type.priority; - IF psys.currentPriority < priority THEN - CallHandlers(event); WorkupQueue; - ELSIF queueHandler # NIL THEN - queueHandler(event); - ELSIF ~SYS.TAS(lock) THEN - AddToQueue(event); - lock := FALSE; - END; - END; + IF event.type.reaction # ignore THEN + priority := event.type.priority; + IF psys.currentPriority < priority THEN + CallHandlers(event); WorkupQueue; + ELSIF queueHandler # NIL THEN + queueHandler(event); + ELSIF ~SYS.TAS(lock) THEN + AddToQueue(event); + lock := FALSE; + END; + END; END; DEC(nestlevel); END Raise; @@ -452,7 +452,7 @@ MODULE ulmEvents; PROCEDURE SwitchPrioritySystem*(prioritySystem: PrioritySystem); (* switch to another priority system; this is typically - done in case of task switches + done in case of task switches *) BEGIN psys := prioritySystem; @@ -460,52 +460,52 @@ MODULE ulmEvents; PROCEDURE EnterPriority*(priority: Priority); (* sets the current priority to `priority'; - it is an error to give a priority less than - the current priority (event `badpriority') + it is an error to give a priority less than + the current priority (event `badpriority') *) BEGIN IF psys.currentPriority <= priority THEN - IF (psys.overflow = 0) & (psys.priotop < priotabsize) THEN - psys.priotab[psys.priotop] := psys.currentPriority; - INC(psys.priotop); - psys.currentPriority := priority; - ELSE - INC(psys.overflow); - END; + IF (psys.overflow = 0) & (psys.priotop < priotabsize) THEN + psys.priotab[psys.priotop] := psys.currentPriority; + INC(psys.priotop); + psys.currentPriority := priority; + ELSE + INC(psys.overflow); + END; ELSE - Error(priorityViolation); - INC(psys.overflow); + Error(priorityViolation); + INC(psys.overflow); END; END EnterPriority; PROCEDURE AssertPriority*(priority: Priority); (* current priority - < priority: set the current priority to `priority' - >= priority: the current priority remains unchanged + < priority: set the current priority to `priority' + >= priority: the current priority remains unchanged *) BEGIN IF (psys.overflow = 0) & (psys.priotop < priotabsize) THEN - psys.priotab[psys.priotop] := psys.currentPriority; INC(psys.priotop); - IF psys.currentPriority < priority THEN - psys.currentPriority := priority; - END; + psys.priotab[psys.priotop] := psys.currentPriority; INC(psys.priotop); + IF psys.currentPriority < priority THEN + psys.currentPriority := priority; + END; ELSE - INC(psys.overflow); + INC(psys.overflow); END; END AssertPriority; PROCEDURE ExitPriority*; (* causes the priority before the last effective call - of SetPriority or AssertPriority to be restored + of SetPriority or AssertPriority to be restored *) BEGIN IF psys.overflow > 0 THEN - DEC(psys.overflow); + DEC(psys.overflow); ELSIF psys.priotop = 0 THEN - Error(unbalancedExitPriority); + Error(unbalancedExitPriority); ELSE - DEC(psys.priotop); psys.currentPriority := psys.priotab[psys.priotop]; - WorkupQueue; + DEC(psys.priotop); psys.currentPriority := psys.priotab[psys.priotop]; + WorkupQueue; END; END ExitPriority; @@ -517,11 +517,11 @@ MODULE ulmEvents; PROCEDURE SaveReaction*(type: EventType); (* saves current reaction until call of RestoreReaction; - the new reaction of `type' is defined to be `ignore' - but can be changed by Events.Handler or Events.RemoveHandlers + the new reaction of `type' is defined to be `ignore' + but can be changed by Events.Handler or Events.RemoveHandlers *) VAR - savelist: SaveList; + savelist: SaveList; BEGIN NEW(savelist); savelist.reaction := type.reaction; @@ -530,27 +530,27 @@ MODULE ulmEvents; type.savelist := savelist; type.handlers := NIL; IF type.reaction # ignore THEN - type.reaction := ignore; type.manager(type, ignore); + type.reaction := ignore; type.manager(type, ignore); END; END SaveReaction; PROCEDURE RestoreReaction*(type: EventType); (* restores old reaction; - must be properly nested + must be properly nested *) VAR - savelist: SaveList; + savelist: SaveList; BEGIN IF type.savelist = NIL THEN - Error(unbalancedRestoreReaction); + Error(unbalancedRestoreReaction); ELSE - savelist := type.savelist; - type.savelist := savelist.next; - type.handlers := savelist.handlers; - IF type.reaction # savelist.reaction THEN - type.reaction := savelist.reaction; - type.manager(type, savelist.reaction); - END; + savelist := type.savelist; + type.savelist := savelist.next; + type.handlers := savelist.handlers; + IF type.reaction # savelist.reaction THEN + type.reaction := savelist.reaction; + type.manager(type, savelist.reaction); + END; END; END RestoreReaction; diff --git a/src/library/ulm/ulmForwarders.Mod b/src/library/ulm/ulmForwarders.Mod index ac4fa0b8..27f68104 100644 --- a/src/library/ulm/ulmForwarders.Mod +++ b/src/library/ulm/ulmForwarders.Mod @@ -1,244 +1,252 @@ (* Ulm's Oberon Library - Copyright (C) 1989-1995 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. + Copyright (C) 1989-1995 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Forwarders.om,v 1.1 1996/01/04 16:40:57 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Forwarders.om,v $ - Revision 1.1 1996/01/04 16:40:57 borchert - Initial revision + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Forwarders.om,v 1.1 1996/01/04 16:40:57 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Forwarders.om,v $ + Revision 1.1 1996/01/04 16:40:57 borchert + Initial revision - ---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- *) MODULE ulmForwarders; (* AFB 3/95 *) - IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Resources := ulmResources, Services := ulmServices, SYSTEM; - (* SYSTEM is necessary to cast to Disciplines.Discipline; noch *) + IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Resources := ulmResources, Services := ulmServices; - TYPE - Object* = Services.Object; - ForwardProc* = PROCEDURE (from, to: Object); + TYPE + Object* = Services.Object; + ForwardProc* = PROCEDURE (from, to: Object); - TYPE - ListOfForwarders = POINTER TO ListOfForwardersRec; - ListOfForwardersRec = - RECORD - forward: ForwardProc; - next: ListOfForwarders; - END; - ListOfDependants = POINTER TO ListOfDependantsRec; - ListOfDependantsRec = - RECORD - dependant: Object; - next: ListOfDependants; - END; - TypeDiscipline = POINTER TO TypeDisciplineRec; - TypeDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - list: ListOfForwarders; - END; - ObjectDiscipline = POINTER TO ObjectDisciplineRec; - ObjectDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - dependants: ListOfDependants; - forwarders: ListOfForwarders; - dependsOn: Object; - END; - VAR - genlist: ListOfForwarders; (* list which applies to all types *) - typeDiscID: Disciplines.Identifier; - objectDiscID: Disciplines.Identifier; - - (* === private procedures ============================================ *) - - PROCEDURE RemoveDependant(VAR list: ListOfDependants; dependant: Object); - VAR - prev, p: ListOfDependants; - BEGIN - prev := NIL; p := list; - WHILE (p # NIL) & (p.dependant # dependant) DO - prev := p; p := p.next; + TYPE + ListOfForwarders = POINTER TO ListOfForwardersRec; + ListOfForwardersRec = + RECORD + forward: ForwardProc; + next: ListOfForwarders; END; - IF p # NIL THEN - IF prev = NIL THEN - list := p.next; - ELSE - prev.next := p.next; - END; + ListOfDependants = POINTER TO ListOfDependantsRec; + ListOfDependantsRec = + RECORD + dependant: Object; + next: ListOfDependants; END; - END RemoveDependant; - - PROCEDURE TerminationHandler(event: Events.Event); - (* remove list of dependants in case of termination and - remove event.resource from the list of dependants of that - object it depends on - *) - VAR - odisc: ObjectDiscipline; - dependsOn: Object; - BEGIN - WITH event: Resources.Event DO - IF event.change = Resources.terminated THEN - IF Disciplines.Seek(event.resource, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *) - Disciplines.Remove(event.resource, objectDiscID); - dependsOn := odisc.dependsOn; - IF (dependsOn # NIL) & ~Resources.Terminated(dependsOn) & - Disciplines.Seek(dependsOn, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *) - RemoveDependant(odisc.dependants, event.resource(Object)); - END; - END; - END; + TypeDiscipline = POINTER TO TypeDisciplineRec; + TypeDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + list: ListOfForwarders; END; - END TerminationHandler; - - PROCEDURE Insert(VAR list: ListOfForwarders; forward: ForwardProc); - VAR - member: ListOfForwarders; - BEGIN - NEW(member); member.forward := forward; - member.next := list; list := member; - END Insert; - - PROCEDURE GetObjectDiscipline(object: Object; VAR odisc: ObjectDiscipline); - VAR - resourceNotification: Events.EventType; - BEGIN - IF ~Disciplines.Seek(object, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *) - NEW(odisc); odisc.id := objectDiscID; odisc.dependants := NIL; - odisc.forwarders := NIL; odisc.dependsOn := NIL; - (* let's state our interest in termination of `object' if - we see this object the first time - *) - Resources.TakeInterest(object, resourceNotification); - Events.Handler(resourceNotification, TerminationHandler); - Disciplines.Add(object, odisc); + ObjectDiscipline = POINTER TO ObjectDisciplineRec; + ObjectDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + dependants: ListOfDependants; + forwarders: ListOfForwarders; + dependsOn: Object; END; - END GetObjectDiscipline; + VAR + genlist: ListOfForwarders; (* list which applies to all types *) + typeDiscID: Disciplines.Identifier; + objectDiscID: Disciplines.Identifier; - (* === exported procedures =========================================== *) + (* === private procedures ============================================ *) - PROCEDURE Register*(for: ARRAY OF CHAR; forward: ForwardProc); - (* register a forwarder which is to be called for all - forward operations which affects extensions of `for'; - "" may be given for Services.Object - *) - - VAR - type: Services.Type; - tdisc: TypeDiscipline; - - BEGIN (* Register *) - IF for = "" THEN - Insert(genlist, forward); + PROCEDURE RemoveDependant(VAR list: ListOfDependants; dependant: Object); + VAR + prev, p: ListOfDependants; + BEGIN + prev := NIL; p := list; + WHILE (p # NIL) & (p.dependant # dependant) DO + prev := p; p := p.next; + END; + IF p # NIL THEN + IF prev = NIL THEN + list := p.next; ELSE - Services.SeekType(for, type); - ASSERT(type # NIL); - IF ~Disciplines.Seek(type, typeDiscID, SYSTEM.VAL(Disciplines.Discipline, tdisc)) THEN - NEW(tdisc); tdisc.id := typeDiscID; tdisc.list := NIL; - END; - Insert(tdisc.list, forward); - Disciplines.Add(type, tdisc); + prev.next := p.next; END; - END Register; + END; + END RemoveDependant; - PROCEDURE RegisterObject*(object: Object; forward: ForwardProc); - (* to be called instead of Register if specific objects - are supported only and not all extensions of a type + PROCEDURE TerminationHandler(event: Events.Event); + (* remove list of dependants in case of termination and + remove event.resource from the list of dependants of that + object it depends on + *) + VAR + odisc: Disciplines.Discipline; + dependsOn: Object; + BEGIN + WITH event: Resources.Event DO + IF event.change = Resources.terminated THEN + IF Disciplines.Seek(event.resource, objectDiscID, odisc) THEN + Disciplines.Remove(event.resource, objectDiscID); + dependsOn := odisc(ObjectDiscipline).dependsOn; + IF (dependsOn # NIL) & ~Resources.Terminated(dependsOn) & + Disciplines.Seek(dependsOn, objectDiscID, odisc) THEN + RemoveDependant(odisc(ObjectDiscipline).dependants, event.resource(Object)); + END; + END; + END; + END; + END TerminationHandler; + + PROCEDURE Insert(VAR list: ListOfForwarders; forward: ForwardProc); + VAR + member: ListOfForwarders; + BEGIN + NEW(member); member.forward := forward; + member.next := list; list := member; + END Insert; + + PROCEDURE GetObjectDiscipline(object: Object; VAR odisc: ObjectDiscipline); + VAR + disc: Disciplines.Discipline; + resourceNotification: Events.EventType; + BEGIN + IF Disciplines.Seek(object, objectDiscID, disc) THEN + odisc := disc(ObjectDiscipline) + ELSE + NEW(odisc); odisc.id := objectDiscID; odisc.dependants := NIL; + odisc.forwarders := NIL; odisc.dependsOn := NIL; + (* let's state our interest in termination of `object' if + we see this object the first time *) - VAR - odisc: ObjectDiscipline; - BEGIN - GetObjectDiscipline(object, odisc); - Insert(odisc.forwarders, forward); - END RegisterObject; + Resources.TakeInterest(object, resourceNotification); + Events.Handler(resourceNotification, TerminationHandler); + Disciplines.Add(object, odisc); + END; + END GetObjectDiscipline; - PROCEDURE Update*(object: Object; forward: ForwardProc); - (* is to be called by one of the registered forwarders if - an interface for object has been newly installed or changed - in a way which needs forward to be called for each of - the filter objects which delegate to `object' - *) - VAR - odisc: ObjectDiscipline; - client: ListOfDependants; - BEGIN - IF Disciplines.Seek(object, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *) - client := odisc.dependants; - WHILE client # NIL DO - forward(client.dependant, object); - client := client.next; - END; + (* === exported procedures =========================================== *) + + PROCEDURE Register*(for: ARRAY OF CHAR; forward: ForwardProc); + (* register a forwarder which is to be called for all + forward operations which affects extensions of `for'; + "" may be given for Services.Object + *) + + VAR + type: Services.Type; + tdisc: TypeDiscipline; + disc: Disciplines.Discipline; + + BEGIN (* Register *) + IF for = "" THEN + Insert(genlist, forward); + ELSE + Services.SeekType(for, type); + ASSERT(type # NIL); + IF Disciplines.Seek(type, typeDiscID, disc) THEN + tdisc := disc(TypeDiscipline) + ELSE + NEW(tdisc); tdisc.id := typeDiscID; tdisc.list := NIL; END; - END Update; + Insert(tdisc.list, forward); + Disciplines.Add(type, tdisc); + END; + END Register; - PROCEDURE Forward*(from, to: Object); - (* forward (as far as supported) all operations from `from' to `to' *) - VAR - type, otherType, baseType: Services.Type; - tdisc: TypeDiscipline; - odisc: ObjectDiscipline; - client: ListOfDependants; - forwarder: ListOfForwarders; + PROCEDURE RegisterObject*(object: Object; forward: ForwardProc); + (* to be called instead of Register if specific objects + are supported only and not all extensions of a type + *) + VAR + odisc: ObjectDiscipline; + BEGIN + GetObjectDiscipline(object, odisc); + Insert(odisc.forwarders, forward); + END RegisterObject; - PROCEDURE CallForwarders(list: ListOfForwarders); - BEGIN - WHILE list # NIL DO - list.forward(from, to); - list := list.next; - END; - END CallForwarders; - - BEGIN (* Forward *) - Services.GetType(from, type); - Services.GetType(to, otherType); - ASSERT((type # NIL) & (otherType # NIL)); - - IF Resources.Terminated(to) OR Resources.Terminated(from) THEN - (* forwarding operations is no longer useful *) - RETURN + PROCEDURE Update*(object: Object; forward: ForwardProc); + (* is to be called by one of the registered forwarders if + an interface for object has been newly installed or changed + in a way which needs forward to be called for each of + the filter objects which delegate to `object' + *) + VAR + odisc: ObjectDiscipline; + disc: Disciplines.Discipline; + client: ListOfDependants; + BEGIN + IF Disciplines.Seek(object, objectDiscID, disc) THEN + odisc := disc(ObjectDiscipline); + client := odisc.dependants; + WHILE client # NIL DO + forward(client.dependant, object); + client := client.next; END; - Resources.DependsOn(from, to); + END; + END Update; - (* update the list of dependants for `to' *) - GetObjectDiscipline(to, odisc); - NEW(client); client.dependant := from; - client.next := odisc.dependants; odisc.dependants := client; + PROCEDURE Forward*(from, to: Object); + (* forward (as far as supported) all operations from `from' to `to' *) + VAR + type, otherType, baseType: Services.Type; + disc: Disciplines.Discipline; + tdisc: TypeDiscipline; + odisc: ObjectDiscipline; + client: ListOfDependants; + forwarder: ListOfForwarders; - (* call object-specific forwarders *) - CallForwarders(odisc.forwarders); - - LOOP (* go through the list of base types in descending order *) - IF Disciplines.Seek(type, typeDiscID, SYSTEM.VAL(Disciplines.Discipline, tdisc)) & (* noch *) - Services.IsExtensionOf(otherType, type) THEN - CallForwarders(tdisc.list); - END; - Services.GetBaseType(type, baseType); - IF baseType = NIL THEN EXIT END; - type := baseType; + PROCEDURE CallForwarders(list: ListOfForwarders); + BEGIN + WHILE list # NIL DO + list.forward(from, to); + list := list.next; END; - CallForwarders(genlist); - END Forward; + END CallForwarders; + + BEGIN (* Forward *) + Services.GetType(from, type); + Services.GetType(to, otherType); + ASSERT((type # NIL) & (otherType # NIL)); + + IF Resources.Terminated(to) OR Resources.Terminated(from) THEN + (* forwarding operations is no longer useful *) + RETURN + END; + Resources.DependsOn(from, to); + + (* update the list of dependants for `to' *) + GetObjectDiscipline(to, odisc); + NEW(client); client.dependant := from; + client.next := odisc.dependants; odisc.dependants := client; + + (* call object-specific forwarders *) + CallForwarders(odisc.forwarders); + + LOOP (* go through the list of base types in descending order *) + IF Disciplines.Seek(type, typeDiscID, disc) & Services.IsExtensionOf(otherType, type) THEN + tdisc := disc(TypeDiscipline); + CallForwarders(tdisc.list); + END; + Services.GetBaseType(type, baseType); + IF baseType = NIL THEN EXIT END; + type := baseType; + END; + CallForwarders(genlist); + END Forward; BEGIN - genlist := NIL; - typeDiscID := Disciplines.Unique(); - objectDiscID := Disciplines.Unique(); + genlist := NIL; + typeDiscID := Disciplines.Unique(); + objectDiscID := Disciplines.Unique(); END ulmForwarders. diff --git a/src/library/ulm/ulmIO.Mod b/src/library/ulm/ulmIO.Mod index 04bc3bcb..162aa127 100644 --- a/src/library/ulm/ulmIO.Mod +++ b/src/library/ulm/ulmIO.Mod @@ -42,9 +42,7 @@ MODULE ulmIO; dig : LONGINT; NumberLen : SHORTINT; BEGIN - IF SIZE(LONGINT) = 4 THEN - NumberLen := 11 - ELSIF SIZE(LONGINT) = 8 THEN + IF SIZE(LONGINT) = 8 THEN NumberLen := 21 ELSE NumberLen := 11 (* default value, corresponds to 32 bit *) diff --git a/src/library/ulm/ulmIndirectDisciplines.Mod b/src/library/ulm/ulmIndirectDisciplines.Mod index 3118852e..22e06b14 100644 --- a/src/library/ulm/ulmIndirectDisciplines.Mod +++ b/src/library/ulm/ulmIndirectDisciplines.Mod @@ -43,23 +43,24 @@ MODULE ulmIndirectDisciplines; TYPE IndDiscipline = POINTER TO IndDisciplineRec; IndDisciplineRec = - RECORD - (DisciplineRec) - forwardTo: Object; - END; + RECORD + (DisciplineRec) + forwardTo: Object; + END; + VAR discID: Identifier; PROCEDURE Forward*(from, to: Object); VAR - disc: IndDiscipline; + disc: IndDiscipline; BEGIN IF to = NIL THEN - Disciplines.Remove(from, discID); + Disciplines.Remove(from, discID); ELSE - NEW(disc); disc.id := discID; - disc.forwardTo := to; - Disciplines.Add(from, disc); + NEW(disc); disc.id := discID; + disc.forwardTo := to; + Disciplines.Add(from, disc); END; END Forward; @@ -70,44 +71,43 @@ MODULE ulmIndirectDisciplines; PROCEDURE Add*(object: Object; discipline: Discipline); VAR - disc: IndDiscipline; + disc: Discipline; BEGIN - WHILE Disciplines.Seek(object, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) DO - object := disc.forwardTo; + WHILE Disciplines.Seek(object, discID, disc) DO + object := disc(IndDiscipline).forwardTo; END; Disciplines.Add(object, discipline); END Add; PROCEDURE Remove*(object: Object; id: Identifier); VAR - dummy: Discipline; - disc: IndDiscipline; + dummy, disc: Discipline; BEGIN LOOP - IF Disciplines.Seek(object, id, dummy) THEN - Disciplines.Remove(object, id); - EXIT - END; - IF ~Disciplines.Seek(object, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - EXIT - END; - object := disc.forwardTo; + IF Disciplines.Seek(object, id, dummy) THEN + Disciplines.Remove(object, id); + EXIT + END; + IF ~Disciplines.Seek(object, discID, disc) THEN + EXIT + END; + object := disc(IndDiscipline).forwardTo; END; END Remove; PROCEDURE Seek*(object: Object; id: Identifier; - VAR discipline: Discipline) : BOOLEAN; + VAR discipline: Discipline) : BOOLEAN; VAR - disc: IndDiscipline; + disc: Discipline; BEGIN LOOP - IF Disciplines.Seek(object, id, discipline) THEN - RETURN TRUE - END; - IF ~Disciplines.Seek(object, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - RETURN FALSE - END; - object := disc.forwardTo; + IF Disciplines.Seek(object, id, discipline) THEN + RETURN TRUE + END; + IF ~Disciplines.Seek(object, discID, disc) THEN + RETURN FALSE + END; + object := disc(IndDiscipline).forwardTo; END; END Seek; diff --git a/src/library/ulm/ulmIntOperations.Mod b/src/library/ulm/ulmIntOperations.Mod index 33ec3161..3f1799aa 100644 --- a/src/library/ulm/ulmIntOperations.Mod +++ b/src/library/ulm/ulmIntOperations.Mod @@ -28,52 +28,53 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) - IMPORT Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, Services := ulmServices, Streams := ulmStreams, Types := ulmTypes, SYSTEM; + IMPORT + Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, + Services := ulmServices, Streams := ulmStreams, + Types := ulmTypes; -(* SYSTEM added to make casts necessary to port ulm library because ulm compiler is not as strict (read it's wrong) as it had to be --noch *) - - CONST + CONST mod* = 5; pow* = 6; inc* = 7; dec* = 8; mmul* = 9; mpow* = 10; odd* = 11; shift* = 12; - TYPE + TYPE Operation* = Operations.Operation; (* Operations.add..mpow *) Operand* = POINTER TO OperandRec; TYPE - CapabilitySet* = Operations.CapabilitySet; - (* SET of [Operations.add..shift] *) + CapabilitySet* = Operations.CapabilitySet; + (* SET of [Operations.add..shift] *) IsLargeEnoughForProc* = PROCEDURE (op: Operations.Operand; - n: LONGINT): BOOLEAN; + n: LONGINT): BOOLEAN; UnsignedProc* = PROCEDURE (op: Operations.Operand): BOOLEAN; IntToOpProc* = PROCEDURE (int32: Types.Int32; VAR op: Operations.Operand); OpToIntProc* = PROCEDURE (op: Operations.Operand; VAR int32: Types.Int32); Log2Proc* = PROCEDURE (op: Operations.Operand): LONGINT; OddProc* = PROCEDURE (op: Operations.Operand): BOOLEAN; - ShiftProc* = PROCEDURE (op: Operations.Operand; - n: INTEGER): Operations.Operand; - IntOperatorProc* = PROCEDURE(op: Operation; - op1, op2, op3: Operations.Operand; - VAR result: Operations.Operand); + ShiftProc* = PROCEDURE (op: Operations.Operand; + n: INTEGER): Operations.Operand; + IntOperatorProc* = PROCEDURE(op: Operation; + op1, op2, op3: Operations.Operand; + VAR result: Operations.Operand); Interface* = POINTER TO InterfaceRec; InterfaceRec* = RECORD - (Operations.InterfaceRec) - isLargeEnoughFor*: IsLargeEnoughForProc; - unsigned* : UnsignedProc; - intToOp* : IntToOpProc; - opToInt* : OpToIntProc; - log2* : Log2Proc; - odd* : OddProc; - shift* : ShiftProc; - intOp* : IntOperatorProc; + (Operations.InterfaceRec) + isLargeEnoughFor*: IsLargeEnoughForProc; + unsigned* : UnsignedProc; + intToOp* : IntToOpProc; + opToInt* : OpToIntProc; + log2* : Log2Proc; + odd* : OddProc; + shift* : ShiftProc; + intOp* : IntOperatorProc; END; TYPE OperandRec* = RECORD - (Operations.OperandRec); - (* private components *) - if : Interface; - caps: CapabilitySet; + (Operations.OperandRec); + (* private components *) + if : Interface; + caps: CapabilitySet; END; VAR @@ -97,7 +98,7 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) PROCEDURE IsLargeEnoughFor*(op: Operations.Operand; n: LONGINT): BOOLEAN; BEGIN WITH op: Operand DO - RETURN op.if.isLargeEnoughFor(op, n) + RETURN op.if.isLargeEnoughFor(op, n) END; END IsLargeEnoughFor; @@ -105,34 +106,18 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) PROCEDURE Unsigned*(op: Operations.Operand): BOOLEAN; BEGIN WITH op: Operand DO - RETURN op.if.unsigned(op) + RETURN op.if.unsigned(op) END; END Unsigned; PROCEDURE IntToOp*(int32: Types.Int32; VAR op: Operations.Operand); (* converts int32 into operand type, and stores result in already - initialized op + initialized op *) BEGIN - (*WITH op: Operand DO*) - (* - with original ulm source we were getting: - - WITH op: Operand DO - ^ - pos 4101 err 245 guarded pointer variable may be manipulated by non-local operations; use auxiliary pointer variable - - thus we considered changing WITH op: Operand by op(Operand) - - -- noch - - *) - (*ASSERT(op.if # NIL);*) - ASSERT(op(Operand).if # NIL); - (*op.if.intToOp(int32, op);*) - op(Operand).if.intToOp(int32, op(Operations.Operand)); - (*END;*) + ASSERT(op(Operand).if # NIL); + op(Operand).if.intToOp(int32, op); END IntToOp; @@ -140,7 +125,7 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) (* converts op into int32 *) BEGIN WITH op: Operand DO - op.if.opToInt(op, int32); + op.if.opToInt(op, int32); END; END OpToInt; @@ -148,7 +133,7 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) PROCEDURE Log2*(op: Operations.Operand): LONGINT; BEGIN WITH op: Operand DO - RETURN op.if.log2(op) + RETURN op.if.log2(op) END; END Log2; @@ -162,22 +147,22 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) END Odd; - PROCEDURE Op(op: Operation; op1, op2, op3: Operations.Operand; - VAR result: Operations.Operand); + PROCEDURE Op(op: Operation; op1, op2, op3: Operations.Operand; + VAR result: Operations.Operand); VAR tmpresult: Operations.Operand; BEGIN WITH op1: Operand DO - IF (op2#NIL) & (op3#NIL) THEN - ASSERT((op1.if = op2(Operand).if) & - (op2(Operand).if = op3(Operand).if)); - ELSIF (op2#NIL) THEN - ASSERT(op1.if = op2(Operand).if); - END; - ASSERT(op IN op1.caps); - op1.if.create(tmpresult); - op1.if.intOp(op, op1, op2, op3, tmpresult); - result := tmpresult; + IF (op2#NIL) & (op3#NIL) THEN + ASSERT((op1.if = op2(Operand).if) & + (op2(Operand).if = op3(Operand).if)); + ELSIF (op2#NIL) THEN + ASSERT(op1.if = op2(Operand).if); + END; + ASSERT(op IN op1.caps); + op1.if.create(tmpresult); + op1.if.intOp(op, op1, op2, op3, tmpresult); + result := tmpresult; END; END Op; @@ -197,15 +182,15 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) END Shift2; - PROCEDURE Shift3*(VAR result: Operations.Operand; op1: Operations.Operand; - n : INTEGER); + PROCEDURE Shift3*(VAR result: Operations.Operand; op1: Operations.Operand; + n : INTEGER); VAR tmpresult: Operations.Operand; BEGIN WITH op1: Operand DO - op1.if.create(tmpresult); - tmpresult := Shift(op1, n); - result := tmpresult; + op1.if.create(tmpresult); + tmpresult := Shift(op1, n); + result := tmpresult; END; END Shift3; @@ -230,7 +215,7 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) BEGIN Op(inc,op1,NIL,NIL,result); END Inc3; - + PROCEDURE Dec*(op1: Operations.Operand): Operations.Operand; VAR @@ -252,7 +237,7 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) BEGIN Op(dec,op1,NIL,NIL,result); END Dec3; - + PROCEDURE Mod*(op1, op2: Operations.Operand): Operations.Operand; VAR @@ -278,11 +263,10 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) PROCEDURE Pow*(op1, op2: Operations.Operand): Operations.Operand; VAR - result : Operand; + result: Operations.Operand; BEGIN result := NIL; - (*Op(pow, op1, op2, NIL, result);*) - Op(pow, op1, op2, NIL, SYSTEM.VAL(Operations.Operand, result)); (* -- noch *) + Op(pow, op1, op2, NIL, result); RETURN result END Pow; @@ -301,11 +285,10 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) PROCEDURE MMul*(op1, op2, op3: Operations.Operand): Operations.Operand; VAR - result : Operand; + result : Operations.Operand; BEGIN result := NIL; - (*Op(mmul, op1, op2, op3, result); *) - Op(mmul, op1, op2, op3, SYSTEM.VAL(Operations.Operand, result)); (* --noch*) + Op(mmul, op1, op2, op3, result); RETURN result END MMul; @@ -316,8 +299,8 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) END MMul2; - PROCEDURE MMul3*(VAR result: Operations.Operand; - op1, op2, op3: Operations.Operand); + PROCEDURE MMul3*(VAR result: Operations.Operand; + op1, op2, op3: Operations.Operand); BEGIN Op(mmul, op1, op2, op3, result); END MMul3; @@ -325,11 +308,10 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) PROCEDURE MPow*(op1, op2, op3: Operations.Operand): Operations.Operand; VAR - result : Operand; + result : Operations.Operand; BEGIN result := NIL; - (*Op(mpow, op1, op2, op3, result); *) - Op(mpow, op1, op2, op3, SYSTEM.VAL(Operations.Operand, result)); (* -- noch*) + Op(mpow, op1, op2, op3, result); RETURN result END MPow; @@ -340,8 +322,8 @@ MODULE ulmIntOperations; (* Frank B.J. Fischer *) END MPow2; - PROCEDURE MPow3*(VAR result: Operations.Operand; - op1, op2, op3: Operations.Operand); + PROCEDURE MPow3*(VAR result: Operations.Operand; + op1, op2, op3: Operations.Operand); BEGIN Op(mpow, op1, op2, op3, result); END MPow3; diff --git a/src/library/ulm/ulmNetIO.Mod b/src/library/ulm/ulmNetIO.Mod index 0d0d44a0..b9741f30 100644 --- a/src/library/ulm/ulmNetIO.Mod +++ b/src/library/ulm/ulmNetIO.Mod @@ -1,546 +1,554 @@ (* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: NetIO.om,v 1.4 2004/05/21 15:19:03 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: NetIO.om,v $ - Revision 1.4 2004/05/21 15:19:03 borchert - performance improvements: - - ReadConstStringD prefers Streams.ReadPart and ConstStrings.CreateD, - if possible - (based on code by Christian Ehrhardt) - - WriteConstString uses Streams.Copy instead of a loop that uses - Streams.ReadByte and Streams.WriteByte + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: NetIO.om,v 1.4 2004/05/21 15:19:03 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: NetIO.om,v $ + Revision 1.4 2004/05/21 15:19:03 borchert + performance improvements: + - ReadConstStringD prefers Streams.ReadPart and ConstStrings.CreateD, + if possible + (based on code by Christian Ehrhardt) + - WriteConstString uses Streams.Copy instead of a loop that uses + Streams.ReadByte and Streams.WriteByte - Revision 1.3 1995/03/17 16:28:20 borchert - - SizeOf stuff removed - - support of const strings added - - support of Forwarders added + Revision 1.3 1995/03/17 16:28:20 borchert + - SizeOf stuff removed + - support of const strings added + - support of Forwarders added - Revision 1.2 1994/07/18 14:18:37 borchert - unused variables of WriteString (ch + index) removed + Revision 1.2 1994/07/18 14:18:37 borchert + unused variables of WriteString (ch + index) removed - Revision 1.1 1994/02/22 20:08:43 borchert - Initial revision + Revision 1.1 1994/02/22 20:08:43 borchert + Initial revision - ---------------------------------------------------------------------------- - AFB 6/93 - ---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- + AFB 6/93 + ---------------------------------------------------------------------------- *) MODULE ulmNetIO; - (* abstraction for the exchange of Oberon base types which - are components of persistent data structures - *) + (* abstraction for the exchange of Oberon base types which + are components of persistent data structures + *) - IMPORT ConstStrings := ulmConstStrings, Disciplines := ulmDisciplines, Forwarders := ulmForwarders, Streams := ulmStreams, Strings := ulmStrings, - SYS := SYSTEM, Types := ulmTypes; + IMPORT ConstStrings := ulmConstStrings, Disciplines := ulmDisciplines, Forwarders := ulmForwarders, Streams := ulmStreams, Strings := ulmStrings, + SYS := SYSTEM, Types := ulmTypes; - TYPE - Byte* = Types.Byte; + TYPE + Byte* = Types.Byte; - TYPE - ReadByteProc* = - PROCEDURE (s: Streams.Stream; VAR byte: Byte) : BOOLEAN; - ReadCharProc* = - PROCEDURE (s: Streams.Stream; VAR char: CHAR) : BOOLEAN; - ReadBooleanProc* = - PROCEDURE (s: Streams.Stream; VAR boolean: BOOLEAN) : BOOLEAN; - ReadShortIntProc* = - PROCEDURE (s: Streams.Stream; VAR shortint: SHORTINT) : BOOLEAN; - ReadIntegerProc* = - PROCEDURE (s: Streams.Stream; VAR integer: INTEGER) : BOOLEAN; - ReadLongIntProc* = - PROCEDURE (s: Streams.Stream; VAR longint: LONGINT) : BOOLEAN; - ReadRealProc* = - PROCEDURE (s: Streams.Stream; VAR real: REAL) : BOOLEAN; - ReadLongRealProc* = - PROCEDURE (s: Streams.Stream; VAR longreal: LONGREAL) : BOOLEAN; - ReadSetProc* = - PROCEDURE (s: Streams.Stream; VAR set: SET) : BOOLEAN; - ReadStringProc* = - PROCEDURE (s: Streams.Stream; VAR string: ARRAY OF CHAR) : BOOLEAN; - ReadConstStringProc* = - PROCEDURE (s: Streams.Stream; domain: ConstStrings.Domain; - VAR string: ConstStrings.String) : BOOLEAN; + TYPE + ReadByteProc* = + PROCEDURE (s: Streams.Stream; VAR byte: Byte) : BOOLEAN; + ReadCharProc* = + PROCEDURE (s: Streams.Stream; VAR char: CHAR) : BOOLEAN; + ReadBooleanProc* = + PROCEDURE (s: Streams.Stream; VAR boolean: BOOLEAN) : BOOLEAN; + ReadShortIntProc* = + PROCEDURE (s: Streams.Stream; VAR shortint: SHORTINT) : BOOLEAN; + ReadIntegerProc* = + PROCEDURE (s: Streams.Stream; VAR integer: INTEGER) : BOOLEAN; + ReadLongIntProc* = + PROCEDURE (s: Streams.Stream; VAR longint: LONGINT) : BOOLEAN; + ReadRealProc* = + PROCEDURE (s: Streams.Stream; VAR real: REAL) : BOOLEAN; + ReadLongRealProc* = + PROCEDURE (s: Streams.Stream; VAR longreal: LONGREAL) : BOOLEAN; + ReadSetProc* = + PROCEDURE (s: Streams.Stream; VAR set: SET) : BOOLEAN; + ReadStringProc* = + PROCEDURE (s: Streams.Stream; VAR string: ARRAY OF CHAR) : BOOLEAN; + ReadConstStringProc* = + PROCEDURE (s: Streams.Stream; domain: ConstStrings.Domain; + VAR string: ConstStrings.String) : BOOLEAN; - WriteByteProc* = - PROCEDURE (s: Streams.Stream; byte: Byte) : BOOLEAN; - WriteCharProc* = - PROCEDURE (s: Streams.Stream; char: CHAR) : BOOLEAN; - WriteBooleanProc* = - PROCEDURE (s: Streams.Stream; boolean: BOOLEAN) : BOOLEAN; - WriteShortIntProc* = - PROCEDURE (s: Streams.Stream; shortint: SHORTINT) : BOOLEAN; - WriteIntegerProc* = - PROCEDURE (s: Streams.Stream; integer: INTEGER) : BOOLEAN; - WriteLongIntProc* = - PROCEDURE (s: Streams.Stream; longint: LONGINT) : BOOLEAN; - WriteRealProc* = - PROCEDURE (s: Streams.Stream; real: REAL) : BOOLEAN; - WriteLongRealProc* = - PROCEDURE (s: Streams.Stream; longreal: LONGREAL) : BOOLEAN; - WriteSetProc* = - PROCEDURE (s: Streams.Stream; set: SET) : BOOLEAN; - WriteStringProc* = - PROCEDURE (s: Streams.Stream; string: ARRAY OF CHAR) : BOOLEAN; - WriteConstStringProc* = - PROCEDURE (s: Streams.Stream; - string: ConstStrings.String) : BOOLEAN; + WriteByteProc* = + PROCEDURE (s: Streams.Stream; byte: Byte) : BOOLEAN; + WriteCharProc* = + PROCEDURE (s: Streams.Stream; char: CHAR) : BOOLEAN; + WriteBooleanProc* = + PROCEDURE (s: Streams.Stream; boolean: BOOLEAN) : BOOLEAN; + WriteShortIntProc* = + PROCEDURE (s: Streams.Stream; shortint: SHORTINT) : BOOLEAN; + WriteIntegerProc* = + PROCEDURE (s: Streams.Stream; integer: INTEGER) : BOOLEAN; + WriteLongIntProc* = + PROCEDURE (s: Streams.Stream; longint: LONGINT) : BOOLEAN; + WriteRealProc* = + PROCEDURE (s: Streams.Stream; real: REAL) : BOOLEAN; + WriteLongRealProc* = + PROCEDURE (s: Streams.Stream; longreal: LONGREAL) : BOOLEAN; + WriteSetProc* = + PROCEDURE (s: Streams.Stream; set: SET) : BOOLEAN; + WriteStringProc* = + PROCEDURE (s: Streams.Stream; string: ARRAY OF CHAR) : BOOLEAN; + WriteConstStringProc* = + PROCEDURE (s: Streams.Stream; + string: ConstStrings.String) : BOOLEAN; - Interface* = POINTER TO InterfaceRec; - InterfaceRec* = - RECORD - readByte*: ReadByteProc; - readChar*: ReadCharProc; - readBoolean*: ReadBooleanProc; - readShortInt*: ReadShortIntProc; - readInteger*: ReadIntegerProc; - readLongInt*: ReadLongIntProc; - readReal*: ReadRealProc; - readLongReal*: ReadLongRealProc; - readSet*: ReadSetProc; - readString*: ReadStringProc; - readConstString*: ReadConstStringProc; + Interface* = POINTER TO InterfaceRec; + InterfaceRec* = + RECORD + readByte*: ReadByteProc; + readChar*: ReadCharProc; + readBoolean*: ReadBooleanProc; + readShortInt*: ReadShortIntProc; + readInteger*: ReadIntegerProc; + readLongInt*: ReadLongIntProc; + readReal*: ReadRealProc; + readLongReal*: ReadLongRealProc; + readSet*: ReadSetProc; + readString*: ReadStringProc; + readConstString*: ReadConstStringProc; - writeByte*: WriteByteProc; - writeChar*: WriteCharProc; - writeBoolean*: WriteBooleanProc; - writeShortInt*: WriteShortIntProc; - writeInteger*: WriteIntegerProc; - writeLongInt*: WriteLongIntProc; - writeReal*: WriteRealProc; - writeLongReal*: WriteLongRealProc; - writeSet*: WriteSetProc; - writeString*: WriteStringProc; - writeConstString*: WriteConstStringProc; - END; - - (* private data structures *) - TYPE - Discipline = POINTER TO DisciplineRec; - DisciplineRec = - RECORD - (Disciplines.DisciplineRec) - if: Interface; - END; - VAR - discID: Disciplines.Identifier; - - PROCEDURE Swap (VAR a : ARRAY OF SYS.BYTE); - VAR - i,j : LONGINT; - tmp : SYS.BYTE; - BEGIN - i := 0; j := LEN (a) - 1; - WHILE i < j DO - tmp := a[i]; a[i] := a[j]; a[j] := tmp; - INC (i); DEC (j); + writeByte*: WriteByteProc; + writeChar*: WriteCharProc; + writeBoolean*: WriteBooleanProc; + writeShortInt*: WriteShortIntProc; + writeInteger*: WriteIntegerProc; + writeLongInt*: WriteLongIntProc; + writeReal*: WriteRealProc; + writeLongReal*: WriteLongRealProc; + writeSet*: WriteSetProc; + writeString*: WriteStringProc; + writeConstString*: WriteConstStringProc; END; - END Swap; - PROCEDURE BitSwap (VAR a : ARRAY OF SYS.BYTE); - VAR - i,old, bit : LONGINT; - new : LONGINT; - - BEGIN - i := 0; - WHILE i < LEN (a) DO - old := ORD (SYS.VAL (CHAR, a[i])); - new := 0; bit := 080H; - WHILE old # 0 DO - IF ODD (old) THEN - INC (new, bit); - END; - bit := ASH (bit, -1);; - old := ASH (old, -1); - END; - a[i] := SYS.VAL (SYS.BYTE, new); - INC (i); + (* private data structures *) + TYPE + Discipline = POINTER TO DisciplineRec; + DisciplineRec = + RECORD + (Disciplines.DisciplineRec) + if: Interface; END; - END BitSwap; + VAR + discID: Disciplines.Identifier; - PROCEDURE ^ Forward(from, to: Forwarders.Object); + PROCEDURE Seek(s: Streams.Stream; id: Disciplines.Identifier; disc: Discipline): BOOLEAN; + VAR d: Disciplines.Discipline; result: BOOLEAN; + BEGIN + result := Disciplines.Seek(s, id, d); + IF result THEN disc := d(Discipline) ELSE disc := NIL END; + RETURN result + END Seek; - PROCEDURE AttachInterface*(s: Streams.Stream; if: Interface); - VAR - disc: Discipline; - BEGIN - IF if # NIL THEN - NEW(disc); disc.id := discID; disc.if := if; - Disciplines.Add(s, disc); + PROCEDURE Swap (VAR a : ARRAY OF SYS.BYTE); + VAR + i,j : LONGINT; + tmp : SYS.BYTE; + BEGIN + i := 0; j := LEN (a) - 1; + WHILE i < j DO + tmp := a[i]; a[i] := a[j]; a[j] := tmp; + INC (i); DEC (j); + END; + END Swap; + + PROCEDURE BitSwap (VAR a : ARRAY OF SYS.BYTE); + VAR + i,old, bit : LONGINT; + new : LONGINT; + + BEGIN + i := 0; + WHILE i < LEN (a) DO + old := ORD (SYS.VAL (CHAR, a[i])); + new := 0; bit := 080H; + WHILE old # 0 DO + IF ODD (old) THEN + INC (new, bit); + END; + bit := ASH (bit, -1);; + old := ASH (old, -1); + END; + a[i] := SYS.VAL (SYS.BYTE, new); + INC (i); + END; + END BitSwap; + + PROCEDURE ^ Forward(from, to: Forwarders.Object); + + PROCEDURE AttachInterface*(s: Streams.Stream; if: Interface); + VAR + disc: Discipline; + BEGIN + IF if # NIL THEN + NEW(disc); disc.id := discID; disc.if := if; + Disciplines.Add(s, disc); + ELSE + Disciplines.Remove(s, discID); + END; + Forwarders.Update(s, Forward); + END AttachInterface; + + PROCEDURE GetInterface(s: Streams.Stream; VAR if: Interface); + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + if := disc.if; + ELSE + if := NIL; + END; + END GetInterface; + + PROCEDURE CopyInterface*(from, to: Streams.Stream); + VAR + if: Interface; + BEGIN + GetInterface(from, if); + AttachInterface(to, if); + END CopyInterface; + + PROCEDURE Forward(from, to: Forwarders.Object); + BEGIN + (* this check is necessary because of Forwarders.Update *) + IF ~(from IS Streams.Stream) OR ~(to IS Streams.Stream) THEN + RETURN + END; + + WITH from: Streams.Stream DO WITH to: Streams.Stream DO + (* be careful here, from & to must be reversed *) + CopyInterface(to, from); + END; END; + END Forward; + + PROCEDURE ReadByte*(s: Streams.Stream; VAR byte: Byte) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readByte(s, byte) + ELSE + RETURN Streams.ReadByte(s, byte) + END; + END ReadByte; + + PROCEDURE ReadChar*(s: Streams.Stream; VAR char: CHAR) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readChar(s, char) + ELSE + RETURN Streams.ReadByte(s, char) + END; + END ReadChar; + + PROCEDURE ReadBoolean*(s: Streams.Stream; VAR boolean: BOOLEAN) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readBoolean(s, boolean) + ELSE + RETURN Streams.Read(s, boolean) + END; + END ReadBoolean; + + PROCEDURE ReadShortInt*(s: Streams.Stream; VAR shortint: SHORTINT) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readShortInt(s, shortint) + ELSE + RETURN Streams.ReadByte(s, shortint) + END; + END ReadShortInt; + + PROCEDURE ReadInteger*(s: Streams.Stream; VAR integer: INTEGER) : BOOLEAN; + VAR + disc: Discipline; + ret : BOOLEAN; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readInteger(s, integer) + ELSE + ret := Streams.Read(s, integer); + IF Types.byteorder = Types.littleEndian THEN + Swap (integer); + END; + RETURN ret; + END; + END ReadInteger; + + PROCEDURE ReadLongInt*(s: Streams.Stream; VAR longint: LONGINT) : BOOLEAN; + VAR + disc: Discipline; + ret : BOOLEAN; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readLongInt(s, longint) + ELSE + ret := Streams.Read(s, longint); + IF Types.byteorder = Types.littleEndian THEN + Swap (longint); + END; + RETURN ret; + END; + END ReadLongInt; + + PROCEDURE ReadReal*(s: Streams.Stream; VAR real: REAL) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readReal(s, real) + ELSE + RETURN Streams.Read(s, real) + END; + END ReadReal; + + PROCEDURE ReadLongReal*(s: Streams.Stream; VAR longreal: LONGREAL) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readLongReal(s, longreal) + ELSE + RETURN Streams.Read(s, longreal) + END; + END ReadLongReal; + + PROCEDURE ReadSet*(s: Streams.Stream; VAR set: SET) : BOOLEAN; + VAR + disc: Discipline; + ret : BOOLEAN; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readSet(s, set) + ELSE + ret := Streams.Read(s, set); + IF Types.byteorder = Types.littleEndian THEN + BitSwap (set); + END; + RETURN ret; + END; + END ReadSet; + + PROCEDURE ReadString*(s: Streams.Stream; VAR string: ARRAY OF CHAR) : BOOLEAN; + VAR + disc: Discipline; + ch: CHAR; index: LONGINT; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readString(s, string) + ELSE + index := 0; + WHILE Streams.ReadByte(s, ch) & (ch # 0X) DO + IF index + 1 < LEN(string) THEN + string[index] := ch; INC(index); + END; + END; + string[index] := 0X; + RETURN ~s.error + END; + END ReadString; + + PROCEDURE ReadConstStringD*(s: Streams.Stream; + domain: ConstStrings.Domain; + VAR string: ConstStrings.String) : BOOLEAN; + CONST + bufsize = 512; + VAR + length: LONGINT; + buf: Streams.Stream; + ch: CHAR; + disc: Discipline; + stringbuf: ARRAY bufsize OF CHAR; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.readConstString(s, domain, string) + ELSE + IF ReadLongInt(s, length) THEN + IF length >= bufsize THEN + ConstStrings.Init(buf); + IF ~Streams.Copy(s, buf, length) THEN + RETURN FALSE + END; + ConstStrings.CloseD(buf, domain, string); + RETURN length = s.count; + ELSE + IF ~Streams.ReadPart(s, stringbuf, 0, length) THEN + RETURN FALSE + END; + stringbuf[length] := 0X; + ConstStrings.CreateD(string, domain, stringbuf); + RETURN TRUE + END; ELSE - Disciplines.Remove(s, discID); + RETURN FALSE END; - Forwarders.Update(s, Forward); - END AttachInterface; + END; + END ReadConstStringD; - PROCEDURE GetInterface(s: Streams.Stream; VAR if: Interface); - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - if := disc.if; + PROCEDURE ReadConstString*(s: Streams.Stream; + VAR string: ConstStrings.String) : BOOLEAN; + BEGIN + RETURN ReadConstStringD(s, ConstStrings.std, string) + END ReadConstString; + + PROCEDURE WriteByte*(s: Streams.Stream; byte: Byte) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeByte(s, byte) + ELSE + RETURN Streams.WriteByte(s, byte) + END; + END WriteByte; + + PROCEDURE WriteChar*(s: Streams.Stream; char: CHAR) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeChar(s, char) + ELSE + RETURN Streams.WriteByte(s, char) + END; + END WriteChar; + + PROCEDURE WriteBoolean*(s: Streams.Stream; boolean: BOOLEAN) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeBoolean(s, boolean) + ELSE + RETURN Streams.Write(s, boolean) + END; + END WriteBoolean; + + PROCEDURE WriteShortInt*(s: Streams.Stream; shortint: SHORTINT) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeShortInt(s, shortint) + ELSE + RETURN Streams.WriteByte(s, shortint) + END; + END WriteShortInt; + + PROCEDURE WriteInteger*(s: Streams.Stream; integer: INTEGER) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeInteger(s, integer) + ELSE + IF Types.byteorder = Types.littleEndian THEN + Swap (integer); + END; + RETURN Streams.Write(s, integer); + END; + END WriteInteger; + + PROCEDURE WriteLongInt*(s: Streams.Stream; longint: LONGINT) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeLongInt(s, longint) + ELSE + IF Types.byteorder = Types.littleEndian THEN + Swap (longint); + END; + RETURN Streams.Write(s, longint); + END; + END WriteLongInt; + + PROCEDURE WriteReal*(s: Streams.Stream; real: REAL) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeReal(s, real) + ELSE + RETURN Streams.Write(s, real) + END; + END WriteReal; + + PROCEDURE WriteLongReal*(s: Streams.Stream; longreal: LONGREAL) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeLongReal(s, longreal) + ELSE + RETURN Streams.Write(s, longreal) + END; + END WriteLongReal; + + PROCEDURE WriteSet*(s: Streams.Stream; set: SET) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeSet(s, set) + ELSE + IF Types.byteorder = Types.littleEndian THEN + BitSwap (set); + END; + RETURN Streams.Write(s, set) + END; + END WriteSet; + + PROCEDURE WriteString*(s: Streams.Stream; string: ARRAY OF CHAR) : BOOLEAN; + VAR + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeString(s, string) + ELSE + RETURN Streams.WritePart(s, string, 0, Strings.Len(string)) & + Streams.WriteByte(s, 0X) + END; + END WriteString; + + PROCEDURE WriteConstString*(s: Streams.Stream; + string: ConstStrings.String) : BOOLEAN; + VAR + ch: CHAR; + buf: Streams.Stream; + disc: Discipline; + BEGIN + IF Seek(s, discID, disc) THEN + RETURN disc.if.writeConstString(s, string) + ELSE + IF WriteLongInt(s, string.len) THEN + ConstStrings.Open(buf, string); + RETURN Streams.Copy(buf, s, string.len) ELSE - if := NIL; + RETURN FALSE END; - END GetInterface; - - PROCEDURE CopyInterface*(from, to: Streams.Stream); - VAR - if: Interface; - BEGIN - GetInterface(from, if); - AttachInterface(to, if); - END CopyInterface; - - PROCEDURE Forward(from, to: Forwarders.Object); - BEGIN - (* this check is necessary because of Forwarders.Update *) - IF ~(from IS Streams.Stream) OR ~(to IS Streams.Stream) THEN - RETURN - END; - - WITH from: Streams.Stream DO WITH to: Streams.Stream DO - (* be careful here, from & to must be reversed *) - CopyInterface(to, from); - END; END; - END Forward; - - PROCEDURE ReadByte*(s: Streams.Stream; VAR byte: Byte) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readByte(s, byte) - ELSE - RETURN Streams.ReadByte(s, byte) - END; - END ReadByte; - - PROCEDURE ReadChar*(s: Streams.Stream; VAR char: CHAR) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readChar(s, char) - ELSE - RETURN Streams.ReadByte(s, char) - END; - END ReadChar; - - PROCEDURE ReadBoolean*(s: Streams.Stream; VAR boolean: BOOLEAN) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readBoolean(s, boolean) - ELSE - RETURN Streams.Read(s, boolean) - END; - END ReadBoolean; - - PROCEDURE ReadShortInt*(s: Streams.Stream; VAR shortint: SHORTINT) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readShortInt(s, shortint) - ELSE - RETURN Streams.ReadByte(s, shortint) - END; - END ReadShortInt; - - PROCEDURE ReadInteger*(s: Streams.Stream; VAR integer: INTEGER) : BOOLEAN; - VAR - disc: Discipline; - ret : BOOLEAN; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readInteger(s, integer) - ELSE - ret := Streams.Read(s, integer); - IF Types.byteorder = Types.littleEndian THEN - Swap (integer); - END; - RETURN ret; - END; - END ReadInteger; - - PROCEDURE ReadLongInt*(s: Streams.Stream; VAR longint: LONGINT) : BOOLEAN; - VAR - disc: Discipline; - ret : BOOLEAN; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readLongInt(s, longint) - ELSE - ret := Streams.Read(s, longint); - IF Types.byteorder = Types.littleEndian THEN - Swap (longint); - END; - RETURN ret; - END; - END ReadLongInt; - - PROCEDURE ReadReal*(s: Streams.Stream; VAR real: REAL) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readReal(s, real) - ELSE - RETURN Streams.Read(s, real) - END; - END ReadReal; - - PROCEDURE ReadLongReal*(s: Streams.Stream; VAR longreal: LONGREAL) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readLongReal(s, longreal) - ELSE - RETURN Streams.Read(s, longreal) - END; - END ReadLongReal; - - PROCEDURE ReadSet*(s: Streams.Stream; VAR set: SET) : BOOLEAN; - VAR - disc: Discipline; - ret : BOOLEAN; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readSet(s, set) - ELSE - ret := Streams.Read(s, set); - IF Types.byteorder = Types.littleEndian THEN - BitSwap (set); - END; - RETURN ret; - END; - END ReadSet; - - PROCEDURE ReadString*(s: Streams.Stream; VAR string: ARRAY OF CHAR) : BOOLEAN; - VAR - disc: Discipline; - ch: CHAR; index: LONGINT; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readString(s, string) - ELSE - index := 0; - WHILE Streams.ReadByte(s, ch) & (ch # 0X) DO - IF index + 1 < LEN(string) THEN - string[index] := ch; INC(index); - END; - END; - string[index] := 0X; - RETURN ~s.error - END; - END ReadString; - - PROCEDURE ReadConstStringD*(s: Streams.Stream; - domain: ConstStrings.Domain; - VAR string: ConstStrings.String) : BOOLEAN; - CONST - bufsize = 512; - VAR - length: LONGINT; - buf: Streams.Stream; - ch: CHAR; - disc: Discipline; - stringbuf: ARRAY bufsize OF CHAR; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.readConstString(s, domain, string) - ELSE - IF ReadLongInt(s, length) THEN - IF length >= bufsize THEN - ConstStrings.Init(buf); - IF ~Streams.Copy(s, buf, length) THEN - RETURN FALSE - END; - ConstStrings.CloseD(buf, domain, string); - RETURN length = s.count; - ELSE - IF ~Streams.ReadPart(s, stringbuf, 0, length) THEN - RETURN FALSE - END; - stringbuf[length] := 0X; - ConstStrings.CreateD(string, domain, stringbuf); - RETURN TRUE - END; - ELSE - RETURN FALSE - END; - END; - END ReadConstStringD; - - PROCEDURE ReadConstString*(s: Streams.Stream; - VAR string: ConstStrings.String) : BOOLEAN; - BEGIN - RETURN ReadConstStringD(s, ConstStrings.std, string) - END ReadConstString; - - PROCEDURE WriteByte*(s: Streams.Stream; byte: Byte) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeByte(s, byte) - ELSE - RETURN Streams.WriteByte(s, byte) - END; - END WriteByte; - - PROCEDURE WriteChar*(s: Streams.Stream; char: CHAR) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeChar(s, char) - ELSE - RETURN Streams.WriteByte(s, char) - END; - END WriteChar; - - PROCEDURE WriteBoolean*(s: Streams.Stream; boolean: BOOLEAN) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeBoolean(s, boolean) - ELSE - RETURN Streams.Write(s, boolean) - END; - END WriteBoolean; - - PROCEDURE WriteShortInt*(s: Streams.Stream; shortint: SHORTINT) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeShortInt(s, shortint) - ELSE - RETURN Streams.WriteByte(s, shortint) - END; - END WriteShortInt; - - PROCEDURE WriteInteger*(s: Streams.Stream; integer: INTEGER) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeInteger(s, integer) - ELSE - IF Types.byteorder = Types.littleEndian THEN - Swap (integer); - END; - RETURN Streams.Write(s, integer); - END; - END WriteInteger; - - PROCEDURE WriteLongInt*(s: Streams.Stream; longint: LONGINT) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeLongInt(s, longint) - ELSE - IF Types.byteorder = Types.littleEndian THEN - Swap (longint); - END; - RETURN Streams.Write(s, longint); - END; - END WriteLongInt; - - PROCEDURE WriteReal*(s: Streams.Stream; real: REAL) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeReal(s, real) - ELSE - RETURN Streams.Write(s, real) - END; - END WriteReal; - - PROCEDURE WriteLongReal*(s: Streams.Stream; longreal: LONGREAL) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeLongReal(s, longreal) - ELSE - RETURN Streams.Write(s, longreal) - END; - END WriteLongReal; - - PROCEDURE WriteSet*(s: Streams.Stream; set: SET) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeSet(s, set) - ELSE - IF Types.byteorder = Types.littleEndian THEN - BitSwap (set); - END; - RETURN Streams.Write(s, set) - END; - END WriteSet; - - PROCEDURE WriteString*(s: Streams.Stream; string: ARRAY OF CHAR) : BOOLEAN; - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeString(s, string) - ELSE - RETURN Streams.WritePart(s, string, 0, Strings.Len(string)) & - Streams.WriteByte(s, 0X) - END; - END WriteString; - - PROCEDURE WriteConstString*(s: Streams.Stream; - string: ConstStrings.String) : BOOLEAN; - VAR - ch: CHAR; - buf: Streams.Stream; - disc: Discipline; - BEGIN - IF Disciplines.Seek(s, discID, SYS.VAL(Disciplines.Discipline, disc)) THEN - RETURN disc.if.writeConstString(s, string) - ELSE - IF WriteLongInt(s, string.len) THEN - ConstStrings.Open(buf, string); - RETURN Streams.Copy(buf, s, string.len) - ELSE - RETURN FALSE - END; - END; - END WriteConstString; + END; + END WriteConstString; BEGIN - discID := Disciplines.Unique(); - Forwarders.Register("Streams.Stream", Forward); + discID := Disciplines.Unique(); + Forwarders.Register("Streams.Stream", Forward); END ulmNetIO. diff --git a/src/library/ulm/ulmOperations.Mod b/src/library/ulm/ulmOperations.Mod index 4f74cc61..617b9808 100644 --- a/src/library/ulm/ulmOperations.Mod +++ b/src/library/ulm/ulmOperations.Mod @@ -1,234 +1,234 @@ (* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Operations.om,v 1.4 2004/09/16 18:31:54 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Operations.om,v $ - Revision 1.4 2004/09/16 18:31:54 borchert - optimization for Assign added in case of a non-NIL target - and identical types for target and source + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Operations.om,v 1.4 2004/09/16 18:31:54 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Operations.om,v $ + Revision 1.4 2004/09/16 18:31:54 borchert + optimization for Assign added in case of a non-NIL target + and identical types for target and source - Revision 1.3 1997/02/05 16:27:45 borchert - Init asserts now that Services.Init hat been called previously - for ``op'' + Revision 1.3 1997/02/05 16:27:45 borchert + Init asserts now that Services.Init hat been called previously + for ``op'' - Revision 1.2 1995/01/16 21:39:50 borchert - - assertions of Assertions have been converted into real assertions - - some fixes due to changes of PersistentObjects + Revision 1.2 1995/01/16 21:39:50 borchert + - assertions of Assertions have been converted into real assertions + - some fixes due to changes of PersistentObjects - Revision 1.1 1994/02/22 20:09:03 borchert - Initial revision + Revision 1.1 1994/02/22 20:09:03 borchert + Initial revision - ---------------------------------------------------------------------------- - AFB 12/91 - ---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- + AFB 12/91 + ---------------------------------------------------------------------------- *) MODULE ulmOperations; - (* generic support of arithmetic operations *) + (* generic support of arithmetic operations *) - IMPORT Events := ulmEvents, Objects := ulmObjects, PersistentDisciplines := ulmPersistentDisciplines, PersistentObjects := ulmPersistentObjects, Services := ulmServices; + IMPORT Events := ulmEvents, Objects := ulmObjects, PersistentDisciplines := ulmPersistentDisciplines, PersistentObjects := ulmPersistentObjects, Services := ulmServices; - CONST - add* = 0; sub* = 1; mul* = 2; div* = 3; cmp* = 4; - TYPE - Operation* = SHORTINT; (* add..cmp *) - Operand* = POINTER TO OperandRec; + CONST + add* = 0; sub* = 1; mul* = 2; div* = 3; cmp* = 4; + TYPE + Operation* = SHORTINT; (* add..cmp *) + Operand* = POINTER TO OperandRec; - TYPE - CapabilitySet* = SET; (* SET OF [add..cmp] *) - CreateProc* = PROCEDURE (VAR op: Operand); - (* should call Operations.Init for op *) - OperatorProc* = PROCEDURE (op: Operation; op1, op2: Operand; - VAR result: Operand); - AssignProc* = PROCEDURE (VAR target: Operand; source: Operand); - CompareProc* = PROCEDURE (op1, op2: Operand) : INTEGER; - Interface* = POINTER TO InterfaceRec; - InterfaceRec* = - RECORD - (Objects.ObjectRec) - create*: CreateProc; - assign*: AssignProc; - op*: OperatorProc; - compare*: CompareProc; - END; - - TYPE - OperandRec* = - RECORD - (PersistentDisciplines.ObjectRec) - if: Interface; - caps: CapabilitySet; - END; - VAR - operandType: Services.Type; - - PROCEDURE Init*(op: Operand; if: Interface; caps: CapabilitySet); - VAR - type: Services.Type; - BEGIN - Services.GetType(op, type); ASSERT(type # NIL); - op.if := if; op.caps := caps; - END Init; - - PROCEDURE Capabilities*(op: Operand) : CapabilitySet; - BEGIN - RETURN op.caps - END Capabilities; - - PROCEDURE Compatible*(op1, op2: Operand) : BOOLEAN; - (* return TRUE if both operands have the same interface *) - BEGIN - RETURN op1.if = op2.if - END Compatible; - - (* the interface of the first operand must match the interface - of all other operands; - the result parameter must be either NIL or already initialized - with the same interface - *) - - PROCEDURE Op(op: Operation; op1, op2: Operand; VAR result: Operand); - - VAR - tmpresult: Operand; - BEGIN - ASSERT(op1.if = op2.if); - ASSERT(op IN op1.caps); - (* we are very defensive here because the type of tmpresult - is perhaps not identical to result or an extension of it; - op1.if.create(result) will not work in all cases - because of type guard failures - *) - op1.if.create(tmpresult); - op1.if.op(op, op1, op2, tmpresult); - result := tmpresult; - END Op; - - PROCEDURE Add*(op1, op2: Operand) : Operand; - VAR result: Operand; - BEGIN - result := NIL; - Op(add, op1, op2, result); - RETURN result - END Add; - - PROCEDURE Add2*(VAR op1: Operand; op2: Operand); - BEGIN - Op(add, op1, op2, op1); - END Add2; - - PROCEDURE Add3*(VAR result: Operand; op1, op2: Operand); - BEGIN - Op(add, op1, op2, result); - END Add3; - - PROCEDURE Sub*(op1, op2: Operand) : Operand; - VAR result: Operand; - BEGIN - result := NIL; - Op(sub, op1, op2, result); - RETURN result - END Sub; - - PROCEDURE Sub2*(VAR op1: Operand; op2: Operand); - BEGIN - Op(sub, op1, op2, op1); - END Sub2; - - PROCEDURE Sub3*(VAR result: Operand; op1, op2: Operand); - BEGIN - Op(sub, op1, op2, result); - END Sub3; - - PROCEDURE Mul*(op1, op2: Operand) : Operand; - VAR result: Operand; - BEGIN - result := NIL; - Op(mul, op1, op2, result); - RETURN result - END Mul; - - PROCEDURE Mul2*(VAR op1: Operand; op2: Operand); - BEGIN - Op(mul, op1, op2, op1); - END Mul2; - - PROCEDURE Mul3*(VAR result: Operand; op1, op2: Operand); - BEGIN - Op(mul, op1, op2, result); - END Mul3; - - PROCEDURE Div*(op1, op2: Operand) : Operand; - VAR result: Operand; - BEGIN - result := NIL; - Op(div, op1, op2, result); - RETURN result - END Div; - - PROCEDURE Div2*(VAR op1: Operand; op2: Operand); - BEGIN - Op(div, op1, op2, op1); - END Div2; - - PROCEDURE Div3*(VAR result: Operand; op1, op2: Operand); - BEGIN - Op(div, op1, op2, result); - END Div3; - - PROCEDURE Compare*(op1, op2: Operand) : INTEGER; - BEGIN - ASSERT(op1.if = op2.if); - ASSERT(cmp IN op1.caps); - RETURN op1.if.compare(op1, op2) - END Compare; - - PROCEDURE Assign*(VAR target: Operand; source: Operand); - VAR - tmpTarget: Operand; - typesIdentical: BOOLEAN; - targetType, sourceType: Services.Type; - BEGIN - IF (target # NIL) & (target.if = source.if) THEN - Services.GetType(target, targetType); - Services.GetType(source, sourceType); - typesIdentical := targetType = sourceType; - ELSE - typesIdentical := FALSE; + TYPE + CapabilitySet* = SET; (* SET OF [add..cmp] *) + CreateProc* = PROCEDURE (VAR op: Operand); + (* should call Operations.Init for op *) + OperatorProc* = PROCEDURE (op: Operation; op1, op2: Operand; + VAR result: Operand); + AssignProc* = PROCEDURE (VAR target: Operand; source: Operand); + CompareProc* = PROCEDURE (op1, op2: Operand) : INTEGER; + Interface* = POINTER TO InterfaceRec; + InterfaceRec* = + RECORD + (Objects.ObjectRec) + create*: CreateProc; + assign*: AssignProc; + op*: OperatorProc; + compare*: CompareProc; END; - IF typesIdentical THEN - source.if.assign(target, source); - ELSE - source.if.create(tmpTarget); - source.if.assign(tmpTarget, source); - target := tmpTarget; - END; - END Assign; - PROCEDURE Copy*(source, target: Operand); - BEGIN + TYPE + OperandRec* = + RECORD + (PersistentDisciplines.ObjectRec) + if: Interface; + caps: CapabilitySet; + END; + VAR + operandType: Services.Type; + + PROCEDURE Init*(op: Operand; if: Interface; caps: CapabilitySet); + VAR + type: Services.Type; + BEGIN + Services.GetType(op, type); ASSERT(type # NIL); + op.if := if; op.caps := caps; + END Init; + + PROCEDURE Capabilities*(op: Operand) : CapabilitySet; + BEGIN + RETURN op.caps + END Capabilities; + + PROCEDURE Compatible*(op1, op2: Operand) : BOOLEAN; + (* return TRUE if both operands have the same interface *) + BEGIN + RETURN op1.if = op2.if + END Compatible; + + (* the interface of the first operand must match the interface + of all other operands; + the result parameter must be either NIL or already initialized + with the same interface + *) + + PROCEDURE Op(op: Operation; op1, op2: Operand; VAR result: Operand); + + VAR + tmpresult: Operand; + BEGIN + ASSERT(op1.if = op2.if); + ASSERT(op IN op1.caps); + (* we are very defensive here because the type of tmpresult + is perhaps not identical to result or an extension of it; + op1.if.create(result) will not work in all cases + because of type guard failures + *) + op1.if.create(tmpresult); + op1.if.op(op, op1, op2, tmpresult); + result := tmpresult; + END Op; + + PROCEDURE Add*(op1, op2: Operand) : Operand; + VAR result: Operand; + BEGIN + result := NIL; + Op(add, op1, op2, result); + RETURN result + END Add; + + PROCEDURE Add2*(VAR op1: Operand; op2: Operand); + BEGIN + Op(add, op1, op2, op1); + END Add2; + + PROCEDURE Add3*(VAR result: Operand; op1, op2: Operand); + BEGIN + Op(add, op1, op2, result); + END Add3; + + PROCEDURE Sub*(op1, op2: Operand) : Operand; + VAR result: Operand; + BEGIN + result := NIL; + Op(sub, op1, op2, result); + RETURN result + END Sub; + + PROCEDURE Sub2*(VAR op1: Operand; op2: Operand); + BEGIN + Op(sub, op1, op2, op1); + END Sub2; + + PROCEDURE Sub3*(VAR result: Operand; op1, op2: Operand); + BEGIN + Op(sub, op1, op2, result); + END Sub3; + + PROCEDURE Mul*(op1, op2: Operand) : Operand; + VAR result: Operand; + BEGIN + result := NIL; + Op(mul, op1, op2, result); + RETURN result + END Mul; + + PROCEDURE Mul2*(VAR op1: Operand; op2: Operand); + BEGIN + Op(mul, op1, op2, op1); + END Mul2; + + PROCEDURE Mul3*(VAR result: Operand; op1, op2: Operand); + BEGIN + Op(mul, op1, op2, result); + END Mul3; + + PROCEDURE Div*(op1, op2: Operand) : Operand; + VAR result: Operand; + BEGIN + result := NIL; + Op(div, op1, op2, result); + RETURN result + END Div; + + PROCEDURE Div2*(VAR op1: Operand; op2: Operand); + BEGIN + Op(div, op1, op2, op1); + END Div2; + + PROCEDURE Div3*(VAR result: Operand; op1, op2: Operand); + BEGIN + Op(div, op1, op2, result); + END Div3; + + PROCEDURE Compare*(op1, op2: Operand) : INTEGER; + BEGIN + ASSERT(op1.if = op2.if); + ASSERT(cmp IN op1.caps); + RETURN op1.if.compare(op1, op2) + END Compare; + + PROCEDURE Assign*(VAR target: Operand; source: Operand); + VAR + tmpTarget: Operand; + typesIdentical: BOOLEAN; + targetType, sourceType: Services.Type; + BEGIN + IF (target # NIL) & (target.if = source.if) THEN + Services.GetType(target, targetType); + Services.GetType(source, sourceType); + typesIdentical := targetType = sourceType; + ELSE + typesIdentical := FALSE; + END; + IF typesIdentical THEN source.if.assign(target, source); - END Copy; + ELSE + source.if.create(tmpTarget); + source.if.assign(tmpTarget, source); + target := tmpTarget; + END; + END Assign; + + PROCEDURE Copy*(source, target: Operand); + BEGIN + source.if.assign(target, source); + END Copy; BEGIN - PersistentObjects.RegisterType(operandType, - "Operations.Operand", "PersistentDisciplines.Object", NIL); + PersistentObjects.RegisterType(operandType, + "Operations.Operand", "PersistentDisciplines.Object", NIL); END ulmOperations. diff --git a/src/library/ulm/ulmPersistentDisciplines.Mod b/src/library/ulm/ulmPersistentDisciplines.Mod index 8f37d4ce..538b8de6 100644 --- a/src/library/ulm/ulmPersistentDisciplines.Mod +++ b/src/library/ulm/ulmPersistentDisciplines.Mod @@ -1,391 +1,392 @@ (* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: PersistentD.om,v 1.4 1998/02/22 10:25:22 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: PersistentD.om,v $ - Revision 1.4 1998/02/22 10:25:22 borchert - bug fix in GetObject: Disciplines.Add was missing if the main object - is just an extension of Disciplines.Object and not of - PersistentDisciplines.Object + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: PersistentD.om,v 1.4 1998/02/22 10:25:22 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: PersistentD.om,v $ + Revision 1.4 1998/02/22 10:25:22 borchert + bug fix in GetObject: Disciplines.Add was missing if the main object + is just an extension of Disciplines.Object and not of + PersistentDisciplines.Object - Revision 1.3 1996/07/24 07:41:28 borchert - bug fix: count component was not initialized (with the - exception of CreateObject) -- detected by Martin Hasch + Revision 1.3 1996/07/24 07:41:28 borchert + bug fix: count component was not initialized (with the + exception of CreateObject) -- detected by Martin Hasch - Revision 1.2 1995/03/17 16:13:33 borchert - - persistent disciplines may now be attached to non-persistent objects - - some fixes due to changes of PersistentObjects + Revision 1.2 1995/03/17 16:13:33 borchert + - persistent disciplines may now be attached to non-persistent objects + - some fixes due to changes of PersistentObjects - Revision 1.1 1994/02/22 20:09:12 borchert - Initial revision + Revision 1.1 1994/02/22 20:09:12 borchert + Initial revision - ---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- *) MODULE ulmPersistentDisciplines; - IMPORT Disciplines := ulmDisciplines, Forwarders := ulmForwarders, NetIO := ulmNetIO, Objects := ulmObjects, PersistentObjects := ulmPersistentObjects, - Services := ulmServices, Streams := ulmStreams, SYS := SYSTEM; + IMPORT Disciplines := ulmDisciplines, Forwarders := ulmForwarders, NetIO := ulmNetIO, Objects := ulmObjects, PersistentObjects := ulmPersistentObjects, + Services := ulmServices, Streams := ulmStreams; - CONST - objectName = "PersistentDisciplines.Object"; - disciplineName = "PersistentDisciplines.Discipline"; + CONST + objectName = "PersistentDisciplines.Object"; + disciplineName = "PersistentDisciplines.Discipline"; - TYPE - Identifier* = LONGINT; + TYPE + Identifier* = LONGINT; - Discipline* = POINTER TO DisciplineRec; - DisciplineRec* = - RECORD - (PersistentObjects.ObjectRec) - id*: Identifier; (* should be unique for all types of disciplines *) - END; + Discipline* = POINTER TO DisciplineRec; + DisciplineRec* = + RECORD + (PersistentObjects.ObjectRec) + id*: Identifier; (* should be unique for all types of disciplines *) + END; - DisciplineList = POINTER TO DisciplineListRec; - DisciplineListRec = - RECORD - discipline: Discipline; - id: Identifier; (* copied from discipline.id *) - next: DisciplineList; - END; + DisciplineList = POINTER TO DisciplineListRec; + DisciplineListRec = + RECORD + discipline: Discipline; + id: Identifier; (* copied from discipline.id *) + next: DisciplineList; + END; - Interface = POINTER TO InterfaceRec; - Object = POINTER TO ObjectRec; - ObjectRec* = - RECORD - (PersistentObjects.ObjectRec) - (* private part *) - count: LONGINT; (* number of attached disciplines *) - list: DisciplineList; (* set of disciplines *) - if: Interface; (* overrides builtins if # NIL *) - forwardTo: Object; - usedBy: Object; (* used as target of UseInterfaceOf *) - (* very restrictive way of avoiding reference cycles: - forwardTo references must be built from inner to - outer objects and not vice versa - *) - END; + Interface = POINTER TO InterfaceRec; + Object = POINTER TO ObjectRec; + ObjectRec* = + RECORD + (PersistentObjects.ObjectRec) + (* private part *) + count: LONGINT; (* number of attached disciplines *) + list: DisciplineList; (* set of disciplines *) + if: Interface; (* overrides builtins if # NIL *) + forwardTo: Object; + usedBy: Object; (* used as target of UseInterfaceOf *) + (* very restrictive way of avoiding reference cycles: + forwardTo references must be built from inner to + outer objects and not vice versa + *) + END; - TYPE - VolatileDiscipline = POINTER TO VolatileDisciplineRec; - VolatileDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - object: Object; - END; - VAR - volDiscID: Disciplines.Identifier; + TYPE + VolatileDiscipline = POINTER TO VolatileDisciplineRec; + VolatileDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + object: Object; + END; + VAR + volDiscID: Disciplines.Identifier; - TYPE - AddProc* = PROCEDURE (object: Disciplines.Object; discipline: Discipline); - RemoveProc* = PROCEDURE (object: Disciplines.Object; id: Identifier); - SeekProc* = PROCEDURE (object: Disciplines.Object; id: Identifier; - VAR discipline: Discipline) : BOOLEAN; - InterfaceRec* = - RECORD - (Objects.ObjectRec) - add*: AddProc; - remove*: RemoveProc; - seek*: SeekProc; - END; + TYPE + AddProc* = PROCEDURE (object: Disciplines.Object; discipline: Discipline); + RemoveProc* = PROCEDURE (object: Disciplines.Object; id: Identifier); + SeekProc* = PROCEDURE (object: Disciplines.Object; id: Identifier; + VAR discipline: Discipline) : BOOLEAN; + InterfaceRec* = + RECORD + (Objects.ObjectRec) + add*: AddProc; + remove*: RemoveProc; + seek*: SeekProc; + END; - VAR - unique: Identifier; - objIf: PersistentObjects.Interface; - objDatatype, discDatatype: Services.Type; + VAR + unique: Identifier; + objIf: PersistentObjects.Interface; + objDatatype, discDatatype: Services.Type; - CONST - hashtabsize = 32; - TYPE - Sample = POINTER TO SampleRec; - SampleRec = - RECORD - id: Identifier; - sample: Discipline; - next: Sample; - END; - BucketTable = ARRAY hashtabsize OF Sample; - VAR - samples: BucketTable; + CONST + hashtabsize = 32; + TYPE + Sample = POINTER TO SampleRec; + SampleRec = + RECORD + id: Identifier; + sample: Discipline; + next: Sample; + END; + BucketTable = ARRAY hashtabsize OF Sample; + VAR + samples: BucketTable; - PROCEDURE CreateObject*(VAR object: Object); - (* creates a new object; this procedures should be called instead of - NEW for objects of type `Object' + PROCEDURE CreateObject*(VAR object: Object); + (* creates a new object; this procedures should be called instead of + NEW for objects of type `Object' + *) + BEGIN + NEW(object); + object.count := 0; (* up to now, there are no attached disciplines *) + object.list := NIL; + object.if := NIL; + PersistentObjects.Init(object, objDatatype); + END CreateObject; + + PROCEDURE GetObject(obj: Disciplines.Object; VAR object: Object); + VAR + disc: Disciplines.Discipline; + vdisc: VolatileDiscipline; + BEGIN + IF obj IS Object THEN + object := obj(Object); + (* initialize private components now if not done already; + we assume here that pointers which have not been + initialized yet are defined to be NIL + (because of the garbage collection); + a similar assumption does not necessarily hold for + other types (e.g. integers) *) - BEGIN - NEW(object); - object.count := 0; (* up to now, there are no attached disciplines *) - object.list := NIL; - object.if := NIL; - PersistentObjects.Init(object, objDatatype); - END CreateObject; + IF object.list = NIL THEN + object.count := 0; + END; + ELSIF Disciplines.Seek(obj, volDiscID, disc) THEN + object := disc(VolatileDiscipline).object; + ELSE + CreateObject(object); + NEW(vdisc); vdisc.id := volDiscID; vdisc.object := object; + Disciplines.Add(obj, vdisc); + END; + END GetObject; - PROCEDURE GetObject(obj: Disciplines.Object; VAR object: Object); - VAR - disc: VolatileDiscipline; - BEGIN - IF obj IS Object THEN - object := obj(Object); - (* initialize private components now if not done already; - we assume here that pointers which have not been - initialized yet are defined to be NIL - (because of the garbage collection); - a similar assumption does not necessarily hold for - other types (e.g. integers) - *) - IF object.list = NIL THEN - object.count := 0; - END; - ELSIF Disciplines.Seek(obj, volDiscID, SYS.VAL(Disciplines.Discipline, disc)) THEN - object := disc.object; + (* === normal stuff for disciplines ===================================== *) + + PROCEDURE Unique*(sample: Discipline) : Identifier; + (* returns a unique identifier; + this procedure should be called during initialization by + all modules defining a discipline type; + a sample of the associated discipline has to be provided + *) + VAR + hashval: Identifier; + entry: Sample; + BEGIN + INC(unique); + NEW(entry); entry.id := unique; entry.sample := sample; + hashval := unique MOD hashtabsize; + entry.next := samples[hashval]; samples[hashval] := entry; + RETURN unique + END Unique; + + PROCEDURE GetSample*(id: Identifier) : Discipline; + (* return sample for the given identifier; + NIL will be returned if id has not yet been returned by Unique + *) + VAR + hashval: Identifier; + ptr: Sample; + BEGIN + hashval := id MOD hashtabsize; + ptr := samples[hashval]; + WHILE (ptr # NIL) & (ptr.id # id) DO + ptr := ptr.next; + END; + IF ptr # NIL THEN + RETURN ptr.sample + ELSE + RETURN NIL + END; + END GetSample; + + PROCEDURE AttachInterface*(object: Disciplines.Object; if: Interface); + (* override the builtin implementations of Add, Remove and + Seek for `object' with the implementations given by `if' + *) + VAR + po: Object; + BEGIN + GetObject(object, po); + IF (po.list = NIL) & (po.forwardTo = NIL) THEN + po.if := if; + END; + END AttachInterface; + + PROCEDURE UseInterfaceOf*(object, host: Disciplines.Object); + (* forward Add, Remove and Seek operations from object to host *) + VAR + po, phost: Object; + BEGIN + GetObject(object, po); GetObject(host, phost); + IF (po.list = NIL) & (po.forwardTo = NIL) & + (po.usedBy = NIL) THEN + po.forwardTo := phost; + phost.usedBy := po; (* avoid reference cycles *) + END; + END UseInterfaceOf; + + PROCEDURE Forward(from, to: Forwarders.Object); + BEGIN + UseInterfaceOf(from, to); + END Forward; + + PROCEDURE Remove*(object: Disciplines.Object; id: Identifier); + (* remove the discipline with the given id from object, if it exists *) + VAR + po: Object; + prev, dl: DisciplineList; + BEGIN + GetObject(object, po); + WHILE po.forwardTo # NIL DO + po := po.forwardTo; + END; + IF po.if = NIL THEN + prev := NIL; + dl := po.list; + WHILE (dl # NIL) & (dl.id # id) DO + prev := dl; dl := dl.next; + END; + IF dl # NIL THEN + IF prev = NIL THEN + po.list := dl.next; + ELSE + prev.next := dl.next; + END; + DEC(po.count); (* discipline removed *) + END; + ELSE + po.if.remove(po, id); + END; + END Remove; + + PROCEDURE Add*(object: Disciplines.Object; discipline: Discipline); + (* adds a new discipline to the given object; + if already a discipline with the same identifier exist + it is deleted first + *) + VAR + po: Object; + dl: DisciplineList; + BEGIN + GetObject(object, po); + WHILE po.forwardTo # NIL DO + po := po.forwardTo; + END; + IF po.if = NIL THEN + dl := po.list; + WHILE (dl # NIL) & (dl.id # discipline.id) DO + dl := dl.next; + END; + IF dl = NIL THEN + NEW(dl); + dl.id := discipline.id; + dl.next := po.list; + po.list := dl; + INC(po.count); (* discipline added *) + END; + dl.discipline := discipline; + ELSE + po.if.add(po, discipline); + END; + END Add; + + PROCEDURE Seek*(object: Disciplines.Object; id: Identifier; + VAR discipline: Discipline) : BOOLEAN; + (* returns TRUE if a discipline with the given id is found *) + VAR + po: Object; + dl: DisciplineList; + BEGIN + GetObject(object, po); + WHILE po.forwardTo # NIL DO + po := po.forwardTo; + END; + IF po.if = NIL THEN + dl := po.list; + WHILE (dl # NIL) & (dl.id # id) DO + dl := dl.next; + END; + IF dl # NIL THEN + discipline := dl.discipline; ELSE - CreateObject(object); - NEW(disc); disc.id := volDiscID; disc.object := object; - Disciplines.Add(obj, disc); + discipline := NIL; END; - END GetObject; + RETURN discipline # NIL + ELSE + RETURN po.if.seek(po, id, discipline) + END; + END Seek; - (* === normal stuff for disciplines ===================================== *) + (* === interface procedures for PersistentObjects for Object === *) - PROCEDURE Unique*(sample: Discipline) : Identifier; - (* returns a unique identifier; - this procedure should be called during initialization by - all modules defining a discipline type; - a sample of the associated discipline has to be provided - *) - VAR - hashval: Identifier; - entry: Sample; - BEGIN - INC(unique); - NEW(entry); entry.id := unique; entry.sample := sample; - hashval := unique MOD hashtabsize; - entry.next := samples[hashval]; samples[hashval] := entry; - RETURN unique - END Unique; + PROCEDURE ReadObjectData(stream: Streams.Stream; + object: PersistentObjects.Object) : BOOLEAN; + (* read data and attached disciplines of given object from stream *) + VAR + discipline: PersistentObjects.Object; (* Discipline *) + count: LONGINT; + BEGIN + (* get number of attached disciplines *) + IF ~NetIO.ReadLongInt(stream, count) THEN + RETURN FALSE; + END; + (* read all disciplines from `stream' and attach them to `object' *) + WHILE count > 0 DO + IF ~PersistentObjects.Read(stream, discipline) THEN + RETURN FALSE; + END; + Add(object(Object), discipline(Discipline)); + DEC(count); + END; + RETURN TRUE; + END ReadObjectData; - PROCEDURE GetSample*(id: Identifier) : Discipline; - (* return sample for the given identifier; - NIL will be returned if id has not yet been returned by Unique - *) - VAR - hashval: Identifier; - ptr: Sample; - BEGIN - hashval := id MOD hashtabsize; - ptr := samples[hashval]; - WHILE (ptr # NIL) & (ptr.id # id) DO - ptr := ptr.next; + PROCEDURE WriteObjectData(stream: Streams.Stream; + object: PersistentObjects.Object) : BOOLEAN; + (* write data and attached disciplines of given object to stream *) + VAR + dl: DisciplineList; + BEGIN + WITH object: Object DO + (* write number of attached disciplines to `stream' *) + IF ~NetIO.WriteLongInt(stream, object.count) THEN + RETURN FALSE; END; - IF ptr # NIL THEN - RETURN ptr.sample - ELSE - RETURN NIL + (* write all attached disciplines to the stream *) + dl := object.list; + WHILE dl # NIL DO + IF ~PersistentObjects.Write(stream, dl.discipline) THEN + RETURN FALSE; + END; + dl := dl.next; END; - END GetSample; + END; + RETURN TRUE; + END WriteObjectData; - PROCEDURE AttachInterface*(object: Disciplines.Object; if: Interface); - (* override the builtin implementations of Add, Remove and - Seek for `object' with the implementations given by `if' - *) - VAR - po: Object; - BEGIN - GetObject(object, po); - IF (po.list = NIL) & (po.forwardTo = NIL) THEN - po.if := if; - END; - END AttachInterface; - - PROCEDURE UseInterfaceOf*(object, host: Disciplines.Object); - (* forward Add, Remove and Seek operations from object to host *) - VAR - po, phost: Object; - BEGIN - GetObject(object, po); GetObject(host, phost); - IF (po.list = NIL) & (po.forwardTo = NIL) & - (po.usedBy = NIL) THEN - po.forwardTo := phost; - phost.usedBy := po; (* avoid reference cycles *) - END; - END UseInterfaceOf; - - PROCEDURE Forward(from, to: Forwarders.Object); - BEGIN - UseInterfaceOf(from, to); - END Forward; - - PROCEDURE Remove*(object: Disciplines.Object; id: Identifier); - (* remove the discipline with the given id from object, if it exists *) - VAR - po: Object; - prev, dl: DisciplineList; - BEGIN - GetObject(object, po); - WHILE po.forwardTo # NIL DO - po := po.forwardTo; - END; - IF po.if = NIL THEN - prev := NIL; - dl := po.list; - WHILE (dl # NIL) & (dl.id # id) DO - prev := dl; dl := dl.next; - END; - IF dl # NIL THEN - IF prev = NIL THEN - po.list := dl.next; - ELSE - prev.next := dl.next; - END; - DEC(po.count); (* discipline removed *) - END; - ELSE - po.if.remove(po, id); - END; - END Remove; - - PROCEDURE Add*(object: Disciplines.Object; discipline: Discipline); - (* adds a new discipline to the given object; - if already a discipline with the same identifier exist - it is deleted first - *) - VAR - po: Object; - dl: DisciplineList; - BEGIN - GetObject(object, po); - WHILE po.forwardTo # NIL DO - po := po.forwardTo; - END; - IF po.if = NIL THEN - dl := po.list; - WHILE (dl # NIL) & (dl.id # discipline.id) DO - dl := dl.next; - END; - IF dl = NIL THEN - NEW(dl); - dl.id := discipline.id; - dl.next := po.list; - po.list := dl; - INC(po.count); (* discipline added *) - END; - dl.discipline := discipline; - ELSE - po.if.add(po, discipline); - END; - END Add; - - PROCEDURE Seek*(object: Disciplines.Object; id: Identifier; - VAR discipline: Discipline) : BOOLEAN; - (* returns TRUE if a discipline with the given id is found *) - VAR - po: Object; - dl: DisciplineList; - BEGIN - GetObject(object, po); - WHILE po.forwardTo # NIL DO - po := po.forwardTo; - END; - IF po.if = NIL THEN - dl := po.list; - WHILE (dl # NIL) & (dl.id # id) DO - dl := dl.next; - END; - IF dl # NIL THEN - discipline := dl.discipline; - ELSE - discipline := NIL; - END; - RETURN discipline # NIL - ELSE - RETURN po.if.seek(po, id, discipline) - END; - END Seek; - - (* === interface procedures for PersistentObjects for Object === *) - - PROCEDURE ReadObjectData(stream: Streams.Stream; - object: PersistentObjects.Object) : BOOLEAN; - (* read data and attached disciplines of given object from stream *) - VAR - discipline: Discipline; - count: LONGINT; - BEGIN - (* get number of attached disciplines *) - IF ~NetIO.ReadLongInt(stream, count) THEN - RETURN FALSE; - END; - (* read all disciplines from `stream' and attach them to `object' *) - WHILE count > 0 DO - IF ~PersistentObjects.Read(stream, SYS.VAL(PersistentObjects.Object, discipline)) THEN - RETURN FALSE; - END; - Add(object(Object), discipline); - DEC(count); - END; - RETURN TRUE; - END ReadObjectData; - - PROCEDURE WriteObjectData(stream: Streams.Stream; - object: PersistentObjects.Object) : BOOLEAN; - (* write data and attached disciplines of given object to stream *) - VAR - dl: DisciplineList; - BEGIN - WITH object: Object DO - (* write number of attached disciplines to `stream' *) - IF ~NetIO.WriteLongInt(stream, object.count) THEN - RETURN FALSE; - END; - (* write all attached disciplines to the stream *) - dl := object.list; - WHILE dl # NIL DO - IF ~PersistentObjects.Write(stream, dl.discipline) THEN - RETURN FALSE; - END; - dl := dl.next; - END; - END; - RETURN TRUE; - END WriteObjectData; - - PROCEDURE InternalCreate(VAR obj: PersistentObjects.Object); - VAR - myObject: Object; - BEGIN - CreateObject(myObject); - obj := myObject; - END InternalCreate; + PROCEDURE InternalCreate(VAR obj: PersistentObjects.Object); + VAR + myObject: Object; + BEGIN + CreateObject(myObject); + obj := myObject; + END InternalCreate; BEGIN - unique := 0; + unique := 0; - NEW(objIf); - objIf.read := ReadObjectData; - objIf.write := WriteObjectData; - objIf.create := InternalCreate; - objIf.createAndRead := NIL; - PersistentObjects.RegisterType(objDatatype, objectName, "", objIf); - PersistentObjects.RegisterType(discDatatype, disciplineName, "", NIL); + NEW(objIf); + objIf.read := ReadObjectData; + objIf.write := WriteObjectData; + objIf.create := InternalCreate; + objIf.createAndRead := NIL; + PersistentObjects.RegisterType(objDatatype, objectName, "", objIf); + PersistentObjects.RegisterType(discDatatype, disciplineName, "", NIL); - volDiscID := Disciplines.Unique(); + volDiscID := Disciplines.Unique(); - Forwarders.Register("", Forward); + Forwarders.Register("", Forward); END ulmPersistentDisciplines. diff --git a/src/library/ulm/ulmPersistentObjects.Mod b/src/library/ulm/ulmPersistentObjects.Mod index 3f82e089..c64b4fc0 100644 --- a/src/library/ulm/ulmPersistentObjects.Mod +++ b/src/library/ulm/ulmPersistentObjects.Mod @@ -1,1079 +1,1086 @@ (* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: PersistentO.om,v 1.8 2004/03/30 13:14:16 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: PersistentO.om,v $ - Revision 1.8 2004/03/30 13:14:16 borchert - introduced more elaborate error events for cannotReadData + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: PersistentO.om,v 1.8 2004/03/30 13:14:16 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: PersistentO.om,v $ + Revision 1.8 2004/03/30 13:14:16 borchert + introduced more elaborate error events for cannotReadData - Revision 1.7 1998/04/09 16:55:48 borchert - bug fix: ReadTypeInfo failed on hierarchical mode if none of the - types were known by returning TRUE with type set to NIL + Revision 1.7 1998/04/09 16:55:48 borchert + bug fix: ReadTypeInfo failed on hierarchical mode if none of the + types were known by returning TRUE with type set to NIL - Revision 1.6 1998/03/24 22:42:28 borchert - improvements: - - it is now acceptable that read and write if procedures are given - but neither create nor createAndRead -- this is fine for - abstractions that maintain some components - - Read operates now immediately on the given object to support - LinearizedStructures -- otherwise it would be nearly impossible - to reconstruct self-referential data structures; - note that this is *not supported* by GuardedRead + Revision 1.6 1998/03/24 22:42:28 borchert + improvements: + - it is now acceptable that read and write if procedures are given + but neither create nor createAndRead -- this is fine for + abstractions that maintain some components + - Read operates now immediately on the given object to support + LinearizedStructures -- otherwise it would be nearly impossible + to reconstruct self-referential data structures; + note that this is *not supported* by GuardedRead - Revision 1.5 1995/04/04 12:36:39 borchert - major redesign of PersistentObjects: - - new type encoding schemes - - size if proc removed - - support for NIL and guards added + Revision 1.5 1995/04/04 12:36:39 borchert + major redesign of PersistentObjects: + - new type encoding schemes + - size if proc removed + - support for NIL and guards added - Revision 1.4 1994/07/18 14:19:13 borchert - bug fix: SizeOf used uninitialized variable (name) and added the - length of all type names of the hierarchy to the sum + Revision 1.4 1994/07/18 14:19:13 borchert + bug fix: SizeOf used uninitialized variable (name) and added the + length of all type names of the hierarchy to the sum - Revision 1.3 1994/07/05 08:47:26 borchert - bug fix: modifications due to last bug fix didn't work correctly in - in all cases - code cleaned up at several locations + Revision 1.3 1994/07/05 08:47:26 borchert + bug fix: modifications due to last bug fix didn't work correctly in + in all cases + code cleaned up at several locations - Revision 1.2 1994/03/25 15:54:09 borchert - bug fix: the complete type hierarchy together with all abstract types - was written -- this caused a NIL-procedure to be called in - case of projections. Now, we write shorter type hierarchies and - GetCreate checks the create-procedure against NIL + Revision 1.2 1994/03/25 15:54:09 borchert + bug fix: the complete type hierarchy together with all abstract types + was written -- this caused a NIL-procedure to be called in + case of projections. Now, we write shorter type hierarchies and + GetCreate checks the create-procedure against NIL - Revision 1.1 1994/02/22 20:09:21 borchert - Initial revision + Revision 1.1 1994/02/22 20:09:21 borchert + Initial revision - ---------------------------------------------------------------------------- - DB 7/93 - ---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- + DB 7/93 + ---------------------------------------------------------------------------- *) MODULE ulmPersistentObjects; - (* handling of persistent objects *) + (* handling of persistent objects *) - IMPORT ASCII := ulmASCII, ConstStrings := ulmConstStrings, Disciplines := ulmDisciplines, Errors := ulmErrors, Events := ulmEvents, Forwarders := ulmForwarders, - IndirectDisciplines := ulmIndirectDisciplines, Loader := ulmLoader, NetIO := ulmNetIO, Objects := ulmObjects, Priorities := ulmPriorities, - RelatedEvents := ulmRelatedEvents, Services := ulmServices, StreamDisciplines := ulmStreamDisciplines, Streams := ulmStreams, Strings := ulmStrings, Texts := ulmTexts, SYS := SYSTEM; + IMPORT ASCII := ulmASCII, ConstStrings := ulmConstStrings, Disciplines := ulmDisciplines, Errors := ulmErrors, Events := ulmEvents, Forwarders := ulmForwarders, + IndirectDisciplines := ulmIndirectDisciplines, Loader := ulmLoader, NetIO := ulmNetIO, Objects := ulmObjects, Priorities := ulmPriorities, + RelatedEvents := ulmRelatedEvents, Services := ulmServices, StreamDisciplines := ulmStreamDisciplines, Streams := ulmStreams, Strings := ulmStrings, Texts := ulmTexts, SYS := SYSTEM; - CONST - maxNameLen = 128; (* max length of data type names *) - TYPE - TypeName = ARRAY maxNameLen OF CHAR; (* for temporary use only *) - ShortTypeName = ARRAY 32 OF CHAR; (* for error messages only *) + CONST + maxNameLen = 128; (* max length of data type names *) + TYPE + TypeName = ARRAY maxNameLen OF CHAR; (* for temporary use only *) + ShortTypeName = ARRAY 32 OF CHAR; (* for error messages only *) - CONST - cannotReadData* = 0; - cannotWriteData* = 1; - cannotReadType* = 2; - cannotWriteType* = 3; - invalidType* = 4; - unknownType* = 5; - otherTypeHier* = 6; - eofReached* = 7; - cannotSkip* = 8; - typeGuardFailure* = 9; (* GuardedRead failed to type guard failure *) - errorcodes* = 10; (* number of error codes *) + CONST + cannotReadData* = 0; + cannotWriteData* = 1; + cannotReadType* = 2; + cannotWriteType* = 3; + invalidType* = 4; + unknownType* = 5; + otherTypeHier* = 6; + eofReached* = 7; + cannotSkip* = 8; + typeGuardFailure* = 9; (* GuardedRead failed to type guard failure *) + errorcodes* = 10; (* number of error codes *) - (* how are types specified: fullTypeName, typeCode, incrTypeCode - with or without size info: withSize, withoutSize - with or without type hier: withHier, withoutHier + (* how are types specified: fullTypeName, typeCode, incrTypeCode + with or without size info: withSize, withoutSize + with or without type hier: withHier, withoutHier - combinations are given as additions, - e.g. typeCode + withSize + withHier - *) - fullTypeName* = 1; typeCode* = 2; incrTypeCode* = 3; - withSize* = 4; withoutSize* = 0; - withHier* = 8; withoutHier* = 0; + combinations are given as additions, + e.g. typeCode + withSize + withHier + *) + fullTypeName* = 1; typeCode* = 2; incrTypeCode* = 3; + withSize* = 4; withoutSize* = 0; + withHier* = 8; withoutHier* = 0; - defaultMode = fullTypeName + withSize + withHier; - (* provide all informations on default *) + defaultMode = fullTypeName + withSize + withHier; + (* provide all informations on default *) - (* forms: - type spec: codeF | incrF | nameF | incrhierF | hierF - size spec: sizeF | noSizeF - add specs, eg. codeF + sizeF - *) - codeF = 1; (* just a type code *) - incrF = 2; (* type name + code given *) - nameF = 3; (* type name given *) - incrhierF = 4; (* type hierarchy with codes *) - hierF = 5; (* type hierarchy without codes *) - sizeF = 8; (* size information given *) - noSizeF = 0; (* no size information given *) - maskF = 8; - maxF = 13; (* maximal valid form code *) + (* forms: + type spec: codeF | incrF | nameF | incrhierF | hierF + size spec: sizeF | noSizeF + add specs, eg. codeF + sizeF + *) + codeF = 1; (* just a type code *) + incrF = 2; (* type name + code given *) + nameF = 3; (* type name given *) + incrhierF = 4; (* type hierarchy with codes *) + hierF = 5; (* type hierarchy without codes *) + sizeF = 8; (* size information given *) + noSizeF = 0; (* no size information given *) + maskF = 8; + maxF = 13; (* maximal valid form code *) - TYPE - Mode* = SHORTINT; - Form = SHORTINT; + TYPE + Mode* = SHORTINT; + Form = SHORTINT; - Object* = POINTER TO ObjectRec; - Type = POINTER TO TypeRec; + Object* = POINTER TO ObjectRec; + Type = POINTER TO TypeRec; - ReadProc* = PROCEDURE (s: Streams.Stream; o: Object) : BOOLEAN; - WriteProc* = PROCEDURE (s: Streams.Stream; o: Object) : BOOLEAN; - CreateProc* = PROCEDURE (VAR o: Object); - CreateAndReadProc* = PROCEDURE (s: Streams.Stream; - create: BOOLEAN; - VAR o: Object) : BOOLEAN; + ReadProc* = PROCEDURE (s: Streams.Stream; o: Object) : BOOLEAN; + WriteProc* = PROCEDURE (s: Streams.Stream; o: Object) : BOOLEAN; + CreateProc* = PROCEDURE (VAR o: Object); + CreateAndReadProc* = PROCEDURE (s: Streams.Stream; + create: BOOLEAN; + VAR o: Object) : BOOLEAN; - Interface* = POINTER TO InterfaceRec; - InterfaceRec* = - RECORD - (Objects.ObjectRec) - create*: CreateProc; (* create object *) - read*: ReadProc; (* read data from stream *) - write*: WriteProc; (* write data to stream *) - createAndRead*: CreateAndReadProc; (* replaces create & read *) - END; + Interface* = POINTER TO InterfaceRec; + InterfaceRec* = + RECORD + (Objects.ObjectRec) + create*: CreateProc; (* create object *) + read*: ReadProc; (* read data from stream *) + write*: WriteProc; (* write data to stream *) + createAndRead*: CreateAndReadProc; (* replaces create & read *) + END; - ObjectRec* = - RECORD - (Services.ObjectRec) - (* private data *) - type: Type; - projected: BOOLEAN; (* set after Read *) - END; + ObjectRec* = + RECORD + (Services.ObjectRec) + (* private data *) + type: Type; + projected: BOOLEAN; (* set after Read *) + END; - CONST - ttlen = 16; - TYPE - TypeEntry = POINTER TO TypeEntryRec; - TypeEntryRec = - RECORD - code: LONGINT; - type: Type; - next: TypeEntry; - END; - TypeTable = ARRAY ttlen OF TypeEntry; - StreamDiscipline = POINTER TO StreamDisciplineRec; - StreamDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - mode: Mode; (* type encoding mode for the stream *) - rtypes, wtypes: TypeTable; - END; + CONST + ttlen = 16; + TYPE + TypeEntry = POINTER TO TypeEntryRec; + TypeEntryRec = + RECORD + code: LONGINT; + type: Type; + next: TypeEntry; + END; + TypeTable = ARRAY ttlen OF TypeEntry; + StreamDiscipline = POINTER TO StreamDisciplineRec; + StreamDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + mode: Mode; (* type encoding mode for the stream *) + rtypes, wtypes: TypeTable; + END; - InterfaceList = POINTER TO InterfaceListRec; - InterfaceListRec = - RECORD - if: Interface; - next: InterfaceList; (* points to next extension *) - END; - TypeRec = - RECORD - (Services.TypeRec) - baseType: Type; (* the next non-abstract base type *) - if: Interface; (* may be = NIL for abstract types *) - ifs: InterfaceList; (* list of interfaces in reverse order *) - code: LONGINT; (* unique number *) - END; + InterfaceList = POINTER TO InterfaceListRec; + InterfaceListRec = + RECORD + if: Interface; + next: InterfaceList; (* points to next extension *) + END; + TypeRec = + RECORD + (Services.TypeRec) + baseType: Type; (* the next non-abstract base type *) + if: Interface; (* may be = NIL for abstract types *) + ifs: InterfaceList; (* list of interfaces in reverse order *) + code: LONGINT; (* unique number *) + END; - (* this list is used for storing the base type list of an object during - reading this object - *) - BaseTypeList = POINTER TO BaseTypeRec; - BaseTypeRec = - RECORD - name: ConstStrings.String; (* name of the base type *) - next: BaseTypeList; - END; + (* this list is used for storing the base type list of an object during + reading this object + *) + BaseTypeList = POINTER TO BaseTypeRec; + BaseTypeRec = + RECORD + name: ConstStrings.String; (* name of the base type *) + next: BaseTypeList; + END; - (* each error causes an event; the error number is stored in - event.errorcode; the associated text can be taken from event.message - *) - ErrorCode = SHORTINT; - Event = POINTER TO EventRec; - EventRec* = - RECORD - (Events.EventRec) - stream*: Streams.Stream; - errorcode*: ErrorCode; - END; - UnknownTypeEvent = POINTER TO UnknownTypeEventRec; - UnknownTypeEventRec = - RECORD - (EventRec) - typeName: ARRAY 80 OF CHAR; - END; - DecodeFailureEvent = POINTER TO DecodeFailureEventRec; - DecodeFailureEventRec = - RECORD - (EventRec) - objectType: Services.Type; - END; - TypeGuardFailureEvent = POINTER TO TypeGuardFailureEventRec; - TypeGuardFailureEventRec = - RECORD - (EventRec) - found, expected: Services.Type; - END; + (* each error causes an event; the error number is stored in + event.errorcode; the associated text can be taken from event.message + *) + ErrorCode = SHORTINT; + Event = POINTER TO EventRec; + EventRec* = + RECORD + (Events.EventRec) + stream*: Streams.Stream; + errorcode*: ErrorCode; + END; + UnknownTypeEvent = POINTER TO UnknownTypeEventRec; + UnknownTypeEventRec = + RECORD + (EventRec) + typeName: ARRAY 80 OF CHAR; + END; + DecodeFailureEvent = POINTER TO DecodeFailureEventRec; + DecodeFailureEventRec = + RECORD + (EventRec) + objectType: Services.Type; + END; + TypeGuardFailureEvent = POINTER TO TypeGuardFailureEventRec; + TypeGuardFailureEventRec = + RECORD + (EventRec) + found, expected: Services.Type; + END; - VAR - id: Disciplines.Identifier; - nextTypeCode: LONGINT; (* for the generation of unique numbers *) - potype: Services.Type; + VAR + id: Disciplines.Identifier; + nextTypeCode: LONGINT; (* for the generation of unique numbers *) + potype: Services.Type; - errormsg*: ARRAY errorcodes OF Events.Message; - (* readable text for error codes *) - error*: Events.EventType; - (* raised on failed stream operations; ignored by default *) + errormsg*: ARRAY errorcodes OF Events.Message; + (* readable text for error codes *) + error*: Events.EventType; + (* raised on failed stream operations; ignored by default *) - (* ===== for internal use only ========================================== *) + (* ===== for internal use only ========================================== *) - PROCEDURE Error(stream: Streams.Stream; code: ErrorCode); - (* raise an error event with the error code `code' *) + PROCEDURE Error(stream: Streams.Stream; code: ErrorCode); + (* raise an error event with the error code `code' *) + VAR + event: Event; + BEGIN + stream.count := 0; + NEW(event); + event.type := error; + event.message := errormsg[code]; + event.stream := stream; + event.errorcode := code; + RelatedEvents.Raise(stream, event); + END Error; + + PROCEDURE UnknownType(stream: Streams.Stream; typeName: ARRAY OF CHAR); + VAR + event: UnknownTypeEvent; + BEGIN + stream.count := 0; + NEW(event); + event.type := error; + event.message := errormsg[unknownType]; + event.stream := stream; + event.errorcode := unknownType; + COPY(typeName, event.typeName); + RelatedEvents.Raise(stream, event); + END UnknownType; + + PROCEDURE TypeGuardFailure(stream: Streams.Stream; + found, expected: Services.Type); + VAR + event: TypeGuardFailureEvent; + BEGIN + stream.count := 0; + NEW(event); + event.type := error; + event.message := errormsg[typeGuardFailure]; + event.stream := stream; + event.errorcode := typeGuardFailure; + event.found := found; + event.expected := expected; + RelatedEvents.Raise(stream, event); + END TypeGuardFailure; + + PROCEDURE WriteEvent(s: Streams.Stream; event: Events.Event); + + VAR + typename: ARRAY 128 OF CHAR; + + PROCEDURE WriteString(s: Streams.Stream; + string: ARRAY OF CHAR) : BOOLEAN; + BEGIN + RETURN Streams.WritePart(s, string, 0, Strings.Len(string)) + END WriteString; + + PROCEDURE WriteLn(s: Streams.Stream) : BOOLEAN; VAR - event: Event; - BEGIN - stream.count := 0; + lineterm: StreamDisciplines.LineTerminator; + width: INTEGER; + BEGIN + StreamDisciplines.GetLineTerm(s, lineterm); + IF ~WriteString(s, lineterm) THEN RETURN FALSE END; + StreamDisciplines.GetIndentationWidth(s, width); + WHILE width > 0 DO + IF ~Streams.WriteByte(s, " ") THEN RETURN FALSE END; + DEC(width); + END; + RETURN TRUE + END WriteLn; + + PROCEDURE WriteType(s: Streams.Stream; + type: Services.Type) : BOOLEAN; + VAR + name: TypeName; + BEGIN + Services.GetTypeName(type, name); + RETURN Streams.WriteByte(s, ASCII.quote) & + WriteString(s, name) & + Streams.WriteByte(s, ASCII.quote) + END WriteType; + + BEGIN + IF event IS UnknownTypeEvent THEN + WITH event: UnknownTypeEvent DO + IF WriteString(s, event.message) & + WriteString(s, ": ") & + Streams.WriteByte(s, ASCII.quote) & + WriteString(s, event.typeName) & + Streams.WriteByte(s, ASCII.quote) THEN + END; + END; + ELSIF event IS TypeGuardFailureEvent THEN + WITH event: TypeGuardFailureEvent DO + IF WriteString(s, event.message) & + WriteString(s, ":") & + WriteLn(s) & + WriteString(s, "expected extension of ") & + WriteType(s, event.expected) & + WriteString(s, " but got ") & + WriteType(s, event.found) THEN + END; + END; + ELSIF event IS DecodeFailureEvent THEN + WITH event: DecodeFailureEvent DO + Services.GetTypeName(event.objectType, typename); + IF WriteString(s, event.message) & + WriteString(s, ":") & + WriteLn(s) & + WriteString(s, "unable to parse object of type ") & + Streams.WriteByte(s, ASCII.quote) & + WriteString(s, typename) & + Streams.WriteByte(s, ASCII.quote) THEN + END; + END; + ELSE + IF WriteString(s, event.message) THEN END; + END; + END WriteEvent; + + PROCEDURE InitErrorHandling; + BEGIN + errormsg[cannotReadData] := "cannot read data part of persistent object"; + errormsg[cannotWriteData] := "cannot write data part of persistent object"; + errormsg[cannotReadType] := "cannot read type of persistent object"; + errormsg[cannotWriteType] := "cannot write type of persistent object"; + errormsg[invalidType] := "invalid type form read"; + errormsg[unknownType] := "unknown type information found"; + errormsg[otherTypeHier] := "different & nonconforming type hierarchy found"; + errormsg[eofReached] := "unexpected EOF encountered during reading"; + errormsg[cannotSkip] := "unable to skip unknown data parts"; + errormsg[typeGuardFailure] := "read object is of unexpected type"; + + Events.Define(error); + Events.SetPriority(error, Priorities.liberrors); + Events.Ignore(error); + Errors.AssignWriteProcedure(error, WriteEvent); + END InitErrorHandling; + + (* ==== marshalling procedures ======================================== *) + + (* encoding scheme: + + Object = Form Type Size ObjectInfo . + Form = SHORTINT; + Type = Code (* codeF *) | + Code TypeName (* incrF *) | + TypeName (* nameF *) | + Code TypeName { Code TypeName } 0 (* incrhierF *) | + TypeName { TypeName } 0X (* hierF *) . + Size = (* noSizeF *) | + Size (* sizeF *) . (* size of object info in bytes *) + ObjectInfo = { Byte } . + *) + + PROCEDURE DecodeForm(form: Form; + VAR nameGiven, codeGiven, hier, size: BOOLEAN); + VAR + typeform: SHORTINT; + sizeform: SHORTINT; + BEGIN + typeform := form MOD maskF; sizeform := form DIV maskF; + nameGiven := typeform IN {incrF, nameF, hierF, incrhierF}; + codeGiven := typeform IN {codeF, incrF, incrhierF}; + hier := (typeform = incrhierF) OR (typeform = hierF); + size := (sizeform = sizeF); + END DecodeForm; + + PROCEDURE GetModule(name: ARRAY OF CHAR; VAR module: ARRAY OF CHAR); + (* get the name of the module where 'name' was defined *) + VAR + index: INTEGER; + BEGIN + index := 0; + WHILE (name[index] # ".") & (name[index] # 0X) & + (index < LEN(module)-1) DO + module[index] := name[index]; INC(index); + END; + module[index] := 0X; + END GetModule; + + PROCEDURE Failure(s: Streams.Stream; code: ErrorCode); + BEGIN + IF s.eof THEN + Error(s, eofReached); + ELSE + Error(s, code); + END; + END Failure; + + PROCEDURE DecodeFailure(s: Streams.Stream; type: Services.Type); + VAR + event: DecodeFailureEvent; + BEGIN + IF s.eof THEN + Error(s, eofReached); + ELSE NEW(event); event.type := error; - event.message := errormsg[code]; - event.stream := stream; - event.errorcode := code; - RelatedEvents.Raise(stream, event); - END Error; + event.message := errormsg[cannotReadData]; + event.stream := s; + event.errorcode := cannotReadData; + event.objectType := type; + RelatedEvents.Raise(s, event); + END; + END DecodeFailure; - PROCEDURE UnknownType(stream: Streams.Stream; typeName: ARRAY OF CHAR); + PROCEDURE GetStreamDisc(s: Streams.Stream; VAR disc: StreamDiscipline); + VAR d: IndirectDisciplines.Discipline; + BEGIN + IF IndirectDisciplines.Seek(s, id, d) THEN + disc := d(StreamDiscipline) + ELSE + NEW(disc); disc.id := id; disc.mode := defaultMode; + IndirectDisciplines.Add(s, disc); + END; + END GetStreamDisc; + + PROCEDURE ReadTypeInfo(s: Streams.Stream; VAR type: Type; + VAR projection: BOOLEAN; + VAR size: Streams.Count) : BOOLEAN; + VAR + form: Form; + btype: Type; + nameGiven, codeGiven, hier, sizeGiven: BOOLEAN; + disc: StreamDiscipline; + sentinelFound, unknownTypeFound: BOOLEAN; + lastType: Type; + + PROCEDURE ReadType(s: Streams.Stream; VAR type: Type; + VAR sentinelFound, unknownTypeFound: BOOLEAN) : BOOLEAN; VAR - event: UnknownTypeEvent; - BEGIN - stream.count := 0; - NEW(event); - event.type := error; - event.message := errormsg[unknownType]; - event.stream := stream; - event.errorcode := unknownType; - COPY(typeName, event.typeName); - RelatedEvents.Raise(stream, event); - END UnknownType; + code: LONGINT; + entry: TypeEntry; + typeName: TypeName; + btype: Type; - PROCEDURE TypeGuardFailure(stream: Streams.Stream; - found, expected: Services.Type); - VAR - event: TypeGuardFailureEvent; - BEGIN - stream.count := 0; - NEW(event); - event.type := error; - event.message := errormsg[typeGuardFailure]; - event.stream := stream; - event.errorcode := typeGuardFailure; - event.found := found; - event.expected := expected; - RelatedEvents.Raise(stream, event); - END TypeGuardFailure; - - PROCEDURE WriteEvent(s: Streams.Stream; event: Events.Event); - - VAR - typename: ARRAY 128 OF CHAR; - - PROCEDURE WriteString(s: Streams.Stream; - string: ARRAY OF CHAR) : BOOLEAN; + PROCEDURE SeekType(typeName: ARRAY OF CHAR; + VAR type: Type) : BOOLEAN; + VAR + t: Services.Type; + module: TypeName; BEGIN - RETURN Streams.WritePart(s, string, 0, Strings.Len(string)) - END WriteString; + Services.SeekType(typeName, t); + IF t = NIL THEN + GetModule(typeName, module); + IF Loader.Load(module, s) THEN + (* maybe the type is now registered *) + Services.SeekType(typeName, t); + END; + END; + IF (t # NIL) & (t IS Type) THEN + type := t(Type); RETURN TRUE + END; + RETURN FALSE + END SeekType; - PROCEDURE WriteLn(s: Streams.Stream) : BOOLEAN; - VAR - lineterm: StreamDisciplines.LineTerminator; - width: INTEGER; - BEGIN - StreamDisciplines.GetLineTerm(s, lineterm); - IF ~WriteString(s, lineterm) THEN RETURN FALSE END; - StreamDisciplines.GetIndentationWidth(s, width); - WHILE width > 0 DO - IF ~Streams.WriteByte(s, " ") THEN RETURN FALSE END; - DEC(width); - END; - RETURN TRUE - END WriteLn; - - PROCEDURE WriteType(s: Streams.Stream; - type: Services.Type) : BOOLEAN; - VAR - name: TypeName; - BEGIN - Services.GetTypeName(type, name); - RETURN Streams.WriteByte(s, ASCII.quote) & - WriteString(s, name) & - Streams.WriteByte(s, ASCII.quote) - END WriteType; - - BEGIN - IF event IS UnknownTypeEvent THEN - WITH event: UnknownTypeEvent DO - IF WriteString(s, event.message) & - WriteString(s, ": ") & - Streams.WriteByte(s, ASCII.quote) & - WriteString(s, event.typeName) & - Streams.WriteByte(s, ASCII.quote) THEN - END; - END; - ELSIF event IS TypeGuardFailureEvent THEN - WITH event: TypeGuardFailureEvent DO - IF WriteString(s, event.message) & - WriteString(s, ":") & - WriteLn(s) & - WriteString(s, "expected extension of ") & - WriteType(s, event.expected) & - WriteString(s, " but got ") & - WriteType(s, event.found) THEN - END; - END; - ELSIF event IS DecodeFailureEvent THEN - WITH event: DecodeFailureEvent DO - Services.GetTypeName(event.objectType, typename); - IF WriteString(s, event.message) & - WriteString(s, ":") & - WriteLn(s) & - WriteString(s, "unable to parse object of type ") & - Streams.WriteByte(s, ASCII.quote) & - WriteString(s, typename) & - Streams.WriteByte(s, ASCII.quote) THEN - END; - END; - ELSE - IF WriteString(s, event.message) THEN END; - END; - END WriteEvent; - - PROCEDURE InitErrorHandling; - BEGIN - errormsg[cannotReadData] := "cannot read data part of persistent object"; - errormsg[cannotWriteData] := "cannot write data part of persistent object"; - errormsg[cannotReadType] := "cannot read type of persistent object"; - errormsg[cannotWriteType] := "cannot write type of persistent object"; - errormsg[invalidType] := "invalid type form read"; - errormsg[unknownType] := "unknown type information found"; - errormsg[otherTypeHier] := "different & nonconforming type hierarchy found"; - errormsg[eofReached] := "unexpected EOF encountered during reading"; - errormsg[cannotSkip] := "unable to skip unknown data parts"; - errormsg[typeGuardFailure] := "read object is of unexpected type"; - - Events.Define(error); - Events.SetPriority(error, Priorities.liberrors); - Events.Ignore(error); - Errors.AssignWriteProcedure(error, WriteEvent); - END InitErrorHandling; - - (* ==== marshalling procedures ======================================== *) - - (* encoding scheme: - - Object = Form Type Size ObjectInfo . - Form = SHORTINT; - Type = Code (* codeF *) | - Code TypeName (* incrF *) | - TypeName (* nameF *) | - Code TypeName { Code TypeName } 0 (* incrhierF *) | - TypeName { TypeName } 0X (* hierF *) . - Size = (* noSizeF *) | - Size (* sizeF *) . (* size of object info in bytes *) - ObjectInfo = { Byte } . - *) - - PROCEDURE DecodeForm(form: Form; - VAR nameGiven, codeGiven, hier, size: BOOLEAN); - VAR - typeform: SHORTINT; - sizeform: SHORTINT; - BEGIN - typeform := form MOD maskF; sizeform := form DIV maskF; - nameGiven := typeform IN {incrF, nameF, hierF, incrhierF}; - codeGiven := typeform IN {codeF, incrF, incrhierF}; - hier := (typeform = incrhierF) OR (typeform = hierF); - size := (sizeform = sizeF); - END DecodeForm; - - PROCEDURE GetModule(name: ARRAY OF CHAR; VAR module: ARRAY OF CHAR); - (* get the name of the module where 'name' was defined *) - VAR - index: INTEGER; - BEGIN - index := 0; - WHILE (name[index] # ".") & (name[index] # 0X) & - (index < LEN(module)-1) DO - module[index] := name[index]; INC(index); - END; - module[index] := 0X; - END GetModule; - - PROCEDURE Failure(s: Streams.Stream; code: ErrorCode); - BEGIN - IF s.eof THEN - Error(s, eofReached); - ELSE - Error(s, code); - END; - END Failure; - - PROCEDURE DecodeFailure(s: Streams.Stream; type: Services.Type); - VAR - event: DecodeFailureEvent; - BEGIN - IF s.eof THEN - Error(s, eofReached); - ELSE - NEW(event); - event.type := error; - event.message := errormsg[cannotReadData]; - event.stream := s; - event.errorcode := cannotReadData; - event.objectType := type; - RelatedEvents.Raise(s, event); - END; - END DecodeFailure; - - PROCEDURE GetStreamDisc(s: Streams.Stream; VAR disc: StreamDiscipline); - BEGIN - IF ~IndirectDisciplines.Seek(s, id, SYS.VAL(IndirectDisciplines.Discipline, disc)) THEN - NEW(disc); disc.id := id; disc.mode := defaultMode; - IndirectDisciplines.Add(s, disc); - END; - END GetStreamDisc; - - PROCEDURE ReadTypeInfo(s: Streams.Stream; VAR type: Type; - VAR projection: BOOLEAN; - VAR size: Streams.Count) : BOOLEAN; - VAR - form: Form; - btype: Type; - nameGiven, codeGiven, hier, sizeGiven: BOOLEAN; - disc: StreamDiscipline; - sentinelFound, unknownTypeFound: BOOLEAN; - lastType: Type; - - PROCEDURE ReadType(s: Streams.Stream; VAR type: Type; - VAR sentinelFound, unknownTypeFound: BOOLEAN) : BOOLEAN; - VAR - code: LONGINT; - entry: TypeEntry; - typeName: TypeName; - btype: Type; - - PROCEDURE SeekType(typeName: ARRAY OF CHAR; - VAR type: Type) : BOOLEAN; - VAR - t: Services.Type; - module: TypeName; - BEGIN - Services.SeekType(typeName, t); - IF t = NIL THEN - GetModule(typeName, module); - IF Loader.Load(module, s) THEN - (* maybe the type is now registered *) - Services.SeekType(typeName, t); - END; - END; - IF (t # NIL) & (t IS Type) THEN - type := t(Type); RETURN TRUE - END; - RETURN FALSE - END SeekType; - - BEGIN (* ReadType *) - sentinelFound := FALSE; unknownTypeFound := FALSE; - type := NIL; - IF codeGiven THEN - IF ~NetIO.ReadLongInt(s, code) THEN - Failure(s, cannotReadType); RETURN FALSE - END; - IF code = 0 THEN sentinelFound := TRUE; RETURN FALSE END; - entry := disc.rtypes[code MOD ttlen]; - WHILE (entry # NIL) & (entry.code # code) DO - entry := entry.next; - END; - IF entry # NIL THEN - type := entry.type; - END; - IF (entry = NIL) & ~nameGiven THEN - Failure(s, unknownType); unknownTypeFound := TRUE; RETURN FALSE - END; - END; - IF nameGiven THEN - IF ~NetIO.ReadString(s, typeName) THEN - Failure(s, cannotReadType); RETURN FALSE - END; - IF typeName[0] = 0X THEN sentinelFound := TRUE; RETURN FALSE END; - IF (type = NIL) & ~SeekType(typeName, type) THEN - UnknownType(s, typeName); unknownTypeFound := TRUE; RETURN FALSE - END; - END; - IF codeGiven & (entry = NIL) THEN - NEW(entry); - entry.code := code; - entry.type := type; - entry.next := disc.rtypes[code MOD ttlen]; - disc.rtypes[code MOD ttlen] := entry; - END; - RETURN TRUE - END ReadType; - - BEGIN (* ReadTypeInfo *) - (* read & check form of type info *) - IF ~NetIO.ReadShortInt(s, form) THEN - Failure(s, cannotReadType); RETURN FALSE - END; - IF (form <= 0) OR (form > maxF) THEN - Failure(s, invalidType); RETURN FALSE - END; - DecodeForm(form, nameGiven, codeGiven, hier, sizeGiven); + BEGIN (* ReadType *) + sentinelFound := FALSE; unknownTypeFound := FALSE; + type := NIL; IF codeGiven THEN - GetStreamDisc(s, disc); + IF ~NetIO.ReadLongInt(s, code) THEN + Failure(s, cannotReadType); RETURN FALSE + END; + IF code = 0 THEN sentinelFound := TRUE; RETURN FALSE END; + entry := disc.rtypes[code MOD ttlen]; + WHILE (entry # NIL) & (entry.code # code) DO + entry := entry.next; + END; + IF entry # NIL THEN + type := entry.type; + END; + IF (entry = NIL) & ~nameGiven THEN + Failure(s, unknownType); unknownTypeFound := TRUE; RETURN FALSE + END; END; - - (* read first type information *) - IF ~ReadType(s, type, sentinelFound, unknownTypeFound) & ~hier THEN - RETURN FALSE + IF nameGiven THEN + IF ~NetIO.ReadString(s, typeName) THEN + Failure(s, cannotReadType); RETURN FALSE + END; + IF typeName[0] = 0X THEN sentinelFound := TRUE; RETURN FALSE END; + IF (type = NIL) & ~SeekType(typeName, type) THEN + UnknownType(s, typeName); unknownTypeFound := TRUE; RETURN FALSE + END; END; - - (* read type hierarchy, if any *) - projection := FALSE; - IF hier THEN - IF sentinelFound THEN - Failure(s, invalidType); RETURN FALSE - END; - lastType := type; - LOOP (* until type hierarchy is read *) - IF ReadType(s, btype, sentinelFound, unknownTypeFound) THEN - IF (lastType # NIL) & (lastType.baseType # btype) THEN - Failure(s, otherTypeHier); RETURN FALSE - END; - IF type = NIL THEN - projection := TRUE; - type := btype; - END; - lastType := btype; - ELSIF sentinelFound THEN - EXIT - ELSIF unknownTypeFound THEN - IF lastType # NIL THEN - Failure(s, otherTypeHier); RETURN FALSE - END; - ELSE - RETURN FALSE - END; - END; - IF type = NIL THEN - (* error events already generated by ReadType *) - RETURN FALSE - END; - END; - - (* read size information, if any *) - IF sizeGiven THEN - IF ~NetIO.ReadLongInt(s, size) THEN - Failure(s, cannotReadType); RETURN FALSE - END; - IF size < 0 THEN - Failure(s, invalidType); RETURN FALSE - END; - ELSE - size := -1; + IF codeGiven & (entry = NIL) THEN + NEW(entry); + entry.code := code; + entry.type := type; + entry.next := disc.rtypes[code MOD ttlen]; + disc.rtypes[code MOD ttlen] := entry; END; RETURN TRUE - END ReadTypeInfo; + END ReadType; - PROCEDURE ReadData(s: Streams.Stream; VAR object: Object) : BOOLEAN; - (* use the interface list to read all data in the right order *) + BEGIN (* ReadTypeInfo *) + (* read & check form of type info *) + IF ~NetIO.ReadShortInt(s, form) THEN + Failure(s, cannotReadType); RETURN FALSE + END; + IF (form <= 0) OR (form > maxF) THEN + Failure(s, invalidType); RETURN FALSE + END; + DecodeForm(form, nameGiven, codeGiven, hier, sizeGiven); + IF codeGiven THEN + GetStreamDisc(s, disc); + END; + + (* read first type information *) + IF ~ReadType(s, type, sentinelFound, unknownTypeFound) & ~hier THEN + RETURN FALSE + END; + + (* read type hierarchy, if any *) + projection := FALSE; + IF hier THEN + IF sentinelFound THEN + Failure(s, invalidType); RETURN FALSE + END; + lastType := type; + LOOP (* until type hierarchy is read *) + IF ReadType(s, btype, sentinelFound, unknownTypeFound) THEN + IF (lastType # NIL) & (lastType.baseType # btype) THEN + Failure(s, otherTypeHier); RETURN FALSE + END; + IF type = NIL THEN + projection := TRUE; + type := btype; + END; + lastType := btype; + ELSIF sentinelFound THEN + EXIT + ELSIF unknownTypeFound THEN + IF lastType # NIL THEN + Failure(s, otherTypeHier); RETURN FALSE + END; + ELSE + RETURN FALSE + END; + END; + IF type = NIL THEN + (* error events already generated by ReadType *) + RETURN FALSE + END; + END; + + (* read size information, if any *) + IF sizeGiven THEN + IF ~NetIO.ReadLongInt(s, size) THEN + Failure(s, cannotReadType); RETURN FALSE + END; + IF size < 0 THEN + Failure(s, invalidType); RETURN FALSE + END; + ELSE + size := -1; + END; + RETURN TRUE + END ReadTypeInfo; + + PROCEDURE ReadData(s: Streams.Stream; VAR object: Object) : BOOLEAN; + (* use the interface list to read all data in the right order *) + VAR + ifList: InterfaceList; + BEGIN + ifList := object.type.ifs; + WHILE ifList # NIL DO + IF ~ifList.if.read(s, object) THEN + (* error handling is done by the calling procedure *) + RETURN FALSE + END; + ifList := ifList.next; + END; + RETURN (object.type.if.read = NIL) OR object.type.if.read(s, object) + END ReadData; + + PROCEDURE EncodeForm(s: Streams.Stream; type: Type; VAR form: Form); + VAR + mode: Mode; + disc: IndirectDisciplines.Discipline; + hier: BOOLEAN; + + PROCEDURE KnownType() : BOOLEAN; VAR - ifList: InterfaceList; - BEGIN - ifList := object.type.ifs; - WHILE ifList # NIL DO - IF ~ifList.if.read(s, object) THEN - (* error handling is done by the calling procedure *) - RETURN FALSE - END; - ifList := ifList.next; + p: TypeEntry; + BEGIN + p := disc(StreamDiscipline).wtypes[type.code MOD ttlen]; + WHILE (p # NIL) & (p.type # type) DO + p := p.next; END; - RETURN (object.type.if.read = NIL) OR object.type.if.read(s, object) - END ReadData; + RETURN p # NIL + END KnownType; - PROCEDURE EncodeForm(s: Streams.Stream; type: Type; VAR form: Form); + BEGIN + IF ~IndirectDisciplines.Seek(s, id, disc) THEN + mode := defaultMode; disc := NIL; + ELSE + mode := disc(StreamDiscipline).mode; + END; + form := 0; + hier := mode DIV 8 MOD 2 > 0; + CASE mode MOD 4 OF + | fullTypeName: IF hier THEN form := hierF ELSE form := nameF END; + | typeCode: form := codeF; ASSERT(~hier); + | incrTypeCode: IF KnownType() THEN + form := codeF; + ELSIF hier THEN + form := incrhierF; + ELSE + form := incrF; + END; + ELSE + END; + IF mode DIV 4 MOD 2 > 0 THEN + INC(form, sizeF); + ELSE + INC(form, noSizeF); + END; + END EncodeForm; + + PROCEDURE WriteTypeInfo(s: Streams.Stream; type: Type; + VAR giveSize: BOOLEAN) : BOOLEAN; + (* write type information without size *) + VAR + form: Form; + giveName, giveCode, hier: BOOLEAN; + mode: Mode; incr: BOOLEAN; + disc: IndirectDisciplines.Discipline; + btype: Type; + + PROCEDURE WriteType(s: Streams.Stream; type: Type) : BOOLEAN; VAR - mode: Mode; - disc: StreamDiscipline; - hier: BOOLEAN; - - PROCEDURE KnownType() : BOOLEAN; - VAR - p: TypeEntry; - BEGIN - p := disc.wtypes[type.code MOD ttlen]; - WHILE (p # NIL) & (p.type # type) DO - p := p.next; - END; - RETURN p # NIL - END KnownType; - - BEGIN - IF ~IndirectDisciplines.Seek(s, id, SYS.VAL(IndirectDisciplines.Discipline, disc)) THEN - mode := defaultMode; disc := NIL; - ELSE - mode := disc.mode; + typeName: TypeName; + entry: TypeEntry; + BEGIN + IF giveCode THEN + IF ~NetIO.WriteLongInt(s, type.code) THEN + Error(s, cannotWriteType); RETURN FALSE + END; END; - form := 0; - hier := mode DIV 8 MOD 2 > 0; - CASE mode MOD 4 OF - | fullTypeName: IF hier THEN form := hierF ELSE form := nameF END; - | typeCode: form := codeF; ASSERT(~hier); - | incrTypeCode: IF KnownType() THEN - form := codeF; - ELSIF hier THEN - form := incrhierF; - ELSE - form := incrF; - END; - ELSE + IF giveName THEN + Services.GetTypeName(type, typeName); + IF ~NetIO.WriteString(s, typeName) THEN + Error(s, cannotWriteType); RETURN FALSE + END; END; - IF mode DIV 4 MOD 2 > 0 THEN - INC(form, sizeF); - ELSE - INC(form, noSizeF); + IF incr THEN + NEW(entry); entry.type := type; entry.code := type.code; + entry.next := disc(StreamDiscipline).wtypes[type.code MOD ttlen]; + disc(StreamDiscipline).wtypes[type.code MOD ttlen] := entry; END; - END EncodeForm; - - PROCEDURE WriteTypeInfo(s: Streams.Stream; type: Type; - VAR giveSize: BOOLEAN) : BOOLEAN; - (* write type information without size *) - VAR - form: Form; - giveName, giveCode, hier: BOOLEAN; - mode: Mode; incr: BOOLEAN; - disc: StreamDiscipline; - btype: Type; - - PROCEDURE WriteType(s: Streams.Stream; type: Type) : BOOLEAN; - VAR - typeName: TypeName; - entry: TypeEntry; - BEGIN - IF giveCode THEN - IF ~NetIO.WriteLongInt(s, type.code) THEN - Error(s, cannotWriteType); RETURN FALSE - END; - END; - IF giveName THEN - Services.GetTypeName(type, typeName); - IF ~NetIO.WriteString(s, typeName) THEN - Error(s, cannotWriteType); RETURN FALSE - END; - END; - IF incr THEN - NEW(entry); entry.type := type; entry.code := type.code; - entry.next := disc.wtypes[type.code MOD ttlen]; - disc.wtypes[type.code MOD ttlen] := entry; - END; - RETURN TRUE - END WriteType; - - BEGIN (* WriteTypeInfo *) - EncodeForm(s, type, form); - IF ~NetIO.WriteShortInt(s, form) THEN - Error(s, cannotWriteType); - END; - DecodeForm(form, giveName, giveCode, hier, giveSize); - IF ~IndirectDisciplines.Seek(s, id, SYS.VAL(IndirectDisciplines.Discipline, disc)) THEN - mode := defaultMode; - END; - incr := giveName & giveCode; - - IF ~WriteType(s, type) THEN RETURN FALSE END; - - IF hier THEN - btype := type.baseType; - WHILE btype # NIL DO - IF ~WriteType(s, btype) THEN RETURN FALSE END; - btype := btype.baseType; - END; - (* write sentinel *) - IF giveCode THEN - IF ~NetIO.WriteLongInt(s, 0) THEN - Error(s, cannotWriteType); - RETURN FALSE - END; - ELSE - IF ~NetIO.WriteString(s, "") THEN - Error(s, cannotWriteType); - RETURN FALSE - END; - END; - END; - RETURN TRUE - END WriteTypeInfo; + END WriteType; - PROCEDURE WriteData(s: Streams.Stream; object: Object) : BOOLEAN; - (* use the interface list to write all data in the right order *) - VAR - ifList: InterfaceList; - BEGIN - ifList := object.type.ifs; - WHILE ifList # NIL DO - IF ~ifList.if.write(s, object) THEN - (* error handling is done by the calling procedure *) - RETURN FALSE - END; - ifList := ifList.next; + BEGIN (* WriteTypeInfo *) + EncodeForm(s, type, form); + IF ~NetIO.WriteShortInt(s, form) THEN + Error(s, cannotWriteType); + END; + DecodeForm(form, giveName, giveCode, hier, giveSize); + IF ~IndirectDisciplines.Seek(s, id, disc) THEN + mode := defaultMode; + END; + incr := giveName & giveCode; + + IF ~WriteType(s, type) THEN RETURN FALSE END; + + IF hier THEN + btype := type.baseType; + WHILE btype # NIL DO + IF ~WriteType(s, btype) THEN RETURN FALSE END; + btype := btype.baseType; END; - RETURN (object.type.if.write = NIL) OR object.type.if.write(s, object) - END WriteData; - - (* ===== exported procedures ============================================ *) - - PROCEDURE RegisterType*(VAR type: Services.Type; - name, baseName: ARRAY OF CHAR; - if: Interface); - VAR - newtype: Type; - baseType: Services.Type; - member: InterfaceList; - bt: Type; - ifval: INTEGER; - BEGIN - (* check the parameters *) - ASSERT(name[0] # 0X); - IF if # NIL THEN - ifval := 0; - IF if.create # NIL THEN INC(ifval, 1) END; - IF if.read # NIL THEN INC(ifval, 2) END; - IF if.write # NIL THEN INC(ifval, 4) END; - IF if.createAndRead # NIL THEN INC(ifval, 8) END; - (* legal variants: - - if = NIL abstract data type - - create read write createAndRead - #NIL NIL NIL NIL 1 empty data type - NIL #NIL #NIL NIL 6 abstract data type - #NIL #NIL #NIL NIL 7 normal case - NIL NIL #NIL #NIL 12 special case - - note that the special case must not be given as base type! - *) - ASSERT(ifval IN {1, 6, 7, 12}); - END; - - (* create type and determine next non-abstract base type *) - NEW(newtype); - newtype.code := nextTypeCode; INC(nextTypeCode); - newtype.if := if; - IF baseName = "" THEN - Services.InitType(newtype, name, "PersistentObjects.Object"); + (* write sentinel *) + IF giveCode THEN + IF ~NetIO.WriteLongInt(s, 0) THEN + Error(s, cannotWriteType); + RETURN FALSE + END; ELSE - Services.InitType(newtype, name, baseName); + IF ~NetIO.WriteString(s, "") THEN + Error(s, cannotWriteType); + RETURN FALSE + END; END; - IF baseName = "" THEN - newtype.baseType := NIL; - ELSE - Services.GetBaseType(newtype, baseType); - ASSERT((baseType # NIL) & (baseType IS Type)); - WHILE (baseType # NIL) & (baseType IS Type) & - (baseType(Type).if = NIL) DO - Services.GetBaseType(baseType, baseType); - END; - IF (baseType = NIL) OR ~(baseType IS Type) THEN - newtype.baseType := NIL; - ELSE - newtype.baseType := baseType(Type); - ASSERT(newtype.baseType.if.createAndRead = NIL); - END; + END; + + RETURN TRUE + END WriteTypeInfo; + + PROCEDURE WriteData(s: Streams.Stream; object: Object) : BOOLEAN; + (* use the interface list to write all data in the right order *) + VAR + ifList: InterfaceList; + BEGIN + ifList := object.type.ifs; + WHILE ifList # NIL DO + IF ~ifList.if.write(s, object) THEN + (* error handling is done by the calling procedure *) + RETURN FALSE END; + ifList := ifList.next; + END; + RETURN (object.type.if.write = NIL) OR object.type.if.write(s, object) + END WriteData; - (* build up list of interfaces *) - newtype.ifs := NIL; bt := newtype.baseType; - WHILE bt # NIL DO - NEW(member); member.if := bt.if; - member.next := newtype.ifs; newtype.ifs := member; - bt := bt.baseType; - END; + (* ===== exported procedures ============================================ *) - type := newtype; - END RegisterType; + PROCEDURE RegisterType*(VAR type: Services.Type; + name, baseName: ARRAY OF CHAR; + if: Interface); + VAR + newtype: Type; + baseType: Services.Type; + member: InterfaceList; + bt: Type; + ifval: INTEGER; + BEGIN + (* check the parameters *) + ASSERT(name[0] # 0X); + IF if # NIL THEN + ifval := 0; + IF if.create # NIL THEN INC(ifval, 1) END; + IF if.read # NIL THEN INC(ifval, 2) END; + IF if.write # NIL THEN INC(ifval, 4) END; + IF if.createAndRead # NIL THEN INC(ifval, 8) END; + (* legal variants: - PROCEDURE Init*(object: Object; type: Services.Type); - BEGIN - ASSERT(type IS Type); - WITH type: Type DO - ASSERT((type.if.create # NIL) OR (type.if.createAndRead # NIL)); - object.type := type; - object.projected := FALSE; - Services.Init(object, type); - END; - END Init; + if = NIL abstract data type - PROCEDURE SetMode*(s: Streams.Stream; mode: Mode); - VAR - disc: StreamDiscipline; - BEGIN - IF ~Disciplines.Seek(s, id, SYS.VAL(Disciplines.Discipline, disc)) THEN - NEW(disc); disc.id := id; - END; - disc.mode := mode; - Disciplines.Add(s, disc); - END SetMode; + create read write createAndRead + #NIL NIL NIL NIL 1 empty data type + NIL #NIL #NIL NIL 6 abstract data type + #NIL #NIL #NIL NIL 7 normal case + NIL NIL #NIL #NIL 12 special case - PROCEDURE GetMode*(s: Streams.Stream; VAR mode: Mode); - (* return the current mode for the given stream *) - VAR - disc: StreamDiscipline; - BEGIN - IF Disciplines.Seek(s, id, SYS.VAL(Disciplines.Discipline, disc)) THEN - mode := disc.mode; - ELSE - mode := defaultMode; - END; - END GetMode; - - PROCEDURE IsProjected*(object: Object) : BOOLEAN; - (* show whether the object was a victim of projection or not *) - BEGIN - RETURN object.projected - END IsProjected; - - PROCEDURE InternalRead(s: Streams.Stream; create: BOOLEAN; - VAR object: Object) : BOOLEAN; - (* read `object' from `s'; - note that we have to operate on `object' directly because - LinearizedStructures relies on this in case of cyclic - references + note that the special case must not be given as base type! *) - VAR - streamCaps: Streams.CapabilitySet; - type, objectType: Type; - projection: BOOLEAN; (* necessary due to unknown types? *) - size: Streams.Count; (* size information, if unknown it equals -1 *) - skipUnknownParts: BOOLEAN; (* are we able to skip data if necessary? *) + ASSERT(ifval IN {1, 6, 7, 12}); + END; - (* these vars are used for skipping unknown data areas *) - oldPos, newPos: Streams.Count; - textbuf: Texts.Text; - - BEGIN (* InternalRead *) - IF ~ReadTypeInfo(s, type, projection, size) THEN RETURN FALSE END; - IF ~create & (type.if.createAndRead = NIL) THEN - (* projection necessary due to target object? *) - Services.GetType(object, SYS.VAL(Services.Type, objectType)); - IF ~Services.IsExtensionOf(type, objectType) THEN - TypeGuardFailure(s, type, objectType); RETURN FALSE - END; - projection := projection OR (type # objectType); + (* create type and determine next non-abstract base type *) + NEW(newtype); + newtype.code := nextTypeCode; INC(nextTypeCode); + newtype.if := if; + IF baseName = "" THEN + Services.InitType(newtype, name, "PersistentObjects.Object"); + ELSE + Services.InitType(newtype, name, baseName); + END; + IF baseName = "" THEN + newtype.baseType := NIL; + ELSE + Services.GetBaseType(newtype, baseType); + ASSERT((baseType # NIL) & (baseType IS Type)); + WHILE (baseType # NIL) & (baseType IS Type) & + (baseType(Type).if = NIL) DO + Services.GetBaseType(baseType, baseType); END; - skipUnknownParts := projection & (size > 0); + IF (baseType = NIL) OR ~(baseType IS Type) THEN + newtype.baseType := NIL; + ELSE + newtype.baseType := baseType(Type); + ASSERT(newtype.baseType.if.createAndRead = NIL); + END; + END; + + (* build up list of interfaces *) + newtype.ifs := NIL; bt := newtype.baseType; + WHILE bt # NIL DO + NEW(member); member.if := bt.if; + member.next := newtype.ifs; newtype.ifs := member; + bt := bt.baseType; + END; + + type := newtype; + END RegisterType; + + PROCEDURE Init*(object: Object; type: Services.Type); + BEGIN + ASSERT(type IS Type); + WITH type: Type DO + ASSERT((type.if.create # NIL) OR (type.if.createAndRead # NIL)); + object.type := type; + object.projected := FALSE; + Services.Init(object, type); + END; + END Init; + + PROCEDURE SetMode*(s: Streams.Stream; mode: Mode); + VAR + disc: StreamDiscipline; + d: Disciplines.Discipline; + BEGIN + IF Disciplines.Seek(s, id, d) THEN + disc := d(StreamDiscipline) + ELSE + NEW(disc); disc.id := id; + END; + disc.mode := mode; + Disciplines.Add(s, disc); + END SetMode; + + PROCEDURE GetMode*(s: Streams.Stream; VAR mode: Mode); + (* return the current mode for the given stream *) + VAR + disc: Disciplines.Discipline; + BEGIN + IF Disciplines.Seek(s, id, disc) THEN + mode := disc(StreamDiscipline).mode; + ELSE + mode := defaultMode; + END; + END GetMode; + + PROCEDURE IsProjected*(object: Object) : BOOLEAN; + (* show whether the object was a victim of projection or not *) + BEGIN + RETURN object.projected + END IsProjected; + + PROCEDURE InternalRead(s: Streams.Stream; create: BOOLEAN; + VAR object: Object) : BOOLEAN; + (* read `object' from `s'; + note that we have to operate on `object' directly because + LinearizedStructures relies on this in case of cyclic + references + *) + VAR + streamCaps: Streams.CapabilitySet; + type: Type; + objectType: Services.Type; + projection: BOOLEAN; (* necessary due to unknown types? *) + size: Streams.Count; (* size information, if unknown it equals -1 *) + skipUnknownParts: BOOLEAN; (* are we able to skip data if necessary? *) + + (* these vars are used for skipping unknown data areas *) + oldPos, newPos: Streams.Count; + textbuf: Texts.Text; + + BEGIN (* InternalRead *) + IF ~ReadTypeInfo(s, type, projection, size) THEN RETURN FALSE END; + IF ~create & (type.if.createAndRead = NIL) THEN + (* projection necessary due to target object? *) + Services.GetType(object, objectType); + IF ~Services.IsExtensionOf(type, objectType) THEN + TypeGuardFailure(s, type, objectType); RETURN FALSE + END; + projection := projection OR (type # objectType); + END; + skipUnknownParts := projection & (size > 0); + streamCaps := Streams.Capabilities(s); + IF skipUnknownParts THEN + IF Streams.tell IN streamCaps THEN + Streams.GetPos(s, oldPos); + ELSE + Texts.Open(SYS.VAL(Streams.Stream, textbuf)); + IF ~Streams.Copy(s, textbuf, size) THEN + Failure(s, cannotReadData); RETURN FALSE + END; + Forwarders.Forward(textbuf, s); + RelatedEvents.Forward(textbuf, s); + s := textbuf; + skipUnknownParts := FALSE; + END; + END; + + IF type.if.createAndRead # NIL THEN + IF ~type.if.createAndRead(s, create, object) THEN + DecodeFailure(s, type); object := NIL; RETURN FALSE + END; + ELSE + IF create THEN + type.if.create(object); + END; + IF ~ReadData(s, object) THEN + DecodeFailure(s, type); + object := NIL; + RETURN FALSE + END; + END; + + (* store information about projection into object *) + object.projected := projection; + + IF skipUnknownParts THEN + IF Streams.seek IN streamCaps THEN + Streams.SetPos(s, oldPos + size); + ELSE + Streams.GetPos(s, newPos); + IF ~Streams.Copy(s, Streams.null, size - newPos + oldPos) THEN + Failure(s, cannotSkip); RETURN FALSE + END; + END; + ELSIF projection & (size < 0) THEN + Error(s, cannotSkip); RETURN FALSE + END; + + s.count := 1; (* show success *) + RETURN TRUE + END InternalRead; + + PROCEDURE Read*(s: Streams.Stream; VAR object: Object) : BOOLEAN; + (* read `object' from `s'; object # NIL on success *) + BEGIN + RETURN InternalRead(s, (* create = *) TRUE, object) + END Read; + + PROCEDURE ReadInto*(s: Streams.Stream; object: Object) : BOOLEAN; + (* read an object from `s' and assign it to `object'; + this fails if `object' doesn't has the IDENTICAL type + (thus projections are not supported here) + *) + BEGIN + RETURN InternalRead(s, (* create = *) FALSE, object) + END ReadInto; + + PROCEDURE GuardedRead*(s: Streams.Stream; guard: Services.Type; + VAR object: Object) : BOOLEAN; + (* read an object from `s' and return it, provided + the type of the read object is an extension of `guard' + *) + VAR + testObject: Object; + type: Services.Type; + BEGIN + IF ~Read(s, testObject) THEN RETURN FALSE END; + Services.GetType(testObject, type); + IF Services.IsExtensionOf(type, guard) THEN + object := testObject; RETURN TRUE + ELSE + TypeGuardFailure(s, type, guard); + RETURN FALSE + END; + END GuardedRead; + + PROCEDURE Write*(s: Streams.Stream; object: Object) : BOOLEAN; + (* write `obj' to `s' *) + VAR + giveSize: BOOLEAN; + streamCaps: Streams.CapabilitySet; + patchSize: BOOLEAN; + sizePos, beginPos, endPos: Streams.Count; + textbuf, origStream: Streams.Stream; + mode: Mode; + BEGIN + IF ~WriteTypeInfo(s, object.type, giveSize) THEN RETURN FALSE END; + IF giveSize THEN streamCaps := Streams.Capabilities(s); - IF skipUnknownParts THEN - IF Streams.tell IN streamCaps THEN - Streams.GetPos(s, oldPos); - ELSE - Texts.Open(SYS.VAL(Streams.Stream, textbuf)); - IF ~Streams.Copy(s, textbuf, size) THEN - Failure(s, cannotReadData); RETURN FALSE - END; - Forwarders.Forward(textbuf, s); - RelatedEvents.Forward(textbuf, s); - s := textbuf; - skipUnknownParts := FALSE; - END; - END; - - IF type.if.createAndRead # NIL THEN - IF ~type.if.createAndRead(s, create, object) THEN - DecodeFailure(s, type); object := NIL; RETURN FALSE - END; + patchSize := ({Streams.tell, Streams.seek} - streamCaps = {}) & + Streams.Tell(s, sizePos); + IF patchSize THEN + IF ~NetIO.WriteLongInt(s, 0) THEN + Error(s, cannotWriteData); RETURN FALSE + END; + Streams.GetPos(s, beginPos); ELSE - IF create THEN - type.if.create(object); - END; - IF ~ReadData(s, object) THEN - DecodeFailure(s, type); - object := NIL; - RETURN FALSE - END; + Texts.Open(textbuf); + Forwarders.Forward(textbuf, s); + RelatedEvents.Forward(textbuf, s); + GetMode(s, mode); SetMode(textbuf, mode); + origStream := s; s := textbuf; END; + END; - (* store information about projection into object *) - object.projected := projection; - - IF skipUnknownParts THEN - IF Streams.seek IN streamCaps THEN - Streams.SetPos(s, oldPos + size); - ELSE - Streams.GetPos(s, newPos); - IF ~Streams.Copy(s, Streams.null, size - newPos + oldPos) THEN - Failure(s, cannotSkip); RETURN FALSE - END; - END; - ELSIF projection & (size < 0) THEN - Error(s, cannotSkip); RETURN FALSE + IF object.type.if.createAndRead # NIL THEN + IF ~object.type.if.write(s, object) THEN + Error(s, cannotWriteData); RETURN FALSE END; + ELSE + IF ~WriteData(s, object) THEN + Error(s, cannotWriteData); RETURN FALSE + END; + END; - s.count := 1; (* show success *) - RETURN TRUE - END InternalRead; - - PROCEDURE Read*(s: Streams.Stream; VAR object: Object) : BOOLEAN; - (* read `object' from `s'; object # NIL on success *) - BEGIN - RETURN InternalRead(s, (* create = *) TRUE, object) - END Read; - - PROCEDURE ReadInto*(s: Streams.Stream; object: Object) : BOOLEAN; - (* read an object from `s' and assign it to `object'; - this fails if `object' doesn't has the IDENTICAL type - (thus projections are not supported here) - *) - BEGIN - RETURN InternalRead(s, (* create = *) FALSE, object) - END ReadInto; - - PROCEDURE GuardedRead*(s: Streams.Stream; guard: Services.Type; - VAR object: Object) : BOOLEAN; - (* read an object from `s' and return it, provided - the type of the read object is an extension of `guard' - *) - VAR - testObject: Object; - type: Services.Type; - BEGIN - IF ~Read(s, testObject) THEN RETURN FALSE END; - Services.GetType(testObject, type); - IF Services.IsExtensionOf(type, guard) THEN - object := testObject; RETURN TRUE + IF giveSize THEN + IF patchSize THEN + Streams.GetPos(s, endPos); + Streams.SetPos(s, sizePos); + IF ~NetIO.WriteLongInt(s, endPos - beginPos) THEN + Streams.SetPos(s, endPos); + Error(s, cannotWriteData); + RETURN FALSE + END; + Streams.SetPos(s, endPos); ELSE - TypeGuardFailure(s, type, guard); - RETURN FALSE + Streams.GetPos(textbuf, endPos); + Streams.SetPos(textbuf, 0); + s := origStream; + IF ~NetIO.WriteLongInt(s, endPos) OR + ~Streams.Copy(textbuf, s, endPos) THEN + Error(s, cannotWriteData); + END; END; - END GuardedRead; + END; + s.count := 1; + RETURN TRUE + END Write; - PROCEDURE Write*(s: Streams.Stream; object: Object) : BOOLEAN; - (* write `obj' to `s' *) - VAR - giveSize: BOOLEAN; - streamCaps: Streams.CapabilitySet; - patchSize: BOOLEAN; - sizePos, beginPos, endPos: Streams.Count; - textbuf, origStream: Streams.Stream; - mode: Mode; - BEGIN - IF ~WriteTypeInfo(s, object.type, giveSize) THEN RETURN FALSE END; - IF giveSize THEN - streamCaps := Streams.Capabilities(s); - patchSize := ({Streams.tell, Streams.seek} - streamCaps = {}) & - Streams.Tell(s, sizePos); - IF patchSize THEN - IF ~NetIO.WriteLongInt(s, 0) THEN - Error(s, cannotWriteData); RETURN FALSE - END; - Streams.GetPos(s, beginPos); - ELSE - Texts.Open(textbuf); - Forwarders.Forward(textbuf, s); - RelatedEvents.Forward(textbuf, s); - GetMode(s, mode); SetMode(textbuf, mode); - origStream := s; s := textbuf; - END; - END; + PROCEDURE ReadObjectOrNIL*(s: Streams.Stream; VAR object: Object) : BOOLEAN; + VAR + nil: BOOLEAN; + BEGIN + object := NIL; + RETURN NetIO.ReadBoolean(s, nil) & (nil OR Read(s, object)) + END ReadObjectOrNIL; - IF object.type.if.createAndRead # NIL THEN - IF ~object.type.if.write(s, object) THEN - Error(s, cannotWriteData); RETURN FALSE - END; - ELSE - IF ~WriteData(s, object) THEN - Error(s, cannotWriteData); RETURN FALSE - END; - END; - - IF giveSize THEN - IF patchSize THEN - Streams.GetPos(s, endPos); - Streams.SetPos(s, sizePos); - IF ~NetIO.WriteLongInt(s, endPos - beginPos) THEN - Streams.SetPos(s, endPos); - Error(s, cannotWriteData); - RETURN FALSE - END; - Streams.SetPos(s, endPos); - ELSE - Streams.GetPos(textbuf, endPos); - Streams.SetPos(textbuf, 0); - s := origStream; - IF ~NetIO.WriteLongInt(s, endPos) OR - ~Streams.Copy(textbuf, s, endPos) THEN - Error(s, cannotWriteData); - END; - END; - END; - s.count := 1; - RETURN TRUE - END Write; - - PROCEDURE ReadObjectOrNIL*(s: Streams.Stream; VAR object: Object) : BOOLEAN; - VAR - nil: BOOLEAN; - BEGIN + PROCEDURE GuardedReadObjectOrNIL*(s: Streams.Stream; guard: Services.Type; + VAR object: Object) : BOOLEAN; + (* may be used instead of ReadObjectOrNIL *) + VAR + testObject: Object; + type: Services.Type; + nil: BOOLEAN; + BEGIN + IF ~NetIO.ReadBoolean(s, nil) THEN RETURN FALSE END; + IF nil THEN object := NIL; - RETURN NetIO.ReadBoolean(s, nil) & (nil OR Read(s, object)) - END ReadObjectOrNIL; + RETURN TRUE + END; + IF ~Read(s, testObject) THEN RETURN FALSE END; + IF testObject = NIL THEN RETURN TRUE END; + Services.GetType(testObject, type); + IF Services.IsExtensionOf(type, guard) THEN + object := testObject; RETURN TRUE + ELSE + TypeGuardFailure(s, type, guard); + RETURN FALSE + END; + END GuardedReadObjectOrNIL; - PROCEDURE GuardedReadObjectOrNIL*(s: Streams.Stream; guard: Services.Type; - VAR object: Object) : BOOLEAN; - (* may be used instead of ReadObjectOrNIL *) - VAR - testObject: Object; - type: Services.Type; - nil: BOOLEAN; - BEGIN - IF ~NetIO.ReadBoolean(s, nil) THEN RETURN FALSE END; - IF nil THEN - object := NIL; - RETURN TRUE - END; - IF ~Read(s, testObject) THEN RETURN FALSE END; - IF testObject = NIL THEN RETURN TRUE END; - Services.GetType(testObject, type); - IF Services.IsExtensionOf(type, guard) THEN - object := testObject; RETURN TRUE - ELSE - TypeGuardFailure(s, type, guard); - RETURN FALSE - END; - END GuardedReadObjectOrNIL; - - PROCEDURE WriteObjectOrNIL*(s: Streams.Stream; object: Object) : BOOLEAN; - VAR - nil: BOOLEAN; - BEGIN - nil := object = NIL; - RETURN NetIO.WriteBoolean(s, nil) & (nil OR Write(s, object)) - END WriteObjectOrNIL; + PROCEDURE WriteObjectOrNIL*(s: Streams.Stream; object: Object) : BOOLEAN; + VAR + nil: BOOLEAN; + BEGIN + nil := object = NIL; + RETURN NetIO.WriteBoolean(s, nil) & (nil OR Write(s, object)) + END WriteObjectOrNIL; BEGIN - id := Disciplines.Unique(); - nextTypeCode := 1; - InitErrorHandling; - Services.CreateType(potype, "PersistentObjects.Object", ""); + id := Disciplines.Unique(); + nextTypeCode := 1; + InitErrorHandling; + Services.CreateType(potype, "PersistentObjects.Object", ""); END ulmPersistentObjects. diff --git a/src/library/ulm/ulmRandomGenerators.Mod b/src/library/ulm/ulmRandomGenerators.Mod index cb63a9a5..f1aa36de 100644 --- a/src/library/ulm/ulmRandomGenerators.Mod +++ b/src/library/ulm/ulmRandomGenerators.Mod @@ -1,419 +1,421 @@ (* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: RandomGener.om,v 1.9 2004/03/09 21:44:12 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: RandomGener.om,v $ - Revision 1.9 2004/03/09 21:44:12 borchert - unpredictable added to the standard set of PRNGs + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: RandomGener.om,v 1.9 2004/03/09 21:44:12 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: RandomGener.om,v $ + Revision 1.9 2004/03/09 21:44:12 borchert + unpredictable added to the standard set of PRNGs - Revision 1.8 2004/03/06 07:22:09 borchert - Init asserts that the sequence has been registered at Services + Revision 1.8 2004/03/06 07:22:09 borchert + Init asserts that the sequence has been registered at Services - Revision 1.7 1998/02/14 22:04:09 martin - Missing calls of Services.Init and Services.CreateType added. + Revision 1.7 1998/02/14 22:04:09 martin + Missing calls of Services.Init and Services.CreateType added. - Revision 1.6 1997/10/11 21:22:03 martin - assertion in ValS added, obsolete variable removed + Revision 1.6 1997/10/11 21:22:03 martin + assertion in ValS added, obsolete variable removed - Revision 1.5 1997/10/10 16:26:49 martin - RestartSequence added, range conversions improved, - default implementation replaced. + Revision 1.5 1997/10/10 16:26:49 martin + RestartSequence added, range conversions improved, + default implementation replaced. - Revision 1.4 1997/04/01 16:33:41 borchert - major revision of Random: - - module renamed to RandomGenerators - - abstraction instead of simple implementation (work by Frank Fischer) + Revision 1.4 1997/04/01 16:33:41 borchert + major revision of Random: + - module renamed to RandomGenerators + - abstraction instead of simple implementation (work by Frank Fischer) - Revision 1.3 1994/09/01 18:15:41 borchert - bug fix: avoid arithmetic overflow in ValS + Revision 1.3 1994/09/01 18:15:41 borchert + bug fix: avoid arithmetic overflow in ValS - Revision 1.2 1994/08/30 09:48:00 borchert - sequences added + Revision 1.2 1994/08/30 09:48:00 borchert + sequences added - Revision 1.1 1994/02/23 07:25:30 borchert - Initial revision + Revision 1.1 1994/02/23 07:25:30 borchert + Initial revision - ---------------------------------------------------------------------------- - original implementation by AFB 2/90 - conversion to abstraction by Frank B.J. Fischer 3/97 - ---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- + original implementation by AFB 2/90 + conversion to abstraction by Frank B.J. Fischer 3/97 + ---------------------------------------------------------------------------- *) MODULE ulmRandomGenerators; - (* Anyone who considers arithmetical - methods of producing random digits - is, of course, in a state of sin. - - John von Neumann (1951) - *) + (* Anyone who considers arithmetical + methods of producing random digits + is, of course, in a state of sin. + - John von Neumann (1951) + *) - IMPORT - Clocks := ulmClocks, Disciplines := ulmDisciplines, Objects := ulmObjects, Operations := ulmOperations, Process := ulmProcess, Services := ulmServices, Times := ulmTimes, - Types := ulmTypes, S := SYSTEM; + IMPORT + Clocks := ulmClocks, Disciplines := ulmDisciplines, + Objects := ulmObjects, Operations := ulmOperations, + Process := ulmProcess, Services := ulmServices, + Times := ulmTimes, Types := ulmTypes; - TYPE - Sequence* = POINTER TO SequenceRec; + TYPE + Sequence* = POINTER TO SequenceRec; - Int32ValSProc* = PROCEDURE (sequence: Sequence): Types.Int32; - LongRealValSProc* = PROCEDURE (sequence: Sequence): LONGREAL; - RewindSequenceProc* = PROCEDURE (sequence: Sequence); - RestartSequenceProc* = PROCEDURE (sequence, seed: Sequence); - SetValSProc* = PROCEDURE (sequence: Sequence; value: Operations.Operand); + Int32ValSProc* = PROCEDURE (sequence: Sequence): Types.Int32; + LongRealValSProc* = PROCEDURE (sequence: Sequence): LONGREAL; + RewindSequenceProc* = PROCEDURE (sequence: Sequence); + RestartSequenceProc* = PROCEDURE (sequence, seed: Sequence); + SetValSProc* = PROCEDURE (sequence: Sequence; value: Operations.Operand); - CONST - int32ValS* = 0; longRealValS* = 1; rewindSequence* = 2; restartSequence* = 3; + CONST + int32ValS* = 0; longRealValS* = 1; rewindSequence* = 2; restartSequence* = 3; - TYPE - CapabilitySet* = SET; (* of [int32ValS..restartSequence] *) - Interface* = POINTER TO InterfaceRec; - InterfaceRec* = - RECORD - (Objects.ObjectRec) - int32ValS* : Int32ValSProc; (* at least one of ... *) - longRealValS* : LongRealValSProc; (* ... these required *) - rewindSequence* : RewindSequenceProc; (* optional *) - restartSequence*: RestartSequenceProc; (* optional *) - END; + TYPE + CapabilitySet* = SET; (* of [int32ValS..restartSequence] *) + Interface* = POINTER TO InterfaceRec; + InterfaceRec* = + RECORD + (Objects.ObjectRec) + int32ValS* : Int32ValSProc; (* at least one of ... *) + longRealValS* : LongRealValSProc; (* ... these required *) + rewindSequence* : RewindSequenceProc; (* optional *) + restartSequence*: RestartSequenceProc; (* optional *) + END; - SequenceRec* = - RECORD - (Services.ObjectRec) - (* private components *) - if : Interface; - caps: CapabilitySet; - END; + SequenceRec* = + RECORD + (Services.ObjectRec) + (* private components *) + if : Interface; + caps: CapabilitySet; + END; - VAR - std* : Sequence; (* default sequence *) - seed*: Sequence; (* sequence of seed values *) - unpredictable*: Sequence; - (* reasonably fast sequence of unpredictable values; - is initially NIL - *) + VAR + std* : Sequence; (* default sequence *) + seed*: Sequence; (* sequence of seed values *) + unpredictable*: Sequence; + (* reasonably fast sequence of unpredictable values; + is initially NIL + *) - (* ----- private definitions ----- *) + (* ----- private definitions ----- *) - CONST - modulus1 = 2147483647; (* a Mersenne prime *) - factor1 = 48271; (* passes spectral test *) - quotient1 = modulus1 DIV factor1; (* 44488 *) - remainder1 = modulus1 MOD factor1; (* 3399; must be < quotient1 *) - modulus2 = 2147483399; (* a non-Mersenne prime *) - factor2 = 40692; (* also passes spectral test *) - quotient2 = modulus2 DIV factor2; (* 52774 *) - remainder2 = modulus2 MOD factor2; (* 3791; must be < quotient2 *) + CONST + modulus1 = 2147483647; (* a Mersenne prime *) + factor1 = 48271; (* passes spectral test *) + quotient1 = modulus1 DIV factor1; (* 44488 *) + remainder1 = modulus1 MOD factor1; (* 3399; must be < quotient1 *) + modulus2 = 2147483399; (* a non-Mersenne prime *) + factor2 = 40692; (* also passes spectral test *) + quotient2 = modulus2 DIV factor2; (* 52774 *) + remainder2 = modulus2 MOD factor2; (* 3791; must be < quotient2 *) - TYPE - DefaultSequence = POINTER TO DefaultSequenceRec; - DefaultSequenceRec = - RECORD - (SequenceRec) - seed1, seed2: LONGINT; - value1, value2: LONGINT; - END; + TYPE + DefaultSequence = POINTER TO DefaultSequenceRec; + DefaultSequenceRec = + RECORD + (SequenceRec) + seed1, seed2: LONGINT; + value1, value2: LONGINT; + END; - ServiceDiscipline = POINTER TO ServiceDisciplineRec; - ServiceDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - setValS: SetValSProc; - END; + ServiceDiscipline = POINTER TO ServiceDisciplineRec; + ServiceDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + setValS: SetValSProc; + END; - VAR - service : Services.Service; - serviceDiscID: Disciplines.Identifier; - sequenceType, - defaultSequenceType: Services.Type; + VAR + service : Services.Service; + serviceDiscID: Disciplines.Identifier; + sequenceType, + defaultSequenceType: Services.Type; - (* ----- bug workaround ----- *) + (* ----- bug workaround ----- *) - PROCEDURE Entier(value: LONGREAL): LONGINT; + PROCEDURE Entier(value: LONGREAL): LONGINT; + VAR + result: LONGINT; + BEGIN + result := ENTIER(value); + IF result > value THEN + DEC(result); + END; + RETURN result + END Entier; + + (* ----- exported procedures ----- *) + + PROCEDURE Init*(sequence: Sequence; if: Interface; caps: CapabilitySet); + (* initialize sequence *) + VAR + type: Services.Type; + BEGIN + ASSERT((if.int32ValS # NIL) OR (if.longRealValS # NIL)); + ASSERT(~(int32ValS IN caps) OR (if.int32ValS # NIL)); + ASSERT(~(longRealValS IN caps) OR (if.longRealValS # NIL)); + ASSERT(~(rewindSequence IN caps) OR (if.rewindSequence # NIL)); + Services.GetType(sequence, type); ASSERT(type # NIL); + sequence.if := if; + sequence.caps := caps; + END Init; + + PROCEDURE Capabilities*(sequence: Sequence): CapabilitySet; + (* tell which procedures are implemented *) + BEGIN + RETURN sequence.caps + END Capabilities; + + PROCEDURE RewindSequence*(sequence: Sequence); + (* re-examine sequence *) + BEGIN + ASSERT(rewindSequence IN sequence.caps); + sequence.if.rewindSequence(sequence); + END RewindSequence; + + PROCEDURE RestartSequence*(sequence, seed: Sequence); + (* restart sequence with new seed values *) + BEGIN + ASSERT(restartSequence IN sequence.caps); + sequence.if.restartSequence(sequence, seed); + END RestartSequence; + + PROCEDURE ^ LongRealValS*(sequence: Sequence): LONGREAL; + + PROCEDURE Int32ValS*(sequence: Sequence): Types.Int32; + (* get random 32-bit value from sequence *) + VAR + real: LONGREAL; + BEGIN + IF int32ValS IN sequence.caps THEN + RETURN sequence.if.int32ValS(sequence) + ELSE + real := LongRealValS(sequence); + RETURN SHORT(Entier( (1. - real - real) * MIN(Types.Int32) )) + END; + END Int32ValS; + + PROCEDURE Int32Val*(): Types.Int32; + (* get random 32-bit value from std sequence *) + BEGIN + RETURN Int32ValS(std); + END Int32Val; + + PROCEDURE LongRealValS*(sequence: Sequence): LONGREAL; + (* get a uniformly distributed longreal value in [0..1) *) + BEGIN + IF longRealValS IN sequence.caps THEN + RETURN sequence.if.longRealValS(sequence) + ELSE + RETURN 0.5 + + Int32ValS(sequence) / (0. - MIN(Types.Int32) - MIN(Types.Int32)) + END; + END LongRealValS; + + PROCEDURE LongRealVal*(): LONGREAL; + (* get a uniformly distributed longreal value in [0..1) *) + BEGIN + RETURN LongRealValS(std) + END LongRealVal; + + PROCEDURE RealValS*(sequence: Sequence): REAL; + (* get a uniformly distributed real value in [0..1) *) + BEGIN + RETURN SHORT(LongRealValS(sequence)) + END RealValS; + + PROCEDURE RealVal*(): REAL; + (* get a uniformly distributed real value in [0..1) *) + BEGIN + RETURN SHORT(LongRealValS(std)) + END RealVal; + + PROCEDURE ValS*(sequence: Sequence; low, high: LONGINT): LONGINT; + (* get a uniformly distributed integer in [low..high] *) + BEGIN + ASSERT(low <= high); + RETURN Entier( low + LongRealValS(sequence) * (1. + high - low) ) + END ValS; + + PROCEDURE Val*(low, high: LONGINT): LONGINT; + (* get a uniformly distributed integer in [low..high] *) + BEGIN + RETURN ValS(std, low, high) + END Val; + + PROCEDURE FlipS*(sequence: Sequence): BOOLEAN; + (* return TRUE or FALSE *) + BEGIN + IF int32ValS IN sequence.caps THEN + RETURN sequence.if.int32ValS(sequence) >= 0 + ELSE + RETURN sequence.if.longRealValS(sequence) >= 0.5 + END; + END FlipS; + + PROCEDURE Flip*(): BOOLEAN; + (* return TRUE or FALSE *) + BEGIN + RETURN FlipS(std) + END Flip; + + PROCEDURE Support*(type: Services.Type; setValS: SetValSProc); + (* support service for type *) + VAR + serviceDisc: ServiceDiscipline; + BEGIN + NEW(serviceDisc); + serviceDisc.id := serviceDiscID; + serviceDisc.setValS := setValS; + Disciplines.Add(type, serviceDisc); + Services.Define(type, service, NIL); + END Support; + + PROCEDURE SetValS*(sequence: Sequence; value: Operations.Operand); + (* store random value from sequence into already initialized value *) + VAR + baseType : Services.Type; + serviceDisc: Disciplines.Discipline; (* ServiceDiscipline *) + ok : BOOLEAN; + BEGIN + Services.GetSupportedBaseType(value, service, baseType); + ok := Disciplines.Seek(baseType, serviceDiscID, serviceDisc); + ASSERT(ok); + serviceDisc(ServiceDiscipline).setValS(sequence, value); + END SetValS; + + PROCEDURE SetVal*(value: Operations.Operand); + (* store random value from std sequence into already initialized value *) + BEGIN + SetValS(std, value); + END SetVal; + + (* ----- DefaultSequence ----- *) + + PROCEDURE CongruentialStep(VAR value1, value2: LONGINT); + BEGIN + value1 := + factor1 * (value1 MOD quotient1) - remainder1 * (value1 DIV quotient1); + IF value1 < 0 THEN + INC(value1, modulus1); + END; + value2 := + factor2 * (value2 MOD quotient2) - remainder2 * (value2 DIV quotient2); + IF value2 < 0 THEN + INC(value2, modulus2); + END; + END CongruentialStep; + + PROCEDURE DefaultSequenceValue(sequence: Sequence): LONGREAL; + VAR + value: LONGINT; + BEGIN + WITH sequence: DefaultSequence DO + CongruentialStep(sequence.value1, sequence.value2); + value := sequence.value1 - sequence.value2; + IF value <= 0 THEN + INC(value, modulus1); + END; + RETURN (value - 1.) / (modulus1 - 1.) + END; + END DefaultSequenceValue; + + PROCEDURE DefaultSequenceRewind(sequence: Sequence); + BEGIN + WITH sequence: DefaultSequence DO + sequence.value1 := sequence.seed1; + sequence.value2 := sequence.seed2; + END; + END DefaultSequenceRewind; + + PROCEDURE DefaultSequenceRestart(sequence, seed: Sequence); + BEGIN + WITH sequence: DefaultSequence DO + sequence.seed1 := ValS(seed, 1, modulus1-1); + sequence.seed2 := ValS(seed, 1, modulus2-1); + sequence.value1 := sequence.seed1; + sequence.value2 := sequence.seed2; + END; + END DefaultSequenceRestart; + + PROCEDURE CreateDefaultSequences; + VAR + mySeed, myStd: DefaultSequence; + if: Interface; + daytime: Times.Time; + timeval: Times.TimeValueRec; + count: LONGINT; + + PROCEDURE Hash(str: ARRAY OF CHAR): LONGINT; VAR - result: LONGINT; - BEGIN - result := ENTIER(value); - IF result > value THEN - DEC(result); - END; - RETURN result - END Entier; + index, + val: LONGINT; + BEGIN + val := 27567352; + index := 0; + WHILE str[index] # 0X DO + val := (val MOD 16777216) * 128 + + (val DIV 16777216 + ORD(str[index])) MOD 128; + INC(index); + END; (*WHILE*) + RETURN val + END Hash; - (* ----- exported procedures ----- *) + BEGIN + (* define interface for all default sequences *) + NEW(if); + if.longRealValS := DefaultSequenceValue; + if.rewindSequence := DefaultSequenceRewind; + if.restartSequence := DefaultSequenceRestart; - PROCEDURE Init*(sequence: Sequence; if: Interface; caps: CapabilitySet); - (* initialize sequence *) - VAR - type: Services.Type; - BEGIN - ASSERT((if.int32ValS # NIL) OR (if.longRealValS # NIL)); - ASSERT(~(int32ValS IN caps) OR (if.int32ValS # NIL)); - ASSERT(~(longRealValS IN caps) OR (if.longRealValS # NIL)); - ASSERT(~(rewindSequence IN caps) OR (if.rewindSequence # NIL)); - Services.GetType(sequence, type); ASSERT(type # NIL); - sequence.if := if; - sequence.caps := caps; - END Init; + (* fake initial randomness using some portably accessible sources *) + NEW(mySeed); + Services.Init(mySeed, defaultSequenceType); + Init(mySeed, if, {longRealValS}); + Clocks.GetTime(Clocks.system, daytime); + Times.GetValue(daytime, timeval); + (* extract those 31 bits from daytime that are most likely to vary *) + mySeed.value1 := timeval.usec * 2048 + timeval.second MOD 65536 + 1; + (* generate 31 more bits from the process name *) + mySeed.value2 := Hash(Process.name) MOD (modulus2 - 1) + 1; + (* scramble these values *) + count := 0; + WHILE count < 4 DO + CongruentialStep(mySeed.value1, mySeed.value2); + INC(count); + END; + (* mix them together *) + DefaultSequenceRestart(mySeed, mySeed); + seed := mySeed; - PROCEDURE Capabilities*(sequence: Sequence): CapabilitySet; - (* tell which procedures are implemented *) - BEGIN - RETURN sequence.caps - END Capabilities; + (* now use our seed to initialize std sequence *) + NEW(myStd); + Services.Init(myStd, defaultSequenceType); + Init(myStd, if, {longRealValS, rewindSequence, restartSequence}); + DefaultSequenceRestart(myStd, mySeed); + std := myStd; - PROCEDURE RewindSequence*(sequence: Sequence); - (* re-examine sequence *) - BEGIN - ASSERT(rewindSequence IN sequence.caps); - sequence.if.rewindSequence(sequence); - END RewindSequence; - - PROCEDURE RestartSequence*(sequence, seed: Sequence); - (* restart sequence with new seed values *) - BEGIN - ASSERT(restartSequence IN sequence.caps); - sequence.if.restartSequence(sequence, seed); - END RestartSequence; - - PROCEDURE ^ LongRealValS*(sequence: Sequence): LONGREAL; - - PROCEDURE Int32ValS*(sequence: Sequence): Types.Int32; - (* get random 32-bit value from sequence *) - VAR - real: LONGREAL; - BEGIN - IF int32ValS IN sequence.caps THEN - RETURN sequence.if.int32ValS(sequence) - ELSE - real := LongRealValS(sequence); - RETURN SHORT(Entier( (1. - real - real) * MIN(Types.Int32) )) - END; - END Int32ValS; - - PROCEDURE Int32Val*(): Types.Int32; - (* get random 32-bit value from std sequence *) - BEGIN - RETURN Int32ValS(std); - END Int32Val; - - PROCEDURE LongRealValS*(sequence: Sequence): LONGREAL; - (* get a uniformly distributed longreal value in [0..1) *) - BEGIN - IF longRealValS IN sequence.caps THEN - RETURN sequence.if.longRealValS(sequence) - ELSE - RETURN 0.5 + - Int32ValS(sequence) / (0. - MIN(Types.Int32) - MIN(Types.Int32)) - END; - END LongRealValS; - - PROCEDURE LongRealVal*(): LONGREAL; - (* get a uniformly distributed longreal value in [0..1) *) - BEGIN - RETURN LongRealValS(std) - END LongRealVal; - - PROCEDURE RealValS*(sequence: Sequence): REAL; - (* get a uniformly distributed real value in [0..1) *) - BEGIN - RETURN SHORT(LongRealValS(sequence)) - END RealValS; - - PROCEDURE RealVal*(): REAL; - (* get a uniformly distributed real value in [0..1) *) - BEGIN - RETURN SHORT(LongRealValS(std)) - END RealVal; - - PROCEDURE ValS*(sequence: Sequence; low, high: LONGINT): LONGINT; - (* get a uniformly distributed integer in [low..high] *) - BEGIN - ASSERT(low <= high); - RETURN Entier( low + LongRealValS(sequence) * (1. + high - low) ) - END ValS; - - PROCEDURE Val*(low, high: LONGINT): LONGINT; - (* get a uniformly distributed integer in [low..high] *) - BEGIN - RETURN ValS(std, low, high) - END Val; - - PROCEDURE FlipS*(sequence: Sequence): BOOLEAN; - (* return TRUE or FALSE *) - BEGIN - IF int32ValS IN sequence.caps THEN - RETURN sequence.if.int32ValS(sequence) >= 0 - ELSE - RETURN sequence.if.longRealValS(sequence) >= 0.5 - END; - END FlipS; - - PROCEDURE Flip*(): BOOLEAN; - (* return TRUE or FALSE *) - BEGIN - RETURN FlipS(std) - END Flip; - - PROCEDURE Support*(type: Services.Type; setValS: SetValSProc); - (* support service for type *) - VAR - serviceDisc: ServiceDiscipline; - BEGIN - NEW(serviceDisc); - serviceDisc.id := serviceDiscID; - serviceDisc.setValS := setValS; - Disciplines.Add(type, serviceDisc); - Services.Define(type, service, NIL); - END Support; - - PROCEDURE SetValS*(sequence: Sequence; value: Operations.Operand); - (* store random value from sequence into already initialized value *) - VAR - baseType : Services.Type; - serviceDisc: ServiceDiscipline; - ok : BOOLEAN; - BEGIN - Services.GetSupportedBaseType(value, service, baseType); - ok := Disciplines.Seek(baseType, serviceDiscID, S.VAL(Disciplines.Discipline, serviceDisc)); - ASSERT(ok); - serviceDisc.setValS(sequence, value); - END SetValS; - - PROCEDURE SetVal*(value: Operations.Operand); - (* store random value from std sequence into already initialized value *) - BEGIN - SetValS(std, value); - END SetVal; - - (* ----- DefaultSequence ----- *) - - PROCEDURE CongruentialStep(VAR value1, value2: LONGINT); - BEGIN - value1 := - factor1 * (value1 MOD quotient1) - remainder1 * (value1 DIV quotient1); - IF value1 < 0 THEN - INC(value1, modulus1); - END; - value2 := - factor2 * (value2 MOD quotient2) - remainder2 * (value2 DIV quotient2); - IF value2 < 0 THEN - INC(value2, modulus2); - END; - END CongruentialStep; - - PROCEDURE DefaultSequenceValue(sequence: Sequence): LONGREAL; - VAR - value: LONGINT; - BEGIN - WITH sequence: DefaultSequence DO - CongruentialStep(sequence.value1, sequence.value2); - value := sequence.value1 - sequence.value2; - IF value <= 0 THEN - INC(value, modulus1); - END; - RETURN (value - 1.) / (modulus1 - 1.) - END; - END DefaultSequenceValue; - - PROCEDURE DefaultSequenceRewind(sequence: Sequence); - BEGIN - WITH sequence: DefaultSequence DO - sequence.value1 := sequence.seed1; - sequence.value2 := sequence.seed2; - END; - END DefaultSequenceRewind; - - PROCEDURE DefaultSequenceRestart(sequence, seed: Sequence); - BEGIN - WITH sequence: DefaultSequence DO - sequence.seed1 := ValS(seed, 1, modulus1-1); - sequence.seed2 := ValS(seed, 1, modulus2-1); - sequence.value1 := sequence.seed1; - sequence.value2 := sequence.seed2; - END; - END DefaultSequenceRestart; - - PROCEDURE CreateDefaultSequences; - VAR - mySeed, myStd: DefaultSequence; - if: Interface; - daytime: Times.Time; - timeval: Times.TimeValueRec; - count: LONGINT; - - PROCEDURE Hash(str: ARRAY OF CHAR): LONGINT; - VAR - index, - val: LONGINT; - BEGIN - val := 27567352; - index := 0; - WHILE str[index] # 0X DO - val := (val MOD 16777216) * 128 + - (val DIV 16777216 + ORD(str[index])) MOD 128; - INC(index); - END; (*WHILE*) - RETURN val - END Hash; - - BEGIN - (* define interface for all default sequences *) - NEW(if); - if.longRealValS := DefaultSequenceValue; - if.rewindSequence := DefaultSequenceRewind; - if.restartSequence := DefaultSequenceRestart; - - (* fake initial randomness using some portably accessible sources *) - NEW(mySeed); - Services.Init(mySeed, defaultSequenceType); - Init(mySeed, if, {longRealValS}); - Clocks.GetTime(Clocks.system, daytime); - Times.GetValue(daytime, timeval); - (* extract those 31 bits from daytime that are most likely to vary *) - mySeed.value1 := timeval.usec * 2048 + timeval.second MOD 65536 + 1; - (* generate 31 more bits from the process name *) - mySeed.value2 := Hash(Process.name) MOD (modulus2 - 1) + 1; - (* scramble these values *) - count := 0; - WHILE count < 4 DO - CongruentialStep(mySeed.value1, mySeed.value2); - INC(count); - END; - (* mix them together *) - DefaultSequenceRestart(mySeed, mySeed); - seed := mySeed; - - (* now use our seed to initialize std sequence *) - NEW(myStd); - Services.Init(myStd, defaultSequenceType); - Init(myStd, if, {longRealValS, rewindSequence, restartSequence}); - DefaultSequenceRestart(myStd, mySeed); - std := myStd; - - unpredictable := NIL; - END CreateDefaultSequences; + unpredictable := NIL; + END CreateDefaultSequences; BEGIN - serviceDiscID := Disciplines.Unique(); - Services.Create(service, "RandomGenerators"); - Services.CreateType(sequenceType, "RandomGenerators.Sequence", ""); - Services.CreateType(defaultSequenceType, "RandomGenerators.DefaultSequence", - "RandomGenerators.Sequence"); - CreateDefaultSequences; + serviceDiscID := Disciplines.Unique(); + Services.Create(service, "RandomGenerators"); + Services.CreateType(sequenceType, "RandomGenerators.Sequence", ""); + Services.CreateType(defaultSequenceType, "RandomGenerators.DefaultSequence", + "RandomGenerators.Sequence"); + CreateDefaultSequences; END ulmRandomGenerators. diff --git a/src/library/ulm/ulmRelatedEvents.Mod b/src/library/ulm/ulmRelatedEvents.Mod index 6f9a0c32..a5ad5453 100644 --- a/src/library/ulm/ulmRelatedEvents.Mod +++ b/src/library/ulm/ulmRelatedEvents.Mod @@ -1,422 +1,429 @@ (* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: RelatedEven.om,v 1.8 2005/04/28 08:30:09 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: RelatedEven.om,v $ - Revision 1.8 2005/04/28 08:30:09 borchert - added assertion to Forward that takes care that from # to - (otherwise we get a nasty infinite loop) + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: RelatedEven.om,v 1.8 2005/04/28 08:30:09 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: RelatedEven.om,v $ + Revision 1.8 2005/04/28 08:30:09 borchert + added assertion to Forward that takes care that from # to + (otherwise we get a nasty infinite loop) - Revision 1.7 2004/09/09 21:04:24 borchert - undoing change of Revision 1.5: - fields dependants and dependson must not be subject of - Save/Restore as this makes it impossible to undo the - dependencies within the TerminationHandler - we no longer remove the discipline in case of terminated - objects as this causes a list of error events to be lost + Revision 1.7 2004/09/09 21:04:24 borchert + undoing change of Revision 1.5: + fields dependants and dependson must not be subject of + Save/Restore as this makes it impossible to undo the + dependencies within the TerminationHandler + we no longer remove the discipline in case of terminated + objects as this causes a list of error events to be lost - Revision 1.6 2004/02/18 17:01:59 borchert - Raise asserts now that event.type # NIL + Revision 1.6 2004/02/18 17:01:59 borchert + Raise asserts now that event.type # NIL - Revision 1.5 2004/02/18 16:53:48 borchert - fields dependants and dependson moved from discipline to state - object to support them for Save/Restore + Revision 1.5 2004/02/18 16:53:48 borchert + fields dependants and dependson moved from discipline to state + object to support them for Save/Restore - Revision 1.4 1998/01/12 14:39:18 borchert - some bug fixes around RelatedEvents.null + Revision 1.4 1998/01/12 14:39:18 borchert + some bug fixes around RelatedEvents.null - Revision 1.3 1995/03/20 17:05:13 borchert - - Save & Restore added - - support for Forwarders & Resources added + Revision 1.3 1995/03/20 17:05:13 borchert + - Save & Restore added + - support for Forwarders & Resources added - Revision 1.2 1994/08/27 14:49:44 borchert - null object added + Revision 1.2 1994/08/27 14:49:44 borchert + null object added - Revision 1.1 1994/02/22 20:09:53 borchert - Initial revision + Revision 1.1 1994/02/22 20:09:53 borchert + Initial revision - ---------------------------------------------------------------------------- - AFB 11/91 - ---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- + AFB 11/91 + ---------------------------------------------------------------------------- *) MODULE ulmRelatedEvents; - (* relate events to objects *) + (* relate events to objects *) - IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Forwarders := ulmForwarders, Objects := ulmObjects, Priorities := ulmPriorities, Resources := ulmResources, SYSTEM; + IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Forwarders := ulmForwarders, Objects := ulmObjects, Priorities := ulmPriorities, Resources := ulmResources, SYSTEM; - CONST - (* possible directions of propagated events *) - forward = 0; (* forward along the forwardTo chain, if given *) - backward = 1; (* forward event to all dependants, if present *) - both = 2; (* forward event to both directions *) - TYPE - Direction = SHORTINT; (* forward, backward, both *) + CONST + (* possible directions of propagated events *) + forward = 0; (* forward along the forwardTo chain, if given *) + backward = 1; (* forward event to all dependants, if present *) + both = 2; (* forward event to both directions *) + TYPE + Direction = SHORTINT; (* forward, backward, both *) - TYPE - Object* = Disciplines.Object; - Event* = POINTER TO EventRec; - EventRec* = - RECORD - (Events.EventRec) - object*: Object; - event*: Events.Event; - END; - Queue* = POINTER TO QueueRec; - QueueRec* = - RECORD - (Objects.ObjectRec) - event*: Events.Event; - next*: Queue; - END; - ObjectList = POINTER TO ObjectListRec; - ObjectListRec = - RECORD - object: Object; - next: ObjectList; - END; - - TYPE - State = POINTER TO StateRec; - StateRec = - RECORD - default: BOOLEAN; (* default reaction? *) - eventType: Events.EventType; (* may be NIL *) - queue: BOOLEAN; (* are events to be queued? *) - forwardto: Object; - head, tail: Queue; - saved: State; - END; - Discipline = POINTER TO DisciplineRec; - DisciplineRec = - RECORD - (Disciplines.DisciplineRec) - state: State; - dependants: ObjectList; - dependsOn: Object; - END; - VAR - id: Disciplines.Identifier; - VAR - null*: Object; (* object which ignores all related events *) - nullevent: Events.EventType; - - PROCEDURE RemoveDependant(VAR list: ObjectList; dependant: Object); - VAR - prev, p: ObjectList; - BEGIN - prev := NIL; p := list; - WHILE (p # NIL) & (p.object # dependant) DO - prev := p; p := p.next; + TYPE + Object* = Disciplines.Object; + Event* = POINTER TO EventRec; + EventRec* = + RECORD + (Events.EventRec) + object*: Object; + event*: Events.Event; END; - IF p # NIL THEN - IF prev = NIL THEN - list := p.next; - ELSE - prev.next := p.next; - END; + Queue* = POINTER TO QueueRec; + QueueRec* = + RECORD + (Objects.ObjectRec) + event*: Events.Event; + next*: Queue; END; - END RemoveDependant; - - PROCEDURE TerminationHandler(event: Events.Event); - VAR - disc: Discipline; - BEGIN - WITH event: Resources.Event DO - IF (event.change = Resources.terminated) & - Disciplines.Seek(event.resource, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *) - IF (disc.dependsOn # NIL) & - Disciplines.Seek(disc.dependsOn, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *) - RemoveDependant(disc.dependants, event.resource); - disc.dependsOn := NIL; - END; - (* - afb 9/2004: - do not remove this discipline for dead objects - as this makes it impossible to retrieve the final - list of error events - Disciplines.Remove(event.resource, id); - *) - END; + ObjectList = POINTER TO ObjectListRec; + ObjectListRec = + RECORD + object: Object; + next: ObjectList; END; - END TerminationHandler; - PROCEDURE CreateState(VAR state: State); - BEGIN - NEW(state); - state.eventType := NIL; - state.queue := FALSE; state.head := NIL; state.tail := NIL; - state.forwardto := NIL; - state.default := TRUE; - state.saved := NIL; - END CreateState; + TYPE + State = POINTER TO StateRec; + StateRec = + RECORD + default: BOOLEAN; (* default reaction? *) + eventType: Events.EventType; (* may be NIL *) + queue: BOOLEAN; (* are events to be queued? *) + forwardto: Object; + head, tail: Queue; + saved: State; + END; + Discipline = POINTER TO DisciplineRec; + DisciplineRec = + RECORD + (Disciplines.DisciplineRec) + state: State; + dependants: ObjectList; + dependsOn: Object; + END; + VAR + id: Disciplines.Identifier; + VAR + null*: Object; (* object which ignores all related events *) + nullevent: Events.EventType; - PROCEDURE CreateDiscipline(VAR disc: Discipline); - BEGIN - NEW(disc); disc.id := id; CreateState(disc.state); - END CreateDiscipline; - - PROCEDURE GetEventType*(object: Object; VAR eventType: Events.EventType); - (* returns an event type for the given object; - all events related to the object are also handled by this event type - *) - VAR - disc: Discipline; - state: State; - BEGIN - IF object = null THEN - eventType := nullevent; + PROCEDURE RemoveDependant(VAR list: ObjectList; dependant: Object); + VAR + prev, p: ObjectList; + BEGIN + prev := NIL; p := list; + WHILE (p # NIL) & (p.object # dependant) DO + prev := p; p := p.next; + END; + IF p # NIL THEN + IF prev = NIL THEN + list := p.next; ELSE - IF ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *) - CreateDiscipline(disc); - Disciplines.Add(object, disc); - END; - state := disc.state; - state.default := FALSE; - IF state.eventType = NIL THEN - Events.Define(state.eventType); - Events.SetPriority(state.eventType, Priorities.liberrors + 1); - Events.Ignore(state.eventType); - END; - eventType := state.eventType; + prev.next := p.next; END; - END GetEventType; + END; + END RemoveDependant; - PROCEDURE Forward*(from, to: Object); - (* causes all events related to `from' to be forwarded to `to' *) - VAR - disc: Discipline; - BEGIN - IF (from # NIL) & (from # null) THEN - ASSERT(from # to); - IF ~Disciplines.Seek(from, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *) - CreateDiscipline(disc); - Disciplines.Add(from, disc); - END; - IF to = null THEN - to := NIL; - END; - disc.state.forwardto := to; - disc.state.default := FALSE; + PROCEDURE Seek(object: Object; id: Disciplines.Identifier; + VAR discipline: Discipline): BOOLEAN; + VAR + disc: Disciplines.Discipline; + result: BOOLEAN; + BEGIN + result := Disciplines.Seek(object, id, disc); + IF result THEN discipline := disc(Discipline) ELSE discipline := NIL END; + RETURN result + END Seek; + + PROCEDURE TerminationHandler(event: Events.Event); + VAR + disc: Discipline; + BEGIN + WITH event: Resources.Event DO + IF (event.change = Resources.terminated) & Seek(event.resource, id, disc) THEN + IF (disc.dependsOn # NIL) & Seek(disc.dependsOn, id, disc) THEN + RemoveDependant(disc.dependants, event.resource); + disc.dependsOn := NIL; + END; + (* + afb 9/2004: + do not remove this discipline for dead objects + as this makes it impossible to retrieve the final + list of error events + Disciplines.Remove(event.resource, id); + *) END; - END Forward; + END; + END TerminationHandler; - PROCEDURE ForwardToDependants(from, to: Forwarders.Object); - (* is called by Forwarders.Forward: - build a backward chain from `to' to `from' - *) - VAR - fromDisc, toDisc: Discipline; - member: ObjectList; - eventType: Events.EventType; - BEGIN - IF (from = null) OR (to = null) THEN RETURN END; - IF ~Disciplines.Seek(from, id, SYSTEM.VAL(Disciplines.Discipline, fromDisc)) THEN (* noch *) - CreateDiscipline(fromDisc); Disciplines.Add(from, fromDisc); + PROCEDURE CreateState(VAR state: State); + BEGIN + NEW(state); + state.eventType := NIL; + state.queue := FALSE; state.head := NIL; state.tail := NIL; + state.forwardto := NIL; + state.default := TRUE; + state.saved := NIL; + END CreateState; + + PROCEDURE CreateDiscipline(VAR disc: Discipline); + BEGIN + NEW(disc); disc.id := id; CreateState(disc.state); + END CreateDiscipline; + + PROCEDURE GetEventType*(object: Object; VAR eventType: Events.EventType); + (* returns an event type for the given object; + all events related to the object are also handled by this event type + *) + VAR + disc: Discipline; + state: State; + BEGIN + IF object = null THEN + eventType := nullevent; + ELSE + IF ~Seek(object, id, disc) THEN + CreateDiscipline(disc); + Disciplines.Add(object, disc); END; - IF fromDisc.dependsOn # NIL THEN RETURN END; - fromDisc.dependsOn := to; - Resources.TakeInterest(from, eventType); - Events.Handler(eventType, TerminationHandler); - - IF ~Disciplines.Seek(to, id, SYSTEM.VAL(Disciplines.Discipline, toDisc)) THEN (* noch *) - CreateDiscipline(toDisc); Disciplines.Add(to, toDisc); + state := disc.state; + state.default := FALSE; + IF state.eventType = NIL THEN + Events.Define(state.eventType); + Events.SetPriority(state.eventType, Priorities.liberrors + 1); + Events.Ignore(state.eventType); END; - NEW(member); member.object := from; - member.next := toDisc.dependants; toDisc.dependants := member; - END ForwardToDependants; + eventType := state.eventType; + END; + END GetEventType; - PROCEDURE QueueEvents*(object: Object); - (* put all incoming events into a queue *) - VAR - disc: Discipline; - state: State; - BEGIN - IF (object # NIL) & (object # null) THEN - IF ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - CreateDiscipline(disc); - Disciplines.Add(object, disc); - END; - state := disc.state; - state.default := FALSE; - IF ~state.queue THEN - state.queue := TRUE; state.head := NIL; state.tail := NIL; - END; + PROCEDURE Forward*(from, to: Object); + (* causes all events related to `from' to be forwarded to `to' *) + VAR + disc: Discipline; + BEGIN + IF (from # NIL) & (from # null) THEN + ASSERT(from # to); + IF ~Seek(from, id, disc) THEN + CreateDiscipline(disc); + Disciplines.Add(from, disc); END; - END QueueEvents; + IF to = null THEN + to := NIL; + END; + disc.state.forwardto := to; + disc.state.default := FALSE; + END; + END Forward; - PROCEDURE GetQueue*(object: Object; VAR queue: Queue); - (* return queue of related events which is removed - from the object; - object must have been prepared by QueueEvents - *) - VAR - disc: Discipline; - state: State; - BEGIN - IF (object # NIL) & (object # null) & - Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) & disc.state.queue THEN (* noch *) - state := disc.state; - queue := state.head; state.head := NIL; state.tail := NIL; + PROCEDURE ForwardToDependants(from, to: Forwarders.Object); + (* is called by Forwarders.Forward: + build a backward chain from `to' to `from' + *) + VAR + fromDisc, toDisc: Discipline; + member: ObjectList; + eventType: Events.EventType; + BEGIN + IF (from = null) OR (to = null) THEN RETURN END; + IF ~Seek(from, id, fromDisc) THEN + CreateDiscipline(fromDisc); Disciplines.Add(from, fromDisc); + END; + IF fromDisc.dependsOn # NIL THEN RETURN END; + fromDisc.dependsOn := to; + Resources.TakeInterest(from, eventType); + Events.Handler(eventType, TerminationHandler); + + IF ~Seek(to, id, toDisc) THEN + CreateDiscipline(toDisc); Disciplines.Add(to, toDisc); + END; + NEW(member); member.object := from; + member.next := toDisc.dependants; toDisc.dependants := member; + END ForwardToDependants; + + PROCEDURE QueueEvents*(object: Object); + (* put all incoming events into a queue *) + VAR + disc: Discipline; + state: State; + BEGIN + IF (object # NIL) & (object # null) THEN + IF ~Seek(object, id, disc) THEN + CreateDiscipline(disc); + Disciplines.Add(object, disc); + END; + state := disc.state; + state.default := FALSE; + IF ~state.queue THEN + state.queue := TRUE; state.head := NIL; state.tail := NIL; + END; + END; + END QueueEvents; + + PROCEDURE GetQueue*(object: Object; VAR queue: Queue); + (* return queue of related events which is removed + from the object; + object must have been prepared by QueueEvents + *) + VAR + disc: Discipline; + state: State; + BEGIN + IF (object # NIL) & (object # null) & Seek(object, id, disc) & disc.state.queue THEN + state := disc.state; + queue := state.head; state.head := NIL; state.tail := NIL; + ELSE + queue := NIL; + END; + END GetQueue; + + PROCEDURE EventsPending*(object: Object) : BOOLEAN; + (* return TRUE if GetQueue will return a queue # NIL *) + VAR + disc: Discipline; + BEGIN + IF (object # NIL) & (object # null) & Seek(object, id, disc) & disc.state.queue THEN + RETURN disc.state.head # NIL + ELSE + RETURN FALSE + END; + END EventsPending; + + PROCEDURE Reset*(object: Object); + (* return to default behaviour *) + VAR + disc: Discipline; + state: State; + BEGIN + IF object # null THEN + IF Seek(object, id, disc) THEN + IF (disc.state.saved = NIL) & + (disc.dependsOn = NIL) & + (disc.dependants = NIL) THEN + Disciplines.Remove(object, id); + ELSE + state := disc.state; + state.queue := FALSE; state.head := NIL; state.tail := NIL; + state.eventType := NIL; state.forwardto := NIL; + state.default := TRUE; + END; + END; + END; + END Reset; + + PROCEDURE Save*(object: Object); + (* save current status of the given object and reset to + default behaviour; + the status includes the reaction types and event queues; + Save operations may be nested + *) + VAR + disc: Discipline; + state: State; + BEGIN + IF object # null THEN + IF ~Seek(object, id, disc) THEN + CreateDiscipline(disc); + Disciplines.Add(object, disc); + END; + CreateState(state); + state.saved := disc.state; disc.state := state; + END; + END Save; + + PROCEDURE Restore*(object: Object); + (* restore status saved earlier by Save *) + VAR + disc: Discipline; + BEGIN + IF Seek(object, id, disc) & (disc.state.saved # NIL) THEN + disc.state := disc.state.saved; + END; + END Restore; + + PROCEDURE InternalRaise(object: Object; dir: Direction; event: Events.Event); + VAR + disc: Discipline; + state: State; + relEvent: Event; + element: Queue; (* new element of queue *) + dependant: ObjectList; + BEGIN + IF (object = null) OR ~Seek(object, id, disc) THEN RETURN END; + + (* backward chaining *) + IF (disc.dependants # NIL) & (dir IN {backward, both}) THEN + dependant := disc.dependants; + WHILE dependant # NIL DO + InternalRaise(dependant.object, backward, event); + dependant := dependant.next; + END; + END; + + (* local handling & forward chaining *) + IF ~disc.state.default THEN + state := disc.state; + IF state.queue THEN + NEW(element); element.next := NIL; element.event := event; + IF state.tail # NIL THEN + state.tail.next := element; + ELSE + state.head := element; + END; + state.tail := element; + END; + IF state.eventType # NIL THEN + NEW(relEvent); + relEvent.message := event.message; + relEvent.type := state.eventType; + relEvent.object := object; + relEvent.event := event; + Events.Raise(relEvent); + END; + IF (state.forwardto # NIL) & (dir IN {both, forward}) THEN + InternalRaise(state.forwardto, forward, event); + END; + END; + END InternalRaise; + + PROCEDURE Raise*(object: Object; event: Events.Event); + VAR + disc: Discipline; + BEGIN + ASSERT(event.type # NIL); + IF object # null THEN + IF (object = NIL) OR ~Seek(object, id, disc) THEN + Events.Raise(event); ELSE - queue := NIL; + InternalRaise(object, both, event); END; - END GetQueue; + END; + END Raise; - PROCEDURE EventsPending*(object: Object) : BOOLEAN; - (* return TRUE if GetQueue will return a queue # NIL *) - VAR - disc: Discipline; - BEGIN - IF (object # NIL) & (object # null) & - Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) & disc.state.queue THEN (* noch *) - RETURN disc.state.head # NIL - ELSE - RETURN FALSE - END; - END EventsPending; - - PROCEDURE Reset*(object: Object); - (* return to default behaviour *) - VAR - disc: Discipline; - state: State; - BEGIN - IF object # null THEN - IF Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *) - IF (disc.state.saved = NIL) & - (disc.dependsOn = NIL) & - (disc.dependants = NIL) THEN - Disciplines.Remove(object, id); - ELSE - state := disc.state; - state.queue := FALSE; state.head := NIL; state.tail := NIL; - state.eventType := NIL; state.forwardto := NIL; - state.default := TRUE; - END; - END; - END; - END Reset; - - PROCEDURE Save*(object: Object); - (* save current status of the given object and reset to - default behaviour; - the status includes the reaction types and event queues; - Save operations may be nested - *) - VAR - disc: Discipline; - state: State; - BEGIN - IF object # null THEN - IF ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *) - CreateDiscipline(disc); - Disciplines.Add(object, disc); - END; - CreateState(state); - state.saved := disc.state; disc.state := state; - END; - END Save; - - PROCEDURE Restore*(object: Object); - (* restore status saved earlier by Save *) - VAR - disc: Discipline; - BEGIN - IF Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) & (disc.state.saved # NIL) THEN (* noch *) - disc.state := disc.state.saved; - END; - END Restore; - - PROCEDURE InternalRaise(object: Object; dir: Direction; event: Events.Event); - VAR - disc: Discipline; - state: State; - relEvent: Event; - element: Queue; (* new element of queue *) - dependant: ObjectList; - BEGIN - IF (object = null) OR ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN RETURN END; - - (* backward chaining *) - IF (disc.dependants # NIL) & (dir IN {backward, both}) THEN - dependant := disc.dependants; - WHILE dependant # NIL DO - InternalRaise(dependant.object, backward, event); - dependant := dependant.next; - END; - END; - - (* local handling & forward chaining *) - IF ~disc.state.default THEN - state := disc.state; - IF state.queue THEN - NEW(element); element.next := NIL; element.event := event; - IF state.tail # NIL THEN - state.tail.next := element; - ELSE - state.head := element; - END; - state.tail := element; - END; - IF state.eventType # NIL THEN - NEW(relEvent); - relEvent.message := event.message; - relEvent.type := state.eventType; - relEvent.object := object; - relEvent.event := event; - Events.Raise(relEvent); - END; - IF (state.forwardto # NIL) & (dir IN {both, forward}) THEN - InternalRaise(state.forwardto, forward, event); - END; - END; - END InternalRaise; - - PROCEDURE Raise*(object: Object; event: Events.Event); - VAR - disc: Discipline; - BEGIN - ASSERT(event.type # NIL); - IF object # null THEN - IF (object = NIL) OR ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *) - Events.Raise(event); - ELSE - InternalRaise(object, both, event); - END; - END; - END Raise; - - PROCEDURE AppendQueue*(object: Object; queue: Queue); - (* Raise(object, event) for all events of the queue *) - BEGIN - WHILE queue # NIL DO - Raise(object, queue.event); - queue := queue.next; - END; - END AppendQueue; + PROCEDURE AppendQueue*(object: Object; queue: Queue); + (* Raise(object, event) for all events of the queue *) + BEGIN + WHILE queue # NIL DO + Raise(object, queue.event); + queue := queue.next; + END; + END AppendQueue; BEGIN - id := Disciplines.Unique(); - NEW(null); - Events.Define(nullevent); - Forwarders.Register("", ForwardToDependants); + id := Disciplines.Unique(); + NEW(null); + Events.Define(nullevent); + Forwarders.Register("", ForwardToDependants); END ulmRelatedEvents. diff --git a/src/library/ulm/ulmResources.Mod b/src/library/ulm/ulmResources.Mod index 9ff929bd..a700d22a 100644 --- a/src/library/ulm/ulmResources.Mod +++ b/src/library/ulm/ulmResources.Mod @@ -107,19 +107,11 @@ MODULE ulmResources; (* === private procedures ============================================ *) PROCEDURE GetDisc(resource: Resource; VAR disc: Discipline); + VAR d: Disciplines.Discipline; BEGIN - (*IF ~Disciplines.Seek(resource, discID, disc) THEN*) - (* this line causes error - err 123 type of actual parameter is not identical with that of formal VAR-parameter - because Discipline defined in this module is an extention of the same type in module Disciplines - Disciplines.Seek expects Disciplines.Discipline, not the extended type. - voc (ofront, OP2, as well as oo2c) behaves right by not allowing this, while Ulm's Oberon system - accepts this. - So we introduce here a workaround, which makes usage of this module unsafe; - - noch - *) - IF ~Disciplines.Seek(resource, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *) + IF Disciplines.Seek(resource, discID, d) THEN + disc := d(Discipline) + ELSE NEW(disc); disc.id := discID; disc.state := alive; disc.refcnt := 0; disc.eventType := NIL; diff --git a/src/library/ulm/ulmScales.Mod b/src/library/ulm/ulmScales.Mod index 5de1188b..12cf5363 100644 --- a/src/library/ulm/ulmScales.Mod +++ b/src/library/ulm/ulmScales.Mod @@ -1,446 +1,446 @@ (* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Scales.om,v 1.3 2004/09/03 09:31:53 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Scales.om,v $ - Revision 1.3 2004/09/03 09:31:53 borchert - bug fixes: Services.Init added in CreateOperand - Scales.Measure changed to Measure + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Scales.om,v 1.3 2004/09/03 09:31:53 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Scales.om,v $ + Revision 1.3 2004/09/03 09:31:53 borchert + bug fixes: Services.Init added in CreateOperand + Scales.Measure changed to Measure - Revision 1.2 1995/01/16 21:40:39 borchert - - assertions of Assertions converted into real assertions - - fixes due to changed if of PersistentObjects + Revision 1.2 1995/01/16 21:40:39 borchert + - assertions of Assertions converted into real assertions + - fixes due to changed if of PersistentObjects - Revision 1.1 1994/02/22 20:10:03 borchert - Initial revision + Revision 1.1 1994/02/22 20:10:03 borchert + Initial revision - ---------------------------------------------------------------------------- - AFB 12/91 - ---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- + AFB 12/91 + ---------------------------------------------------------------------------- *) MODULE ulmScales; - IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, - RelatedEvents := ulmRelatedEvents, Services := ulmServices, SYS := SYSTEM; + IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, + RelatedEvents := ulmRelatedEvents, Services := ulmServices, SYS := SYSTEM; - TYPE - Scale* = POINTER TO ScaleRec; - Family* = POINTER TO FamilyRec; - FamilyRec* = - RECORD - (Disciplines.ObjectRec) - (* private components *) - reference: Scale; - END; - - TYPE - Unit* = POINTER TO UnitRec; - UnitList = POINTER TO UnitListRec; - UnitListRec = - RECORD - unit: Unit; - next: UnitList; - END; - Interface* = POINTER TO InterfaceRec; - ScaleRec* = - RECORD - (Disciplines.ObjectRec) - (* private components *) - if: Interface; - family: Family; - head, tail: UnitList; - nextUnit: UnitList; - END; - - CONST - unitNameLength* = 32; - TYPE - UnitName* = ARRAY unitNameLength OF CHAR; - UnitRec* = RECORD - (Disciplines.ObjectRec) - name: UnitName; - scale: Scale; + TYPE + Scale* = POINTER TO ScaleRec; + Family* = POINTER TO FamilyRec; + FamilyRec* = + RECORD + (Disciplines.ObjectRec) + (* private components *) + reference: Scale; END; - CONST - undefined = 0; absolute* = 1; relative* = 2; - TYPE - Measure* = POINTER TO MeasureRec; - MeasureRec* = - RECORD - (Operations.OperandRec) - scale: Scale; - type: SHORTINT; (* absolute or relative? *) - END; - VAR - measureType: Services.Type; + TYPE + Unit* = POINTER TO UnitRec; + UnitList = POINTER TO UnitListRec; + UnitListRec = + RECORD + unit: Unit; + next: UnitList; + END; + Interface* = POINTER TO InterfaceRec; + ScaleRec* = + RECORD + (Disciplines.ObjectRec) + (* private components *) + if: Interface; + family: Family; + head, tail: UnitList; + nextUnit: UnitList; + END; - TYPE - Value* = LONGINT; + CONST + unitNameLength* = 32; + TYPE + UnitName* = ARRAY unitNameLength OF CHAR; + UnitRec* = RECORD + (Disciplines.ObjectRec) + name: UnitName; + scale: Scale; + END; - CONST - add* = Operations.add; sub* = Operations.sub; - TYPE - Operation* = SHORTINT; (* add or sub *) - TYPE - CreateProc* = PROCEDURE (scale: Scale; VAR measure: Measure; abs: BOOLEAN); - GetValueProc* = PROCEDURE (measure: Measure; unit: Unit; VAR value: Value); - SetValueProc* = PROCEDURE (measure: Measure; unit: Unit; value: Value); - AssignProc* = PROCEDURE (target: Measure; source: Measure); - OperatorProc* = PROCEDURE (op: Operation; op1, op2, result: Measure); - CompareProc* = PROCEDURE (op1, op2: Measure) : INTEGER; - ConvertProc* = PROCEDURE (from, to: Measure); - - InterfaceRec* = - RECORD - (Objects.ObjectRec) - create*: CreateProc; - getvalue*: GetValueProc; - setvalue*: SetValueProc; - assign*: AssignProc; - op*: OperatorProc; - compare*: CompareProc; - (* the conversion routines are only to be provided - if the scaling system belongs to a family - *) - scaleToReference*: ConvertProc; - referenceToScale*: ConvertProc; - END; + CONST + undefined = 0; absolute* = 1; relative* = 2; + TYPE + Measure* = POINTER TO MeasureRec; + MeasureRec* = + RECORD + (Operations.OperandRec) + scale: Scale; + type: SHORTINT; (* absolute or relative? *) + END; + VAR + measureType: Services.Type; - VAR - invalidOperation*: Events.EventType; - (* operation cannot be performed for the given combination - of types (absolute or relative) - *) - incompatibleScales*: Events.EventType; - (* the scales of the operands do not belong to the same family *) - badCombination*: Events.EventType; - (* SetValue or GetValue: - given measure and unit do not belong to the same scaling system - *) + TYPE + Value* = LONGINT; - (* our interface to Operations *) - opif: Operations.Interface; - opcaps: Operations.CapabilitySet; + CONST + add* = Operations.add; sub* = Operations.sub; + TYPE + Operation* = SHORTINT; (* add or sub *) + TYPE + CreateProc* = PROCEDURE (scale: Scale; VAR measure: Measure; abs: BOOLEAN); + GetValueProc* = PROCEDURE (measure: Measure; unit: Unit; VAR value: Value); + SetValueProc* = PROCEDURE (measure: Measure; unit: Unit; value: Value); + AssignProc* = PROCEDURE (target: Measure; source: Measure); + OperatorProc* = PROCEDURE (op: Operation; op1, op2, result: Measure); + CompareProc* = PROCEDURE (op1, op2: Measure) : INTEGER; + ConvertProc* = PROCEDURE (from, to: Measure); - (* ======= private procedures ===================================== *) + InterfaceRec* = + RECORD + (Objects.ObjectRec) + create*: CreateProc; + getvalue*: GetValueProc; + setvalue*: SetValueProc; + assign*: AssignProc; + op*: OperatorProc; + compare*: CompareProc; + (* the conversion routines are only to be provided + if the scaling system belongs to a family + *) + scaleToReference*: ConvertProc; + referenceToScale*: ConvertProc; + END; - PROCEDURE DummyConversion(from, to: Measure); - BEGIN - from.scale.if.assign(to, from); - END DummyConversion; + VAR + invalidOperation*: Events.EventType; + (* operation cannot be performed for the given combination + of types (absolute or relative) + *) + incompatibleScales*: Events.EventType; + (* the scales of the operands do not belong to the same family *) + badCombination*: Events.EventType; + (* SetValue or GetValue: + given measure and unit do not belong to the same scaling system + *) - (* ======== exported procedures ==================================== *) + (* our interface to Operations *) + opif: Operations.Interface; + opcaps: Operations.CapabilitySet; - PROCEDURE InitFamily*(family: Family; reference: Scale); - BEGIN - family.reference := reference; - (* the reference scale becomes now a member of the family *) - reference.family := family; - reference.if.scaleToReference := DummyConversion; - reference.if.referenceToScale := DummyConversion; - END InitFamily; + (* ======= private procedures ===================================== *) - PROCEDURE Init*(scale: Scale; family: Family; if: Interface); - (* reference scales are to be initialized with family = NIL *) - BEGIN - scale.if := if; - scale.family := family; - scale.head := NIL; scale.tail := NIL; - scale.nextUnit := NIL; - END Init; + PROCEDURE DummyConversion(from, to: Measure); + BEGIN + from.scale.if.assign(to, from); + END DummyConversion; - PROCEDURE InitUnit*(scale: Scale; unit: Unit; name: UnitName); - VAR - listp: UnitList; - BEGIN - unit.name := name; - unit.scale := scale; - NEW(listp); listp.unit := unit; listp.next := NIL; - IF scale.head # NIL THEN - scale.tail.next := listp; + (* ======== exported procedures ==================================== *) + + PROCEDURE InitFamily*(family: Family; reference: Scale); + BEGIN + family.reference := reference; + (* the reference scale becomes now a member of the family *) + reference.family := family; + reference.if.scaleToReference := DummyConversion; + reference.if.referenceToScale := DummyConversion; + END InitFamily; + + PROCEDURE Init*(scale: Scale; family: Family; if: Interface); + (* reference scales are to be initialized with family = NIL *) + BEGIN + scale.if := if; + scale.family := family; + scale.head := NIL; scale.tail := NIL; + scale.nextUnit := NIL; + END Init; + + PROCEDURE InitUnit*(scale: Scale; unit: Unit; name: UnitName); + VAR + listp: UnitList; + BEGIN + unit.name := name; + unit.scale := scale; + NEW(listp); listp.unit := unit; listp.next := NIL; + IF scale.head # NIL THEN + scale.tail.next := listp; + ELSE + scale.head := listp; + END; + scale.tail := listp; + END InitUnit; + + PROCEDURE CreateMeasure*(scale: Scale; VAR measure: Measure; type: SHORTINT); + BEGIN + scale.if.create(scale, measure, type = absolute); + Operations.Init(measure, opif, opcaps); + measure.scale := scale; + measure.type := type; + END CreateMeasure; + + PROCEDURE CreateAbsMeasure*(scale: Scale; VAR measure: Measure); + (* init measure to the origin of the given system *) + BEGIN + CreateMeasure(scale, measure, absolute); + END CreateAbsMeasure; + + PROCEDURE CreateRelMeasure*(scale: Scale; VAR measure: Measure); + (* init relative measure to 0 *) + BEGIN + CreateMeasure(scale, measure, relative); + END CreateRelMeasure; + + PROCEDURE ConvertMeasure*(scale: Scale; VAR measure: Measure); + (* convert measure to the given scale which must belong + to the same family as the original scale of measure + *) + VAR + newMeasure: Measure; + refMeasure: Measure; + reference: Scale; + BEGIN + IF scale = measure.scale THEN + (* trivial case -- nothing is to be done *) + RETURN + END; + (* check that both scales belong to the same family *) + ASSERT((scale.family # NIL) & (scale.family = measure.scale.family)); + CreateMeasure(scale, newMeasure, measure.type); + reference := scale.family.reference; + CreateMeasure(reference, refMeasure, measure.type); + measure.scale.if.scaleToReference(measure, refMeasure); + scale.if.referenceToScale(refMeasure, newMeasure); + measure := newMeasure; + END ConvertMeasure; + + PROCEDURE GetReference*(family: Family; VAR reference: Scale); + BEGIN + reference := family.reference; + END GetReference; + + PROCEDURE GetFamily*(scale: Scale; VAR family: Family); + BEGIN + family := scale.family; + END GetFamily; + + PROCEDURE GetScaleOfUnit*(unit: Unit; VAR scale: Scale); + BEGIN + scale := unit.scale; + END GetScaleOfUnit; + + PROCEDURE GetScale*(measure: Measure; VAR scale: Scale); + BEGIN + scale := measure.scale; + END GetScale; + + PROCEDURE TraverseUnits*(scale: Scale); + BEGIN + scale.nextUnit := scale.head; + END TraverseUnits; + + PROCEDURE NextUnit*(scale: Scale; VAR unit: Unit) : BOOLEAN; + BEGIN + IF scale.nextUnit # NIL THEN + unit := scale.nextUnit.unit; + scale.nextUnit := scale.nextUnit.next; + RETURN TRUE + ELSE + RETURN FALSE + END; + END NextUnit; + + PROCEDURE GetName*(unit: Unit; VAR name: UnitName); + BEGIN + name := unit.name; + END GetName; + + PROCEDURE GetValue*(measure: Measure; unit: Unit; VAR value: Value); + VAR + scale: Scale; + BEGIN + scale := measure.scale; + ASSERT(unit.scale = scale); + scale.if.getvalue(measure, unit, value); + END GetValue; + + PROCEDURE SetValue*(measure: Measure; unit: Unit; value: Value); + VAR + scale: Scale; + BEGIN + scale := measure.scale; + ASSERT(unit.scale = scale); + scale.if.setvalue(measure, unit, value); + END SetValue; + + PROCEDURE IsAbsolute*(measure: Measure) : BOOLEAN; + BEGIN + RETURN measure.type = absolute + END IsAbsolute; + + PROCEDURE IsRelative*(measure: Measure) : BOOLEAN; + BEGIN + RETURN measure.type = relative + END IsRelative; + + PROCEDURE MeasureType*(measure: Measure) : SHORTINT; + BEGIN + RETURN measure.type + END MeasureType; + + (* ======== interface procedures for Operations ================= *) + + PROCEDURE CreateOperand(VAR op: Operations.Operand); + (* at this time we don't know anything about the + associated scale -- so we've have to delay this decision + *) + VAR + measure: Measure; + BEGIN + NEW(measure); + measure.type := undefined; + measure.scale := NIL; + Services.Init(measure, measureType); + op := measure; + Operations.Init(op, opif, {Operations.add..Operations.cmp}); + END CreateOperand; + + PROCEDURE Assign(VAR target: Operations.Operand; source: Operations.Operand); + BEGIN + (*WITH source: Measure DO WITH target: Measure DO*) + WITH source: Measure DO IF target IS Measure THEN (* WITH is replaced by IS -- noch *) + (* target is already initialized but possibly to a dummy operand + by CreateOperand + *) + IF target(Measure).type = undefined THEN (* type guard introduced *) + (* init target with the scale of source *) + CreateMeasure(source.scale, SYS.VAL(Measure, target), source.type); (* need to cast *) + END; + IF target(Measure).scale # source.scale THEN + (* adapt scale type from source -- + this could lead to a type guard failure if + target is not of the appropiate type + *) + CreateMeasure(source.scale, SYS.VAL(Measure, target), source.type); + END; + IF target(Measure).type # source.type THEN + (* adapt measure type from source *) + CreateMeasure(target(Measure).scale, SYS.VAL(Measure, target), source.type); + END; + source.scale.if.assign(SYS.VAL(Measure, target), source); + END; END; + END Assign; + + PROCEDURE CheckCompatibility(op1, op2: Operations.Operand; + VAR m1, m2: Measure); + (* is needed by Op and Compare: + both operands are checked to be members of the same family; + if they have different scales of the same family a + conversion is done; + *) + VAR + scale1, scale2: Scale; + BEGIN + WITH op1: Measure DO WITH op2: Measure DO + scale1 := op1.scale; scale2 := op2.scale; + IF scale1 # scale2 THEN + ASSERT((scale1.family # NIL) & (scale1.family = scale2.family)); + (* convert both operands to the reference scale *) + CreateMeasure(scale1.family.reference, m1, op1.type); + scale1.if.scaleToReference(op1, m1); + CreateMeasure(scale2.family.reference, m2, op2.type); + scale2.if.scaleToReference(op2, m2); ELSE - scale.head := listp; + m1 := op1; + m2 := op2; END; - scale.tail := listp; - END InitUnit; + END; END; + END CheckCompatibility; - PROCEDURE CreateMeasure*(scale: Scale; VAR measure: Measure; type: SHORTINT); - BEGIN - scale.if.create(scale, measure, type = absolute); - Operations.Init(measure, opif, opcaps); - measure.scale := scale; - measure.type := type; - END CreateMeasure; + PROCEDURE Op(op: Operations.Operation; op1, op2: Operations.Operand; + VAR result: Operations.Operand); + VAR + restype: SHORTINT; (* type of result -- set by CheckTypes *) + m1, m2: Measure; - PROCEDURE CreateAbsMeasure*(scale: Scale; VAR measure: Measure); - (* init measure to the origin of the given system *) - BEGIN - CreateMeasure(scale, measure, absolute); - END CreateAbsMeasure; - - PROCEDURE CreateRelMeasure*(scale: Scale; VAR measure: Measure); - (* init relative measure to 0 *) - BEGIN - CreateMeasure(scale, measure, relative); - END CreateRelMeasure; - - PROCEDURE ConvertMeasure*(scale: Scale; VAR measure: Measure); - (* convert measure to the given scale which must belong - to the same family as the original scale of measure + PROCEDURE CheckTypes(VAR restype: SHORTINT); + (* check operands for correct typing; + sets restype to the correct result type; *) - VAR - newMeasure: Measure; - refMeasure: Measure; - reference: Scale; - BEGIN - IF scale = measure.scale THEN - (* trivial case -- nothing is to be done *) - RETURN - END; - (* check that both scales belong to the same family *) - ASSERT((scale.family # NIL) & (scale.family = measure.scale.family)); - CreateMeasure(scale, newMeasure, measure.type); - reference := scale.family.reference; - CreateMeasure(reference, refMeasure, measure.type); - measure.scale.if.scaleToReference(measure, refMeasure); - scale.if.referenceToScale(refMeasure, newMeasure); - measure := newMeasure; - END ConvertMeasure; - - PROCEDURE GetReference*(family: Family; VAR reference: Scale); - BEGIN - reference := family.reference; - END GetReference; - - PROCEDURE GetFamily*(scale: Scale; VAR family: Family); - BEGIN - family := scale.family; - END GetFamily; - - PROCEDURE GetScaleOfUnit*(unit: Unit; VAR scale: Scale); - BEGIN - scale := unit.scale; - END GetScaleOfUnit; - - PROCEDURE GetScale*(measure: Measure; VAR scale: Scale); - BEGIN - scale := measure.scale; - END GetScale; - - PROCEDURE TraverseUnits*(scale: Scale); - BEGIN - scale.nextUnit := scale.head; - END TraverseUnits; - - PROCEDURE NextUnit*(scale: Scale; VAR unit: Unit) : BOOLEAN; - BEGIN - IF scale.nextUnit # NIL THEN - unit := scale.nextUnit.unit; - scale.nextUnit := scale.nextUnit.next; - RETURN TRUE - ELSE - RETURN FALSE - END; - END NextUnit; - - PROCEDURE GetName*(unit: Unit; VAR name: UnitName); - BEGIN - name := unit.name; - END GetName; - - PROCEDURE GetValue*(measure: Measure; unit: Unit; VAR value: Value); - VAR - scale: Scale; - BEGIN - scale := measure.scale; - ASSERT(unit.scale = scale); - scale.if.getvalue(measure, unit, value); - END GetValue; - - PROCEDURE SetValue*(measure: Measure; unit: Unit; value: Value); - VAR - scale: Scale; - BEGIN - scale := measure.scale; - ASSERT(unit.scale = scale); - scale.if.setvalue(measure, unit, value); - END SetValue; - - PROCEDURE IsAbsolute*(measure: Measure) : BOOLEAN; - BEGIN - RETURN measure.type = absolute - END IsAbsolute; - - PROCEDURE IsRelative*(measure: Measure) : BOOLEAN; - BEGIN - RETURN measure.type = relative - END IsRelative; - - PROCEDURE MeasureType*(measure: Measure) : SHORTINT; - BEGIN - RETURN measure.type - END MeasureType; - - (* ======== interface procedures for Operations ================= *) - - PROCEDURE CreateOperand(VAR op: Operations.Operand); - (* at this time we don't know anything about the - associated scale -- so we've have to delay this decision - *) - VAR - measure: Measure; - BEGIN - NEW(measure); - measure.type := undefined; - measure.scale := NIL; - Services.Init(measure, measureType); - op := measure; - Operations.Init(op, opif, {Operations.add..Operations.cmp}); - END CreateOperand; - - PROCEDURE Assign(VAR target: Operations.Operand; source: Operations.Operand); - BEGIN - (*WITH source: Measure DO WITH target: Measure DO*) - WITH source: Measure DO IF target IS Measure THEN (* WITH is replaced by IS -- noch *) - (* target is already initialized but possibly to a dummy operand - by CreateOperand - *) - IF target(Measure).type = undefined THEN (* type guard introduced *) - (* init target with the scale of source *) - CreateMeasure(source.scale, SYS.VAL(Measure, target), source.type); (* need to cast *) - END; - IF target(Measure).scale # source.scale THEN - (* adapt scale type from source -- - this could lead to a type guard failure if - target is not of the appropiate type - *) - CreateMeasure(source.scale, SYS.VAL(Measure, target), source.type); - END; - IF target(Measure).type # source.type THEN - (* adapt measure type from source *) - CreateMeasure(target(Measure).scale, SYS.VAL(Measure, target), source.type); - END; - source.scale.if.assign(SYS.VAL(Measure, target), source); + VAR ok: BOOLEAN; + BEGIN + (*WITH op1: Measure DO WITH op2: Measure DO*) + IF op1 IS Measure THEN IF op2 IS Measure THEN + CASE op OF + | Operations.add: (* only abs + abs is invalid *) + ok := (op1(Measure).type = relative) OR + (op2(Measure).type = relative); + IF op1(Measure).type = op2(Measure).type THEN + (* both are relative *) + restype := relative; + ELSE + (* exactly one absolute type is involved *) + restype := absolute; + END; + | Operations.sub: (* only rel - abs is invalid *) + ok := op1(Measure).type <= op2(Measure).type; + IF op1(Measure).type # op2(Measure).type THEN + (* abs - rel *) + restype := absolute; + ELSE + (* abs - abs or rel - rel *) + restype := relative; + END; + ELSE + END; + ASSERT(ok); (* invalid operation *) END; END; - END Assign; + END CheckTypes; - PROCEDURE CheckCompatibility(op1, op2: Operations.Operand; - VAR m1, m2: Measure); - (* is needed by Op and Compare: - both operands are checked to be members of the same family; - if they have different scales of the same family a - conversion is done; - *) - VAR - scale1, scale2: Scale; - BEGIN - WITH op1: Measure DO WITH op2: Measure DO - scale1 := op1.scale; scale2 := op2.scale; - IF scale1 # scale2 THEN - ASSERT((scale1.family # NIL) & (scale1.family = scale2.family)); - (* convert both operands to the reference scale *) - CreateMeasure(scale1.family.reference, m1, op1.type); - scale1.if.scaleToReference(op1, m1); - CreateMeasure(scale2.family.reference, m2, op2.type); - scale2.if.scaleToReference(op2, m2); - ELSE - m1 := op1; - m2 := op2; - END; - END; END; - END CheckCompatibility; - - PROCEDURE Op(op: Operations.Operation; op1, op2: Operations.Operand; - VAR result: Operations.Operand); - VAR - restype: SHORTINT; (* type of result -- set by CheckTypes *) - m1, m2: Measure; - - PROCEDURE CheckTypes(VAR restype: SHORTINT); - (* check operands for correct typing; - sets restype to the correct result type; - *) - VAR ok: BOOLEAN; - BEGIN - (*WITH op1: Measure DO WITH op2: Measure DO*) - IF op1 IS Measure THEN IF op2 IS Measure THEN - CASE op OF - | Operations.add: (* only abs + abs is invalid *) - ok := (op1(Measure).type = relative) OR - (op2(Measure).type = relative); - IF op1(Measure).type = op2(Measure).type THEN - (* both are relative *) - restype := relative; - ELSE - (* exactly one absolute type is involved *) - restype := absolute; - END; - | Operations.sub: (* only rel - abs is invalid *) - ok := op1(Measure).type <= op2(Measure).type; - IF op1(Measure).type # op2(Measure).type THEN - (* abs - rel *) - restype := absolute; - ELSE - (* abs - abs or rel - rel *) - restype := relative; - END; - ELSE - END; - ASSERT(ok); (* invalid operation *) - END; END; - END CheckTypes; - - BEGIN (* Op *) - (* result is already of type Measure; this is guaranteed by Operations *) - IF result IS Measure THEN - CheckTypes(restype); - CheckCompatibility(op1, op2, m1, m2); - CreateMeasure(m1.scale, SYS.VAL(Measure, result), restype); - m1.scale.if.op(op, m1, m2, SYS.VAL(Measure, result)); - END; - END Op; - - PROCEDURE Compare(op1, op2: Operations.Operand) : INTEGER; - VAR - m1, m2: Measure; - BEGIN + BEGIN (* Op *) + (* result is already of type Measure; this is guaranteed by Operations *) + IF result IS Measure THEN + CheckTypes(restype); CheckCompatibility(op1, op2, m1, m2); - ASSERT(m1.type = m2.type); - CheckCompatibility(op1, op2, m1, m2); - RETURN m1.scale.if.compare(m1, m2) - END Compare; + CreateMeasure(m1.scale, SYS.VAL(Measure, result), restype); + m1.scale.if.op(op, m1, m2, SYS.VAL(Measure, result)); + END; + END Op; - PROCEDURE InitInterface; - BEGIN - NEW(opif); - opif.create := CreateOperand; - opif.assign := Assign; - opif.op := Op; - opif.compare := Compare; - opcaps := {Operations.add, Operations.sub, Operations.cmp}; - END InitInterface; + PROCEDURE Compare(op1, op2: Operations.Operand) : INTEGER; + VAR + m1, m2: Measure; + BEGIN + CheckCompatibility(op1, op2, m1, m2); + ASSERT(m1.type = m2.type); + CheckCompatibility(op1, op2, m1, m2); + RETURN m1.scale.if.compare(m1, m2) + END Compare; + + PROCEDURE InitInterface; + BEGIN + NEW(opif); + opif.create := CreateOperand; + opif.assign := Assign; + opif.op := Op; + opif.compare := Compare; + opcaps := {Operations.add, Operations.sub, Operations.cmp}; + END InitInterface; BEGIN - InitInterface; - PersistentObjects.RegisterType(measureType, - "Scales.Measure", "Operations.Operand", NIL); + InitInterface; + PersistentObjects.RegisterType(measureType, + "Scales.Measure", "Operations.Operand", NIL); END ulmScales. diff --git a/src/library/ulm/ulmServices.Mod b/src/library/ulm/ulmServices.Mod index 3b804e4f..7ec557df 100644 --- a/src/library/ulm/ulmServices.Mod +++ b/src/library/ulm/ulmServices.Mod @@ -1,520 +1,520 @@ (* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Services.om,v 1.2 2004/09/03 09:34:24 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Services.om,v $ - Revision 1.2 2004/09/03 09:34:24 borchert - cache results of LoadService to avoid further attempts + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Services.om,v 1.2 2004/09/03 09:34:24 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Services.om,v $ + Revision 1.2 2004/09/03 09:34:24 borchert + cache results of LoadService to avoid further attempts - Revision 1.1 1995/03/03 09:32:15 borchert - Initial revision + Revision 1.1 1995/03/03 09:32:15 borchert + Initial revision - ---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- *) MODULE ulmServices; - IMPORT Disciplines := ulmDisciplines, Objects := ulmObjects; + IMPORT Disciplines := ulmDisciplines, Objects := ulmObjects; - TYPE - Type* = POINTER TO TypeRec; - ServiceList = POINTER TO ServiceListRec; - Service* = POINTER TO ServiceRec; - Object* = POINTER TO ObjectRec; - ObjectRec* = - RECORD - (Disciplines.ObjectRec) - type: Type; - installed: ServiceList; (* set of installed services *) - END; - - InstallProc = PROCEDURE (object: Object; service: Service); - - ServiceRec* = - RECORD - (Disciplines.ObjectRec) - name: ARRAY 64 OF CHAR; - next: Service; - END; - - ServiceListRec = - RECORD - service: Service; - type: Type; - install: InstallProc; - next: ServiceList; - END; - - VAR - services: Service; - (* list of services -- needed to support Seek *) - - TYPE - LoadModuleProc* = PROCEDURE (module: ARRAY OF CHAR) : BOOLEAN; - LoadServiceProc* = PROCEDURE (service, for: ARRAY OF CHAR) : BOOLEAN; - LoaderInterface* = POINTER TO LoaderInterfaceRec; - LoaderInterfaceRec* = - RECORD - loadModule*: LoadModuleProc; - loadService*: LoadServiceProc; - END; - VAR - loaderIF: LoaderInterface; - - (* ==== name tables ================================================== *) - - CONST - bufsize = 512; (* length of a name buffer in bytes *) - tabsize = 1171; - TYPE - BufferPosition = INTEGER; - Length = LONGINT; - HashValue = INTEGER; - Buffer = ARRAY bufsize OF CHAR; - NameList = POINTER TO NameListRec; - NameListRec = - RECORD - buffer: Buffer; - next: NameList; - END; - VAR - currentBuf: NameList; currentPos: BufferPosition; - TYPE - TypeRec* = - RECORD - (Disciplines.ObjectRec) - baseType: Type; - services: ServiceList; - cachedservices: ServiceList; (* of base types *) - (* table management *) - hashval: HashValue; - length: Length; - begin: NameList; - pos: BufferPosition; - next: Type; (* next type with same hash value *) - END; - BucketTable = ARRAY tabsize OF Type; - VAR - bucket: BucketTable; - - (* ==== name table management ======================================== *) - - PROCEDURE Hash(name: ARRAY OF CHAR; length: LONGINT) : HashValue; - CONST - shift = 4; - VAR - index: LONGINT; - val: LONGINT; - ch: CHAR; - ordval: INTEGER; - BEGIN - index := 0; val := length; - WHILE index < length DO - ch := name[index]; - IF ch >= " " THEN - ordval := ORD(ch) - ORD(" "); - ELSE - ordval := ORD(MAX(CHAR)) - ORD(" ") + ORD(ch); - END; - val := ASH(val, shift) + ordval; - INC(index); + TYPE + Type* = POINTER TO TypeRec; + ServiceList = POINTER TO ServiceListRec; + Service* = POINTER TO ServiceRec; + Object* = POINTER TO ObjectRec; + ObjectRec* = + RECORD + (Disciplines.ObjectRec) + type: Type; + installed: ServiceList; (* set of installed services *) END; - val := val MOD tabsize; - RETURN SHORT(val) - END Hash; - PROCEDURE CreateBuf(VAR buf: NameList); - BEGIN - NEW(buf); buf.next := NIL; - IF currentBuf # NIL THEN - currentBuf.next := buf; + InstallProc = PROCEDURE (object: Object; service: Service); + + ServiceRec* = + RECORD + (Disciplines.ObjectRec) + name: ARRAY 64 OF CHAR; + next: Service; END; - currentBuf := buf; - currentPos := 0; - END CreateBuf; - PROCEDURE StringLength(string: ARRAY OF CHAR) : LONGINT; - VAR - index: LONGINT; - BEGIN - index := 0; - WHILE (index < LEN(string)) & (string[index] # 0X) DO - INC(index); + ServiceListRec = + RECORD + service: Service; + type: Type; + install: InstallProc; + next: ServiceList; END; - RETURN index - END StringLength; - PROCEDURE InitName(name: Type; string: ARRAY OF CHAR); - VAR - index, length: LONGINT; - firstbuf, buf: NameList; - startpos: BufferPosition; - BEGIN - IF currentBuf = NIL THEN - CreateBuf(buf); + VAR + services: Service; + (* list of services -- needed to support Seek *) + + TYPE + LoadModuleProc* = PROCEDURE (module: ARRAY OF CHAR) : BOOLEAN; + LoadServiceProc* = PROCEDURE (service, for: ARRAY OF CHAR) : BOOLEAN; + LoaderInterface* = POINTER TO LoaderInterfaceRec; + LoaderInterfaceRec* = + RECORD + loadModule*: LoadModuleProc; + loadService*: LoadServiceProc; + END; + VAR + loaderIF: LoaderInterface; + + (* ==== name tables ================================================== *) + + CONST + bufsize = 512; (* length of a name buffer in bytes *) + tabsize = 1171; + TYPE + BufferPosition = INTEGER; + Length = LONGINT; + HashValue = INTEGER; + Buffer = ARRAY bufsize OF CHAR; + NameList = POINTER TO NameListRec; + NameListRec = + RECORD + buffer: Buffer; + next: NameList; + END; + VAR + currentBuf: NameList; currentPos: BufferPosition; + TYPE + TypeRec* = + RECORD + (Disciplines.ObjectRec) + baseType: Type; + services: ServiceList; + cachedservices: ServiceList; (* of base types *) + (* table management *) + hashval: HashValue; + length: Length; + begin: NameList; + pos: BufferPosition; + next: Type; (* next type with same hash value *) + END; + BucketTable = ARRAY tabsize OF Type; + VAR + bucket: BucketTable; + + (* ==== name table management ======================================== *) + + PROCEDURE Hash(name: ARRAY OF CHAR; length: LONGINT) : HashValue; + CONST + shift = 4; + VAR + index: LONGINT; + val: LONGINT; + ch: CHAR; + ordval: INTEGER; + BEGIN + index := 0; val := length; + WHILE index < length DO + ch := name[index]; + IF ch >= " " THEN + ordval := ORD(ch) - ORD(" "); ELSE - buf := currentBuf; + ordval := ORD(MAX(CHAR)) - ORD(" ") + ORD(ch); END; + val := ASH(val, shift) + ordval; + INC(index); + END; + val := val MOD tabsize; + RETURN SHORT(val) + END Hash; - firstbuf := buf; startpos := currentPos; - index := 0; - WHILE (index < LEN(string)) & (string[index] # 0X) DO - IF currentPos = bufsize THEN - CreateBuf(buf); - END; - buf.buffer[currentPos] := string[index]; INC(currentPos); - INC(index); + PROCEDURE CreateBuf(VAR buf: NameList); + BEGIN + NEW(buf); buf.next := NIL; + IF currentBuf # NIL THEN + currentBuf.next := buf; + END; + currentBuf := buf; + currentPos := 0; + END CreateBuf; + + PROCEDURE StringLength(string: ARRAY OF CHAR) : LONGINT; + VAR + index: LONGINT; + BEGIN + index := 0; + WHILE (index < LEN(string)) & (string[index] # 0X) DO + INC(index); + END; + RETURN index + END StringLength; + + PROCEDURE InitName(name: Type; string: ARRAY OF CHAR); + VAR + index, length: LONGINT; + firstbuf, buf: NameList; + startpos: BufferPosition; + BEGIN + IF currentBuf = NIL THEN + CreateBuf(buf); + ELSE + buf := currentBuf; + END; + + firstbuf := buf; startpos := currentPos; + index := 0; + WHILE (index < LEN(string)) & (string[index] # 0X) DO + IF currentPos = bufsize THEN + CreateBuf(buf); END; - length := index; + buf.buffer[currentPos] := string[index]; INC(currentPos); + INC(index); + END; + length := index; - name.hashval := Hash(string, length); - name.length := length; - name.begin := firstbuf; - name.pos := startpos; - name.next := bucket[name.hashval]; - bucket[name.hashval] := name; - END InitName; + name.hashval := Hash(string, length); + name.length := length; + name.begin := firstbuf; + name.pos := startpos; + name.next := bucket[name.hashval]; + bucket[name.hashval] := name; + END InitName; - PROCEDURE EqualName(name: Type; string: ARRAY OF CHAR) : BOOLEAN; - (* precondition: both have the same length *) + PROCEDURE EqualName(name: Type; string: ARRAY OF CHAR) : BOOLEAN; + (* precondition: both have the same length *) + VAR + index: LONGINT; + buf: NameList; + pos: INTEGER; + BEGIN + buf := name.begin; pos := name.pos; + index := 0; + WHILE index < name.length DO + IF pos = bufsize THEN + buf := buf.next; pos := 0; + END; + IF string[index] # buf.buffer[pos] THEN + RETURN FALSE + END; + INC(pos); + INC(index); + END; + RETURN TRUE + END EqualName; + + PROCEDURE SeekName(string: ARRAY OF CHAR; VAR name: Type) : BOOLEAN; + VAR + length: LONGINT; + hashval: HashValue; + p: Type; + BEGIN + length := StringLength(string); + hashval := Hash(string, length); + p := bucket[hashval]; + WHILE (p # NIL) & ((length # p.length) OR ~EqualName(p, string)) DO + p := p.next; + END; + name := p; + RETURN p # NIL + END SeekName; + + PROCEDURE ExtractName(name: Type; VAR string: ARRAY OF CHAR); + VAR + index: LONGINT; + buf: NameList; + pos: INTEGER; + BEGIN + buf := name.begin; pos := name.pos; + index := 0; + WHILE (index + 1 < LEN(string)) & (index < name.length) DO + IF pos = bufsize THEN + buf := buf.next; pos := 0; + END; + string[index] := buf.buffer[pos]; + INC(pos); + INC(index); + END; + string[index] := 0X; + END ExtractName; + + PROCEDURE LoadModule(module: ARRAY OF CHAR) : BOOLEAN; + BEGIN + IF (loaderIF # NIL) & (loaderIF.loadModule # NIL) THEN + RETURN loaderIF.loadModule(module) + ELSE + RETURN FALSE + END; + END LoadModule; + + PROCEDURE LoadService(service, for: ARRAY OF CHAR) : BOOLEAN; + BEGIN + IF (loaderIF # NIL) & (loaderIF.loadService # NIL) THEN + RETURN loaderIF.loadService(service, for) + ELSE + RETURN FALSE + END; + END LoadService; + + PROCEDURE MemberOf(list: ServiceList; service: Service; + VAR member: ServiceList) : BOOLEAN; + VAR + p: ServiceList; + BEGIN + p := list; + WHILE (p # NIL) & (p.service # service) DO + p := p.next; + END; + member := p; + RETURN p # NIL + END MemberOf; + + PROCEDURE SeekService(type: Type; service: Service; + VAR member: ServiceList; + VAR baseType: Type) : BOOLEAN; + + VAR + btype: Type; + cachedservice: ServiceList; + + PROCEDURE Seek(type: Type; service: Service; + VAR member: ServiceList) : BOOLEAN; VAR - index: LONGINT; - buf: NameList; - pos: INTEGER; - BEGIN - buf := name.begin; pos := name.pos; - index := 0; - WHILE index < name.length DO - IF pos = bufsize THEN - buf := buf.next; pos := 0; - END; - IF string[index] # buf.buffer[pos] THEN - RETURN FALSE - END; - INC(pos); - INC(index); + typeName: ARRAY 512 OF CHAR; + BEGIN + IF MemberOf(type.services, service, member) OR + MemberOf(type.cachedservices, service, member) THEN + RETURN TRUE END; + ExtractName(type, typeName); + RETURN LoadService(service.name, typeName) & + MemberOf(type.services, service, member) + END Seek; + + BEGIN (* SeekService *) + btype := type; + WHILE (btype # NIL) & ~Seek(btype, service, member) DO + btype := btype.baseType; + END; + IF (member # NIL) & (btype # type) THEN + (* cache result to avoid further tries to load + a more fitting variant dynamically + *) + NEW(cachedservice); + cachedservice.service := service; + cachedservice.type := member.type; + cachedservice.install := member.install; + cachedservice.next := type.cachedservices; + type.cachedservices := cachedservice; + baseType := member.type; RETURN TRUE - END EqualName; + END; + IF member = NIL THEN + RETURN FALSE + ELSE + baseType := member.type; + RETURN TRUE + END; + END SeekService; - PROCEDURE SeekName(string: ARRAY OF CHAR; VAR name: Type) : BOOLEAN; - VAR - length: LONGINT; - hashval: HashValue; - p: Type; - BEGIN - length := StringLength(string); - hashval := Hash(string, length); - p := bucket[hashval]; - WHILE (p # NIL) & ((length # p.length) OR ~EqualName(p, string)) DO - p := p.next; + PROCEDURE GetModule(name: ARRAY OF CHAR; VAR module: ARRAY OF CHAR); + (* get the name of the module where 'name' was defined *) + VAR + index: INTEGER; + BEGIN + index := 0; + WHILE (name[index] # ".") & (name[index] # 0X) & + (index < LEN(module)-1) DO + module[index] := name[index]; INC(index); + END; + module[index] := 0X; + END GetModule; + + (* ==== exported procedures ========================================== *) + + PROCEDURE InitLoader*(if: LoaderInterface); + BEGIN + ASSERT((loaderIF = NIL) & (if # NIL)); + loaderIF := if; + END InitLoader; + + PROCEDURE InitType*(type: Type; name, baseName: ARRAY OF CHAR); + VAR + baseType: Type; + otherType: Type; + ok: BOOLEAN; + BEGIN + IF baseName = "" THEN + baseType := NIL; + ELSE + ok := SeekName(baseName, baseType); ASSERT(ok); + END; + ASSERT(~SeekName(name, otherType)); + InitName(type, name); + type.baseType := baseType; + type.services := NIL; + type.cachedservices := NIL; + END InitType; + + PROCEDURE CreateType*(VAR type: Type; name, baseName: ARRAY OF CHAR); + BEGIN + NEW(type); InitType(type, name, baseName); + END CreateType; + + PROCEDURE Init*(object: Object; type: Type); + BEGIN + ASSERT(type # NIL); + ASSERT(object.type = NIL); + object.type := type; + object.installed := NIL; + END Init; + + PROCEDURE GetType*(object: Object; VAR type: Type); + BEGIN + type := object.type; + END GetType; + + PROCEDURE GetTypeName*(type: Type; VAR name: ARRAY OF CHAR); + BEGIN + ExtractName(type, name); + END GetTypeName; + + PROCEDURE GetBaseType*(type: Type; VAR baseType: Type); + BEGIN + baseType := type.baseType; + END GetBaseType; + + PROCEDURE IsExtensionOf*(type, baseType: Type) : BOOLEAN; + BEGIN + ASSERT(baseType # NIL); + WHILE (type # NIL) & (type # baseType) DO + type := type.baseType; + END; + RETURN type = baseType + END IsExtensionOf; + + PROCEDURE SeekType*(name: ARRAY OF CHAR; VAR type: Type); + VAR + module: ARRAY 64 OF CHAR; + BEGIN + IF ~SeekName(name, type) THEN + (* try to load the associated module *) + GetModule(name, module); + IF ~LoadModule(module) OR ~SeekName(name, type) THEN + type := NIL; END; - name := p; - RETURN p # NIL - END SeekName; + END; + END SeekType; - PROCEDURE ExtractName(name: Type; VAR string: ARRAY OF CHAR); - VAR - index: LONGINT; - buf: NameList; - pos: INTEGER; - BEGIN - buf := name.begin; pos := name.pos; - index := 0; - WHILE (index + 1 < LEN(string)) & (index < name.length) DO - IF pos = bufsize THEN - buf := buf.next; pos := 0; - END; - string[index] := buf.buffer[pos]; - INC(pos); - INC(index); - END; - string[index] := 0X; - END ExtractName; + PROCEDURE Seek*(name: ARRAY OF CHAR; VAR service: Service); + BEGIN + service := services; + WHILE (service # NIL) & (service.name # name) DO + service := service.next; + END; - PROCEDURE LoadModule(module: ARRAY OF CHAR) : BOOLEAN; - BEGIN - IF (loaderIF # NIL) & (loaderIF.loadModule # NIL) THEN - RETURN loaderIF.loadModule(module) - ELSE - RETURN FALSE - END; - END LoadModule; - - PROCEDURE LoadService(service, for: ARRAY OF CHAR) : BOOLEAN; - BEGIN - IF (loaderIF # NIL) & (loaderIF.loadService # NIL) THEN - RETURN loaderIF.loadService(service, for) - ELSE - RETURN FALSE - END; - END LoadService; - - PROCEDURE MemberOf(list: ServiceList; service: Service; - VAR member: ServiceList) : BOOLEAN; - VAR - p: ServiceList; - BEGIN - p := list; - WHILE (p # NIL) & (p.service # service) DO - p := p.next; - END; - member := p; - RETURN p # NIL - END MemberOf; - - PROCEDURE SeekService(type: Type; service: Service; - VAR member: ServiceList; - VAR baseType: Type) : BOOLEAN; - - VAR - btype: Type; - cachedservice: ServiceList; - - PROCEDURE Seek(type: Type; service: Service; - VAR member: ServiceList) : BOOLEAN; - VAR - typeName: ARRAY 512 OF CHAR; - BEGIN - IF MemberOf(type.services, service, member) OR - MemberOf(type.cachedservices, service, member) THEN - RETURN TRUE - END; - ExtractName(type, typeName); - RETURN LoadService(service.name, typeName) & - MemberOf(type.services, service, member) - END Seek; - - BEGIN (* SeekService *) - btype := type; - WHILE (btype # NIL) & ~Seek(btype, service, member) DO - btype := btype.baseType; - END; - IF (member # NIL) & (btype # type) THEN - (* cache result to avoid further tries to load - a more fitting variant dynamically - *) - NEW(cachedservice); - cachedservice.service := service; - cachedservice.type := member.type; - cachedservice.install := member.install; - cachedservice.next := type.cachedservices; - type.cachedservices := cachedservice; - baseType := member.type; - RETURN TRUE - END; - IF member = NIL THEN - RETURN FALSE - ELSE - baseType := member.type; - RETURN TRUE - END; - END SeekService; - - PROCEDURE GetModule(name: ARRAY OF CHAR; VAR module: ARRAY OF CHAR); - (* get the name of the module where 'name' was defined *) - VAR - index: INTEGER; - BEGIN - index := 0; - WHILE (name[index] # ".") & (name[index] # 0X) & - (index < LEN(module)-1) DO - module[index] := name[index]; INC(index); - END; - module[index] := 0X; - END GetModule; - - (* ==== exported procedures ========================================== *) - - PROCEDURE InitLoader*(if: LoaderInterface); - BEGIN - ASSERT((loaderIF = NIL) & (if # NIL)); - loaderIF := if; - END InitLoader; - - PROCEDURE InitType*(type: Type; name, baseName: ARRAY OF CHAR); - VAR - baseType: Type; - otherType: Type; - ok: BOOLEAN; - BEGIN - IF baseName = "" THEN - baseType := NIL; - ELSE - ok := SeekName(baseName, baseType); ASSERT(ok); - END; - ASSERT(~SeekName(name, otherType)); - InitName(type, name); - type.baseType := baseType; - type.services := NIL; - type.cachedservices := NIL; - END InitType; - - PROCEDURE CreateType*(VAR type: Type; name, baseName: ARRAY OF CHAR); - BEGIN - NEW(type); InitType(type, name, baseName); - END CreateType; - - PROCEDURE Init*(object: Object; type: Type); - BEGIN - ASSERT(type # NIL); - ASSERT(object.type = NIL); - object.type := type; - object.installed := NIL; - END Init; - - PROCEDURE GetType*(object: Object; VAR type: Type); - BEGIN - type := object.type; - END GetType; - - PROCEDURE GetTypeName*(type: Type; VAR name: ARRAY OF CHAR); - BEGIN - ExtractName(type, name); - END GetTypeName; - - PROCEDURE GetBaseType*(type: Type; VAR baseType: Type); - BEGIN - baseType := type.baseType; - END GetBaseType; - - PROCEDURE IsExtensionOf*(type, baseType: Type) : BOOLEAN; - BEGIN - ASSERT(baseType # NIL); - WHILE (type # NIL) & (type # baseType) DO - type := type.baseType; - END; - RETURN type = baseType - END IsExtensionOf; - - PROCEDURE SeekType*(name: ARRAY OF CHAR; VAR type: Type); - VAR - module: ARRAY 64 OF CHAR; - BEGIN - IF ~SeekName(name, type) THEN - (* try to load the associated module *) - GetModule(name, module); - IF ~LoadModule(module) OR ~SeekName(name, type) THEN - type := NIL; - END; - END; - END SeekType; - - PROCEDURE Seek*(name: ARRAY OF CHAR; VAR service: Service); - BEGIN + (* try to load a module named after `name', if not successful *) + IF (service = NIL) & LoadModule(name) THEN service := services; WHILE (service # NIL) & (service.name # name) DO - service := service.next; + service := service.next; END; + END; + END Seek; - (* try to load a module named after `name', if not successful *) - IF (service = NIL) & LoadModule(name) THEN - service := services; - WHILE (service # NIL) & (service.name # name) DO - service := service.next; - END; + PROCEDURE Create*(VAR service: Service; name: ARRAY OF CHAR); + + PROCEDURE Created(name: ARRAY OF CHAR) : BOOLEAN; + VAR + service: Service; + BEGIN + service := services; + WHILE (service # NIL) & (service.name # name) DO + service := service.next; END; - END Seek; + RETURN service # NIL + END Created; - PROCEDURE Create*(VAR service: Service; name: ARRAY OF CHAR); + BEGIN + ASSERT(~Created(name)); + NEW(service); + COPY(name, service.name); + service.next := services; services := service; + END Create; - PROCEDURE Created(name: ARRAY OF CHAR) : BOOLEAN; - VAR - service: Service; - BEGIN - service := services; - WHILE (service # NIL) & (service.name # name) DO - service := service.next; - END; - RETURN service # NIL - END Created; + PROCEDURE Define*(type: Type; service: Service; install: InstallProc); + VAR + member: ServiceList; + BEGIN + ASSERT(service # NIL); + (* protect against multiple definitions: *) + ASSERT(~MemberOf(type.services, service, member)); - BEGIN - ASSERT(~Created(name)); - NEW(service); - COPY(name, service.name); - service.next := services; services := service; - END Create; + NEW(member); member.service := service; + member.install := install; member.type := type; + member.next := type.services; type.services := member; + END Define; - PROCEDURE Define*(type: Type; service: Service; install: InstallProc); - VAR - member: ServiceList; - BEGIN - ASSERT(service # NIL); - (* protect against multiple definitions: *) - ASSERT(~MemberOf(type.services, service, member)); - - NEW(member); member.service := service; - member.install := install; member.type := type; - member.next := type.services; type.services := member; - END Define; - - PROCEDURE Install*(object: Object; service: Service) : BOOLEAN; - VAR - member, installed: ServiceList; - baseType: Type; - BEGIN - IF object.type = NIL THEN RETURN FALSE END; - IF ~SeekService(object.type, service, member, baseType) THEN - (* service not supported for this object type *) - RETURN FALSE + PROCEDURE Install*(object: Object; service: Service) : BOOLEAN; + VAR + member, installed: ServiceList; + baseType: Type; + BEGIN + IF object.type = NIL THEN RETURN FALSE END; + IF ~SeekService(object.type, service, member, baseType) THEN + (* service not supported for this object type *) + RETURN FALSE + END; + IF ~MemberOf(object.installed, service, installed) THEN + (* install services only once *) + IF member.install # NIL THEN + member.install(object, service); END; - IF ~MemberOf(object.installed, service, installed) THEN - (* install services only once *) - IF member.install # NIL THEN - member.install(object, service); - END; - NEW(installed); - installed.service := service; - installed.next := object.installed; - object.installed := installed; - END; - RETURN TRUE - END Install; + NEW(installed); + installed.service := service; + installed.next := object.installed; + object.installed := installed; + END; + RETURN TRUE + END Install; - PROCEDURE Supported*(object: Object; service: Service) : BOOLEAN; - VAR - member: ServiceList; - baseType: Type; - BEGIN - RETURN (object.type # NIL) & - SeekService(object.type, service, member, baseType) - END Supported; + PROCEDURE Supported*(object: Object; service: Service) : BOOLEAN; + VAR + member: ServiceList; + baseType: Type; + BEGIN + RETURN (object.type # NIL) & + SeekService(object.type, service, member, baseType) + END Supported; - PROCEDURE Installed*(object: Object; service: Service) : BOOLEAN; - VAR - member: ServiceList; - BEGIN - RETURN MemberOf(object.installed, service, member) - END Installed; + PROCEDURE Installed*(object: Object; service: Service) : BOOLEAN; + VAR + member: ServiceList; + BEGIN + RETURN MemberOf(object.installed, service, member) + END Installed; - PROCEDURE GetSupportedBaseType*(object: Object; service: Service; - VAR baseType: Type); - VAR - member: ServiceList; - BEGIN - IF ~SeekService(object.type, service, member, baseType) THEN - baseType := NIL; - END; - END GetSupportedBaseType; + PROCEDURE GetSupportedBaseType*(object: Object; service: Service; + VAR baseType: Type); + VAR + member: ServiceList; + BEGIN + IF ~SeekService(object.type, service, member, baseType) THEN + baseType := NIL; + END; + END GetSupportedBaseType; BEGIN - currentBuf := NIL; currentPos := 0; loaderIF := NIL; + currentBuf := NIL; currentPos := 0; loaderIF := NIL; END ulmServices. diff --git a/src/library/ulm/ulmStreamDisciplines.Mod b/src/library/ulm/ulmStreamDisciplines.Mod index 686214c9..522f9cda 100644 --- a/src/library/ulm/ulmStreamDisciplines.Mod +++ b/src/library/ulm/ulmStreamDisciplines.Mod @@ -1,246 +1,249 @@ (* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: StreamDisci.om,v 1.2 1994/07/04 14:53:25 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: StreamDisci.om,v $ - Revision 1.2 1994/07/04 14:53:25 borchert - parameter for indentation width added + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: StreamDisci.om,v 1.2 1994/07/04 14:53:25 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: StreamDisci.om,v $ + Revision 1.2 1994/07/04 14:53:25 borchert + parameter for indentation width added - Revision 1.1 1994/02/22 20:10:34 borchert - Initial revision + Revision 1.1 1994/02/22 20:10:34 borchert + Initial revision - ---------------------------------------------------------------------------- - AFB 10/91 - ---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- + AFB 10/91 + ---------------------------------------------------------------------------- *) MODULE ulmStreamDisciplines; - (* definition of general-purpose disciplines for streams *) + (* definition of general-purpose disciplines for streams *) - IMPORT ASCII := ulmASCII, Disciplines := ulmIndirectDisciplines, Events := ulmEvents, Sets := ulmSets, Streams := ulmStreams, SYSTEM; + IMPORT ASCII := ulmASCII, Disciplines := ulmIndirectDisciplines, Events := ulmEvents, Sets := ulmSets, Streams := ulmStreams, SYSTEM; - TYPE - LineTerminator* = ARRAY 4 OF CHAR; - VAR - badfieldsepset*: Events.EventType; + TYPE + LineTerminator* = ARRAY 4 OF CHAR; + VAR + badfieldsepset*: Events.EventType; - TYPE - StreamDiscipline = POINTER TO StreamDisciplineRec; - StreamDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - lineterm: LineTerminator; - fieldseps: Sets.CharSet; - fieldsep: CHAR; (* one of them *) - whitespace: Sets.CharSet; - indentwidth: INTEGER; - END; - - VAR - id: Disciplines.Identifier; - (* default values *) - defaultFieldSeps: Sets.CharSet; - defaultFieldSep: CHAR; - defaultLineTerm: LineTerminator; - defaultWhiteSpace: Sets.CharSet; - defaultIndentWidth: INTEGER; - - PROCEDURE InitDiscipline(VAR disc: StreamDiscipline); - BEGIN - NEW(disc); disc.id := id; - disc.fieldseps := defaultFieldSeps; - disc.fieldsep := defaultFieldSep; - disc.lineterm := defaultLineTerm; - disc.whitespace := defaultWhiteSpace; - disc.indentwidth := defaultIndentWidth; - END InitDiscipline; - - PROCEDURE SetLineTerm*(s: Streams.Stream; lineterm: LineTerminator); - VAR - disc: StreamDiscipline; - BEGIN - IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - InitDiscipline(disc); + TYPE + StreamDiscipline = POINTER TO StreamDisciplineRec; + StreamDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + lineterm: LineTerminator; + fieldseps: Sets.CharSet; + fieldsep: CHAR; (* one of them *) + whitespace: Sets.CharSet; + indentwidth: INTEGER; END; - disc.lineterm := lineterm; + + VAR + id: Disciplines.Identifier; + (* default values *) + defaultFieldSeps: Sets.CharSet; + defaultFieldSep: CHAR; + defaultLineTerm: LineTerminator; + defaultWhiteSpace: Sets.CharSet; + defaultIndentWidth: INTEGER; + + PROCEDURE InitDiscipline(VAR disc: Disciplines.Discipline); + VAR + sdisc: StreamDiscipline; + BEGIN + NEW(sdisc); sdisc.id := id; + sdisc.fieldseps := defaultFieldSeps; + sdisc.fieldsep := defaultFieldSep; + sdisc.lineterm := defaultLineTerm; + sdisc.whitespace := defaultWhiteSpace; + sdisc.indentwidth := defaultIndentWidth; + disc := sdisc + END InitDiscipline; + + PROCEDURE SetLineTerm*(s: Streams.Stream; lineterm: LineTerminator); + VAR + disc: Disciplines.Discipline; + BEGIN + IF ~Disciplines.Seek(s, id, disc) THEN + InitDiscipline(disc); + END; + disc(StreamDiscipline).lineterm := lineterm; + Disciplines.Add(s, disc); + END SetLineTerm; + + PROCEDURE GetLineTerm*(s: Streams.Stream; VAR lineterm: LineTerminator); + (* default line terminator is ASCII.nl *) + VAR + disc: Disciplines.Discipline; + BEGIN + IF Disciplines.Seek(s, id, disc) THEN + lineterm := disc(StreamDiscipline).lineterm; + ELSE + lineterm := defaultLineTerm; + END; + END GetLineTerm; + + PROCEDURE SetFieldSepSet*(s: Streams.Stream; fieldsepset: Sets.CharSet); + (* cardinality of fieldsepset must be >= 1 *) + VAR + disc: Disciplines.Discipline; + ch: CHAR; found: BOOLEAN; + fieldsep: CHAR; + event: Events.Event; + BEGIN + ch := 0X; + LOOP (* seek for the first element inside fieldsepset *) + IF Sets.CharIn(fieldsepset, ch) THEN + found := TRUE; fieldsep := ch; EXIT + END; + IF ch = MAX(CHAR) THEN + found := FALSE; EXIT + END; + ch := CHR(ORD(ch) + 1); + END; + IF ~found THEN + NEW(event); + event.message := "StreamDisciplines.SetFieldSepSet: empty fieldsepset"; + event.type := badfieldsepset; + Events.Raise(event); + RETURN + END; + IF ~Disciplines.Seek(s, id, disc) THEN + InitDiscipline(disc); + END; + disc(StreamDiscipline).fieldseps := fieldsepset; + disc(StreamDiscipline).fieldsep := fieldsep; + Disciplines.Add(s, disc); + END SetFieldSepSet; + + PROCEDURE GetFieldSepSet*(s: Streams.Stream; VAR fieldsepset: Sets.CharSet); + (* default field separators are ASCII.tab and ASCII.sp *) + VAR + disc: Disciplines.Discipline; + BEGIN + IF Disciplines.Seek(s, id, disc) THEN + fieldsepset := disc(StreamDiscipline).fieldseps; + ELSE + fieldsepset := defaultFieldSeps; + END; + END GetFieldSepSet; + + PROCEDURE SetFieldSep*(s: Streams.Stream; fieldsep: CHAR); + VAR + disc: Disciplines.Discipline; + BEGIN + IF ~Disciplines.Seek(s, id, disc) THEN + InitDiscipline(disc); + END; + Sets.InclChar(disc(StreamDiscipline).fieldseps, fieldsep); + disc(StreamDiscipline).fieldsep := fieldsep; + Disciplines.Add(s, disc); + END SetFieldSep; + + PROCEDURE GetFieldSep*(s: Streams.Stream; VAR fieldsep: CHAR); + (* default field separator is ASCII.tab; + if a set of field separators has been given via SetFieldSepSet, + one of them is returned + *) + VAR + disc: Disciplines.Discipline; + BEGIN + IF Disciplines.Seek(s, id, disc) THEN + fieldsep := disc(StreamDiscipline).fieldsep; + ELSE + fieldsep := defaultFieldSep; + END; + END GetFieldSep; + + PROCEDURE GetWhiteSpace*(s: Streams.Stream; VAR whitespace: Sets.CharSet); + (* default: ASCII.tab, ASCII.sp, ASCII.np and ASCII.nl *) + VAR + disc: Disciplines.Discipline; + BEGIN + IF Disciplines.Seek(s, id, disc) THEN + whitespace := disc(StreamDiscipline).whitespace; + ELSE + whitespace := defaultWhiteSpace; + END; + END GetWhiteSpace; + + PROCEDURE SetWhiteSpace*(s: Streams.Stream; whitespace: Sets.CharSet); + VAR + disc: Disciplines.Discipline; + BEGIN + IF ~Disciplines.Seek(s, id, disc) THEN + InitDiscipline(disc); + END; + disc(StreamDiscipline).whitespace := whitespace; + Disciplines.Add(s, disc); + END SetWhiteSpace; + + PROCEDURE SetIndentationWidth*(s: Streams.Stream; indentwidth: INTEGER); + VAR + disc: Disciplines.Discipline; + BEGIN + IF indentwidth >= 0 THEN + IF ~Disciplines.Seek(s, id, disc) THEN + InitDiscipline(disc); + END; + disc(StreamDiscipline).indentwidth := indentwidth; Disciplines.Add(s, disc); - END SetLineTerm; + END; + END SetIndentationWidth; - PROCEDURE GetLineTerm*(s: Streams.Stream; VAR lineterm: LineTerminator); - (* default line terminator is ASCII.nl *) - VAR - disc: StreamDiscipline; - BEGIN - IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - lineterm := disc.lineterm; - ELSE - lineterm := defaultLineTerm; - END; - END GetLineTerm; + PROCEDURE GetIndentationWidth*(s: Streams.Stream; VAR indentwidth: INTEGER); + VAR + disc: Disciplines.Discipline; + BEGIN + IF Disciplines.Seek(s, id, disc) THEN + indentwidth := disc(StreamDiscipline).indentwidth; + ELSE + indentwidth := defaultIndentWidth; + END; + END GetIndentationWidth; - PROCEDURE SetFieldSepSet*(s: Streams.Stream; fieldsepset: Sets.CharSet); - (* cardinality of fieldsepset must be >= 1 *) - VAR - disc: StreamDiscipline; - ch: CHAR; found: BOOLEAN; - fieldsep: CHAR; - event: Events.Event; - BEGIN - ch := 0X; - LOOP (* seek for the first element inside fieldsepset *) - IF Sets.CharIn(fieldsepset, ch) THEN - found := TRUE; fieldsep := ch; EXIT - END; - IF ch = MAX(CHAR) THEN - found := FALSE; EXIT - END; - ch := CHR(ORD(ch) + 1); - END; - IF ~found THEN - NEW(event); - event.message := "StreamDisciplines.SetFieldSepSet: empty fieldsepset"; - event.type := badfieldsepset; - Events.Raise(event); - RETURN - END; - IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - InitDiscipline(disc); - END; - disc.fieldseps := fieldsepset; - disc.fieldsep := fieldsep; - Disciplines.Add(s, disc); - END SetFieldSepSet; - - PROCEDURE GetFieldSepSet*(s: Streams.Stream; VAR fieldsepset: Sets.CharSet); - (* default field separators are ASCII.tab and ASCII.sp *) - VAR - disc: StreamDiscipline; - BEGIN - IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - fieldsepset := disc.fieldseps; - ELSE - fieldsepset := defaultFieldSeps; - END; - END GetFieldSepSet; - - PROCEDURE SetFieldSep*(s: Streams.Stream; fieldsep: CHAR); - VAR - disc: StreamDiscipline; - BEGIN - IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - InitDiscipline(disc); - END; - Sets.InclChar(disc.fieldseps, fieldsep); - disc.fieldsep := fieldsep; - Disciplines.Add(s, disc); - END SetFieldSep; - - PROCEDURE GetFieldSep*(s: Streams.Stream; VAR fieldsep: CHAR); - (* default field separator is ASCII.tab; - if a set of field separators has been given via SetFieldSepSet, - one of them is returned - *) - VAR - disc: StreamDiscipline; - BEGIN - IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - fieldsep := disc.fieldsep; - ELSE - fieldsep := defaultFieldSep; - END; - END GetFieldSep; - - PROCEDURE GetWhiteSpace*(s: Streams.Stream; VAR whitespace: Sets.CharSet); - (* default: ASCII.tab, ASCII.sp, ASCII.np and ASCII.nl *) - VAR - disc: StreamDiscipline; - BEGIN - IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - whitespace := disc.whitespace; - ELSE - whitespace := defaultWhiteSpace; - END; - END GetWhiteSpace; - - PROCEDURE SetWhiteSpace*(s: Streams.Stream; whitespace: Sets.CharSet); - VAR - disc: StreamDiscipline; - BEGIN - IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - InitDiscipline(disc); - END; - disc.whitespace := whitespace; - Disciplines.Add(s, disc); - END SetWhiteSpace; - - PROCEDURE SetIndentationWidth*(s: Streams.Stream; indentwidth: INTEGER); - VAR - disc: StreamDiscipline; - BEGIN - IF indentwidth >= 0 THEN - IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - InitDiscipline(disc); - END; - disc.indentwidth := indentwidth; - Disciplines.Add(s, disc); - END; - END SetIndentationWidth; - - PROCEDURE GetIndentationWidth*(s: Streams.Stream; VAR indentwidth: INTEGER); - VAR - disc: StreamDiscipline; - BEGIN - IF Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - indentwidth := disc.indentwidth; - ELSE - indentwidth := defaultIndentWidth; - END; - END GetIndentationWidth; - - PROCEDURE IncrIndentationWidth*(s: Streams.Stream; incr: INTEGER); - VAR - disc: StreamDiscipline; - BEGIN - IF ~Disciplines.Seek(s, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN - InitDiscipline(disc); - END; - IF disc.indentwidth + incr >= 0 THEN - INC(disc.indentwidth, incr);; - END; - Disciplines.Add(s, disc); - END IncrIndentationWidth; + PROCEDURE IncrIndentationWidth*(s: Streams.Stream; incr: INTEGER); + VAR + disc: Disciplines.Discipline; + BEGIN + IF ~Disciplines.Seek(s, id, disc) THEN + InitDiscipline(disc); + END; + IF disc(StreamDiscipline).indentwidth + incr >= 0 THEN + INC(disc(StreamDiscipline).indentwidth, incr);; + END; + Disciplines.Add(s, disc); + END IncrIndentationWidth; BEGIN - Events.Define(badfieldsepset); + Events.Define(badfieldsepset); - id := Disciplines.Unique(); - Sets.InitSet(defaultFieldSeps); - Sets.InclChar(defaultFieldSeps, ASCII.tab); - Sets.InclChar(defaultFieldSeps, ASCII.sp); - defaultFieldSep := ASCII.tab; - defaultLineTerm[0] := ASCII.nl; defaultLineTerm[1] := 0X; - Sets.InitSet(defaultWhiteSpace); - Sets.InclChar(defaultWhiteSpace, ASCII.tab); - Sets.InclChar(defaultWhiteSpace, ASCII.sp); - Sets.InclChar(defaultWhiteSpace, ASCII.np); - Sets.InclChar(defaultWhiteSpace, ASCII.nl); - defaultIndentWidth := 0; + id := Disciplines.Unique(); + Sets.InitSet(defaultFieldSeps); + Sets.InclChar(defaultFieldSeps, ASCII.tab); + Sets.InclChar(defaultFieldSeps, ASCII.sp); + defaultFieldSep := ASCII.tab; + defaultLineTerm[0] := ASCII.nl; defaultLineTerm[1] := 0X; + Sets.InitSet(defaultWhiteSpace); + Sets.InclChar(defaultWhiteSpace, ASCII.tab); + Sets.InclChar(defaultWhiteSpace, ASCII.sp); + Sets.InclChar(defaultWhiteSpace, ASCII.np); + Sets.InclChar(defaultWhiteSpace, ASCII.nl); + defaultIndentWidth := 0; END ulmStreamDisciplines. diff --git a/src/library/ulm/ulmStreams.Mod b/src/library/ulm/ulmStreams.Mod index 149b1220..bb55c3e6 100644 --- a/src/library/ulm/ulmStreams.Mod +++ b/src/library/ulm/ulmStreams.Mod @@ -1,2150 +1,2150 @@ (* Ulm's Oberon Library - Copyright (C) 1989-2001 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. + Copyright (C) 1989-2001 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Streams.om,v 1.13 2005/02/14 23:36:35 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Streams.om,v $ - Revision 1.13 2005/02/14 23:36:35 borchert - bug fix: WritePart called InternalFlush without considering - that s.pos may be implicitly changed - (this assumption was wrong since revision 1.11) + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Streams.om,v 1.13 2005/02/14 23:36:35 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Streams.om,v $ + Revision 1.13 2005/02/14 23:36:35 borchert + bug fix: WritePart called InternalFlush without considering + that s.pos may be implicitly changed + (this assumption was wrong since revision 1.11) - Revision 1.12 2004/05/20 09:52:43 borchert - performance improvements: - - WritePart and Write take now the buffer by reference - - ReadByteFromBuf replaced by ReadBytesFromBuf - (contributed by Christian Ehrhardt) + Revision 1.12 2004/05/20 09:52:43 borchert + performance improvements: + - WritePart and Write take now the buffer by reference + - ReadByteFromBuf replaced by ReadBytesFromBuf + (contributed by Christian Ehrhardt) - Revision 1.11 2001/05/03 15:17:58 borchert - InternalFlush adapted for unidirectional pipelines to avoid - unintentional flushes due to buffer boundaries + Revision 1.11 2001/05/03 15:17:58 borchert + InternalFlush adapted for unidirectional pipelines to avoid + unintentional flushes due to buffer boundaries - Revision 1.10 2000/04/25 21:41:47 borchert - Streams.ReadPart loops now for unbuffered streams to collect input - until cnt is reached + Revision 1.10 2000/04/25 21:41:47 borchert + Streams.ReadPart loops now for unbuffered streams to collect input + until cnt is reached - Revision 1.9 1998/03/31 11:13:05 borchert - bug fix: NotificationHandler just reacted on Resources.unreferenced - but not on Resources.terminated + Revision 1.9 1998/03/31 11:13:05 borchert + bug fix: NotificationHandler just reacted on Resources.unreferenced + but not on Resources.terminated - Revision 1.8 1998/03/24 22:58:28 borchert - bug fix in Copy: left was computed incorrectly in case of - copies with fixed length (# -1) + Revision 1.8 1998/03/24 22:58:28 borchert + bug fix in Copy: left was computed incorrectly in case of + copies with fixed length (# -1) - Revision 1.7 1997/04/02 07:50:05 borchert - Copy replaced by a slightly more efficient variant + Revision 1.7 1997/04/02 07:50:05 borchert + Copy replaced by a slightly more efficient variant - Revision 1.6 1996/09/18 07:43:51 borchert - qualified references to own module (i.e. Streams.XXX) removed + Revision 1.6 1996/09/18 07:43:51 borchert + qualified references to own module (i.e. Streams.XXX) removed - Revision 1.5 1996/01/04 16:43:57 borchert - some bug fixes in the updates of read and write regions + Revision 1.5 1996/01/04 16:43:57 borchert + some bug fixes in the updates of read and write regions - Revision 1.4 1995/10/11 09:46:41 borchert - - closeEvent re-introduced (because it gets raised *before* - the actual close) - - bug fix: s.write was diminished in ReadPart but the write region - not properly adjusted - - bug fix: InternalSeek was setting s.left to negative values in - a special case + Revision 1.4 1995/10/11 09:46:41 borchert + - closeEvent re-introduced (because it gets raised *before* + the actual close) + - bug fix: s.write was diminished in ReadPart but the write region + not properly adjusted + - bug fix: InternalSeek was setting s.left to negative values in + a special case - Revision 1.3 1995/04/18 12:17:12 borchert - - Streams.Stream is now an extension of Services.Object - - Library variant of assertions replaced by ASSERT - - support of Resources added - - EnableClose, PreventClose & closeEvent removed + Revision 1.3 1995/04/18 12:17:12 borchert + - Streams.Stream is now an extension of Services.Object + - Library variant of assertions replaced by ASSERT + - support of Resources added + - EnableClose, PreventClose & closeEvent removed - Revision 1.2 1994/07/05 12:45:57 borchert - some minor bug fixes & enhancements: - - ReadPacket added - - streams which don't require cleanup are now subject to the GC - even if Close will never be called for them - - line buffered streams w/o bufio/addrio capability fill now buffer - up to the next line terminator only instead of trying to fill the - whole buffer - - ReadPart didn't set count correctly in all cases - - Touch calls now the flush interface procedure + Revision 1.2 1994/07/05 12:45:57 borchert + some minor bug fixes & enhancements: + - ReadPacket added + - streams which don't require cleanup are now subject to the GC + even if Close will never be called for them + - line buffered streams w/o bufio/addrio capability fill now buffer + up to the next line terminator only instead of trying to fill the + whole buffer + - ReadPart didn't set count correctly in all cases + - Touch calls now the flush interface procedure - Revision 1.1 1994/02/22 20:10:45 borchert - Initial revision + Revision 1.1 1994/02/22 20:10:45 borchert + Initial revision - ---------------------------------------------------------------------------- - AFB 6/89 - Major Revision: AFB 1/92: bufpool - ---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- + AFB 6/89 + Major Revision: AFB 1/92: bufpool + ---------------------------------------------------------------------------- *) MODULE ulmStreams; - IMPORT Events := ulmEvents, Objects := ulmObjects, Priorities := ulmPriorities, Process := ulmProcess, RelatedEvents := ulmRelatedEvents, Resources := ulmResources, - Services := ulmServices, SYS := ulmSYSTEM, SYSTEM, Types := ulmTypes; + IMPORT Events := ulmEvents, Objects := ulmObjects, Priorities := ulmPriorities, Process := ulmProcess, RelatedEvents := ulmRelatedEvents, Resources := ulmResources, + Services := ulmServices, SYS := ulmSYSTEM, SYSTEM, Types := ulmTypes; - CONST - (* 3rd parameter of Seek *) - (* Whence = (fromStart, fromPos, fromEnd); *) - fromStart* = 0; fromPos* = 1; fromEnd* = 2; + CONST + (* 3rd parameter of Seek *) + (* Whence = (fromStart, fromPos, fromEnd); *) + fromStart* = 0; fromPos* = 1; fromEnd* = 2; - (* capabilities of a stream *) - (* Capability = (read, write, addrio, bufio, seek, tell, trunc, close, - holes, handler); + (* capabilities of a stream *) + (* Capability = (read, write, addrio, bufio, seek, tell, trunc, close, + holes, handler); + *) + read* = 0; write* = 1; addrio* = 2; bufio* = 3; seek* = 4; tell* = 5; + trunc* = 6; flush* = 7; close* = 8; holes* = 9; handler* = 10; + + (* BufMode = (nobuf, linebuf, onebuf, bufpool); *) + nobuf* = 0; linebuf* = 1; onebuf* = 2; bufpool* = 3; + + (* ErrorCode = (NoHandlerDefined, CannotRead, CannotSeek, CloseFailed, + NotLineBuffered, SeekFailed, TellFailed, BadWhence, + CannotTell, WriteFailed, CannotWrite, ReadFailed, + Unbuffered, BadParameters, CannotTrunc, TruncFailed, + NestedCall, FlushFailed); + *) + NoHandlerDefined* = 0; (* no handler defined *) + CannotRead* = 1; (* stream is write only *) + CannotSeek* = 2; (* stream is not capable of seeking *) + CloseFailed* = 3; (* Flush or Close failed *) + NotLineBuffered* = 4; (* LineTerm must not be called *) + SeekFailed* = 5; (* seek operation failed *) + TellFailed* = 6; (* tell operation failed *) + BadWhence* = 7; (* whence value out of [fromStart..fromEnd] *) + CannotTell* = 8; (* stream does not have a current position *) + WriteFailed* = 9; (* write error *) + CannotWrite* = 10; (* stream is read only *) + ReadFailed* = 11; (* read error *) + Unbuffered* = 12; (* operation isn't valid for unbuff'd streams *) + BadParameters* = 13; (* e.g. wrong count or offset values *) + CannotTrunc* = 14; (* stream is not capable of truncating *) + TruncFailed* = 15; (* trunc operation failed *) + NestedCall* = 16; (* nested stream operation *) + FlushFailed* = 17; (* flush operation failed *) + errorcodes* = 18; (* number of error codes *) + + (* === private constants ======================================= *) + bufsize = 8192; (* should be the file system block size *) + defaulttermch = 0AX; (* default line terminator (for linebuf) *) + + TYPE + Address* = Types.Address; + Count* = Types.Count; + Byte* = Types.Byte; + Whence* = SHORTINT; (* Whence = (fromStart, fromPos, fromEnd); *) + CapabilitySet* = SET; (* OF Capability; *) + BufMode* = SHORTINT; + ErrorCode* = SHORTINT; + Stream* = POINTER TO StreamRec; + Message* = RECORD (Objects.ObjectRec) END; + + (* the buffering system: + + buffers are always on bufsize-boundaries + + ok: the other components are defined + pos: file position of cont[0] (pos MOD bufsize = 0) + cont: valid data: cont[rbegin]..cont[rend-1] (read-region) + written data: cont[wbegin]..cont[wend-1] (write-region) + + both regions are maintained (even for non-rw streams) + *) + Buffer = POINTER TO BufferRec; + BufferRec = + RECORD + ok: BOOLEAN; (* TRUE if other components are valid *) + pos: Count; (* file position which corresponds to cont[0] *) + rbegin: Count; (* read-region: starting index *) + rend: Count; (* read-region: ending index *) + wbegin: Count; (* write-region: starting index of dirty region *) + wend: Count; (* write-region: ending index *) + cont: ARRAY bufsize OF Byte; (* buffer contents *) + nextfree: Buffer; (* only needed for released buffers *) + (* components for buffers which are members of a buffer pool *) + prevh, nexth: Buffer; (* next buffer with same the hash value *) + preva, nexta: Buffer; (* sorted list of buffers (access time) *) + END; + + CONST + hashtabsize = 128; (* size of bucket table *) + TYPE + BucketTable = ARRAY hashtabsize OF Buffer; + BufferPool = POINTER TO BufferPoolRec; + BufferPoolRec = + RECORD + maxbuf: INTEGER; (* maximal number of buffers to be used *) + nbuf: INTEGER; (* number of buffers in use *) + bucket: BucketTable; + (* list of all buffers sorted after the last access time; + tail points to the buffer most recently accessed + *) + head, tail: Buffer; + END; + + TYPE + AddrIOProc* = PROCEDURE (s: Stream; ptr: Address; cnt: Count) : Count; + BufIOProc* = PROCEDURE (s: Stream; VAR buf: ARRAY OF Byte; + off, cnt: Count) : Count; + SeekProc* = PROCEDURE (s: Stream; cnt: Count; whence: Whence) : BOOLEAN; + TellProc* = PROCEDURE (s: Stream; VAR cnt: Count) : BOOLEAN; + ReadProc* = PROCEDURE (s: Stream; VAR byte: Byte) : BOOLEAN; + WriteProc* = PROCEDURE (s: Stream; byte: Byte) : BOOLEAN; + TruncProc* = PROCEDURE (s: Stream; cnt: Count) : BOOLEAN; + FlushProc* = PROCEDURE (s: Stream) : BOOLEAN; + CloseProc* = PROCEDURE (s: Stream) : BOOLEAN; + HandlerProc* = PROCEDURE (s: Stream; VAR msg: Message); + + Interface* = POINTER TO InterfaceRec; + InterfaceRec* = + RECORD + (Objects.ObjectRec) + addrread*: AddrIOProc; (* read, addrio *) + addrwrite*: AddrIOProc; (* write, addrio *) + bufread*: BufIOProc; (* read, bufio *) + bufwrite*: BufIOProc; (* write, bufio *) + read*: ReadProc; (* read *) + write*: WriteProc; (* write *) + seek*: SeekProc; (* seek *) + tell*: TellProc; (* tell *) + trunc*: TruncProc; (* trunc *) + flush*: FlushProc; (* flush *) + close*: CloseProc; (* close *) + handler*: HandlerProc; (* handler *) + END; + + StreamRec* = + RECORD + (Services.ObjectRec) + (* following components are set after i/o-operations *) + count*: Count; (* resulting count of last operation *) + errors*: INTEGER; (* incremented for each error; may be set to 0 *) + error*: BOOLEAN; (* last operation successful? *) + lasterror*: ErrorCode; (* error code of last error *) + eof*: BOOLEAN; (* last read-operation with count=0 returned *) + (* === private part ============================================ *) + prev, next: Stream; (* list of open streams *) + if: Interface; caps: CapabilitySet; + bufmode: BufMode; (* buffering mode *) + bidirect: BOOLEAN; (* bidirectional buffering? *) + termch: Byte; (* flush on termch (linebuf only) *) + inlist: BOOLEAN; (* member of the list of opened streams? *) + tiedStream: Stream; (* to be flushed before read operations *) + buf: Buffer; (* current buffer; = NIL for unbuffered streams *) + wbuf: Buffer; (* buffer for writing (only if bidirect = TRUE) *) + bufpool: BufferPool; (* only if bufmode = bufpool *) + validpos: BOOLEAN; (* pos valid? *) + pos: Count; (* current position in stream *) + maxpos: Count; (* maximal position until now (only if buf # NIL) *) + left: Count; (* number of bytes left in buf (after pos) *) + write: Count; (* number of bytes which can be written in buf *) + rpos: Count; (* current position of if.tell *) + wextensible: BOOLEAN; (* write region extensible? *) + eofFound: BOOLEAN; (* eof seen yet? temporary use only *) + lock: BOOLEAN; (* avoid recursive operations *) + flushEvent: Events.EventType; (* valid if # NIL *) + closeEvent: Events.EventType; (* valid if # NIL *) + END; + VAR + type: Services.Type; + + TYPE + (* each error causes an event; + the error number is stored in event.errorcode; + the associated text can be taken from event.message + *) + Event* = POINTER TO EventRec; + EventRec* = + RECORD + (Events.EventRec) + stream*: Stream; + errorcode*: ErrorCode; + END; + + VAR + null*: Stream; (* accepts any output; does not return input *) + (* these streams are set by other modules; + after initialization of Streams they equal `null'; + so, connections with the standard UNIX streams must be + done by other modules + *) + stdin*, stdout*, stderr*: Stream; + errormsg*: ARRAY errorcodes OF Events.Message; + error*: Events.EventType; + + (* === private variables ========================================== *) + + opened: Stream; (* list of opened streams *) + (* this list has been reduced to the set of streams which + need to be cleaned up explicitly; + all other streams are subject to the garbage collection + even if Close has never been called for them *) - read* = 0; write* = 1; addrio* = 2; bufio* = 3; seek* = 4; tell* = 5; - trunc* = 6; flush* = 7; close* = 8; holes* = 9; handler* = 10; + freelist: Buffer; (* list of free buffers *) + nullif: Interface; (* interface of null-devices *) - (* BufMode = (nobuf, linebuf, onebuf, bufpool); *) - nobuf* = 0; linebuf* = 1; onebuf* = 2; bufpool* = 3; + (* === private procedures ========================================= *) - (* ErrorCode = (NoHandlerDefined, CannotRead, CannotSeek, CloseFailed, - NotLineBuffered, SeekFailed, TellFailed, BadWhence, - CannotTell, WriteFailed, CannotWrite, ReadFailed, - Unbuffered, BadParameters, CannotTrunc, TruncFailed, - NestedCall, FlushFailed); + PROCEDURE NewStream(s: Stream); + BEGIN + IF s.inlist THEN + s.prev := NIL; + s.next := opened; + IF opened # NIL THEN + opened.prev := s; + END; + opened := s; + END; + END NewStream; + + PROCEDURE OldStream(s: Stream); + BEGIN + IF s.inlist THEN + IF s.prev # NIL THEN + s.prev.next := s.next; + ELSE + opened := s.next; + END; + IF s.next # NIL THEN + s.next.prev := s.prev; + END; + END; + END OldStream; + + PROCEDURE NewBuffer(VAR b: Buffer); + BEGIN + IF freelist # NIL THEN + b := freelist; + freelist := freelist.nextfree; + ELSE + NEW(b); + END; + b.nextfree := NIL; + b.ok := FALSE; + END NewBuffer; + + PROCEDURE OldBuffer(VAR b: Buffer); + BEGIN + b.nextfree := freelist; + freelist := b; + b := NIL; + END OldBuffer; + + PROCEDURE Error(s: Stream; code: ErrorCode); + VAR + event: Event; + BEGIN + IF s # NIL THEN + INC(s.errors); + s.error := TRUE; + s.lasterror := code; + + (* generate error event *) + NEW(event); + event.type := error; + event.message := errormsg[code]; + event.stream := s; + event.errorcode := code; + RelatedEvents.Raise(s, event); + END; + END Error; + + PROCEDURE ^ InternalFlush(s: Stream) : BOOLEAN; + + (* ===== management of buffer pool ================================== *) + + PROCEDURE InitBufPool(s: Stream); + VAR + index: INTEGER; + BEGIN + s.bufpool.maxbuf := 16; (* default size *) + s.bufpool.nbuf := 0; (* currently, no buffers are allocated *) + s.bufpool.head := NIL; s.bufpool.tail := NIL; + index := 0; + WHILE index < hashtabsize DO + s.bufpool.bucket[index] := NIL; + INC(index); + END; + END InitBufPool; + + PROCEDURE HashValue(pos: Count) : INTEGER; + (* HashValue returns a hash value for pos *) + BEGIN + RETURN SHORT(pos DIV bufsize) MOD hashtabsize + END HashValue; + + PROCEDURE FindBuffer(s: Stream; pos: Count; VAR buf: Buffer) : BOOLEAN; + VAR + index: INTEGER; + bp: Buffer; + BEGIN + index := HashValue(pos); + bp := s.bufpool.bucket[index]; + WHILE bp # NIL DO + IF bp.pos = pos THEN + buf := bp; RETURN TRUE + END; + bp := bp.nexth; (* next buffer with same hash value *) + END; + buf := NIL; + RETURN FALSE + END FindBuffer; + + PROCEDURE GetBuffer(s: Stream); + (* look for buffer for s.pos and make it to the current buffer; + set s.left and s.write in dependance of s.pos + *) + VAR + buf: Buffer; + pos: Count; (* buffer boundary for s.pos *) + posindex: Count; (* buf[posindex] corresponds to s.pos *) + index: INTEGER; (* index into bucket table of the buffer pool *) + + PROCEDURE InitBuf(buf: Buffer); + VAR + index: INTEGER; (* of bucket table *) + BEGIN + buf.ok := TRUE; + buf.pos := pos; + buf.rbegin := posindex; buf.rend := posindex; s.left := 0; + buf.wbegin := posindex; buf.wend := posindex; + s.write := bufsize - posindex; + buf.nextfree := NIL; + + (* insert buf into hash list *) + index := HashValue(pos); + buf.prevh := NIL; + buf.nexth := s.bufpool.bucket[index]; + IF buf.nexth # NIL THEN + buf.nexth.prevh := buf; + END; + s.bufpool.bucket[index] := buf; + + (* buf is already at the end of the sorted list if we + re-use an old buffer *) - NoHandlerDefined* = 0; (* no handler defined *) - CannotRead* = 1; (* stream is write only *) - CannotSeek* = 2; (* stream is not capable of seeking *) - CloseFailed* = 3; (* Flush or Close failed *) - NotLineBuffered* = 4; (* LineTerm must not be called *) - SeekFailed* = 5; (* seek operation failed *) - TellFailed* = 6; (* tell operation failed *) - BadWhence* = 7; (* whence value out of [fromStart..fromEnd] *) - CannotTell* = 8; (* stream does not have a current position *) - WriteFailed* = 9; (* write error *) - CannotWrite* = 10; (* stream is read only *) - ReadFailed* = 11; (* read error *) - Unbuffered* = 12; (* operation isn't valid for unbuff'd streams *) - BadParameters* = 13; (* e.g. wrong count or offset values *) - CannotTrunc* = 14; (* stream is not capable of truncating *) - TruncFailed* = 15; (* trunc operation failed *) - NestedCall* = 16; (* nested stream operation *) - FlushFailed* = 17; (* flush operation failed *) - errorcodes* = 18; (* number of error codes *) + IF s.bufpool.tail # buf THEN + (* append buf to the sorted list *) + buf.nexta := NIL; + IF s.bufpool.tail = NIL THEN + s.bufpool.head := buf; + buf.preva := NIL; + ELSE + s.bufpool.tail.nexta := buf; + buf.preva := s.bufpool.tail; + END; + s.bufpool.tail := buf; + END; + END InitBuf; - (* === private constants ======================================= *) - bufsize = 8192; (* should be the file system block size *) - defaulttermch = 0AX; (* default line terminator (for linebuf) *) + PROCEDURE UseBuffer(s: Stream; buf: Buffer); + (* make buf to the current buffer of s *) + BEGIN + IF s.buf # buf THEN + (* remove buf from sorted list *) + IF buf.preva # NIL THEN + buf.preva.nexta := buf.nexta; + ELSE + s.bufpool.head := buf.nexta; + END; + IF buf.nexta # NIL THEN + buf.nexta.preva := buf.preva; + ELSE + s.bufpool.tail := buf.preva; + END; - TYPE - Address* = Types.Address; - Count* = Types.Count; - Byte* = Types.Byte; - Whence* = SHORTINT; (* Whence = (fromStart, fromPos, fromEnd); *) - CapabilitySet* = SET; (* OF Capability; *) - BufMode* = SHORTINT; - ErrorCode* = SHORTINT; - Stream* = POINTER TO StreamRec; - Message* = RECORD (Objects.ObjectRec) END; + (* append buf to sorted list *) + buf.nexta := NIL; + IF s.bufpool.tail = NIL THEN + s.bufpool.head := buf; + buf.preva := NIL; + ELSE + s.bufpool.tail.nexta := buf; + buf.preva := s.bufpool.tail; + END; + s.bufpool.tail := buf; - (* the buffering system: + (* set current buf of s to buf *) + s.buf := buf; - buffers are always on bufsize-boundaries + (* update s.left and s.write *) + IF buf.rbegin = buf.rend THEN + buf.rbegin := posindex; buf.rend := posindex; s.left := 0; + ELSIF (posindex >= buf.rbegin) & (posindex < buf.rend) THEN + s.left := buf.rend - posindex; + ELSE + s.left := 0; + END; + IF buf.wbegin = buf.wend THEN + buf.wbegin := posindex; buf.wend := posindex; + s.write := bufsize - posindex; + ELSIF (posindex >= buf.wbegin) & (posindex < buf.wend) THEN + s.write := bufsize - posindex; + ELSE + s.write := 0; + END; + END; + END UseBuffer; - ok: the other components are defined - pos: file position of cont[0] (pos MOD bufsize = 0) - cont: valid data: cont[rbegin]..cont[rend-1] (read-region) - written data: cont[wbegin]..cont[wend-1] (write-region) + BEGIN (* GetBuffer *) + posindex := s.pos MOD bufsize; + pos := s.pos - posindex; - both regions are maintained (even for non-rw streams) - *) - Buffer = POINTER TO BufferRec; - BufferRec = - RECORD - ok: BOOLEAN; (* TRUE if other components are valid *) - pos: Count; (* file position which corresponds to cont[0] *) - rbegin: Count; (* read-region: starting index *) - rend: Count; (* read-region: ending index *) - wbegin: Count; (* write-region: starting index of dirty region *) - wend: Count; (* write-region: ending index *) - cont: ARRAY bufsize OF Byte; (* buffer contents *) - nextfree: Buffer; (* only needed for released buffers *) - (* components for buffers which are members of a buffer pool *) - prevh, nexth: Buffer; (* next buffer with same the hash value *) - preva, nexta: Buffer; (* sorted list of buffers (access time) *) - END; + IF ~s.buf.ok THEN + (* init first allocated buffer which has not been used until now *) + InitBuf(s.buf); + INC(s.bufpool.nbuf); + ELSIF s.buf.pos # pos THEN + IF FindBuffer(s, pos, buf) THEN + UseBuffer(s, buf); + ELSE + IF s.bufpool.nbuf >= s.bufpool.maxbuf THEN + (* re-use already allocated buffer *) + buf := s.bufpool.head; + UseBuffer(s, buf); + IF buf.wbegin # buf.wend THEN + IF ~InternalFlush(s) THEN END; + END; - CONST - hashtabsize = 128; (* size of bucket table *) - TYPE - BucketTable = ARRAY hashtabsize OF Buffer; - BufferPool = POINTER TO BufferPoolRec; - BufferPoolRec = - RECORD - maxbuf: INTEGER; (* maximal number of buffers to be used *) - nbuf: INTEGER; (* number of buffers in use *) - bucket: BucketTable; - (* list of all buffers sorted after the last access time; - tail points to the buffer most recently accessed - *) - head, tail: Buffer; - END; + (* remove buf from hash list *) + IF buf.prevh # NIL THEN + buf.prevh.nexth := buf.nexth; + ELSE + index := HashValue(buf.pos); + s.bufpool.bucket[index] := buf.nexth; + END; + IF buf.nexth # NIL THEN + buf.nexth.prevh := buf.prevh; + END; - TYPE - AddrIOProc* = PROCEDURE (s: Stream; ptr: Address; cnt: Count) : Count; - BufIOProc* = PROCEDURE (s: Stream; VAR buf: ARRAY OF Byte; - off, cnt: Count) : Count; - SeekProc* = PROCEDURE (s: Stream; cnt: Count; whence: Whence) : BOOLEAN; - TellProc* = PROCEDURE (s: Stream; VAR cnt: Count) : BOOLEAN; - ReadProc* = PROCEDURE (s: Stream; VAR byte: Byte) : BOOLEAN; - WriteProc* = PROCEDURE (s: Stream; byte: Byte) : BOOLEAN; - TruncProc* = PROCEDURE (s: Stream; cnt: Count) : BOOLEAN; - FlushProc* = PROCEDURE (s: Stream) : BOOLEAN; - CloseProc* = PROCEDURE (s: Stream) : BOOLEAN; - HandlerProc* = PROCEDURE (s: Stream; VAR msg: Message); + InitBuf(buf); + ELSE + (* allocate and initialize new buffer *) + NewBuffer(buf); + InitBuf(buf); + INC(s.bufpool.nbuf); + END; + s.buf := buf; + END; + END; + END GetBuffer; - Interface* = POINTER TO InterfaceRec; - InterfaceRec* = - RECORD - (Objects.ObjectRec) - addrread*: AddrIOProc; (* read, addrio *) - addrwrite*: AddrIOProc; (* write, addrio *) - bufread*: BufIOProc; (* read, bufio *) - bufwrite*: BufIOProc; (* write, bufio *) - read*: ReadProc; (* read *) - write*: WriteProc; (* write *) - seek*: SeekProc; (* seek *) - tell*: TellProc; (* tell *) - trunc*: TruncProc; (* trunc *) - flush*: FlushProc; (* flush *) - close*: CloseProc; (* close *) - handler*: HandlerProc; (* handler *) - END; + PROCEDURE FlushBufPool(s: Stream) : BOOLEAN; + VAR + buf: Buffer; + ok: BOOLEAN; + BEGIN + ok := TRUE; + IF s.bufpool.nbuf > 0 THEN + buf := s.bufpool.head; + WHILE buf # NIL DO + s.buf := buf; + ok := InternalFlush(s) & ok; + buf := buf.nexta; + END; + END; + RETURN ok + END FlushBufPool; - StreamRec* = - RECORD - (Services.ObjectRec) - (* following components are set after i/o-operations *) - count*: Count; (* resulting count of last operation *) - errors*: INTEGER; (* incremented for each error; may be set to 0 *) - error*: BOOLEAN; (* last operation successful? *) - lasterror*: ErrorCode; (* error code of last error *) - eof*: BOOLEAN; (* last read-operation with count=0 returned *) - (* === private part ============================================ *) - prev, next: Stream; (* list of open streams *) - if: Interface; caps: CapabilitySet; - bufmode: BufMode; (* buffering mode *) - bidirect: BOOLEAN; (* bidirectional buffering? *) - termch: Byte; (* flush on termch (linebuf only) *) - inlist: BOOLEAN; (* member of the list of opened streams? *) - tiedStream: Stream; (* to be flushed before read operations *) - buf: Buffer; (* current buffer; = NIL for unbuffered streams *) - wbuf: Buffer; (* buffer for writing (only if bidirect = TRUE) *) - bufpool: BufferPool; (* only if bufmode = bufpool *) - validpos: BOOLEAN; (* pos valid? *) - pos: Count; (* current position in stream *) - maxpos: Count; (* maximal position until now (only if buf # NIL) *) - left: Count; (* number of bytes left in buf (after pos) *) - write: Count; (* number of bytes which can be written in buf *) - rpos: Count; (* current position of if.tell *) - wextensible: BOOLEAN; (* write region extensible? *) - eofFound: BOOLEAN; (* eof seen yet? temporary use only *) - lock: BOOLEAN; (* avoid recursive operations *) - flushEvent: Events.EventType; (* valid if # NIL *) - closeEvent: Events.EventType; (* valid if # NIL *) - END; - VAR + PROCEDURE ReleaseBufPool(s: Stream); + (* precondition: all buffers are flushed *) + VAR + buf: Buffer; + BEGIN + IF s.bufpool.nbuf > 0 THEN + buf := s.bufpool.head; + WHILE buf # NIL DO + s.buf := buf; + OldBuffer(s.buf); + buf := buf.nexta; + END; + END; + NewBuffer(s.buf); + InitBufPool(s); + END ReleaseBufPool; + + (* ================================================================== *) + + PROCEDURE GetBufMode*(s: Stream) : BufMode; + BEGIN + RETURN s.bufmode + END GetBufMode; + + PROCEDURE LineTerm*(s: Stream; termch: Byte); + (* set line terminator of `s' (linebuf) to `termch' *) + BEGIN + s.error := FALSE; + IF s.bufmode = linebuf THEN + s.termch := termch; + ELSE + Error(s, NotLineBuffered); + END; + END LineTerm; + + PROCEDURE Tie*(in, out: Stream); + (* PRE: `in' is an line buffered input stream, + `out' an output stream, + and `in' # `out'; + causes `out' to be flushed before reading from `in'; + `out' may be NIL to undo the effect + *) + BEGIN + in.error := FALSE; + IF in.bufmode # linebuf THEN + Error(in, NotLineBuffered); RETURN + END; + IF (in = out) OR ~(read IN in.caps) OR + (out # NIL) & ~(write IN out.caps) THEN + Error(in, BadParameters); RETURN + END; + in.tiedStream := out; + END Tie; + + PROCEDURE SetBufferPoolSize*(s: Stream; nbuf: INTEGER); + BEGIN + s.error := FALSE; + IF SYS.TAS(s.lock) THEN + Error(s, NestedCall); RETURN + END; + IF (s.bufmode = bufpool) & (nbuf >= 1) THEN + s.bufpool.maxbuf := nbuf; + END; + s.lock := FALSE; + END SetBufferPoolSize; + + PROCEDURE GetBufferPoolSize*(s: Stream; VAR nbuf: INTEGER); + BEGIN + s.error := FALSE; + CASE s.bufmode OF + | nobuf: nbuf := 0; + | linebuf: nbuf := 1; + | onebuf: nbuf := 1; + | bufpool: nbuf := s.bufpool.maxbuf; + ELSE (* Explicitly ignore unhandled values of s.bufmode *) + END; + END GetBufferPoolSize; + + PROCEDURE Capabilities*(s: Stream) : CapabilitySet; + BEGIN + s.error := FALSE; + RETURN s.caps + END Capabilities; + + PROCEDURE GetFlushEvent*(s: Stream; VAR type: Events.EventType); + (* `type' will be raised BEFORE every flush operation *) + BEGIN + s.error := FALSE; + IF s.flushEvent = NIL THEN + Events.Define(s.flushEvent); + END; + type := s.flushEvent; + END GetFlushEvent; + + PROCEDURE GetCloseEvent*(s: Stream; VAR type: Events.EventType); + (* `type' will be raised BEFORE the stream gets closed; + that means write operations etc. are legal + *) + BEGIN + s.error := FALSE; + IF s.closeEvent = NIL THEN + Events.Define(s.closeEvent); + END; + type := s.closeEvent; + END GetCloseEvent; + + PROCEDURE Close*(s: Stream) : BOOLEAN; + VAR + event: Event; + type: Events.EventType; + otherStream: Stream; + BEGIN + s.error := FALSE; + + IF (s.closeEvent # NIL) & ~SYS.TAS(s.lock) THEN + type := s.closeEvent; s.closeEvent := NIL; + s.lock := FALSE; + Events.SetPriority(type, Events.GetPriority() + 1); + NEW(event); + event.type := type; + event.message := "close event of Streams"; + event.stream := s; + Events.Raise(event); + END; + + IF ~SYS.TAS(s.lock) THEN + IF write IN s.caps THEN + IF s.bufmode = bufpool THEN + IF ~FlushBufPool(s) THEN END; + ELSE + IF ~InternalFlush(s) THEN END; + END; + END; + IF close IN s.caps THEN + IF ~s.if.close(s) THEN + Error(s, CloseFailed); + END; + END; + IF s.buf # NIL THEN + IF s.bufmode = bufpool THEN + ReleaseBufPool(s); + END; + OldBuffer(s.buf); + END; + OldStream(s); + + (* check if this stream has been tied to another stream *) + otherStream := opened; + WHILE otherStream # NIL DO + IF otherStream.tiedStream = s THEN + otherStream.tiedStream := NIL; (* undo tie operation *) + END; + otherStream := otherStream.next; + END; + (* s.lock remains TRUE to prevent further operations *) + Resources.Notify(s, Resources.terminated); + RETURN ~s.error + ELSE + Error(s, NestedCall); + RETURN FALSE + END; + END Close; + + PROCEDURE Release*(s: Stream); + BEGIN + IF ~Close(s) THEN END; + END Release; + + PROCEDURE CloseAll*; + BEGIN + WHILE opened # NIL DO + (* that's no endless loop; see Close/OldStream *) + Release(opened); + END; + END CloseAll; + + PROCEDURE NotificationHandler(event: Events.Event); + VAR + s: Stream; + BEGIN + IF ~(event IS Resources.Event) THEN RETURN END; + WITH event: Resources.Event DO + IF ~(event.resource IS Stream) THEN RETURN END; + s := event.resource(Stream); + IF event.change IN {Resources.unreferenced, Resources.terminated} THEN + IF ~s.lock THEN + Release(s); + END; + END; + END; + END NotificationHandler; + + PROCEDURE Init*(s: Stream; if: Interface; caps: CapabilitySet; + bufmode: BufMode); + + VAR + eventType: Events.EventType; type: Services.Type; - TYPE - (* each error causes an event; - the error number is stored in event.errorcode; - the associated text can be taken from event.message - *) - Event* = POINTER TO EventRec; - EventRec* = - RECORD - (Events.EventRec) - stream*: Stream; - errorcode*: ErrorCode; - END; + PROCEDURE InitBidirectionalBuffering(s: Stream); + BEGIN + s.validpos := TRUE; + s.pos := 0; + NewBuffer(s.wbuf); + s.buf.ok := TRUE; s.buf.rbegin := 0; s.buf.rend := 0; s.buf.pos := 0; + s.wbuf.ok := TRUE; s.wbuf.wbegin := 0; s.wbuf.wend := 0; + s.wbuf.pos := 0; + s.left := 0; s.write := bufsize; + END InitBidirectionalBuffering; - VAR - null*: Stream; (* accepts any output; does not return input *) - (* these streams are set by other modules; - after initialization of Streams they equal `null'; - so, connections with the standard UNIX streams must be - done by other modules - *) - stdin*, stdout*, stderr*: Stream; - errormsg*: ARRAY errorcodes OF Events.Message; - error*: Events.EventType; - - (* === private variables ========================================== *) - - opened: Stream; (* list of opened streams *) - (* this list has been reduced to the set of streams which - need to be cleaned up explicitly; - all other streams are subject to the garbage collection - even if Close has never been called for them - *) - freelist: Buffer; (* list of free buffers *) - nullif: Interface; (* interface of null-devices *) - - (* === private procedures ========================================= *) - - PROCEDURE NewStream(s: Stream); - BEGIN - IF s.inlist THEN - s.prev := NIL; - s.next := opened; - IF opened # NIL THEN - opened.prev := s; - END; - opened := s; - END; - END NewStream; - - PROCEDURE OldStream(s: Stream); - BEGIN - IF s.inlist THEN - IF s.prev # NIL THEN - s.prev.next := s.next; - ELSE - opened := s.next; - END; - IF s.next # NIL THEN - s.next.prev := s.prev; - END; - END; - END OldStream; - - PROCEDURE NewBuffer(VAR b: Buffer); - BEGIN - IF freelist # NIL THEN - b := freelist; - freelist := freelist.nextfree; - ELSE - NEW(b); - END; - b.nextfree := NIL; - b.ok := FALSE; - END NewBuffer; - - PROCEDURE OldBuffer(VAR b: Buffer); - BEGIN - b.nextfree := freelist; - freelist := b; - b := NIL; - END OldBuffer; - - PROCEDURE Error(s: Stream; code: ErrorCode); - VAR - event: Event; - BEGIN - IF s # NIL THEN - INC(s.errors); - s.error := TRUE; - s.lasterror := code; - - (* generate error event *) - NEW(event); - event.type := error; - event.message := errormsg[code]; - event.stream := s; - event.errorcode := code; - RelatedEvents.Raise(s, event); - END; - END Error; - - PROCEDURE ^ InternalFlush(s: Stream) : BOOLEAN; - - (* ===== management of buffer pool ================================== *) - - PROCEDURE InitBufPool(s: Stream); - VAR - index: INTEGER; - BEGIN - s.bufpool.maxbuf := 16; (* default size *) - s.bufpool.nbuf := 0; (* currently, no buffers are allocated *) - s.bufpool.head := NIL; s.bufpool.tail := NIL; - index := 0; - WHILE index < hashtabsize DO - s.bufpool.bucket[index] := NIL; - INC(index); - END; - END InitBufPool; - - PROCEDURE HashValue(pos: Count) : INTEGER; - (* HashValue returns a hash value for pos *) - BEGIN - RETURN SHORT(pos DIV bufsize) MOD hashtabsize - END HashValue; - - PROCEDURE FindBuffer(s: Stream; pos: Count; VAR buf: Buffer) : BOOLEAN; - VAR - index: INTEGER; - bp: Buffer; - BEGIN - index := HashValue(pos); - bp := s.bufpool.bucket[index]; - WHILE bp # NIL DO - IF bp.pos = pos THEN - buf := bp; RETURN TRUE - END; - bp := bp.nexth; (* next buffer with same hash value *) - END; - buf := NIL; - RETURN FALSE - END FindBuffer; - - PROCEDURE GetBuffer(s: Stream); - (* look for buffer for s.pos and make it to the current buffer; - set s.left and s.write in dependance of s.pos - *) - VAR - buf: Buffer; - pos: Count; (* buffer boundary for s.pos *) - posindex: Count; (* buf[posindex] corresponds to s.pos *) - index: INTEGER; (* index into bucket table of the buffer pool *) - - PROCEDURE InitBuf(buf: Buffer); - VAR - index: INTEGER; (* of bucket table *) - BEGIN - buf.ok := TRUE; - buf.pos := pos; - buf.rbegin := posindex; buf.rend := posindex; s.left := 0; - buf.wbegin := posindex; buf.wend := posindex; - s.write := bufsize - posindex; - buf.nextfree := NIL; - - (* insert buf into hash list *) - index := HashValue(pos); - buf.prevh := NIL; - buf.nexth := s.bufpool.bucket[index]; - IF buf.nexth # NIL THEN - buf.nexth.prevh := buf; - END; - s.bufpool.bucket[index] := buf; - - (* buf is already at the end of the sorted list if we - re-use an old buffer - *) - IF s.bufpool.tail # buf THEN - (* append buf to the sorted list *) - buf.nexta := NIL; - IF s.bufpool.tail = NIL THEN - s.bufpool.head := buf; - buf.preva := NIL; - ELSE - s.bufpool.tail.nexta := buf; - buf.preva := s.bufpool.tail; - END; - s.bufpool.tail := buf; - END; - END InitBuf; - - PROCEDURE UseBuffer(s: Stream; buf: Buffer); - (* make buf to the current buffer of s *) - BEGIN - IF s.buf # buf THEN - (* remove buf from sorted list *) - IF buf.preva # NIL THEN - buf.preva.nexta := buf.nexta; - ELSE - s.bufpool.head := buf.nexta; - END; - IF buf.nexta # NIL THEN - buf.nexta.preva := buf.preva; - ELSE - s.bufpool.tail := buf.preva; - END; - - (* append buf to sorted list *) - buf.nexta := NIL; - IF s.bufpool.tail = NIL THEN - s.bufpool.head := buf; - buf.preva := NIL; - ELSE - s.bufpool.tail.nexta := buf; - buf.preva := s.bufpool.tail; - END; - s.bufpool.tail := buf; - - (* set current buf of s to buf *) - s.buf := buf; - - (* update s.left and s.write *) - IF buf.rbegin = buf.rend THEN - buf.rbegin := posindex; buf.rend := posindex; s.left := 0; - ELSIF (posindex >= buf.rbegin) & (posindex < buf.rend) THEN - s.left := buf.rend - posindex; - ELSE - s.left := 0; - END; - IF buf.wbegin = buf.wend THEN - buf.wbegin := posindex; buf.wend := posindex; - s.write := bufsize - posindex; - ELSIF (posindex >= buf.wbegin) & (posindex < buf.wend) THEN - s.write := bufsize - posindex; - ELSE - s.write := 0; - END; - END; - END UseBuffer; - - BEGIN (* GetBuffer *) - posindex := s.pos MOD bufsize; - pos := s.pos - posindex; - - IF ~s.buf.ok THEN - (* init first allocated buffer which has not been used until now *) - InitBuf(s.buf); - INC(s.bufpool.nbuf); - ELSIF s.buf.pos # pos THEN - IF FindBuffer(s, pos, buf) THEN - UseBuffer(s, buf); - ELSE - IF s.bufpool.nbuf >= s.bufpool.maxbuf THEN - (* re-use already allocated buffer *) - buf := s.bufpool.head; - UseBuffer(s, buf); - IF buf.wbegin # buf.wend THEN - IF ~InternalFlush(s) THEN END; - END; - - (* remove buf from hash list *) - IF buf.prevh # NIL THEN - buf.prevh.nexth := buf.nexth; - ELSE - index := HashValue(buf.pos); - s.bufpool.bucket[index] := buf.nexth; - END; - IF buf.nexth # NIL THEN - buf.nexth.prevh := buf.prevh; - END; - - InitBuf(buf); - ELSE - (* allocate and initialize new buffer *) - NewBuffer(buf); - InitBuf(buf); - INC(s.bufpool.nbuf); - END; - s.buf := buf; - END; - END; - END GetBuffer; - - PROCEDURE FlushBufPool(s: Stream) : BOOLEAN; - VAR - buf: Buffer; - ok: BOOLEAN; - BEGIN - ok := TRUE; - IF s.bufpool.nbuf > 0 THEN - buf := s.bufpool.head; - WHILE buf # NIL DO - s.buf := buf; - ok := InternalFlush(s) & ok; - buf := buf.nexta; - END; - END; - RETURN ok - END FlushBufPool; - - PROCEDURE ReleaseBufPool(s: Stream); - (* precondition: all buffers are flushed *) - VAR - buf: Buffer; - BEGIN - IF s.bufpool.nbuf > 0 THEN - buf := s.bufpool.head; - WHILE buf # NIL DO - s.buf := buf; - OldBuffer(s.buf); - buf := buf.nexta; - END; - END; + BEGIN + ASSERT((s # NIL) & (if # NIL) & ({read, write} * caps # {})); + Services.GetType(s, type); ASSERT(type # NIL); + s.inlist := (close IN caps) OR (bufmode # nobuf) & (write IN caps); + NewStream(s); + (* initialize public part *) + s.count := 0; + s.errors := 0; + s.error := FALSE; + s.lasterror := 0; + s.eof := FALSE; + (* private part *) + s.if := if; s.caps := caps; + s.bufmode := bufmode; + s.validpos := FALSE; + s.left := 0; s.write := 0; + s.tiedStream := NIL; + IF bufmode IN {linebuf, onebuf, bufpool} THEN NewBuffer(s.buf); - InitBufPool(s); - END ReleaseBufPool; - - (* ================================================================== *) - - PROCEDURE GetBufMode*(s: Stream) : BufMode; - BEGIN - RETURN s.bufmode - END GetBufMode; - - PROCEDURE LineTerm*(s: Stream; termch: Byte); - (* set line terminator of `s' (linebuf) to `termch' *) - BEGIN - s.error := FALSE; - IF s.bufmode = linebuf THEN - s.termch := termch; + IF (bufmode = bufpool) & ~(seek IN caps) THEN + bufmode := onebuf; + END; + CASE bufmode OF + | linebuf: s.termch := defaulttermch; + | bufpool: NEW(s.bufpool); InitBufPool(s); ELSE - Error(s, NotLineBuffered); END; - END LineTerm; + s.maxpos := 0; + s.wextensible := {read, write, seek, tell, holes} * caps = + {read, write, seek, tell}; + s.bidirect := {read, write, seek, tell, trunc} * caps = {read, write}; + IF s.bidirect THEN + InitBidirectionalBuffering(s); + ELSE + s.wbuf := NIL; + END; + ELSE + s.buf := NIL; + s.wbuf := NIL; + s.wextensible := FALSE; + s.bidirect := FALSE; + END; + s.flushEvent := NIL; + s.closeEvent := NIL; + Resources.TakeInterest(s, eventType); + Events.Handler(eventType, NotificationHandler); + s.lock := FALSE; + END Init; - PROCEDURE Tie*(in, out: Stream); - (* PRE: `in' is an line buffered input stream, - `out' an output stream, - and `in' # `out'; - causes `out' to be flushed before reading from `in'; - `out' may be NIL to undo the effect - *) - BEGIN - in.error := FALSE; - IF in.bufmode # linebuf THEN - Error(in, NotLineBuffered); RETURN - END; - IF (in = out) OR ~(read IN in.caps) OR - (out # NIL) & ~(write IN out.caps) THEN - Error(in, BadParameters); RETURN - END; - in.tiedStream := out; - END Tie; - - PROCEDURE SetBufferPoolSize*(s: Stream; nbuf: INTEGER); - BEGIN - s.error := FALSE; - IF SYS.TAS(s.lock) THEN - Error(s, NestedCall); RETURN - END; - IF (s.bufmode = bufpool) & (nbuf >= 1) THEN - s.bufpool.maxbuf := nbuf; + PROCEDURE Send*(s: Stream; VAR message: Message); + BEGIN + IF ~SYS.TAS(s.lock) THEN + IF handler IN s.caps THEN + s.if.handler(s, message); + ELSE + Error(s, NoHandlerDefined); END; s.lock := FALSE; - END SetBufferPoolSize; + ELSE + Error(s, NestedCall); + END; + END Send; - PROCEDURE GetBufferPoolSize*(s: Stream; VAR nbuf: INTEGER); - BEGIN - s.error := FALSE; - CASE s.bufmode OF - | nobuf: nbuf := 0; - | linebuf: nbuf := 1; - | onebuf: nbuf := 1; - | bufpool: nbuf := s.bufpool.maxbuf; - ELSE (* Explicitly ignore unhandled values of s.bufmode *) + (* === private i/o procedures ================================= *) + + PROCEDURE ValidPos(s: Stream); + BEGIN + IF ~s.validpos THEN + IF tell IN s.caps THEN + IF ~s.if.tell(s, s.pos) OR (s.pos < 0) THEN + Error(s, TellFailed); + s.pos := 0; + END; + ELSE + s.pos := 0; END; - END GetBufferPoolSize; + s.rpos := s.pos; + s.validpos := TRUE; + s.left := 0; + s.write := 0; + END; + END ValidPos; - PROCEDURE Capabilities*(s: Stream) : CapabilitySet; - BEGIN - s.error := FALSE; - RETURN s.caps - END Capabilities; + PROCEDURE InitBuf(s: Stream); + BEGIN + IF s.bufmode = bufpool THEN + GetBuffer(s); + ELSE + s.buf.pos := s.pos - s.pos MOD bufsize; + s.buf.wbegin := s.pos MOD bufsize; + s.write := bufsize - s.buf.wbegin; + s.buf.wend := s.buf.wbegin; + s.buf.rbegin := s.buf.wbegin; + s.buf.rend := s.buf.wbegin; + s.left := 0; + s.buf.ok := TRUE; + END; + END InitBuf; - PROCEDURE GetFlushEvent*(s: Stream; VAR type: Events.EventType); - (* `type' will be raised BEFORE every flush operation *) - BEGIN - s.error := FALSE; - IF s.flushEvent = NIL THEN - Events.Define(s.flushEvent); - END; - type := s.flushEvent; - END GetFlushEvent; + PROCEDURE FillBuf(s: Stream) : BOOLEAN; + (* return FALSE on EOF or errors *) + VAR + offset, count: Count; + posindex: Count; (* s.pos MOD bufsize *) - PROCEDURE GetCloseEvent*(s: Stream; VAR type: Events.EventType); - (* `type' will be raised BEFORE the stream gets closed; - that means write operations etc. are legal + PROCEDURE Fill(s: Stream; VAR offset, count: Count) : BOOLEAN; + (* try to fill buf.cont[offset]..buf.cont[offset+count-1]; + return FALSE on EOF; + Fill always extends a read region: + s.buf.rend is set to offset + the number of bytes read *) - BEGIN - s.error := FALSE; - IF s.closeEvent = NIL THEN - Events.Define(s.closeEvent); - END; - type := s.closeEvent; - END GetCloseEvent; - - PROCEDURE Close*(s: Stream) : BOOLEAN; VAR - event: Event; - type: Events.EventType; - otherStream: Stream; - BEGIN - s.error := FALSE; - - IF (s.closeEvent # NIL) & ~SYS.TAS(s.lock) THEN - type := s.closeEvent; s.closeEvent := NIL; - s.lock := FALSE; - Events.SetPriority(type, Events.GetPriority() + 1); - NEW(event); - event.type := type; - event.message := "close event of Streams"; - event.stream := s; - Events.Raise(event); + linetermseen: BOOLEAN; + byte: Byte; + BEGIN + IF s.eofFound THEN + RETURN FALSE END; - - IF ~SYS.TAS(s.lock) THEN - IF write IN s.caps THEN - IF s.bufmode = bufpool THEN - IF ~FlushBufPool(s) THEN END; - ELSE - IF ~InternalFlush(s) THEN END; - END; - END; - IF close IN s.caps THEN - IF ~s.if.close(s) THEN - Error(s, CloseFailed); - END; - END; - IF s.buf # NIL THEN - IF s.bufmode = bufpool THEN - ReleaseBufPool(s); - END; - OldBuffer(s.buf); - END; - OldStream(s); - - (* check if this stream has been tied to another stream *) - otherStream := opened; - WHILE otherStream # NIL DO - IF otherStream.tiedStream = s THEN - otherStream.tiedStream := NIL; (* undo tie operation *) - END; - otherStream := otherStream.next; - END; - (* s.lock remains TRUE to prevent further operations *) - Resources.Notify(s, Resources.terminated); - RETURN ~s.error - ELSE - Error(s, NestedCall); - RETURN FALSE - END; - END Close; - - PROCEDURE Release*(s: Stream); - BEGIN - IF ~Close(s) THEN END; - END Release; - - PROCEDURE CloseAll*; - BEGIN - WHILE opened # NIL DO - (* that's no endless loop; see Close/OldStream *) - Release(opened); - END; - END CloseAll; - - PROCEDURE NotificationHandler(event: Events.Event); - VAR - s: Stream; - BEGIN - IF ~(event IS Resources.Event) THEN RETURN END; - WITH event: Resources.Event DO - IF ~(event.resource IS Stream) THEN RETURN END; - s := event.resource(Stream); - IF event.change IN {Resources.unreferenced, Resources.terminated} THEN - IF ~s.lock THEN - Release(s); - END; - END; - END; - END NotificationHandler; - - PROCEDURE Init*(s: Stream; if: Interface; caps: CapabilitySet; - bufmode: BufMode); - - VAR - eventType: Events.EventType; - type: Services.Type; - - PROCEDURE InitBidirectionalBuffering(s: Stream); - BEGIN - s.validpos := TRUE; - s.pos := 0; - NewBuffer(s.wbuf); - s.buf.ok := TRUE; s.buf.rbegin := 0; s.buf.rend := 0; s.buf.pos := 0; - s.wbuf.ok := TRUE; s.wbuf.wbegin := 0; s.wbuf.wend := 0; - s.wbuf.pos := 0; - s.left := 0; s.write := bufsize; - END InitBidirectionalBuffering; - - BEGIN - ASSERT((s # NIL) & (if # NIL) & ({read, write} * caps # {})); - Services.GetType(s, type); ASSERT(type # NIL); - s.inlist := (close IN caps) OR (bufmode # nobuf) & (write IN caps); - NewStream(s); - (* initialize public part *) - s.count := 0; - s.errors := 0; - s.error := FALSE; - s.lasterror := 0; - s.eof := FALSE; - (* private part *) - s.if := if; s.caps := caps; - s.bufmode := bufmode; - s.validpos := FALSE; - s.left := 0; s.write := 0; - s.tiedStream := NIL; - IF bufmode IN {linebuf, onebuf, bufpool} THEN - NewBuffer(s.buf); - IF (bufmode = bufpool) & ~(seek IN caps) THEN - bufmode := onebuf; - END; - CASE bufmode OF - | linebuf: s.termch := defaulttermch; - | bufpool: NEW(s.bufpool); InitBufPool(s); - ELSE - END; - s.maxpos := 0; - s.wextensible := {read, write, seek, tell, holes} * caps = - {read, write, seek, tell}; - s.bidirect := {read, write, seek, tell, trunc} * caps = {read, write}; - IF s.bidirect THEN - InitBidirectionalBuffering(s); - ELSE - s.wbuf := NIL; - END; - ELSE - s.buf := NIL; - s.wbuf := NIL; - s.wextensible := FALSE; - s.bidirect := FALSE; - END; - s.flushEvent := NIL; - s.closeEvent := NIL; - Resources.TakeInterest(s, eventType); - Events.Handler(eventType, NotificationHandler); - s.lock := FALSE; - END Init; - - PROCEDURE Send*(s: Stream; VAR message: Message); - BEGIN - IF ~SYS.TAS(s.lock) THEN - IF handler IN s.caps THEN - s.if.handler(s, message); - ELSE - Error(s, NoHandlerDefined); - END; - s.lock := FALSE; - ELSE - Error(s, NestedCall); - END; - END Send; - - (* === private i/o procedures ================================= *) - - PROCEDURE ValidPos(s: Stream); - BEGIN - IF ~s.validpos THEN - IF tell IN s.caps THEN - IF ~s.if.tell(s, s.pos) OR (s.pos < 0) THEN - Error(s, TellFailed); - s.pos := 0; - END; - ELSE - s.pos := 0; - END; - s.rpos := s.pos; - s.validpos := TRUE; - s.left := 0; - s.write := 0; - END; - END ValidPos; - - PROCEDURE InitBuf(s: Stream); - BEGIN - IF s.bufmode = bufpool THEN - GetBuffer(s); - ELSE - s.buf.pos := s.pos - s.pos MOD bufsize; - s.buf.wbegin := s.pos MOD bufsize; - s.write := bufsize - s.buf.wbegin; - s.buf.wend := s.buf.wbegin; - s.buf.rbegin := s.buf.wbegin; - s.buf.rend := s.buf.wbegin; - s.left := 0; - s.buf.ok := TRUE; - END; - END InitBuf; - - PROCEDURE FillBuf(s: Stream) : BOOLEAN; - (* return FALSE on EOF or errors *) - VAR - offset, count: Count; - posindex: Count; (* s.pos MOD bufsize *) - - PROCEDURE Fill(s: Stream; VAR offset, count: Count) : BOOLEAN; - (* try to fill buf.cont[offset]..buf.cont[offset+count-1]; - return FALSE on EOF; - Fill always extends a read region: - s.buf.rend is set to offset + the number of bytes read - *) - VAR - linetermseen: BOOLEAN; - byte: Byte; - BEGIN - IF s.eofFound THEN - RETURN FALSE - END; - IF addrio IN s.caps THEN - s.buf.rend := s.if.addrread(s, SYSTEM.ADR(s.buf.cont[offset]), count) + - offset; - ELSIF bufio IN s.caps THEN - s.buf.rend := s.if.bufread(s, s.buf.cont, offset, count) + offset; - ELSIF s.bufmode = linebuf THEN - s.buf.rend := offset; linetermseen := FALSE; - WHILE ~linetermseen & (s.buf.rend < offset+count) & - s.if.read(s, byte) DO - s.buf.cont[s.buf.rend] := byte; INC(s.buf.rend); - linetermseen := byte = s.termch; - END; - s.eofFound := ~linetermseen & - (s.buf.rend < offset+count); (* s.if.read failed? *) - ELSE - s.buf.rend := offset; - WHILE (s.buf.rend < offset+count) & - s.if.read(s, s.buf.cont[s.buf.rend]) DO - INC(s.buf.rend); - END; - s.eofFound := s.buf.rend < offset+count; (* s.if.read failed? *) - END; - (* negative counts of addrread or bufread indicate read errors *) - IF s.buf.rend < offset THEN - (* note error and recover s.buf.rend *) - Error(s, ReadFailed); - s.buf.rend := offset; - END; - INC(s.rpos, s.buf.rend - offset); - IF s.buf.rend > offset THEN - DEC(count, s.buf.rend - offset); - offset := s.buf.rend; - RETURN TRUE - ELSE - s.eofFound := TRUE; - RETURN FALSE - END; - END Fill; - - BEGIN (* FillBuf *) - ValidPos(s); - posindex := s.pos MOD bufsize; - s.eofFound := FALSE; - - (* flush associated output streams (line buffered streams only) *) - IF s.bufmode = linebuf THEN - IF write IN s.caps THEN - IF ~InternalFlush(s) THEN END; - END; - IF (s.tiedStream # NIL) & ~SYS.TAS(s.tiedStream.lock) THEN - IF ~InternalFlush(s.tiedStream) THEN END; - s.tiedStream.lock := FALSE; - END; - END; - - (* get a valid buffer and set - offset and count to the buffer range which is to be filled; - on default, we want to fill the whole buffer - *) - offset := 0; count := bufsize; (* default *) - IF ~s.buf.ok THEN - InitBuf(s); - ELSIF s.bidirect THEN - s.buf.rbegin := 0; s.buf.rend := 0; s.pos := 0; posindex := 0; - ELSE - IF s.bufmode = bufpool THEN - GetBuffer(s); - IF s.left > 0 THEN - (* buffer is already filled *) - s.eof := FALSE; RETURN TRUE - END; - ELSIF s.buf.pos # s.pos - posindex THEN - (* reuse filled buffer *) - IF write IN s.caps THEN - IF ~InternalFlush(s) THEN END; - END; - InitBuf(s); - END; - IF s.buf.rbegin # s.buf.rend THEN - IF (write IN s.caps) & - (s.buf.wbegin <= posindex) & (s.buf.wend > posindex) THEN - (* set read region to write region *) - s.buf.rbegin := s.buf.wbegin; s.buf.rend := s.buf.wend; - s.left := s.buf.wend - posindex; - s.eof := FALSE; RETURN TRUE - ELSIF s.buf.rend = posindex THEN - (* stream position equals end of read region *) - offset := s.buf.rend; count := bufsize - offset; - END; - END; - - (* take care of the write region by limiting count; - note that s.pos does *not* point into the write region; - this is guaranteed by WritePart and other operations - which would have extended the read region in such a case - *) - IF (write IN s.caps) & (s.buf.wbegin # s.buf.wend) THEN - IF s.buf.wbegin >= offset THEN - IF s.buf.wbegin > posindex THEN - (* write-region behind current position *) - count := s.buf.wbegin - offset; - ELSE - (* write-region before current position *) - offset := s.buf.wend; count := bufsize - offset; - END; - END; - IF (s.buf.pos + s.buf.wbegin = s.rpos) & ~(seek IN s.caps) THEN - (* flush if the start of write region corresponds to real - file position and we are not able to change the position - *) - IF ~InternalFlush(s) THEN END; - END; - END; - END; - - (* set the real position to the position we want to read from *) - IF ~s.bidirect & (s.buf.pos + offset # s.rpos) THEN - IF (seek IN s.caps) & s.if.seek(s, s.buf.pos+offset, fromStart) THEN - s.rpos := s.buf.pos + offset; - ELSIF s.pos = s.rpos THEN - DEC(count, posindex - offset); - offset := posindex; - ELSIF seek IN s.caps THEN - Error(s, SeekFailed); RETURN FALSE - ELSE - Error(s, CannotSeek); RETURN FALSE - END; - END; - - (* try to fill buf[offset..offset+count-1]; - and set s.buf.rbegin & s.buf.rend to the new read region - *) - IF s.buf.rend # offset THEN - (* forget old read region if we cannot extend it *) - s.buf.rbegin := offset; s.buf.rend := offset; - END; - WHILE Fill(s, offset, count) & (posindex >= s.buf.rend) DO END; - - IF posindex >= s.buf.rend THEN - (* read operation failed *) - IF (s.pos > s.rpos) & - (seek IN s.caps) & s.if.seek(s, s.pos, fromStart) THEN - s.rpos := s.pos; - (* second try: we were not able to fill the whole buffer - but perhaps we are able to read what we were requested for - *) - DEC(count, posindex - offset); - offset := posindex; - s.buf.rbegin := offset; s.buf.rend := offset; - s.eofFound := FALSE; (* retry it *) - s.eof := ~Fill(s, offset, count); - ELSE - s.eof := TRUE; - END; - ELSE - s.eof := FALSE; - END; - - IF s.eof THEN - s.left := 0; - ELSE - s.left := s.buf.rend - posindex; - END; - - RETURN ~s.eof - END FillBuf; - - - (* ==== i/o operations ============================================== *) - - PROCEDURE ReadPart*(s: Stream; VAR buf: ARRAY OF Byte; - off, cnt: Count) : BOOLEAN; - (* fill buf[off..off+cnt-1] *) - - VAR - pos: Count; - partcnt: Count; - - PROCEDURE ReadBytesFromBuf(s: Stream; - VAR to: ARRAY OF Byte; - off, cnt: Count) : BOOLEAN; - VAR - bytes, max, spos: Count; - BEGIN - IF s.left = 0 THEN - IF s.eofFound OR ~FillBuf(s) THEN RETURN FALSE END; - END; - spos := s.pos MOD bufsize; - max := s.left; - IF max > cnt THEN - max := cnt; - END; - bytes := 0; - WHILE bytes < max DO - to[off] := s.buf.cont[spos]; - INC(off); INC(spos); INC(bytes); - END; - INC(s.pos, bytes); DEC(s.left, bytes); INC(s.count, bytes); - IF ~s.bidirect THEN - IF s.write >= bytes THEN - DEC(s.write, bytes); - ELSE - s.write := 0; - END; - END; - RETURN TRUE - END ReadBytesFromBuf; - - BEGIN (* ReadPart *) - IF SYS.TAS(s.lock) THEN - Error(s, NestedCall); - RETURN FALSE - END; - s.error := FALSE; s.count := 0; - IF ~(read IN s.caps) THEN - s.lock := FALSE; Error(s, CannotRead); RETURN FALSE - ELSIF (off < 0) OR (off+cnt > LEN(buf)) OR (cnt < 0) THEN - s.lock := FALSE; Error(s, BadParameters); RETURN FALSE - END; - IF cnt = 0 THEN s.lock := FALSE; RETURN TRUE END; - IF s.buf # NIL THEN - s.eofFound := FALSE; - WHILE (s.count < cnt) & - ReadBytesFromBuf(s, buf, s.count + off, cnt - s.count) DO - (* s.count is already incremented by ReadBytesFromBuf *) - END; - (* extend write region, if necessary *) - IF ~s.bidirect THEN - pos := s.pos MOD bufsize; - IF (s.write > 0) & (s.buf.wend < pos) THEN - IF s.buf.wbegin = s.buf.wend THEN - s.buf.wbegin := pos; - END; - s.buf.wend := pos; - END; - END; - ELSE - IF addrio IN s.caps THEN - s.count := s.if.addrread(s, SYSTEM.ADR(buf[off]), cnt); - IF (s.count > 0) & (s.count < cnt) THEN - LOOP - partcnt := s.if.addrread(s, - SYSTEM.ADR(buf[off + s.count]), cnt - s.count); - IF (partcnt < 0) OR (partcnt = 0) THEN EXIT END; - ASSERT(partcnt <= cnt - s.count); - INC(s.count, partcnt); - IF s.count = cnt THEN EXIT END; - END; - END; - ELSIF bufio IN s.caps THEN - s.count := s.if.bufread(s, buf, off, cnt); - IF (s.count > 0) & (s.count < cnt) THEN - LOOP - partcnt := s.if.bufread(s, buf, off + s.count, cnt - s.count); - IF (partcnt < 0) OR (partcnt = 0) THEN EXIT END; - ASSERT(partcnt <= cnt - s.count); - INC(s.count, partcnt); - IF s.count = cnt THEN EXIT END; - END; - END; - ELSE - s.count := 0; - WHILE (s.count < cnt) & s.if.read(s, buf[s.count+off]) DO - INC(s.count); - END; - END; - IF s.count < 0 THEN - s.count := 0; - Error(s, ReadFailed); - ELSE - s.eof := s.count = 0; - END; - END; - s.lock := FALSE; - RETURN s.count = cnt - END ReadPart; - - PROCEDURE Read*(s: Stream; VAR buf: ARRAY OF Byte) : BOOLEAN; - BEGIN - RETURN ReadPart(s, buf, 0, LEN(buf)) - END Read; - - PROCEDURE ReadByte*(s: Stream; VAR byte: Byte) : BOOLEAN; - VAR - ok: BOOLEAN; - pos: Count; - BEGIN - IF SYS.TAS(s.lock) THEN - Error(s, NestedCall); RETURN FALSE - END; - s.error := FALSE; - IF s.left = 0 THEN - IF ~(read IN s.caps) THEN - s.lock := FALSE; Error(s, CannotRead); s.count := 0; RETURN FALSE - END; - IF s.buf # NIL THEN - IF ~FillBuf(s) THEN - (* FillBuf sets s.eof *) - s.lock := FALSE; - s.count := 0; - RETURN FALSE - END; - ELSE - ok := s.if.read(s, byte); - IF ok THEN - s.count := 1; - ELSE - s.count := 0; - END; - s.eof := ~ok; - s.lock := FALSE; - RETURN ok - END; - END; - (* s.left > 0 *) - s.count := 1; - byte := s.buf.cont[s.pos MOD bufsize]; - INC(s.pos); DEC(s.left); - IF ~s.bidirect & (s.write # 0) THEN - DEC(s.write); - pos := s.pos MOD bufsize; - IF s.buf.wend < pos THEN - IF s.buf.wbegin = s.buf.wend THEN - s.buf.wbegin := pos; - END; - s.buf.wend := pos; - END; - END; - (* s.eof has been set by FillBuf *) - s.lock := FALSE; - RETURN TRUE - END ReadByte; - - PROCEDURE ReadPacket*(s: Stream; VAR buf: ARRAY OF Byte; - off, maxcnt: Count) : Count; - (* fill buf[off..] with next packet *) - BEGIN - IF s.left > 0 THEN - IF maxcnt > s.left THEN - maxcnt := s.left; - END; - IF ReadPart(s, buf, off, maxcnt) THEN END; - RETURN s.count - END; - - IF SYS.TAS(s.lock) THEN - Error(s, NestedCall); - s.count := 0; - RETURN 0 - END; - s.error := FALSE; s.count := 0; - IF ~(read IN s.caps) THEN - s.lock := FALSE; Error(s, CannotRead); s.count := 0; RETURN 0 - ELSIF (off < 0) OR (off+maxcnt > LEN(buf)) OR (maxcnt < 0) THEN - s.lock := FALSE; Error(s, BadParameters); s.count := 0; RETURN 0 - END; - IF maxcnt = 0 THEN s.lock := FALSE; RETURN 0 END; - - IF s.buf # NIL THEN - (* s.left = 0 *) - IF ~FillBuf(s) THEN - (* FillBuf sets s.eof *) - s.lock := FALSE; - RETURN 0 - END; - s.lock := FALSE; - IF maxcnt > s.left THEN - maxcnt := s.left; - END; - IF ReadPart(s, buf, off, maxcnt) THEN END; - RETURN s.count - END; - - (* s.buf = NIL *) IF addrio IN s.caps THEN - s.count := s.if.addrread(s, SYSTEM.ADR(buf[off]), maxcnt); + s.buf.rend := s.if.addrread(s, SYSTEM.ADR(s.buf.cont[offset]), count) + + offset; ELSIF bufio IN s.caps THEN - s.count := s.if.bufread(s, buf, off, maxcnt); + s.buf.rend := s.if.bufread(s, s.buf.cont, offset, count) + offset; + ELSIF s.bufmode = linebuf THEN + s.buf.rend := offset; linetermseen := FALSE; + WHILE ~linetermseen & (s.buf.rend < offset+count) & + s.if.read(s, byte) DO + s.buf.cont[s.buf.rend] := byte; INC(s.buf.rend); + linetermseen := byte = s.termch; + END; + s.eofFound := ~linetermseen & + (s.buf.rend < offset+count); (* s.if.read failed? *) ELSE - s.count := 0; - WHILE (s.count < maxcnt) & s.if.read(s, buf[s.count+off]) DO - INC(s.count); - END; + s.buf.rend := offset; + WHILE (s.buf.rend < offset+count) & + s.if.read(s, s.buf.cont[s.buf.rend]) DO + INC(s.buf.rend); + END; + s.eofFound := s.buf.rend < offset+count; (* s.if.read failed? *) + END; + (* negative counts of addrread or bufread indicate read errors *) + IF s.buf.rend < offset THEN + (* note error and recover s.buf.rend *) + Error(s, ReadFailed); + s.buf.rend := offset; + END; + INC(s.rpos, s.buf.rend - offset); + IF s.buf.rend > offset THEN + DEC(count, s.buf.rend - offset); + offset := s.buf.rend; + RETURN TRUE + ELSE + s.eofFound := TRUE; + RETURN FALSE + END; + END Fill; + + BEGIN (* FillBuf *) + ValidPos(s); + posindex := s.pos MOD bufsize; + s.eofFound := FALSE; + + (* flush associated output streams (line buffered streams only) *) + IF s.bufmode = linebuf THEN + IF write IN s.caps THEN + IF ~InternalFlush(s) THEN END; + END; + IF (s.tiedStream # NIL) & ~SYS.TAS(s.tiedStream.lock) THEN + IF ~InternalFlush(s.tiedStream) THEN END; + s.tiedStream.lock := FALSE; + END; + END; + + (* get a valid buffer and set + offset and count to the buffer range which is to be filled; + on default, we want to fill the whole buffer + *) + offset := 0; count := bufsize; (* default *) + IF ~s.buf.ok THEN + InitBuf(s); + ELSIF s.bidirect THEN + s.buf.rbegin := 0; s.buf.rend := 0; s.pos := 0; posindex := 0; + ELSE + IF s.bufmode = bufpool THEN + GetBuffer(s); + IF s.left > 0 THEN + (* buffer is already filled *) + s.eof := FALSE; RETURN TRUE + END; + ELSIF s.buf.pos # s.pos - posindex THEN + (* reuse filled buffer *) + IF write IN s.caps THEN + IF ~InternalFlush(s) THEN END; + END; + InitBuf(s); + END; + IF s.buf.rbegin # s.buf.rend THEN + IF (write IN s.caps) & + (s.buf.wbegin <= posindex) & (s.buf.wend > posindex) THEN + (* set read region to write region *) + s.buf.rbegin := s.buf.wbegin; s.buf.rend := s.buf.wend; + s.left := s.buf.wend - posindex; + s.eof := FALSE; RETURN TRUE + ELSIF s.buf.rend = posindex THEN + (* stream position equals end of read region *) + offset := s.buf.rend; count := bufsize - offset; + END; + END; + + (* take care of the write region by limiting count; + note that s.pos does *not* point into the write region; + this is guaranteed by WritePart and other operations + which would have extended the read region in such a case + *) + IF (write IN s.caps) & (s.buf.wbegin # s.buf.wend) THEN + IF s.buf.wbegin >= offset THEN + IF s.buf.wbegin > posindex THEN + (* write-region behind current position *) + count := s.buf.wbegin - offset; + ELSE + (* write-region before current position *) + offset := s.buf.wend; count := bufsize - offset; + END; + END; + IF (s.buf.pos + s.buf.wbegin = s.rpos) & ~(seek IN s.caps) THEN + (* flush if the start of write region corresponds to real + file position and we are not able to change the position + *) + IF ~InternalFlush(s) THEN END; + END; + END; + END; + + (* set the real position to the position we want to read from *) + IF ~s.bidirect & (s.buf.pos + offset # s.rpos) THEN + IF (seek IN s.caps) & s.if.seek(s, s.buf.pos+offset, fromStart) THEN + s.rpos := s.buf.pos + offset; + ELSIF s.pos = s.rpos THEN + DEC(count, posindex - offset); + offset := posindex; + ELSIF seek IN s.caps THEN + Error(s, SeekFailed); RETURN FALSE + ELSE + Error(s, CannotSeek); RETURN FALSE + END; + END; + + (* try to fill buf[offset..offset+count-1]; + and set s.buf.rbegin & s.buf.rend to the new read region + *) + IF s.buf.rend # offset THEN + (* forget old read region if we cannot extend it *) + s.buf.rbegin := offset; s.buf.rend := offset; + END; + WHILE Fill(s, offset, count) & (posindex >= s.buf.rend) DO END; + + IF posindex >= s.buf.rend THEN + (* read operation failed *) + IF (s.pos > s.rpos) & + (seek IN s.caps) & s.if.seek(s, s.pos, fromStart) THEN + s.rpos := s.pos; + (* second try: we were not able to fill the whole buffer + but perhaps we are able to read what we were requested for + *) + DEC(count, posindex - offset); + offset := posindex; + s.buf.rbegin := offset; s.buf.rend := offset; + s.eofFound := FALSE; (* retry it *) + s.eof := ~Fill(s, offset, count); + ELSE + s.eof := TRUE; + END; + ELSE + s.eof := FALSE; + END; + + IF s.eof THEN + s.left := 0; + ELSE + s.left := s.buf.rend - posindex; + END; + + RETURN ~s.eof + END FillBuf; + + + (* ==== i/o operations ============================================== *) + + PROCEDURE ReadPart*(s: Stream; VAR buf: ARRAY OF Byte; + off, cnt: Count) : BOOLEAN; + (* fill buf[off..off+cnt-1] *) + + VAR + pos: Count; + partcnt: Count; + + PROCEDURE ReadBytesFromBuf(s: Stream; + VAR to: ARRAY OF Byte; + off, cnt: Count) : BOOLEAN; + VAR + bytes, max, spos: Count; + BEGIN + IF s.left = 0 THEN + IF s.eofFound OR ~FillBuf(s) THEN RETURN FALSE END; + END; + spos := s.pos MOD bufsize; + max := s.left; + IF max > cnt THEN + max := cnt; + END; + bytes := 0; + WHILE bytes < max DO + to[off] := s.buf.cont[spos]; + INC(off); INC(spos); INC(bytes); + END; + INC(s.pos, bytes); DEC(s.left, bytes); INC(s.count, bytes); + IF ~s.bidirect THEN + IF s.write >= bytes THEN + DEC(s.write, bytes); + ELSE + s.write := 0; + END; + END; + RETURN TRUE + END ReadBytesFromBuf; + + BEGIN (* ReadPart *) + IF SYS.TAS(s.lock) THEN + Error(s, NestedCall); + RETURN FALSE + END; + s.error := FALSE; s.count := 0; + IF ~(read IN s.caps) THEN + s.lock := FALSE; Error(s, CannotRead); RETURN FALSE + ELSIF (off < 0) OR (off+cnt > LEN(buf)) OR (cnt < 0) THEN + s.lock := FALSE; Error(s, BadParameters); RETURN FALSE + END; + IF cnt = 0 THEN s.lock := FALSE; RETURN TRUE END; + IF s.buf # NIL THEN + s.eofFound := FALSE; + WHILE (s.count < cnt) & + ReadBytesFromBuf(s, buf, s.count + off, cnt - s.count) DO + (* s.count is already incremented by ReadBytesFromBuf *) + END; + (* extend write region, if necessary *) + IF ~s.bidirect THEN + pos := s.pos MOD bufsize; + IF (s.write > 0) & (s.buf.wend < pos) THEN + IF s.buf.wbegin = s.buf.wend THEN + s.buf.wbegin := pos; + END; + s.buf.wend := pos; + END; + END; + ELSE + IF addrio IN s.caps THEN + s.count := s.if.addrread(s, SYSTEM.ADR(buf[off]), cnt); + IF (s.count > 0) & (s.count < cnt) THEN + LOOP + partcnt := s.if.addrread(s, + SYSTEM.ADR(buf[off + s.count]), cnt - s.count); + IF (partcnt < 0) OR (partcnt = 0) THEN EXIT END; + ASSERT(partcnt <= cnt - s.count); + INC(s.count, partcnt); + IF s.count = cnt THEN EXIT END; + END; + END; + ELSIF bufio IN s.caps THEN + s.count := s.if.bufread(s, buf, off, cnt); + IF (s.count > 0) & (s.count < cnt) THEN + LOOP + partcnt := s.if.bufread(s, buf, off + s.count, cnt - s.count); + IF (partcnt < 0) OR (partcnt = 0) THEN EXIT END; + ASSERT(partcnt <= cnt - s.count); + INC(s.count, partcnt); + IF s.count = cnt THEN EXIT END; + END; + END; + ELSE + s.count := 0; + WHILE (s.count < cnt) & s.if.read(s, buf[s.count+off]) DO + INC(s.count); + END; END; IF s.count < 0 THEN - s.count := 0; - Error(s, ReadFailed); + s.count := 0; + Error(s, ReadFailed); ELSE - s.eof := s.count = 0; + s.eof := s.count = 0; END; - s.lock := FALSE; - RETURN s.count - END ReadPacket; + END; + s.lock := FALSE; + RETURN s.count = cnt + END ReadPart; - PROCEDURE WritePart*(s: Stream; - (* read-only *) VAR buf: ARRAY OF Byte; - off, cnt: Count) : BOOLEAN; - (* write buf[off..off+cnt-1] to s *) - VAR - posindex: Count; + PROCEDURE Read*(s: Stream; VAR buf: ARRAY OF Byte) : BOOLEAN; + BEGIN + RETURN ReadPart(s, buf, 0, LEN(buf)) + END Read; - PROCEDURE NewBuffer(s: Stream) : BOOLEAN; - (* flush and get new buffer *) - BEGIN - IF s.pos - posindex # s.buf.pos THEN - IF s.bufmode # bufpool THEN - IF ~InternalFlush(s) THEN RETURN FALSE END; - END; - InitBuf(s); - IF s.write # 0 THEN RETURN TRUE END; - END; - IF s.buf.wbegin = s.buf.wend THEN - (* nothing written into this buffer until now *) - s.buf.wbegin := posindex; s.buf.wend := posindex; - s.write := bufsize - posindex; - ELSIF s.wextensible & (s.buf.rbegin # s.buf.rend) THEN - (* check if the write region may be extended - over parts of the read region - *) - IF s.buf.wend < posindex THEN - (* write region before current position *) - IF (s.buf.rbegin <= s.buf.wend) & (s.buf.rend >= posindex) THEN - s.buf.wend := posindex; - s.write := bufsize - posindex; - END; - ELSE (* s.wbegin > posindex *) - (* write region after current position *) - IF (s.buf.rbegin <= posindex) & (s.buf.rend >= s.buf.wbegin) THEN - s.buf.wbegin := posindex; - s.write := bufsize - posindex; - END; - END; - END; - IF (* still *) s.write = 0 THEN - (* Flush necessary *) - IF ~InternalFlush(s) THEN RETURN FALSE END; - s.buf.wbegin := posindex; s.buf.wend := posindex; - s.write := bufsize - posindex; - END; - RETURN TRUE - END NewBuffer; - - PROCEDURE UpdateReadRegion(s: Stream); - BEGIN - (* update s.left and extend read region, if possible *) - IF s.buf.rbegin = s.buf.rend THEN - (* set read region to write region *) - s.buf.rbegin := s.buf.wbegin; s.buf.rend := s.buf.wend; - s.left := s.buf.rend - posindex; - ELSIF (s.buf.rbegin < s.buf.wbegin) & (s.buf.rend >= s.buf.wbegin) THEN - (* forward extension of read region possible *) - IF s.buf.rend < s.buf.wend THEN - s.buf.rend := s.buf.wend; - END; - s.left := s.buf.rend - posindex; - ELSIF (s.buf.rbegin <= s.buf.wend) & (s.buf.rend > s.buf.wend) THEN - (* backward extension of read region possible *) - IF s.buf.rbegin > s.buf.wbegin THEN - s.buf.rbegin := s.buf.wend; - END; - s.left := s.buf.rend - posindex; - ELSE - (* posindex does not fall into [s.buf.rbegin..s.buf.rend-1] *) - s.left := 0; - END; - IF s.pos = s.buf.pos + bufsize THEN - s.left := 0; - END; - END UpdateReadRegion; - - BEGIN - IF SYS.TAS(s.lock) THEN - Error(s, NestedCall); RETURN FALSE + PROCEDURE ReadByte*(s: Stream; VAR byte: Byte) : BOOLEAN; + VAR + ok: BOOLEAN; + pos: Count; + BEGIN + IF SYS.TAS(s.lock) THEN + Error(s, NestedCall); RETURN FALSE + END; + s.error := FALSE; + IF s.left = 0 THEN + IF ~(read IN s.caps) THEN + s.lock := FALSE; Error(s, CannotRead); s.count := 0; RETURN FALSE END; - s.error := FALSE; s.count := 0; - IF ~(write IN s.caps) THEN - s.lock := FALSE; Error(s, CannotWrite); RETURN FALSE - ELSIF (off < 0) OR (off+cnt > LEN(buf)) OR (cnt < 0) THEN - s.lock := FALSE; Error(s, BadParameters); RETURN FALSE - ELSIF cnt = 0 THEN - s.lock := FALSE; RETURN TRUE - END; - IF s.buf # NIL THEN - IF s.bidirect THEN - WHILE s.count < cnt DO - IF (s.write = 0) & ~InternalFlush(s) THEN - s.lock := FALSE; RETURN FALSE - END; - s.wbuf.cont[s.wbuf.wend] := buf[off + s.count]; - INC(s.wbuf.wend); INC(s.count); DEC(s.write); - IF (s.bufmode = linebuf) & - (buf[s.count+off-1] = s.termch) THEN - IF ~InternalFlush(s) THEN - s.lock := FALSE; RETURN FALSE - END; - END; - END; - ELSE - ValidPos(s); - posindex := s.pos MOD bufsize; - IF ~s.buf.ok THEN - InitBuf(s); - END; + IF ~FillBuf(s) THEN + (* FillBuf sets s.eof *) + s.lock := FALSE; + s.count := 0; + RETURN FALSE + END; + ELSE + ok := s.if.read(s, byte); + IF ok THEN + s.count := 1; + ELSE + s.count := 0; + END; + s.eof := ~ok; + s.lock := FALSE; + RETURN ok + END; + END; + (* s.left > 0 *) + s.count := 1; + byte := s.buf.cont[s.pos MOD bufsize]; + INC(s.pos); DEC(s.left); + IF ~s.bidirect & (s.write # 0) THEN + DEC(s.write); + pos := s.pos MOD bufsize; + IF s.buf.wend < pos THEN + IF s.buf.wbegin = s.buf.wend THEN + s.buf.wbegin := pos; + END; + s.buf.wend := pos; + END; + END; + (* s.eof has been set by FillBuf *) + s.lock := FALSE; + RETURN TRUE + END ReadByte; - (* copy from buf to s.buf *) - WHILE s.count < cnt DO - IF s.write = 0 THEN - posindex := s.pos MOD bufsize; - IF s.count > 0 THEN - UpdateReadRegion(s); - END; - IF ~NewBuffer(s) THEN - s.lock := FALSE; RETURN FALSE - END; - END; - s.buf.cont[posindex] := buf[off + s.count]; - IF s.buf.wend = posindex THEN - INC(s.buf.wend); - END; - INC(s.count); INC(s.pos); DEC(s.write); INC(posindex); - IF (s.bufmode = linebuf) & - (buf[s.count+off-1] = s.termch) THEN - UpdateReadRegion(s); - IF ~InternalFlush(s) THEN - s.lock := FALSE; RETURN FALSE - END; - (* s.pos can be changed by InternalFlush *) - posindex := s.pos MOD bufsize; - END; - END; - UpdateReadRegion(s); - END; - ELSE (* unbuffered stream *) - IF addrio IN s.caps THEN - s.count := s.if.addrwrite(s, SYSTEM.ADR(buf[off]), cnt); - ELSIF bufio IN s.caps THEN - s.count := s.if.bufwrite(s, buf, off, cnt); - ELSE - s.count := 0; - WHILE (s.count < cnt) & s.if.write(s, buf[off+s.count]) DO - INC(s.count); - END; - END; - IF s.count # cnt THEN - Error(s, WriteFailed); - END; + PROCEDURE ReadPacket*(s: Stream; VAR buf: ARRAY OF Byte; + off, maxcnt: Count) : Count; + (* fill buf[off..] with next packet *) + BEGIN + IF s.left > 0 THEN + IF maxcnt > s.left THEN + maxcnt := s.left; + END; + IF ReadPart(s, buf, off, maxcnt) THEN END; + RETURN s.count + END; + + IF SYS.TAS(s.lock) THEN + Error(s, NestedCall); + s.count := 0; + RETURN 0 + END; + s.error := FALSE; s.count := 0; + IF ~(read IN s.caps) THEN + s.lock := FALSE; Error(s, CannotRead); s.count := 0; RETURN 0 + ELSIF (off < 0) OR (off+maxcnt > LEN(buf)) OR (maxcnt < 0) THEN + s.lock := FALSE; Error(s, BadParameters); s.count := 0; RETURN 0 + END; + IF maxcnt = 0 THEN s.lock := FALSE; RETURN 0 END; + + IF s.buf # NIL THEN + (* s.left = 0 *) + IF ~FillBuf(s) THEN + (* FillBuf sets s.eof *) + s.lock := FALSE; + RETURN 0 END; s.lock := FALSE; - RETURN s.count = cnt - END WritePart; - - PROCEDURE Write*(s: Stream; - (* read-only *) VAR buf: ARRAY OF Byte) : BOOLEAN; - BEGIN - RETURN WritePart(s, buf, 0, LEN(buf)) - END Write; - - PROCEDURE WritePartC*(s: Stream; buf: ARRAY OF Byte; - off, cnt: Count) : BOOLEAN; - (* write buf[off..off+cnt-1] to s *) - BEGIN - RETURN WritePart(s, buf, off, cnt) - END WritePartC; - - PROCEDURE WriteC*(s: Stream; buf: ARRAY OF Byte) : BOOLEAN; - BEGIN - RETURN WritePart(s, buf, 0, LEN(buf)) - END WriteC; - - PROCEDURE WriteByte*(s: Stream; byte: Byte) : BOOLEAN; - VAR - posindex: Count; - BEGIN - IF (s.write > 0) & ~SYS.TAS(s.lock) THEN - s.error := FALSE; s.count := 1; - - IF s.bidirect THEN - s.wbuf.cont[s.wbuf.wend] := byte; INC(s.wbuf.wend); DEC(s.write); - ELSE - (* put byte into s.buf *) - posindex := s.pos MOD bufsize; - s.buf.cont[posindex] := byte; - IF s.buf.wend = posindex THEN - INC(s.buf.wend); - END; - DEC(s.write); - - (* update s.buf.rend and s.left, if necessary *) - IF s.buf.rend = posindex THEN - INC(s.buf.rend); - END; - IF s.left # 0 THEN - DEC(s.left); - ELSIF s.buf.rbegin = s.buf.rend THEN - (* set read-region to write-region *) - s.buf.rbegin := s.buf.wbegin; s.buf.rend := s.buf.wend; - s.left := s.buf.wend - posindex; - END; - - INC(s.pos); - END; - - IF (s.bufmode = linebuf) & (byte = s.termch) THEN - IF ~InternalFlush(s) THEN - s.lock := FALSE; RETURN FALSE - END; - IF ~s.bidirect THEN - s.buf.wbegin := s.pos MOD bufsize; - END; - END; - - s.lock := FALSE; RETURN TRUE - ELSE - RETURN WritePart(s, byte, 0, 1) + IF maxcnt > s.left THEN + maxcnt := s.left; END; - END WriteByte; + IF ReadPart(s, buf, off, maxcnt) THEN END; + RETURN s.count + END; - PROCEDURE InternalSeek(s: Stream; offset: Count; whence: Whence) : BOOLEAN; - VAR - oldpos: Count; pos: Count; - BEGIN - s.error := FALSE; + (* s.buf = NIL *) + IF addrio IN s.caps THEN + s.count := s.if.addrread(s, SYSTEM.ADR(buf[off]), maxcnt); + ELSIF bufio IN s.caps THEN + s.count := s.if.bufread(s, buf, off, maxcnt); + ELSE + s.count := 0; + WHILE (s.count < maxcnt) & s.if.read(s, buf[s.count+off]) DO + INC(s.count); + END; + END; + IF s.count < 0 THEN + s.count := 0; + Error(s, ReadFailed); + ELSE + s.eof := s.count = 0; + END; + s.lock := FALSE; + RETURN s.count + END ReadPacket; + + PROCEDURE WritePart*(s: Stream; + (* read-only *) VAR buf: ARRAY OF Byte; + off, cnt: Count) : BOOLEAN; + (* write buf[off..off+cnt-1] to s *) + VAR + posindex: Count; + + PROCEDURE NewBuffer(s: Stream) : BOOLEAN; + (* flush and get new buffer *) + BEGIN + IF s.pos - posindex # s.buf.pos THEN + IF s.bufmode # bufpool THEN + IF ~InternalFlush(s) THEN RETURN FALSE END; + END; + InitBuf(s); + IF s.write # 0 THEN RETURN TRUE END; + END; + IF s.buf.wbegin = s.buf.wend THEN + (* nothing written into this buffer until now *) + s.buf.wbegin := posindex; s.buf.wend := posindex; + s.write := bufsize - posindex; + ELSIF s.wextensible & (s.buf.rbegin # s.buf.rend) THEN + (* check if the write region may be extended + over parts of the read region + *) + IF s.buf.wend < posindex THEN + (* write region before current position *) + IF (s.buf.rbegin <= s.buf.wend) & (s.buf.rend >= posindex) THEN + s.buf.wend := posindex; + s.write := bufsize - posindex; + END; + ELSE (* s.wbegin > posindex *) + (* write region after current position *) + IF (s.buf.rbegin <= posindex) & (s.buf.rend >= s.buf.wbegin) THEN + s.buf.wbegin := posindex; + s.write := bufsize - posindex; + END; + END; + END; + IF (* still *) s.write = 0 THEN + (* Flush necessary *) + IF ~InternalFlush(s) THEN RETURN FALSE END; + s.buf.wbegin := posindex; s.buf.wend := posindex; + s.write := bufsize - posindex; + END; + RETURN TRUE + END NewBuffer; + + PROCEDURE UpdateReadRegion(s: Stream); + BEGIN + (* update s.left and extend read region, if possible *) + IF s.buf.rbegin = s.buf.rend THEN + (* set read region to write region *) + s.buf.rbegin := s.buf.wbegin; s.buf.rend := s.buf.wend; + s.left := s.buf.rend - posindex; + ELSIF (s.buf.rbegin < s.buf.wbegin) & (s.buf.rend >= s.buf.wbegin) THEN + (* forward extension of read region possible *) + IF s.buf.rend < s.buf.wend THEN + s.buf.rend := s.buf.wend; + END; + s.left := s.buf.rend - posindex; + ELSIF (s.buf.rbegin <= s.buf.wend) & (s.buf.rend > s.buf.wend) THEN + (* backward extension of read region possible *) + IF s.buf.rbegin > s.buf.wbegin THEN + s.buf.rbegin := s.buf.wend; + END; + s.left := s.buf.rend - posindex; + ELSE + (* posindex does not fall into [s.buf.rbegin..s.buf.rend-1] *) + s.left := 0; + END; + IF s.pos = s.buf.pos + bufsize THEN + s.left := 0; + END; + END UpdateReadRegion; + + BEGIN + IF SYS.TAS(s.lock) THEN + Error(s, NestedCall); RETURN FALSE + END; + s.error := FALSE; s.count := 0; + IF ~(write IN s.caps) THEN + s.lock := FALSE; Error(s, CannotWrite); RETURN FALSE + ELSIF (off < 0) OR (off+cnt > LEN(buf)) OR (cnt < 0) THEN + s.lock := FALSE; Error(s, BadParameters); RETURN FALSE + ELSIF cnt = 0 THEN + s.lock := FALSE; RETURN TRUE + END; + + IF s.buf # NIL THEN IF s.bidirect THEN - Error(s, CannotSeek); RETURN FALSE - ELSIF s.buf = NIL THEN - IF ~(seek IN s.caps) THEN - Error(s, CannotSeek); RETURN FALSE - ELSIF ~s.if.seek(s, offset, whence) THEN - Error(s, SeekFailed); RETURN FALSE - END; + WHILE s.count < cnt DO + IF (s.write = 0) & ~InternalFlush(s) THEN + s.lock := FALSE; RETURN FALSE + END; + s.wbuf.cont[s.wbuf.wend] := buf[off + s.count]; + INC(s.wbuf.wend); INC(s.count); DEC(s.write); + IF (s.bufmode = linebuf) & + (buf[s.count+off-1] = s.termch) THEN + IF ~InternalFlush(s) THEN + s.lock := FALSE; RETURN FALSE + END; + END; + END; ELSE - IF ~s.validpos & (seek IN s.caps) THEN - IF (write IN s.caps) & ~InternalFlush(s) THEN END; - IF ~s.if.seek(s, offset, whence) THEN - Error(s, SeekFailed); RETURN FALSE - END; - IF whence = fromStart THEN - s.validpos := TRUE; - s.pos := offset; s.rpos := offset; - END; - ELSE - ValidPos(s); oldpos := s.pos; - IF s.pos > s.maxpos THEN - s.maxpos := s.pos; - END; - CASE whence OF - | fromStart: IF offset < 0 THEN - Error(s, SeekFailed); RETURN FALSE - END; - s.pos := offset; - | fromPos: IF s.pos + offset < 0 THEN - Error(s, SeekFailed); RETURN FALSE - END; - INC(s.pos, offset); - | fromEnd: IF (write IN s.caps) & ~InternalFlush(s) THEN END; - IF ~(seek IN s.caps) OR - ~s.if.seek(s, offset, whence) THEN - Error(s, SeekFailed); RETURN FALSE - END; - s.validpos := FALSE; ValidPos(s); - ELSE - Error(s, BadWhence); RETURN FALSE - END; - IF ~(holes IN s.caps) & (s.pos > s.maxpos) THEN - (* if holes are not permitted - we need to check the new position - *) - IF ~(seek IN s.caps) THEN - Error(s, CannotSeek); RETURN FALSE - ELSIF s.if.seek(s, s.pos, fromStart) THEN - s.rpos := s.pos; s.maxpos := s.pos; - ELSE - Error(s, SeekFailed); RETURN FALSE - END; - END; - IF s.buf.ok & (s.pos # oldpos) THEN - (* set s.left and s.write *) - IF (s.pos < s.buf.pos) OR (s.pos >= s.buf.pos + bufsize) THEN - s.left := 0; s.write := 0; - ELSE - pos := s.pos MOD bufsize; - IF s.buf.rbegin = s.buf.rend THEN - s.buf.rbegin := pos; s.buf.rend := pos; - END; - IF s.buf.wbegin = s.buf.wend THEN - s.buf.wbegin := pos; s.buf.wend := pos; - END; - IF s.pos > oldpos THEN - IF (pos >= s.buf.rbegin) & (pos < s.buf.rend) THEN - s.left := s.buf.rend - pos; - ELSE - s.left := 0; - END; - IF (pos >= s.buf.wbegin) & (pos <= s.buf.wend) THEN - s.write := bufsize - pos; - ELSE - s.write := 0; - END; - IF s.wextensible & - (s.write < s.left) & (s.buf.wbegin # s.buf.wend) THEN - (* s.write = 0 (else s.write >= s.left); - try to extend write-region to avoid - an unnecessary flush operation - *) - IF (s.buf.wbegin < pos) & - (s.buf.wend >= s.buf.rbegin) THEN - (* write-region is followed by read-region *) - s.buf.wend := pos; s.write := bufsize - pos; - ELSIF (pos < s.buf.wbegin) & - (s.buf.wbegin >= s.buf.rend) THEN - (* read-region is followed by write-region *) - s.buf.wbegin := pos; s.write := bufsize - pos; - END; - END; - ELSE (* s.pos < oldpos *) - IF (pos < s.buf.rbegin) OR (pos > s.buf.rend) THEN - s.left := 0; - ELSE - s.left := s.buf.rend - pos; - END; - IF (pos < s.buf.wbegin) OR (pos > s.buf.wend) THEN - s.write := 0; - ELSE - s.write := bufsize - pos; - END; - END; - END; - END; - END; - END; - IF s.left > 0 THEN - s.eof := FALSE; - END; - RETURN TRUE - END InternalSeek; + ValidPos(s); + posindex := s.pos MOD bufsize; + IF ~s.buf.ok THEN + InitBuf(s); + END; - PROCEDURE Seek*(s: Stream; offset: Count; whence: Whence) : BOOLEAN; - VAR - rval: BOOLEAN; - BEGIN - IF ~SYS.TAS(s.lock) THEN - rval := InternalSeek(s, offset, whence); - s.lock := FALSE; - RETURN rval + (* copy from buf to s.buf *) + WHILE s.count < cnt DO + IF s.write = 0 THEN + posindex := s.pos MOD bufsize; + IF s.count > 0 THEN + UpdateReadRegion(s); + END; + IF ~NewBuffer(s) THEN + s.lock := FALSE; RETURN FALSE + END; + END; + s.buf.cont[posindex] := buf[off + s.count]; + IF s.buf.wend = posindex THEN + INC(s.buf.wend); + END; + INC(s.count); INC(s.pos); DEC(s.write); INC(posindex); + IF (s.bufmode = linebuf) & + (buf[s.count+off-1] = s.termch) THEN + UpdateReadRegion(s); + IF ~InternalFlush(s) THEN + s.lock := FALSE; RETURN FALSE + END; + (* s.pos can be changed by InternalFlush *) + posindex := s.pos MOD bufsize; + END; + END; + UpdateReadRegion(s); + END; + ELSE (* unbuffered stream *) + IF addrio IN s.caps THEN + s.count := s.if.addrwrite(s, SYSTEM.ADR(buf[off]), cnt); + ELSIF bufio IN s.caps THEN + s.count := s.if.bufwrite(s, buf, off, cnt); ELSE - Error(s, NestedCall); - RETURN FALSE + s.count := 0; + WHILE (s.count < cnt) & s.if.write(s, buf[off+s.count]) DO + INC(s.count); + END; END; - END Seek; + IF s.count # cnt THEN + Error(s, WriteFailed); + END; + END; + s.lock := FALSE; + RETURN s.count = cnt + END WritePart; - PROCEDURE Tell*(s: Stream; VAR offset: Count) : BOOLEAN; - BEGIN - IF ~SYS.TAS(s.lock) THEN - s.error := FALSE; - IF tell IN s.caps THEN - IF s.buf # NIL THEN - IF s.validpos THEN - offset := s.pos; - ELSIF s.if.tell(s, s.rpos) THEN - s.validpos := TRUE; - s.pos := s.rpos; - offset := s.pos; - ELSE - s.lock := FALSE; - Error(s, TellFailed); - END; - ELSIF ~s.if.tell(s, offset) THEN - s.lock := FALSE; - Error(s, TellFailed); - END; - ELSE - s.lock := FALSE; - Error(s, CannotTell); - END; - s.lock := FALSE; + PROCEDURE Write*(s: Stream; + (* read-only *) VAR buf: ARRAY OF Byte) : BOOLEAN; + BEGIN + RETURN WritePart(s, buf, 0, LEN(buf)) + END Write; + + PROCEDURE WritePartC*(s: Stream; buf: ARRAY OF Byte; + off, cnt: Count) : BOOLEAN; + (* write buf[off..off+cnt-1] to s *) + BEGIN + RETURN WritePart(s, buf, off, cnt) + END WritePartC; + + PROCEDURE WriteC*(s: Stream; buf: ARRAY OF Byte) : BOOLEAN; + BEGIN + RETURN WritePart(s, buf, 0, LEN(buf)) + END WriteC; + + PROCEDURE WriteByte*(s: Stream; byte: Byte) : BOOLEAN; + VAR + posindex: Count; + BEGIN + IF (s.write > 0) & ~SYS.TAS(s.lock) THEN + s.error := FALSE; s.count := 1; + + IF s.bidirect THEN + s.wbuf.cont[s.wbuf.wend] := byte; INC(s.wbuf.wend); DEC(s.write); ELSE - Error(s, NestedCall); + (* put byte into s.buf *) + posindex := s.pos MOD bufsize; + s.buf.cont[posindex] := byte; + IF s.buf.wend = posindex THEN + INC(s.buf.wend); + END; + DEC(s.write); + + (* update s.buf.rend and s.left, if necessary *) + IF s.buf.rend = posindex THEN + INC(s.buf.rend); + END; + IF s.left # 0 THEN + DEC(s.left); + ELSIF s.buf.rbegin = s.buf.rend THEN + (* set read-region to write-region *) + s.buf.rbegin := s.buf.wbegin; s.buf.rend := s.buf.wend; + s.left := s.buf.wend - posindex; + END; + + INC(s.pos); END; - RETURN ~s.error - END Tell; - PROCEDURE GetPos*(s: Stream; VAR offset: Count); - (* IF ~Tell(s, offset) THEN offset := internal position END; *) - BEGIN - IF ~Tell(s, offset) THEN - IF SYS.TAS(s.lock) THEN - Error(s, NestedCall); - ELSE - ValidPos(s); - offset := s.pos; - s.lock := FALSE; - END; + IF (s.bufmode = linebuf) & (byte = s.termch) THEN + IF ~InternalFlush(s) THEN + s.lock := FALSE; RETURN FALSE + END; + IF ~s.bidirect THEN + s.buf.wbegin := s.pos MOD bufsize; + END; END; - END GetPos; - PROCEDURE SetPos*(s: Stream; offset: Count); - (* IF ~Seek(s, offset, fromStart) THEN END; *) - BEGIN - IF ~Seek(s, offset, fromStart) THEN END; - END SetPos; + s.lock := FALSE; RETURN TRUE + ELSE + RETURN WritePart(s, byte, 0, 1) + END; + END WriteByte; - PROCEDURE ^ Touch*(s: Stream); - - PROCEDURE Trunc*(s: Stream; length: Count) : BOOLEAN; - (* truncate `s' to a total length of `length'; - following holds if holes are permitted: - (1) the current position remains unchanged - (2) the contents between `length' and - the current position is undefined - this call fails if holes are not permitted and the - current position is beyond `length' - *) - VAR - ok: BOOLEAN; - BEGIN - IF ~SYS.TAS(s.lock) THEN - IF (trunc IN s.caps) & (length >= 0) THEN - s.error := FALSE; ok := TRUE; - IF s.buf # NIL THEN - ValidPos(s); - IF ~(holes IN s.caps) & (s.pos > length) THEN - ok := FALSE; - ELSIF (s.bufmode = bufpool) OR s.buf.ok & - (s.buf.pos DIV bufsize >= length DIV bufsize) THEN - Touch(s); - END; - END; - IF ~ok OR ~s.if.trunc(s, length) THEN - s.lock := FALSE; Error(s, TruncFailed); - END; - ELSE - s.lock := FALSE; Error(s, CannotTrunc); - END; - s.lock := FALSE; + PROCEDURE InternalSeek(s: Stream; offset: Count; whence: Whence) : BOOLEAN; + VAR + oldpos: Count; pos: Count; + BEGIN + s.error := FALSE; + IF s.bidirect THEN + Error(s, CannotSeek); RETURN FALSE + ELSIF s.buf = NIL THEN + IF ~(seek IN s.caps) THEN + Error(s, CannotSeek); RETURN FALSE + ELSIF ~s.if.seek(s, offset, whence) THEN + Error(s, SeekFailed); RETURN FALSE + END; + ELSE + IF ~s.validpos & (seek IN s.caps) THEN + IF (write IN s.caps) & ~InternalFlush(s) THEN END; + IF ~s.if.seek(s, offset, whence) THEN + Error(s, SeekFailed); RETURN FALSE + END; + IF whence = fromStart THEN + s.validpos := TRUE; + s.pos := offset; s.rpos := offset; + END; ELSE - Error(s, NestedCall); + ValidPos(s); oldpos := s.pos; + IF s.pos > s.maxpos THEN + s.maxpos := s.pos; + END; + CASE whence OF + | fromStart: IF offset < 0 THEN + Error(s, SeekFailed); RETURN FALSE + END; + s.pos := offset; + | fromPos: IF s.pos + offset < 0 THEN + Error(s, SeekFailed); RETURN FALSE + END; + INC(s.pos, offset); + | fromEnd: IF (write IN s.caps) & ~InternalFlush(s) THEN END; + IF ~(seek IN s.caps) OR + ~s.if.seek(s, offset, whence) THEN + Error(s, SeekFailed); RETURN FALSE + END; + s.validpos := FALSE; ValidPos(s); + ELSE + Error(s, BadWhence); RETURN FALSE + END; + IF ~(holes IN s.caps) & (s.pos > s.maxpos) THEN + (* if holes are not permitted + we need to check the new position + *) + IF ~(seek IN s.caps) THEN + Error(s, CannotSeek); RETURN FALSE + ELSIF s.if.seek(s, s.pos, fromStart) THEN + s.rpos := s.pos; s.maxpos := s.pos; + ELSE + Error(s, SeekFailed); RETURN FALSE + END; + END; + IF s.buf.ok & (s.pos # oldpos) THEN + (* set s.left and s.write *) + IF (s.pos < s.buf.pos) OR (s.pos >= s.buf.pos + bufsize) THEN + s.left := 0; s.write := 0; + ELSE + pos := s.pos MOD bufsize; + IF s.buf.rbegin = s.buf.rend THEN + s.buf.rbegin := pos; s.buf.rend := pos; + END; + IF s.buf.wbegin = s.buf.wend THEN + s.buf.wbegin := pos; s.buf.wend := pos; + END; + IF s.pos > oldpos THEN + IF (pos >= s.buf.rbegin) & (pos < s.buf.rend) THEN + s.left := s.buf.rend - pos; + ELSE + s.left := 0; + END; + IF (pos >= s.buf.wbegin) & (pos <= s.buf.wend) THEN + s.write := bufsize - pos; + ELSE + s.write := 0; + END; + IF s.wextensible & + (s.write < s.left) & (s.buf.wbegin # s.buf.wend) THEN + (* s.write = 0 (else s.write >= s.left); + try to extend write-region to avoid + an unnecessary flush operation + *) + IF (s.buf.wbegin < pos) & + (s.buf.wend >= s.buf.rbegin) THEN + (* write-region is followed by read-region *) + s.buf.wend := pos; s.write := bufsize - pos; + ELSIF (pos < s.buf.wbegin) & + (s.buf.wbegin >= s.buf.rend) THEN + (* read-region is followed by write-region *) + s.buf.wbegin := pos; s.write := bufsize - pos; + END; + END; + ELSE (* s.pos < oldpos *) + IF (pos < s.buf.rbegin) OR (pos > s.buf.rend) THEN + s.left := 0; + ELSE + s.left := s.buf.rend - pos; + END; + IF (pos < s.buf.wbegin) OR (pos > s.buf.wend) THEN + s.write := 0; + ELSE + s.write := bufsize - pos; + END; + END; + END; + END; END; - RETURN ~s.error - END Trunc; + END; + IF s.left > 0 THEN + s.eof := FALSE; + END; + RETURN TRUE + END InternalSeek; - PROCEDURE Back*(s: Stream) : BOOLEAN; - (* undo last read operation (one byte); - because of the delayed buffer filling - Back is always successful for buffered streams - immediately after read-operations - *) - VAR - rval: BOOLEAN; - BEGIN - IF ~SYS.TAS(s.lock) THEN - s.error := FALSE; - IF read IN s.caps THEN - IF seek IN s.caps THEN - (* fails if s.pos = 0 *) - rval := InternalSeek(s, -1, 1) - ELSIF s.bidirect & s.buf.ok THEN - IF s.pos > 0 THEN - DEC(s.pos); INC(s.left); - rval := TRUE; - ELSE - rval := FALSE; - END; - ELSIF (s.buf # NIL) & s.buf.ok THEN - rval := InternalSeek(s, -1, 1) & (s.left > 0) - ELSE - rval := FALSE - END; - ELSE - s.lock := FALSE; Error(s, CannotRead); - rval := FALSE - END; - s.lock := FALSE; - RETURN rval - ELSE - Error(s, NestedCall); - RETURN FALSE - END; - END Back; - - PROCEDURE Insert*(s: Stream; byte: Byte) : BOOLEAN; - (* return `byte' on next read-operation *) - BEGIN - IF ~SYS.TAS(s.lock) THEN - s.error := FALSE; - IF read IN s.caps THEN - IF s.buf # NIL THEN - (* seek in buffer possible? *) - IF s.bidirect THEN - IF s.pos > 0 THEN - DEC(s.pos); s.buf.cont[s.pos] := byte; - RETURN TRUE - ELSE - RETURN FALSE - END; - ELSIF s.buf.ok & - (s.pos > s.buf.pos+s.buf.rbegin) & - (s.pos < s.buf.pos+s.buf.rend) & - InternalSeek(s, -1, 1) THEN - s.buf.cont[s.pos MOD bufsize] := byte; - s.lock := FALSE; - RETURN TRUE - ELSE - s.lock := FALSE; - RETURN FALSE - END; - ELSE - s.lock := FALSE; Error(s, Unbuffered); RETURN FALSE - END; - ELSE - s.lock := FALSE; Error(s, CannotRead); RETURN FALSE - END; - ELSE - Error(s, NestedCall); - RETURN FALSE - END; - END Insert; - - PROCEDURE InternalFlush(s: Stream) : BOOLEAN; - - PROCEDURE Write(s: Stream; buf: Buffer) : BOOLEAN; - - VAR - count: Count; - BEGIN - IF addrio IN s.caps THEN - count := s.if.addrwrite(s, SYSTEM.ADR(buf.cont[buf.wbegin]), - buf.wend-buf.wbegin); - ELSIF bufio IN s.caps THEN - count := s.if.bufwrite(s, buf.cont, - buf.wbegin, buf.wend-buf.wbegin); - ELSIF s.if.write(s, buf.cont[buf.wbegin]) THEN - count := 1; - ELSE - count := 0; - END; - IF count < 0 THEN - count := 0; - END; - INC(buf.wbegin, count); INC(s.rpos, count); - RETURN count > 0 - END Write; - - PROCEDURE FlushEvent; - VAR - event: Event; - BEGIN - IF s.flushEvent # NIL THEN - NEW(event); - event.type := s.flushEvent; - event.message := "flush event of Streams"; - event.stream := s; - Events.Raise(event); - END; - END FlushEvent; - - BEGIN - s.error := FALSE; - IF (write IN s.caps) & (s.buf # NIL) & s.buf.ok THEN - IF s.bidirect & (s.wbuf.wend > s.wbuf.wbegin) THEN - FlushEvent; - WHILE (s.wbuf.wend > s.wbuf.wbegin) & Write(s, s.wbuf) DO END; - IF s.wbuf.wend > s.wbuf.wbegin THEN - s.wbuf.wbegin := 0; s.wbuf.wend := 0; s.write := bufsize; - Error(s, WriteFailed); RETURN FALSE - END; - s.wbuf.wbegin := 0; s.wbuf.wend := 0; s.write := bufsize; - ELSIF ~s.bidirect & (s.buf.wend > s.buf.wbegin) THEN - FlushEvent; - ValidPos(s); - IF s.buf.pos + s.buf.wbegin # s.rpos THEN - IF ~(seek IN s.caps) THEN - Error(s, CannotSeek); - (* write in this case at the current position - else there is no easy way to write anyhow - *) - ELSIF ~s.if.seek(s, s.buf.pos + s.buf.wbegin, fromStart) THEN - s.buf.wend := s.buf.wbegin; s.write := 0; - Error(s, SeekFailed); RETURN FALSE - END; - s.rpos := s.buf.pos + s.buf.wbegin; - END; - WHILE (s.buf.wend > s.buf.wbegin) & Write(s, s.buf) DO END; - IF s.buf.wend > s.buf.wbegin THEN - s.buf.wend := s.buf.wbegin; s.write := bufsize - s.buf.wbegin; - Error(s, WriteFailed); RETURN FALSE - END; - IF {seek, tell, trunc} * s.caps = {} THEN - (* unidirectional pipeline; reset s.pos to avoid - unintentional flushes due to buffer boundaries - *) - s.pos := 0; s.rpos := 0; s.buf.pos := 0; - s.buf.wbegin := 0; s.buf.wend := 0; s.write := bufsize; - ELSE - IF (s.pos >= s.buf.pos) & (s.pos < s.buf.pos + bufsize) THEN - s.buf.wbegin := s.pos MOD bufsize; - s.buf.wend := s.buf.wbegin; - s.write := bufsize - s.buf.wbegin; - ELSE - s.write := 0; - END; - END; - END; - END; - RETURN TRUE - END InternalFlush; - - PROCEDURE Flush*(s: Stream) : BOOLEAN; - VAR - ok: BOOLEAN; - BEGIN - IF ~SYS.TAS(s.lock) THEN - IF s.bufmode = bufpool THEN - ok := FlushBufPool(s); - ELSE - ok := InternalFlush(s); - END; - IF ok & (flush IN s.caps) THEN - ok := s.if.flush(s); - IF ~ok THEN - Error(s, FlushFailed); - END; - END; - s.lock := FALSE; - RETURN ok - ELSE - Error(s, NestedCall); - RETURN FALSE - END; - END Flush; - - PROCEDURE InputInBuffer*(s: Stream) : BOOLEAN; - (* returns TRUE if the next byte to be read is buffered *) - VAR - buf: Buffer; - pos: Count; - BEGIN - IF s.bufmode = bufpool THEN - IF ~s.buf.ok THEN RETURN FALSE END; - pos := s.pos - s.pos MOD bufsize; - IF s.buf.pos # pos THEN - IF ~FindBuffer(s, pos, buf) THEN - RETURN FALSE - END; - pos := s.pos - buf.pos; - RETURN (pos >= buf.rbegin) & (pos < buf.rend) - END; - ELSIF s.bidirect THEN - RETURN s.left > 0 - END; - pos := s.pos MOD bufsize; - RETURN (read IN s.caps) & (s.buf # NIL) & s.buf.ok & - ((s.left > 0) OR - (write IN s.caps) & (s.buf.wbegin <= pos) & (s.buf.wend > pos)) - END InputInBuffer; - - PROCEDURE OutputInBuffer*(s: Stream) : BOOLEAN; - (* returns TRUE if Flush would lead to a write-operation *) - VAR - buf: Buffer; - BEGIN - IF s.bufmode = bufpool THEN - buf := s.bufpool.head; - WHILE buf # NIL DO - IF buf.wbegin # buf.wend THEN RETURN TRUE END; - buf := buf.nexta; - END; - RETURN FALSE - ELSIF s.bidirect THEN - RETURN s.wbuf.wend > s.wbuf.wbegin - ELSE - RETURN (write IN s.caps) & (s.buf # NIL) & s.buf.ok & - (s.buf.wend > s.buf.wbegin) - END; - END OutputInBuffer; - - PROCEDURE OutputWillBeBuffered*(s: Stream) : BOOLEAN; - (* returns TRUE if the next written byte will be buffered *) - VAR - buf: Buffer; - pos: Count; - BEGIN - IF s.bufmode = bufpool THEN - IF s.bufpool.nbuf < s.bufpool.maxbuf THEN RETURN TRUE END; - pos := s.pos - s.pos MOD bufsize; - IF s.buf.pos # pos THEN - IF ~FindBuffer(s, pos, buf) THEN RETURN FALSE END; - IF s.buf.wbegin = s.buf.wend THEN RETURN TRUE END; - pos := s.pos - buf.pos; - RETURN (pos >= buf.wbegin) & (pos <= buf.wend) OR - (buf.wbegin > 0) & (pos + 1 = buf.wbegin) - END; - ELSIF s.bidirect THEN - RETURN s.write > 0 - END; - RETURN (write IN s.caps) & (s.buf # NIL) & - ((s.write > 0) OR ~s.buf.ok) - END OutputWillBeBuffered; - - PROCEDURE Touch*(s: Stream); - (* forget any buffer contents *) - BEGIN - IF ~SYS.TAS(s.lock) THEN - s.error := FALSE; - IF write IN s.caps THEN - IF s.bufmode = bufpool THEN - IF ~FlushBufPool(s) THEN END; - ReleaseBufPool(s); - ELSE - IF ~InternalFlush(s) THEN END; - END; - END; - IF flush IN s.caps THEN - IF ~s.if.flush(s) THEN - Error(s, FlushFailed); - END; - END; - IF s.bidirect THEN - s.buf.rbegin := 0; s.buf.rend := 0; s.left := 0; - ELSE - s.validpos := FALSE; - IF s.buf # NIL THEN - s.buf.ok := FALSE; - s.left := 0; - s.write := 0; - s.eofFound := FALSE; - END; - END; - s.lock := FALSE; - ELSE - Error(s, NestedCall); - END; - END Touch; - - PROCEDURE Copy*(source, dest: Stream; maxcnt: Count) : BOOLEAN; - (* more efficient variants are possible *) - VAR - left, count, copied, read, written: Count; - buffer: ARRAY bufsize OF Byte; - ok: BOOLEAN; - BEGIN - IF maxcnt >= 0 THEN - read := 0; written := 0; ok := TRUE; - left := maxcnt; - LOOP - IF left = 0 THEN - EXIT - END; - ASSERT(left > 0); - IF left > bufsize THEN - count := bufsize; - ELSE - count := left; - END; - - ok := ReadPacket(source, buffer, 0, count) > 0; - ASSERT(source.count <= count); - INC(read, source.count); - IF ~ok THEN EXIT END; - - ok := WritePart(dest, buffer, 0, source.count); - ASSERT(dest.count <= source.count); - INC(written, dest.count); - IF ~ok THEN EXIT END; - - DEC(left, dest.count); - END; - source.count := read; dest.count := written; - RETURN ok - ELSE - copied := 0; - WHILE (ReadPacket(source, buffer, 0, bufsize) > 0) & - WritePart(dest, buffer, 0, source.count) DO - INC(copied, source.count); - END; - source.count := copied; dest.count := copied; - RETURN ~source.error & ~dest.error - END; - END Copy; - - (* === nulldev procedures ========================================== *) - - PROCEDURE NulldevRead(s: Stream; VAR byte: Byte) : BOOLEAN; - BEGIN - byte := 0X; + PROCEDURE Seek*(s: Stream; offset: Count; whence: Whence) : BOOLEAN; + VAR + rval: BOOLEAN; + BEGIN + IF ~SYS.TAS(s.lock) THEN + rval := InternalSeek(s, offset, whence); + s.lock := FALSE; + RETURN rval + ELSE + Error(s, NestedCall); RETURN FALSE - END NulldevRead; + END; + END Seek; - PROCEDURE NulldevWrite(s: Stream; byte: Byte) : BOOLEAN; - BEGIN - RETURN TRUE - END NulldevWrite; - - PROCEDURE InitNullIf(VAR nullif: Interface); - BEGIN - NEW(nullif); - nullif.read := NulldevRead; - nullif.write := NulldevWrite; - END InitNullIf; - - PROCEDURE OpenNulldev(VAR s: Stream); - BEGIN - NEW(s); - Services.Init(s, type); - Init(s, nullif, {read, write}, nobuf); - END OpenNulldev; - - PROCEDURE ExitHandler(event: Events.Event); - (* flush all streams on exit; - we do not close them to allow output by other exit event handlers - *) - VAR s: Stream; - BEGIN - s := opened; - WHILE s # NIL DO - IF (s.bufmode # nobuf) & (write IN s.caps) THEN - IF ~Flush(s) THEN END; - END; - s := s.next; + PROCEDURE Tell*(s: Stream; VAR offset: Count) : BOOLEAN; + BEGIN + IF ~SYS.TAS(s.lock) THEN + s.error := FALSE; + IF tell IN s.caps THEN + IF s.buf # NIL THEN + IF s.validpos THEN + offset := s.pos; + ELSIF s.if.tell(s, s.rpos) THEN + s.validpos := TRUE; + s.pos := s.rpos; + offset := s.pos; + ELSE + s.lock := FALSE; + Error(s, TellFailed); + END; + ELSIF ~s.if.tell(s, offset) THEN + s.lock := FALSE; + Error(s, TellFailed); + END; + ELSE + s.lock := FALSE; + Error(s, CannotTell); END; - END ExitHandler; + s.lock := FALSE; + ELSE + Error(s, NestedCall); + END; + RETURN ~s.error + END Tell; - PROCEDURE FreeHandler(event: Events.Event); - (* set all free lists to NIL to return the associated storage - to the garbage collector - *) - BEGIN - freelist := NIL; - END FreeHandler; + PROCEDURE GetPos*(s: Stream; VAR offset: Count); + (* IF ~Tell(s, offset) THEN offset := internal position END; *) + BEGIN + IF ~Tell(s, offset) THEN + IF SYS.TAS(s.lock) THEN + Error(s, NestedCall); + ELSE + ValidPos(s); + offset := s.pos; + s.lock := FALSE; + END; + END; + END GetPos; + + PROCEDURE SetPos*(s: Stream; offset: Count); + (* IF ~Seek(s, offset, fromStart) THEN END; *) + BEGIN + IF ~Seek(s, offset, fromStart) THEN END; + END SetPos; + + PROCEDURE ^ Touch*(s: Stream); + + PROCEDURE Trunc*(s: Stream; length: Count) : BOOLEAN; + (* truncate `s' to a total length of `length'; + following holds if holes are permitted: + (1) the current position remains unchanged + (2) the contents between `length' and + the current position is undefined + this call fails if holes are not permitted and the + current position is beyond `length' + *) + VAR + ok: BOOLEAN; + BEGIN + IF ~SYS.TAS(s.lock) THEN + IF (trunc IN s.caps) & (length >= 0) THEN + s.error := FALSE; ok := TRUE; + IF s.buf # NIL THEN + ValidPos(s); + IF ~(holes IN s.caps) & (s.pos > length) THEN + ok := FALSE; + ELSIF (s.bufmode = bufpool) OR s.buf.ok & + (s.buf.pos DIV bufsize >= length DIV bufsize) THEN + Touch(s); + END; + END; + IF ~ok OR ~s.if.trunc(s, length) THEN + s.lock := FALSE; Error(s, TruncFailed); + END; + ELSE + s.lock := FALSE; Error(s, CannotTrunc); + END; + s.lock := FALSE; + ELSE + Error(s, NestedCall); + END; + RETURN ~s.error + END Trunc; + + PROCEDURE Back*(s: Stream) : BOOLEAN; + (* undo last read operation (one byte); + because of the delayed buffer filling + Back is always successful for buffered streams + immediately after read-operations + *) + VAR + rval: BOOLEAN; + BEGIN + IF ~SYS.TAS(s.lock) THEN + s.error := FALSE; + IF read IN s.caps THEN + IF seek IN s.caps THEN + (* fails if s.pos = 0 *) + rval := InternalSeek(s, -1, 1) + ELSIF s.bidirect & s.buf.ok THEN + IF s.pos > 0 THEN + DEC(s.pos); INC(s.left); + rval := TRUE; + ELSE + rval := FALSE; + END; + ELSIF (s.buf # NIL) & s.buf.ok THEN + rval := InternalSeek(s, -1, 1) & (s.left > 0) + ELSE + rval := FALSE + END; + ELSE + s.lock := FALSE; Error(s, CannotRead); + rval := FALSE + END; + s.lock := FALSE; + RETURN rval + ELSE + Error(s, NestedCall); + RETURN FALSE + END; + END Back; + + PROCEDURE Insert*(s: Stream; byte: Byte) : BOOLEAN; + (* return `byte' on next read-operation *) + BEGIN + IF ~SYS.TAS(s.lock) THEN + s.error := FALSE; + IF read IN s.caps THEN + IF s.buf # NIL THEN + (* seek in buffer possible? *) + IF s.bidirect THEN + IF s.pos > 0 THEN + DEC(s.pos); s.buf.cont[s.pos] := byte; + RETURN TRUE + ELSE + RETURN FALSE + END; + ELSIF s.buf.ok & + (s.pos > s.buf.pos+s.buf.rbegin) & + (s.pos < s.buf.pos+s.buf.rend) & + InternalSeek(s, -1, 1) THEN + s.buf.cont[s.pos MOD bufsize] := byte; + s.lock := FALSE; + RETURN TRUE + ELSE + s.lock := FALSE; + RETURN FALSE + END; + ELSE + s.lock := FALSE; Error(s, Unbuffered); RETURN FALSE + END; + ELSE + s.lock := FALSE; Error(s, CannotRead); RETURN FALSE + END; + ELSE + Error(s, NestedCall); + RETURN FALSE + END; + END Insert; + + PROCEDURE InternalFlush(s: Stream) : BOOLEAN; + + PROCEDURE Write(s: Stream; buf: Buffer) : BOOLEAN; + + VAR + count: Count; + BEGIN + IF addrio IN s.caps THEN + count := s.if.addrwrite(s, SYSTEM.ADR(buf.cont[buf.wbegin]), + buf.wend-buf.wbegin); + ELSIF bufio IN s.caps THEN + count := s.if.bufwrite(s, buf.cont, + buf.wbegin, buf.wend-buf.wbegin); + ELSIF s.if.write(s, buf.cont[buf.wbegin]) THEN + count := 1; + ELSE + count := 0; + END; + IF count < 0 THEN + count := 0; + END; + INC(buf.wbegin, count); INC(s.rpos, count); + RETURN count > 0 + END Write; + + PROCEDURE FlushEvent; + VAR + event: Event; + BEGIN + IF s.flushEvent # NIL THEN + NEW(event); + event.type := s.flushEvent; + event.message := "flush event of Streams"; + event.stream := s; + Events.Raise(event); + END; + END FlushEvent; + + BEGIN + s.error := FALSE; + IF (write IN s.caps) & (s.buf # NIL) & s.buf.ok THEN + IF s.bidirect & (s.wbuf.wend > s.wbuf.wbegin) THEN + FlushEvent; + WHILE (s.wbuf.wend > s.wbuf.wbegin) & Write(s, s.wbuf) DO END; + IF s.wbuf.wend > s.wbuf.wbegin THEN + s.wbuf.wbegin := 0; s.wbuf.wend := 0; s.write := bufsize; + Error(s, WriteFailed); RETURN FALSE + END; + s.wbuf.wbegin := 0; s.wbuf.wend := 0; s.write := bufsize; + ELSIF ~s.bidirect & (s.buf.wend > s.buf.wbegin) THEN + FlushEvent; + ValidPos(s); + IF s.buf.pos + s.buf.wbegin # s.rpos THEN + IF ~(seek IN s.caps) THEN + Error(s, CannotSeek); + (* write in this case at the current position + else there is no easy way to write anyhow + *) + ELSIF ~s.if.seek(s, s.buf.pos + s.buf.wbegin, fromStart) THEN + s.buf.wend := s.buf.wbegin; s.write := 0; + Error(s, SeekFailed); RETURN FALSE + END; + s.rpos := s.buf.pos + s.buf.wbegin; + END; + WHILE (s.buf.wend > s.buf.wbegin) & Write(s, s.buf) DO END; + IF s.buf.wend > s.buf.wbegin THEN + s.buf.wend := s.buf.wbegin; s.write := bufsize - s.buf.wbegin; + Error(s, WriteFailed); RETURN FALSE + END; + IF {seek, tell, trunc} * s.caps = {} THEN + (* unidirectional pipeline; reset s.pos to avoid + unintentional flushes due to buffer boundaries + *) + s.pos := 0; s.rpos := 0; s.buf.pos := 0; + s.buf.wbegin := 0; s.buf.wend := 0; s.write := bufsize; + ELSE + IF (s.pos >= s.buf.pos) & (s.pos < s.buf.pos + bufsize) THEN + s.buf.wbegin := s.pos MOD bufsize; + s.buf.wend := s.buf.wbegin; + s.write := bufsize - s.buf.wbegin; + ELSE + s.write := 0; + END; + END; + END; + END; + RETURN TRUE + END InternalFlush; + + PROCEDURE Flush*(s: Stream) : BOOLEAN; + VAR + ok: BOOLEAN; + BEGIN + IF ~SYS.TAS(s.lock) THEN + IF s.bufmode = bufpool THEN + ok := FlushBufPool(s); + ELSE + ok := InternalFlush(s); + END; + IF ok & (flush IN s.caps) THEN + ok := s.if.flush(s); + IF ~ok THEN + Error(s, FlushFailed); + END; + END; + s.lock := FALSE; + RETURN ok + ELSE + Error(s, NestedCall); + RETURN FALSE + END; + END Flush; + + PROCEDURE InputInBuffer*(s: Stream) : BOOLEAN; + (* returns TRUE if the next byte to be read is buffered *) + VAR + buf: Buffer; + pos: Count; + BEGIN + IF s.bufmode = bufpool THEN + IF ~s.buf.ok THEN RETURN FALSE END; + pos := s.pos - s.pos MOD bufsize; + IF s.buf.pos # pos THEN + IF ~FindBuffer(s, pos, buf) THEN + RETURN FALSE + END; + pos := s.pos - buf.pos; + RETURN (pos >= buf.rbegin) & (pos < buf.rend) + END; + ELSIF s.bidirect THEN + RETURN s.left > 0 + END; + pos := s.pos MOD bufsize; + RETURN (read IN s.caps) & (s.buf # NIL) & s.buf.ok & + ((s.left > 0) OR + (write IN s.caps) & (s.buf.wbegin <= pos) & (s.buf.wend > pos)) + END InputInBuffer; + + PROCEDURE OutputInBuffer*(s: Stream) : BOOLEAN; + (* returns TRUE if Flush would lead to a write-operation *) + VAR + buf: Buffer; + BEGIN + IF s.bufmode = bufpool THEN + buf := s.bufpool.head; + WHILE buf # NIL DO + IF buf.wbegin # buf.wend THEN RETURN TRUE END; + buf := buf.nexta; + END; + RETURN FALSE + ELSIF s.bidirect THEN + RETURN s.wbuf.wend > s.wbuf.wbegin + ELSE + RETURN (write IN s.caps) & (s.buf # NIL) & s.buf.ok & + (s.buf.wend > s.buf.wbegin) + END; + END OutputInBuffer; + + PROCEDURE OutputWillBeBuffered*(s: Stream) : BOOLEAN; + (* returns TRUE if the next written byte will be buffered *) + VAR + buf: Buffer; + pos: Count; + BEGIN + IF s.bufmode = bufpool THEN + IF s.bufpool.nbuf < s.bufpool.maxbuf THEN RETURN TRUE END; + pos := s.pos - s.pos MOD bufsize; + IF s.buf.pos # pos THEN + IF ~FindBuffer(s, pos, buf) THEN RETURN FALSE END; + IF s.buf.wbegin = s.buf.wend THEN RETURN TRUE END; + pos := s.pos - buf.pos; + RETURN (pos >= buf.wbegin) & (pos <= buf.wend) OR + (buf.wbegin > 0) & (pos + 1 = buf.wbegin) + END; + ELSIF s.bidirect THEN + RETURN s.write > 0 + END; + RETURN (write IN s.caps) & (s.buf # NIL) & + ((s.write > 0) OR ~s.buf.ok) + END OutputWillBeBuffered; + + PROCEDURE Touch*(s: Stream); + (* forget any buffer contents *) + BEGIN + IF ~SYS.TAS(s.lock) THEN + s.error := FALSE; + IF write IN s.caps THEN + IF s.bufmode = bufpool THEN + IF ~FlushBufPool(s) THEN END; + ReleaseBufPool(s); + ELSE + IF ~InternalFlush(s) THEN END; + END; + END; + IF flush IN s.caps THEN + IF ~s.if.flush(s) THEN + Error(s, FlushFailed); + END; + END; + IF s.bidirect THEN + s.buf.rbegin := 0; s.buf.rend := 0; s.left := 0; + ELSE + s.validpos := FALSE; + IF s.buf # NIL THEN + s.buf.ok := FALSE; + s.left := 0; + s.write := 0; + s.eofFound := FALSE; + END; + END; + s.lock := FALSE; + ELSE + Error(s, NestedCall); + END; + END Touch; + + PROCEDURE Copy*(source, dest: Stream; maxcnt: Count) : BOOLEAN; + (* more efficient variants are possible *) + VAR + left, count, copied, read, written: Count; + buffer: ARRAY bufsize OF Byte; + ok: BOOLEAN; + BEGIN + IF maxcnt >= 0 THEN + read := 0; written := 0; ok := TRUE; + left := maxcnt; + LOOP + IF left = 0 THEN + EXIT + END; + ASSERT(left > 0); + IF left > bufsize THEN + count := bufsize; + ELSE + count := left; + END; + + ok := ReadPacket(source, buffer, 0, count) > 0; + ASSERT(source.count <= count); + INC(read, source.count); + IF ~ok THEN EXIT END; + + ok := WritePart(dest, buffer, 0, source.count); + ASSERT(dest.count <= source.count); + INC(written, dest.count); + IF ~ok THEN EXIT END; + + DEC(left, dest.count); + END; + source.count := read; dest.count := written; + RETURN ok + ELSE + copied := 0; + WHILE (ReadPacket(source, buffer, 0, bufsize) > 0) & + WritePart(dest, buffer, 0, source.count) DO + INC(copied, source.count); + END; + source.count := copied; dest.count := copied; + RETURN ~source.error & ~dest.error + END; + END Copy; + + (* === nulldev procedures ========================================== *) + + PROCEDURE NulldevRead(s: Stream; VAR byte: Byte) : BOOLEAN; + BEGIN + byte := 0X; + RETURN FALSE + END NulldevRead; + + PROCEDURE NulldevWrite(s: Stream; byte: Byte) : BOOLEAN; + BEGIN + RETURN TRUE + END NulldevWrite; + + PROCEDURE InitNullIf(VAR nullif: Interface); + BEGIN + NEW(nullif); + nullif.read := NulldevRead; + nullif.write := NulldevWrite; + END InitNullIf; + + PROCEDURE OpenNulldev(VAR s: Stream); + BEGIN + NEW(s); + Services.Init(s, type); + Init(s, nullif, {read, write}, nobuf); + END OpenNulldev; + + PROCEDURE ExitHandler(event: Events.Event); + (* flush all streams on exit; + we do not close them to allow output by other exit event handlers + *) + VAR s: Stream; + BEGIN + s := opened; + WHILE s # NIL DO + IF (s.bufmode # nobuf) & (write IN s.caps) THEN + IF ~Flush(s) THEN END; + END; + s := s.next; + END; + END ExitHandler; + + PROCEDURE FreeHandler(event: Events.Event); + (* set all free lists to NIL to return the associated storage + to the garbage collector + *) + BEGIN + freelist := NIL; + END FreeHandler; BEGIN - Services.CreateType(type, "Streams.Stream", ""); + Services.CreateType(type, "Streams.Stream", ""); - errormsg[NoHandlerDefined] := "no handler defined"; - errormsg[CannotRead] := "not opened for reading"; - errormsg[CannotSeek] := "not capable of seeking"; - errormsg[CloseFailed] := "close operation failed"; - errormsg[NotLineBuffered] := "stream is not line buffered"; - errormsg[SeekFailed] := "seek operation failed"; - errormsg[TellFailed] := "tell operation failed"; - errormsg[BadWhence] := "bad value of whence parameter"; - errormsg[CannotTell] := "not capable of telling current position"; - errormsg[WriteFailed] := "write operation failed"; - errormsg[CannotWrite] := "not opened for writing"; - errormsg[ReadFailed] := "read operation failed"; - errormsg[Unbuffered] := "operation is not valid for unbuffered streams"; - errormsg[BadParameters] := "bad parameter values"; - errormsg[CannotTrunc] := "not capable of truncating"; - errormsg[TruncFailed] := "trunc operation failed"; - errormsg[NestedCall] := "nested stream operation"; - errormsg[FlushFailed] := "flush operation failed"; + errormsg[NoHandlerDefined] := "no handler defined"; + errormsg[CannotRead] := "not opened for reading"; + errormsg[CannotSeek] := "not capable of seeking"; + errormsg[CloseFailed] := "close operation failed"; + errormsg[NotLineBuffered] := "stream is not line buffered"; + errormsg[SeekFailed] := "seek operation failed"; + errormsg[TellFailed] := "tell operation failed"; + errormsg[BadWhence] := "bad value of whence parameter"; + errormsg[CannotTell] := "not capable of telling current position"; + errormsg[WriteFailed] := "write operation failed"; + errormsg[CannotWrite] := "not opened for writing"; + errormsg[ReadFailed] := "read operation failed"; + errormsg[Unbuffered] := "operation is not valid for unbuffered streams"; + errormsg[BadParameters] := "bad parameter values"; + errormsg[CannotTrunc] := "not capable of truncating"; + errormsg[TruncFailed] := "trunc operation failed"; + errormsg[NestedCall] := "nested stream operation"; + errormsg[FlushFailed] := "flush operation failed"; - Events.Define(error); Events.SetPriority(error, Priorities.liberrors); - Events.Ignore(error); + Events.Define(error); Events.SetPriority(error, Priorities.liberrors); + Events.Ignore(error); - opened := NIL; - InitNullIf(nullif); - OpenNulldev(null); stdin := null; stdout := null; stderr := null; + opened := NIL; + InitNullIf(nullif); + OpenNulldev(null); stdin := null; stdout := null; stderr := null; - Events.Handler(Process.termination, ExitHandler); - Events.Handler(Process.startOfGarbageCollection, FreeHandler); + Events.Handler(Process.termination, ExitHandler); + Events.Handler(Process.startOfGarbageCollection, FreeHandler); END ulmStreams. diff --git a/src/library/ulm/ulmSysIO.Mod b/src/library/ulm/ulmSysIO.Mod index a961f64d..2a22d29f 100644 --- a/src/library/ulm/ulmSysIO.Mod +++ b/src/library/ulm/ulmSysIO.Mod @@ -30,7 +30,10 @@ MODULE ulmSysIO; - IMPORT RelatedEvents := ulmRelatedEvents, Sys := ulmSys, SYS := SYSTEM, ulmSYSTEM, SysErrors := ulmSysErrors, SysTypes := ulmSysTypes; + IMPORT RelatedEvents := ulmRelatedEvents, + Sys := ulmSys, SYS := SYSTEM, ulmSYSTEM, + SysErrors := ulmSysErrors, SysTypes := ulmSysTypes, + Platform; CONST (* file control options: arguments of Fcntl and Open *) @@ -86,20 +89,20 @@ MODULE ulmSysIO; retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; (* the filename must be 0X-terminated *) VAR - d0, d1: (*INTEGER*)LONGINT; + error: Platform.ErrorCode; BEGIN interrupted := FALSE; LOOP - IF ulmSYSTEM.UNIXCALL(Sys.open, d0, d1, - SYS.ADR(filename), SYS.VAL(LONGINT, options), protection) THEN - fd := d0; - RETURN TRUE + IF options * creat # {} THEN error := Platform.New(filename, fd) + ELSIF options * (rdwr+wronly) # {} THEN error := Platform.OldRW(filename, fd) + ELSE error := Platform.OldRO(filename, fd) END; + IF error = 0 THEN RETURN TRUE ELSE - IF d0 = SysErrors.intr THEN + IF Platform.Interrupted(error) THEN interrupted := TRUE; END; - IF (d0 # SysErrors.intr) OR ~retry THEN - SysErrors.Raise(errors, d0, Sys.open, filename); + IF ~Platform.Interrupted(error) OR ~retry THEN + SysErrors.Raise(errors, error, Sys.open, filename); RETURN FALSE END; END; @@ -119,21 +122,18 @@ MODULE ulmSysIO; errors: RelatedEvents.Object; retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; VAR - d0, d1: LONGINT; - a0, a1 : LONGINT; (* just to match UNIXCALL interface *) + error: Platform.ErrorCode; BEGIN interrupted := FALSE; - a0 := 0; a1 := 0; (* Initialised to disable compiler warning. *) LOOP - IF ulmSYSTEM.UNIXCALL(Sys.close, d0, d1, fd, a0, a1) THEN - (*IF ulmSYSTEM.UNIXCALL(Sys.close, d0, d1, fd) THEN*) - RETURN TRUE + error := Platform.Close(fd); + IF error = 0 THEN RETURN TRUE ELSE - IF d0 = SysErrors.intr THEN + IF Platform.Interrupted(error) THEN interrupted := TRUE; END; - IF (d0 # SysErrors.intr) OR ~retry THEN - SysErrors.Raise(errors, d0, Sys.close, ""); + IF ~Platform.Interrupted(error) OR ~retry THEN + SysErrors.Raise(errors, error, Sys.close, ""); RETURN FALSE END; END; @@ -148,18 +148,19 @@ MODULE ulmSysIO; >0: number of bytes read *) VAR - d0, d1: LONGINT; + error: Platform.ErrorCode; + bytesread: Count; BEGIN interrupted := FALSE; LOOP - IF ulmSYSTEM.UNIXCALL(Sys.read, d0, d1, fd, buf, cnt) THEN - RETURN d0 + error := Platform.Read(fd, buf, cnt, bytesread); + IF error = 0 THEN RETURN bytesread ELSE - IF d0 = SysErrors.intr THEN + IF Platform.Interrupted(error) THEN interrupted := TRUE; END; - IF (d0 # SysErrors.intr) OR ~retry THEN - SysErrors.Raise(errors, d0, Sys.read, ""); + IF ~Platform.Interrupted(error) OR ~retry THEN + SysErrors.Raise(errors, error, Sys.read, ""); RETURN -1 END; END; @@ -173,18 +174,19 @@ MODULE ulmSysIO; >=0: number of bytes written *) VAR - d0, d1: LONGINT; + error: Platform.ErrorCode; + byteswritten: Count; BEGIN interrupted := FALSE; LOOP - IF ulmSYSTEM.UNIXCALL(Sys.write, d0, d1, fd, buf, cnt) THEN - RETURN d0 + error := Platform.Write(fd, buf, cnt); + IF error = 0 THEN RETURN cnt (* todo: Upfate Platform.Write to return actual length written. *) ELSE - IF d0 = SysErrors.intr THEN + IF Platform.Interrupted(error) THEN interrupted := TRUE; END; - IF (d0 # SysErrors.intr) OR ~retry THEN - SysErrors.Raise(errors, d0, Sys.write, ""); + IF ~Platform.Interrupted(error) OR ~retry THEN + SysErrors.Raise(errors, error, Sys.write, ""); RETURN -1 END; END; @@ -194,16 +196,23 @@ MODULE ulmSysIO; PROCEDURE Seek*(fd: File; offset: Count; whence: Whence; errors: RelatedEvents.Object) : BOOLEAN; VAR - d0, d1: LONGINT; + error: Platform.ErrorCode; relativity: INTEGER; BEGIN - IF ulmSYSTEM.UNIXCALL(Sys.lseek, d0, d1, fd, offset, whence) THEN - RETURN TRUE + CASE whence OF + |fromPos: relativity := Platform.SeekCur + |fromEnd: relativity := Platform.SeekEnd + ELSE relativity := Platform.SeekSet + END; + error := Platform.Seek(fd, offset, relativity); + IF error = 0 THEN RETURN TRUE ELSE - SysErrors.Raise(errors, d0, Sys.lseek, ""); + SysErrors.Raise(errors, error, Sys.lseek, ""); RETURN FALSE END; END Seek; +(* + PROCEDURE Tell*(fd: File; VAR offset: Count; errors: RelatedEvents.Object) : BOOLEAN; VAR @@ -229,7 +238,6 @@ MODULE ulmSysIO; (* following system call fails for non-tty's *) RETURN ulmSYSTEM.UNIXCALL(Sys.ioctl, d0, d1, fd, tcgeta, SYS.ADR(buf)) END Isatty; - PROCEDURE Fcntl*(fd: File; request: INTEGER; VAR arg: LONGINT; errors: RelatedEvents.Object; retry: BOOLEAN; VAR interrupted: BOOLEAN) : BOOLEAN; @@ -343,5 +351,6 @@ MODULE ulmSysIO; RETURN FALSE END; END Pipe; +*) END ulmSysIO. diff --git a/src/library/ulm/ulmSysTypes.Mod b/src/library/ulm/ulmSysTypes.Mod index 174140e7..6d16ab4b 100644 --- a/src/library/ulm/ulmSysTypes.Mod +++ b/src/library/ulm/ulmSysTypes.Mod @@ -30,7 +30,7 @@ MODULE ulmSysTypes; - IMPORT Types := ulmTypes; + IMPORT Types := ulmTypes, Platform; TYPE Address* = Types.Address; @@ -39,17 +39,17 @@ MODULE ulmSysTypes; Size* = Types.Size; Byte* = Types.Byte; - File* = (*INTEGER*)LONGINT; (* in ulm's system both INTEGER and LONGINT are 4 bytes long *) + File* = Platform.FileHandle; Offset* = LONGINT; Device* = LONGINT; - Inode* = LONGINT; - Time* = LONGINT; + Inode* = LONGINT; + Time* = LONGINT; - Word* = INTEGER; (* must have the size of C's int-type *) + Word* = INTEGER; (* must have the size of C's int-type *) (* Note: linux supports wait4 but not waitid, i.e. these * constants aren't needed. *) - (* + (* CONST (* possible values of the idtype parameter (4 bytes), see diff --git a/src/library/ulm/ulmTCrypt.Mod b/src/library/ulm/ulmTCrypt.Mod index 4003eaf0..c35c7809 100644 --- a/src/library/ulm/ulmTCrypt.Mod +++ b/src/library/ulm/ulmTCrypt.Mod @@ -1,1764 +1,1770 @@ (* Ulm's Oberon Library - Copyright (C) 1989-1997 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. + Copyright (C) 1989-1997 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: TCrypt.om,v 1.1 1997/04/02 11:54:02 borchert Exp borchert $ - ---------------------------------------------------------------------------- - $Log: TCrypt.om,v $ - Revision 1.1 1997/04/02 11:54:02 borchert - Initial revision + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: TCrypt.om,v 1.1 1997/04/02 11:54:02 borchert Exp borchert $ + ---------------------------------------------------------------------------- + $Log: TCrypt.om,v $ + Revision 1.1 1997/04/02 11:54:02 borchert + Initial revision - ---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- *) MODULE ulmTCrypt; (* Michael Szczuka *) - (* Trautner's association method for key exchange *) + (* Trautner's association method for key exchange *) - IMPORT AsymmetricCiphers := ulmAsymmetricCiphers, BlockCiphers := ulmBlockCiphers, Ciphers := ulmCiphers, Conclusions := ulmConclusions, Events := ulmEvents, - NetIO := ulmNetIO, PersistentObjects := ulmPersistentObjects, Random := ulmRandomGenerators, RelatedEvents := ulmRelatedEvents, - Services := ulmServices, Streams := ulmStreams, SYS := SYSTEM; + IMPORT + AsymmetricCiphers := ulmAsymmetricCiphers, BlockCiphers := ulmBlockCiphers, + Ciphers := ulmCiphers, Conclusions := ulmConclusions, + Events := ulmEvents, NetIO := ulmNetIO, + PersistentObjects := ulmPersistentObjects, Random := ulmRandomGenerators, + RelatedEvents := ulmRelatedEvents, Services := ulmServices, + Streams := ulmStreams, SYS := SYSTEM; - CONST - M = 16; (* size of an element of CC(M) [ring of Circular Convolution] *) - MaxVar = 8; (* number of variables of a polynomial *) - MaxNrExp = 4; (* maxiumum number of different exponts used during - initialisaton *) - Dim = 2; (* dimension of the linear recursion *) - Rounds = 16; (* length of the linear recursion in rounds *) - LastRounds = 4; (* use the last LastRounds polynomial vectors as - the composed function eta *) - reg = 1; sing = 2; random = 3; - LIST = TRUE; NOLIST = FALSE; - MaxTerms = 1000; + CONST + M = 16; (* size of an element of CC(M) [ring of Circular Convolution] *) + MaxVar = 8; (* number of variables of a polynomial *) + MaxNrExp = 4; (* maxiumum number of different exponts used during + initialisaton *) + Dim = 2; (* dimension of the linear recursion *) + Rounds = 16; (* length of the linear recursion in rounds *) + LastRounds = 4; (* use the last LastRounds polynomial vectors as + the composed function eta *) + reg = 1; sing = 2; random = 3; + LIST = TRUE; NOLIST = FALSE; + MaxTerms = 1000; - CONST - writeSetFailed = 0; - readSetFailed = 1; - notRegular = 2; - errorcodes = 3; + CONST + writeSetFailed = 0; + readSetFailed = 1; + notRegular = 2; + errorcodes = 3; - TYPE - (* an element out of CC(M) *) - CCMElement = SET; - Exponent = ARRAY MaxVar OF SHORTINT; + TYPE + (* an element out of CC(M) *) + CCMElement = SET; + Exponent = ARRAY MaxVar OF SHORTINT; - TYPE - (* a polynomial with coefficients out of CC(M) *) - Polynom = POINTER TO PolynomRec; - PolynomRec = RECORD - koeff : CCMElement; - exp : Exponent; - next : Polynom; + TYPE + (* a polynomial with coefficients out of CC(M) *) + Polynom = POINTER TO PolynomRec; + PolynomRec = RECORD + koeff : CCMElement; + exp : Exponent; + next : Polynom; + END; + + TYPE + VektorCCM = ARRAY Dim OF CCMElement; + VektorPolynom = ARRAY Dim OF Polynom; + MatCCM = ARRAY Dim, Dim OF CCMElement; + MatPolynom = ARRAY Dim, Dim OF Polynom; + ListCCM = ARRAY Rounds OF CCMElement; + ListPolynom = ARRAY Rounds OF Polynom; + ChainCCM = ARRAY Rounds OF VektorCCM; + ChainPolynom = ARRAY Rounds OF VektorPolynom; + (* to increase the performance of the algorithm there shouldn't be too + many different exponents to start with *) + ListExp = ARRAY MaxNrExp OF Exponent; + + TYPE + (* this type is the input of the TCrypt method *) + TCryptInput = POINTER TO TCryptInputRec; + TCryptInputRec = RECORD + arg : ARRAY MaxVar OF CCMElement; + END; + + TYPE + (* result type after encryption with the public key *) + TCryptTmp = POINTER TO TCryptTmpRec; + TCryptTmpRec = RECORD + numerator : ChainCCM; + denominator : ListCCM; + END; + + TYPE + (* result type of the algorithm *) + TCryptRes = POINTER TO TCryptResRec; + TCryptResRec = RECORD + arg : ARRAY LastRounds OF VektorCCM; + END; + + TYPE + (* this type represents the public function f resp. phi *) + Phi = POINTER TO PhiRec; + PhiRec = RECORD + num : ChainPolynom; + denom : ListPolynom; + END; + + TYPE + (* the private/secret function g resp. psi consisting of an inital matrix + and a permutation *) + Psi = POINTER TO PsiRec; + PsiRec = RECORD + (* although the inital matrix consists only of elements out of CC(M) + this generalization is useful since all other matrces consist of + polynomials *) + initialmatrix : MatCCM; + (* correcting factors *) + korrNum : ChainCCM; + korrDenom : ListCCM; + END; + + (* the public function h resp. eta being the composition of f/phi + and g/psi *) + TYPE + Eta = POINTER TO EtaRec; + EtaRec = RECORD + p : ARRAY LastRounds OF VektorPolynom; + END; + + TYPE + (* the declaration of a basic type which PublicCipher and PrivateCipher + are descendents from seems a good idea ... at least to me :) *) + Cipher* = POINTER TO CipherRec; + CipherRec* = RECORD (AsymmetricCiphers.CipherRec) END; + (* the specific format of a public key for Trautner's technique *) + PublicCipher = POINTER TO PublicCipherRec; + PublicCipherRec = RECORD + (CipherRec) + phi : Phi; + eta : Eta; + END; + (* the specific format of a key for Trautner's technique *) + PrivateCipher = POINTER TO PrivateCipherRec; + PrivateCipherRec = RECORD + (CipherRec) + phi : Phi; + psi : Psi; + eta : Eta; + END; + + TYPE + ErrorEvent = POINTER TO ErrorEventRec; + ErrorEventRec = RECORD + (Events.EventRec) + errorcode : SHORTINT; + END; + + VAR + pubType, privType, cipherType : Services.Type; + pubIf, privIf, cipherIf : PersistentObjects.Interface; + NullCCM, EinsCCM : CCMElement; (* the zero and unit of CC(M) *) + NullExp : Exponent; (* consists of zero exponents *) + NullExpList : ListExp; (* a pseudo list for CreatePolynom *) + GlobalExpList : ListExp; (* contains the exponents which should be used + when calling CreatePolynom *) + NullPolynom : Polynom; (* the zero polynomial *) + PolFeld : ARRAY MaxTerms OF Polynom; (* used for sorting purposes *) + PreEvalArg : ARRAY M OF TCryptInput; (* precomputed values to speed + up evaluation of a polynomial *) + k : SHORTINT; (* simple counter during initialisation *) + error : Events.EventType; + errormsg : ARRAY errorcodes OF Events.Message; + + + (* ***** error handling ***** *) + + PROCEDURE InitErrorHandling; + BEGIN + Events.Define(error); + errormsg[writeSetFailed] := "couldn't write set"; + errormsg[readSetFailed] := "couldn't read set"; + errormsg[notRegular] := "element isn't regular"; + END InitErrorHandling; + + PROCEDURE Error(s: Streams.Stream; errorcode: SHORTINT); + VAR + event: ErrorEvent; + BEGIN + NEW(event); + event.message := errormsg[errorcode]; + event.type := error; + event.errorcode := errorcode; + RelatedEvents.Raise(s, event); + END Error; + + (* ***** arithmetic functions for elements out of CC(M) ***** *) + + PROCEDURE RegulaerCCM (x: CCMElement) : BOOLEAN; + (* tests x for regularity [a regular CCMElement contains an odd number of + set bits]; returns TRUE when x is regular, FALSE otherwise *) + VAR + res, i : SHORTINT; + BEGIN + i := 0; + res := 0; + REPEAT (* counting the set bits *) + IF i IN x THEN + INC(res); END; + INC(i); + UNTIL i>=M; + RETURN ((res MOD 2) = 1); + END RegulaerCCM; - TYPE - VektorCCM = ARRAY Dim OF CCMElement; - VektorPolynom = ARRAY Dim OF Polynom; - MatCCM = ARRAY Dim, Dim OF CCMElement; - MatPolynom = ARRAY Dim, Dim OF Polynom; - ListCCM = ARRAY Rounds OF CCMElement; - ListPolynom = ARRAY Rounds OF Polynom; - ChainCCM = ARRAY Rounds OF VektorCCM; - ChainPolynom = ARRAY Rounds OF VektorPolynom; - (* to increase the performance of the algorithm there shouldn't be too - many different exponents to start with *) - ListExp = ARRAY MaxNrExp OF Exponent; - - TYPE - (* this type is the input of the TCrypt method *) - TCryptInput = POINTER TO TCryptInputRec; - TCryptInputRec = RECORD - arg : ARRAY MaxVar OF CCMElement; + PROCEDURE EqualCCM (x, y: CCMElement) : BOOLEAN; + (* compares x and y for equality; if x and y are equal TRUE is returned, + FALSE otherwise *) + VAR + i : SHORTINT; + BEGIN + i := 0; + WHILE i < M DO + IF ((i IN x) & (~(i IN y))) OR ((~(i IN x)) & (i IN y)) THEN + RETURN FALSE; END; + INC(i); + END; + RETURN TRUE; + END EqualCCM; - TYPE - (* result type after encryption with the public key *) - TCryptTmp = POINTER TO TCryptTmpRec; - TCryptTmpRec = RECORD - numerator : ChainCCM; - denominator : ListCCM; + PROCEDURE AddCCM (x, y: CCMElement; VAR z: CCMElement); + (* add x and y in CC(M) *) + VAR + i : SHORTINT; + BEGIN + z := NullCCM; + i := 0; + REPEAT + IF ((i IN x) & (~(i IN y))) OR ((~(i IN x)) & (i IN y)) THEN + z := z + {i}; END; + INC(i); + UNTIL i>=M; + END AddCCM; - TYPE - (* result type of the algorithm *) - TCryptRes = POINTER TO TCryptResRec; - TCryptResRec = RECORD - arg : ARRAY LastRounds OF VektorCCM; - END; - - TYPE - (* this type represents the public function f resp. phi *) - Phi = POINTER TO PhiRec; - PhiRec = RECORD - num : ChainPolynom; - denom : ListPolynom; - END; - - TYPE - (* the private/secret function g resp. psi consisting of an inital matrix - and a permutation *) - Psi = POINTER TO PsiRec; - PsiRec = RECORD - (* although the inital matrix consists only of elements out of CC(M) - this generalization is useful since all other matrces consist of - polynomials *) - initialmatrix : MatCCM; - (* correcting factors *) - korrNum : ChainCCM; - korrDenom : ListCCM; - END; - - (* the public function h resp. eta being the composition of f/phi - and g/psi *) - TYPE - Eta = POINTER TO EtaRec; - EtaRec = RECORD - p : ARRAY LastRounds OF VektorPolynom; - END; - - TYPE - (* the declaration of a basic type which PublicCipher and PrivateCipher - are descendents from seems a good idea ... at least to me :) *) - Cipher* = POINTER TO CipherRec; - CipherRec* = RECORD (AsymmetricCiphers.CipherRec) END; - (* the specific format of a public key for Trautner's technique *) - PublicCipher = POINTER TO PublicCipherRec; - PublicCipherRec = RECORD - (CipherRec) - phi : Phi; - eta : Eta; - END; - (* the specific format of a key for Trautner's technique *) - PrivateCipher = POINTER TO PrivateCipherRec; - PrivateCipherRec = RECORD - (CipherRec) - phi : Phi; - psi : Psi; - eta : Eta; - END; - - TYPE - ErrorEvent = POINTER TO ErrorEventRec; - ErrorEventRec = RECORD - (Events.EventRec) - errorcode : SHORTINT; - END; - - VAR - pubType, privType, cipherType : Services.Type; - pubIf, privIf, cipherIf : PersistentObjects.Interface; - NullCCM, EinsCCM : CCMElement; (* the zero and unit of CC(M) *) - NullExp : Exponent; (* consists of zero exponents *) - NullExpList : ListExp; (* a pseudo list for CreatePolynom *) - GlobalExpList : ListExp; (* contains the exponents which should be used - when calling CreatePolynom *) - NullPolynom : Polynom; (* the zero polynomial *) - PolFeld : ARRAY MaxTerms OF Polynom; (* used for sorting purposes *) - PreEvalArg : ARRAY M OF TCryptInput; (* precomputed values to speed - up evaluation of a polynomial *) - k : SHORTINT; (* simple counter during initialisation *) - error : Events.EventType; - errormsg : ARRAY errorcodes OF Events.Message; - - - (* ***** error handling ***** *) - - PROCEDURE InitErrorHandling; - BEGIN - Events.Define(error); - errormsg[writeSetFailed] := "couldn't write set"; - errormsg[readSetFailed] := "couldn't read set"; - errormsg[notRegular] := "element isn't regular"; - END InitErrorHandling; - - PROCEDURE Error(s: Streams.Stream; errorcode: SHORTINT); - VAR - event: ErrorEvent; - BEGIN - NEW(event); - event.message := errormsg[errorcode]; - event.type := error; - event.errorcode := errorcode; - RelatedEvents.Raise(s, event); - END Error; - - (* ***** arithmetic functions for elements out of CC(M) ***** *) - - PROCEDURE RegulaerCCM (x: CCMElement) : BOOLEAN; - (* tests x for regularity [a regular CCMElement contains an odd number of - set bits]; returns TRUE when x is regular, FALSE otherwise *) - VAR - res, i : SHORTINT; - BEGIN - i := 0; - res := 0; - REPEAT (* counting the set bits *) - IF i IN x THEN - INC(res); - END; - INC(i); - UNTIL i>=M; - RETURN ((res MOD 2) = 1); - END RegulaerCCM; - - PROCEDURE EqualCCM (x, y: CCMElement) : BOOLEAN; - (* compares x and y for equality; if x and y are equal TRUE is returned, - FALSE otherwise *) - VAR - i : SHORTINT; - BEGIN - i := 0; - WHILE i < M DO - IF ((i IN x) & (~(i IN y))) OR ((~(i IN x)) & (i IN y)) THEN - RETURN FALSE; - END; - INC(i); - END; - RETURN TRUE; - END EqualCCM; - - PROCEDURE AddCCM (x, y: CCMElement; VAR z: CCMElement); - (* add x and y in CC(M) *) - VAR - i : SHORTINT; - BEGIN - z := NullCCM; - i := 0; + PROCEDURE MulCCM (x, y: CCMElement; VAR z: CCMElement); + (* multiply x and y in CC(M) *) + VAR + i, j, diff : SHORTINT; + tmp : INTEGER; + BEGIN + z := NullCCM; + i := 0; + REPEAT + j := 0; + tmp := 0; REPEAT - IF ((i IN x) & (~(i IN y))) OR ((~(i IN x)) & (i IN y)) THEN - z := z + {i}; - END; - INC(i); - UNTIL i>=M; - END AddCCM; - - PROCEDURE MulCCM (x, y: CCMElement; VAR z: CCMElement); - (* multiply x and y in CC(M) *) - VAR - i, j, diff : SHORTINT; - tmp : INTEGER; - BEGIN - z := NullCCM; - i := 0; - REPEAT - j := 0; - tmp := 0; - REPEAT - diff := i-j; - IF diff >= 0 THEN - IF (j IN x) & (diff IN y) THEN - INC(tmp); - END; - ELSE - IF (j IN x) & ((M+diff) IN y) THEN - INC(tmp); - END; - END; - INC(j); - UNTIL j>=M; - IF (tmp MOD 2) = 1 THEN - z := z + {i}; - END; - INC(i); - UNTIL i>=M; - END MulCCM; - - PROCEDURE PowerCCM (x: CCMElement; exp: INTEGER; VAR z: CCMElement); - (* raises x to the power exp in CC(M) *) - VAR - tmp : CCMElement; - BEGIN - (* some special cases first *) - IF exp >= M THEN - IF ~RegulaerCCM(x) THEN - (* x is singular -> result is zero *) - z := NullCCM; - RETURN; - END; - (* x is regular -> compute the modulus of exp mod M and use this - instead of exp *) - exp := exp MOD M; - END; - IF exp = 0 THEN - z := EinsCCM; - RETURN; - END; - IF exp = 1 THEN - z := x; - RETURN; + diff := i-j; + IF diff >= 0 THEN + IF (j IN x) & (diff IN y) THEN + INC(tmp); + END; + ELSE + IF (j IN x) & ((M+diff) IN y) THEN + INC(tmp); + END; + END; + INC(j); + UNTIL j>=M; + IF (tmp MOD 2) = 1 THEN + z := z + {i}; END; + INC(i); + UNTIL i>=M; + END MulCCM; - (* default case; use a "square and multiply" technique *) - tmp := x; + PROCEDURE PowerCCM (x: CCMElement; exp: INTEGER; VAR z: CCMElement); + (* raises x to the power exp in CC(M) *) + VAR + tmp : CCMElement; + BEGIN + (* some special cases first *) + IF exp >= M THEN + IF ~RegulaerCCM(x) THEN + (* x is singular -> result is zero *) + z := NullCCM; + RETURN; + END; + (* x is regular -> compute the modulus of exp mod M and use this + instead of exp *) + exp := exp MOD M; + END; + IF exp = 0 THEN z := EinsCCM; - REPEAT - IF exp MOD 2 = 1 THEN - MulCCM(z, tmp, z); - END; - exp := exp DIV 2; - MulCCM(tmp, tmp, tmp); - UNTIL exp < 1; - END PowerCCM; + RETURN; + END; + IF exp = 1 THEN + z := x; + RETURN; + END; - PROCEDURE CreateCCM (VAR x: CCMElement; mode: SHORTINT); - (* creates a random element out of CC(M) depending on mode which - can be reg, sing or random; - the result is in any case different from the zero *) + (* default case; use a "square and multiply" technique *) + tmp := x; + z := EinsCCM; + REPEAT + IF exp MOD 2 = 1 THEN + MulCCM(z, tmp, z); + END; + exp := exp DIV 2; + MulCCM(tmp, tmp, tmp); + UNTIL exp < 1; + END PowerCCM; + + PROCEDURE CreateCCM (VAR x: CCMElement; mode: SHORTINT); + (* creates a random element out of CC(M) depending on mode which + can be reg, sing or random; + the result is in any case different from the zero *) + VAR + i, SetBits: SHORTINT; + BEGIN + x := NullCCM; + REPEAT + i := 0; + SetBits := 0; + REPEAT + IF Random.Flip() THEN + (* set bit *) + x := x + {i}; + INC(SetBits); + END; + INC(i); + UNTIL i >= (M-1); + UNTIL SetBits > 0; (* at least one bit must be set so that the result + differs from zero *) + + CASE mode OF + random: + IF Random.Flip() THEN + x := x + {M-1}; + END; + | sing: (* singular element - even # of bits *) + IF (SetBits MOD 2) = 1 THEN + x := x + {M-1}; + END; + | reg: (* regular element - odd # of bits *) + IF ((SetBits + 1) MOD 2) = 1 THEN + x := x + {M-1}; + END; + ELSE + END; + END CreateCCM; + + (* ***** arithmetic functions for polynomials over CC(M) ***** *) + + PROCEDURE LengthPolynom(p: Polynom) : INTEGER; + (* returns the number of terms which make up the polynomial p *) + VAR + i : INTEGER; + BEGIN + i := 0; + WHILE p # NIL DO + INC(i); + p := p.next; + END; + RETURN i; + END LengthPolynom; + + PROCEDURE RegulaerPolynom (p: Polynom) : BOOLEAN; + (* tests the regularity of a polynomial [a polynomial is regular + iff the # of regular coefficients is odd] *) + VAR + regkoeffs : SHORTINT; + BEGIN + regkoeffs := 0; + WHILE p # NIL DO + IF RegulaerCCM(p.koeff) THEN + (* count # of reg. coefficients *) + INC(regkoeffs); + END; + p := p.next; + END; + RETURN (regkoeffs MOD 2) = 1; + END RegulaerPolynom; + + PROCEDURE CmpExp (exp1, exp2: Exponent) : SHORTINT; + (* compares two exponent vectors and returns 0 on equality, a + positive value if exp1>exp2 and a negative value if exp1 e2 THEN + cmp := 1; diff := TRUE; + END; + END; + INC(i); + UNTIL i >= MaxVar; + + IF sum1 < sum2 THEN + RETURN -2; + END; + IF sum1 > sum2 THEN + RETURN 2; + END; + + RETURN cmp + END CmpExp; + + PROCEDURE ArrangePolynom (VAR p: Polynom); + (* arrange a polynomial according to the order given by CmpExp *) + VAR + r : Polynom; + cnt : INTEGER; + + PROCEDURE SortPolynom(left, right: INTEGER); + (* sort the global field PolFeld with the quicksort algorithm *) VAR - i, SetBits: SHORTINT; - BEGIN - x := NullCCM; - REPEAT - i := 0; - SetBits := 0; - REPEAT - IF Random.Flip() THEN - (* set bit *) - x := x + {i}; - INC(SetBits); - END; - INC(i); - UNTIL i >= (M-1); - UNTIL SetBits > 0; (* at least one bit must be set so that the result - differs from zero *) + mid : INTEGER; - CASE mode OF - random: - IF Random.Flip() THEN - x := x + {M-1}; - END; - | sing: (* singular element - even # of bits *) - IF (SetBits MOD 2) = 1 THEN - x := x + {M-1}; - END; - | reg: (* regular element - odd # of bits *) - IF ((SetBits + 1) MOD 2) = 1 THEN - x := x + {M-1}; - END; + PROCEDURE Partition(l, r: INTEGER) : INTEGER; + VAR + koeff : CCMElement; + exp : Exponent; + cmp : Exponent; + i, j : INTEGER; + BEGIN + cmp := PolFeld[(l+r) DIV 2].exp; + i := l-1; + j := r+1; + LOOP + REPEAT + DEC(j); + UNTIL CmpExp(PolFeld[j].exp, cmp) >= 0; + REPEAT + INC(i); + UNTIL CmpExp(PolFeld[i].exp, cmp) <= 0; + IF i < j THEN + koeff := PolFeld[i].koeff; + exp := PolFeld[i].exp; + PolFeld[i].koeff := PolFeld[j].koeff; + PolFeld[i].exp := PolFeld[j].exp; + PolFeld[j].koeff := koeff; + PolFeld[j].exp := exp; + ELSE + RETURN j; + END; + END; + END Partition; + + BEGIN + IF left < right THEN + mid := Partition(left, right); + SortPolynom(left, mid); + SortPolynom(mid+1, right); + END; + END SortPolynom; + + BEGIN (* ArrangePolynom *) + IF p = NIL THEN + RETURN; + END; + r := p; + cnt := 0; + WHILE (p # NIL) & (cnt < MaxTerms) DO + PolFeld[cnt] := p; + INC(cnt); + p := p.next; + END; + (* polynomial contains too many terms; this shouldn't happen if all + parameters are set to reasonable values and MaxTerms is high + enough *) + ASSERT(cnt 1 THEN + SortPolynom(0, cnt-1); + END; + p := r; + END ArrangePolynom; + + PROCEDURE CopyPolynom (s: Polynom; VAR t: Polynom); + (* copy the source polynomial s to a new target t *) + VAR + troot : Polynom; + BEGIN + IF s = NIL THEN + t := NIL; + RETURN; + END; + NEW(t); + troot := t; (* save the root of t *) + WHILE s # NIL DO + troot.koeff := s.koeff; + troot.exp := s.exp; + s := s.next; + IF s # NIL THEN + NEW(troot.next); + troot := troot.next; ELSE + troot.next := NIL; END; - END CreateCCM; + END; + END CopyPolynom; - (* ***** arithmetic functions for polynomials over CC(M) ***** *) - - PROCEDURE LengthPolynom(p: Polynom) : INTEGER; - (* returns the number of terms which make up the polynomial p *) - VAR - i : INTEGER; - BEGIN - i := 0; - WHILE p # NIL DO - INC(i); - p := p.next; - END; - RETURN i; - END LengthPolynom; - - PROCEDURE RegulaerPolynom (p: Polynom) : BOOLEAN; - (* tests the regularity of a polynomial [a polynomial is regular - iff the # of regular coefficients is odd] *) - VAR - regkoeffs : SHORTINT; - BEGIN - regkoeffs := 0; - WHILE p # NIL DO - IF RegulaerCCM(p.koeff) THEN - (* count # of reg. coefficients *) - INC(regkoeffs); - END; - p := p.next; - END; - RETURN (regkoeffs MOD 2) = 1; - END RegulaerPolynom; - - PROCEDURE CmpExp (exp1, exp2: Exponent) : SHORTINT; - (* compares two exponent vectors and returns 0 on equality, a - positive value if exp1>exp2 and a negative value if exp1 e2 THEN - cmp := 1; diff := TRUE; - END; - END; - INC(i); - UNTIL i >= MaxVar; - - IF sum1 < sum2 THEN - RETURN -2; - END; - IF sum1 > sum2 THEN - RETURN 2; - END; - - RETURN cmp - END CmpExp; - - PROCEDURE ArrangePolynom (VAR p: Polynom); - (* arrange a polynomial according to the order given by CmpExp *) - VAR - r : Polynom; - cnt : INTEGER; - - PROCEDURE SortPolynom(left, right: INTEGER); - (* sort the global field PolFeld with the quicksort algorithm *) - VAR - mid : INTEGER; - - PROCEDURE Partition(l, r: INTEGER) : INTEGER; - VAR - koeff : CCMElement; - exp : Exponent; - cmp : Exponent; - i, j : INTEGER; - BEGIN - cmp := PolFeld[(l+r) DIV 2].exp; - i := l-1; - j := r+1; - LOOP - REPEAT - DEC(j); - UNTIL CmpExp(PolFeld[j].exp, cmp) >= 0; - REPEAT - INC(i); - UNTIL CmpExp(PolFeld[i].exp, cmp) <= 0; - IF i < j THEN - koeff := PolFeld[i].koeff; - exp := PolFeld[i].exp; - PolFeld[i].koeff := PolFeld[j].koeff; - PolFeld[i].exp := PolFeld[j].exp; - PolFeld[j].koeff := koeff; - PolFeld[j].exp := exp; - ELSE - RETURN j; - END; - END; - END Partition; - - BEGIN - IF left < right THEN - mid := Partition(left, right); - SortPolynom(left, mid); - SortPolynom(mid+1, right); - END; - END SortPolynom; - - BEGIN (* ArrangePolynom *) - IF p = NIL THEN - RETURN; - END; - r := p; - cnt := 0; - WHILE (p # NIL) & (cnt < MaxTerms) DO - PolFeld[cnt] := p; - INC(cnt); - p := p.next; - END; - (* polynomial contains too many terms; this shouldn't happen if all - parameters are set to reasonable values and MaxTerms is high - enough *) - ASSERT(cnt 1 THEN - SortPolynom(0, cnt-1); - END; - p := r; - END ArrangePolynom; - - PROCEDURE CopyPolynom (s: Polynom; VAR t: Polynom); - (* copy the source polynomial s to a new target t *) - VAR - troot : Polynom; - BEGIN - IF s = NIL THEN - t := NIL; - RETURN; - END; - NEW(t); - troot := t; (* save the root of t *) - WHILE s # NIL DO - troot.koeff := s.koeff; - troot.exp := s.exp; - s := s.next; - IF s # NIL THEN - NEW(troot.next); - troot := troot.next; - ELSE - troot.next := NIL; - END; - END; - END CopyPolynom; - - PROCEDURE AddPolynom (p, q: Polynom; VAR r: Polynom); - (* add two polynomial; the polynomials must be sorted by the exponents as - is the result *) - VAR - term1, term2 : Polynom; - last : Polynom; (* the last term of the result *) - tmp : Polynom; - cmpres : SHORTINT; - BEGIN - IF (p = NIL) & (q = NIL) THEN - r := NIL; - RETURN; - END; - NEW(r); - term1 := p; (* term1 runs through all terms of p *) - term2 := q; (* same with term2 for q *) - tmp := r; (* save the root of r *) - last := tmp; - REPEAT - IF (term1 = NIL) OR (term2 = NIL) THEN - IF term2 = NIL THEN - (* no further terms in q *) - WHILE term1 # NIL DO - (* copy the remaining terms of p *) - tmp.koeff := term1.koeff; - tmp.exp := term1.exp; - term1 := term1.next; - IF ~EqualCCM(tmp.koeff, NullCCM) THEN - last := tmp; - NEW(tmp.next); - tmp := tmp.next; - END; - END; - ELSE (* no further terms in p *) - WHILE term2 # NIL DO - tmp.koeff := term2.koeff; - tmp.exp := term2.exp; - term2 := term2.next; - IF ~EqualCCM(tmp.koeff, NullCCM) THEN - last := tmp; - NEW(tmp.next); - tmp := tmp.next; - END; - END; - END; - ELSE (* both p and q still have a term *) - cmpres := CmpExp(term1.exp, term2.exp); - IF cmpres = 0 THEN (* add when exponents are equal *) - AddCCM(term1.koeff, term2.koeff, tmp.koeff); - tmp.exp := term1.exp; - term1 := term1.next; - term2 := term2.next; - ELSE - IF cmpres < 0 THEN (* exp2 > exp1 *) - tmp.koeff := term2.koeff; - tmp.exp := term2.exp; - term2 := term2.next; - ELSE (* exp1 > exp2 *) - tmp.koeff := term1.koeff; - tmp.exp := term1.exp; - term1 := term1.next; - END; - END; - (* zero coefficients = zero terms shouldn't occur in the result *) - IF ~EqualCCM(tmp.koeff, NullCCM) THEN - NEW(tmp.next); - last := tmp; - tmp := tmp.next; - END; - END; - UNTIL (term1 = NIL) & (term2 = NIL); - - (* forget last created term *) - last.next := NIL; - END AddPolynom; - - PROCEDURE MulTerm (p, term: Polynom; VAR r: Polynom); - (* multiply a polynomial with a single term; is used by MulPolynom *) - VAR - tmp : Polynom; - last : Polynom; - - (* add two exponent vetors; addition is modulo M *) - PROCEDURE AddExp (exp1, exp2 : Exponent; VAR res: Exponent); - VAR - i : SHORTINT; - BEGIN - i := 0; - WHILE i exp1 *) + tmp.koeff := term2.koeff; + tmp.exp := term2.exp; + term2 := term2.next; + ELSE (* exp1 > exp2 *) + tmp.koeff := term1.koeff; + tmp.exp := term1.exp; + term1 := term1.next; + END; + END; + (* zero coefficients = zero terms shouldn't occur in the result *) + IF ~EqualCCM(tmp.koeff, NullCCM) THEN + NEW(tmp.next); + last := tmp; + tmp := tmp.next; + END; END; - qterm := q; - WHILE qterm # NIL DO - MulTerm(p,qterm,tmp); (* multiply p with current term of q *) - AddPolynom(tmp,r,r); (* add up results *) - qterm := qterm.next; - END; - ArrangePolynom(r); - END MulPolynom; + UNTIL (term1 = NIL) & (term2 = NIL); - PROCEDURE MulPolynomWithCCM (p: Polynom; c: CCMElement; VAR r: Polynom); - (* multiplies a polynomial with a single element out of CC(M) *) - VAR - tmp : Polynom; - BEGIN - IF p = NIL THEN - r := NIL; - RETURN; - END; - CopyPolynom(p, r); - tmp := r; - WHILE tmp # NIL DO - MulCCM(tmp.koeff, c, tmp.koeff); - tmp := tmp.next; - END; - END MulPolynomWithCCM; + (* forget last created term *) + last.next := NIL; + END AddPolynom; - PROCEDURE InvertPolynom (p: Polynom; VAR res: Polynom); - (* inverts a regular polynomial; if p is illegal (NIL) or singular the - result is NIL *) - VAR - exp : SHORTINT; - tmp : Polynom; - BEGIN - IF (p = NIL) OR ~RegulaerPolynom(p) THEN - res := NIL; - RETURN; - END; - CopyPolynom(p, tmp); - CopyPolynom(NullPolynom, res); - res.koeff := EinsCCM; - (* works the same way as PowerCCM ["square-and-multiply"] *) - exp := M - 1; (* inverse means "power M-1" *) - WHILE exp > 0 DO - IF (exp MOD 2) = 1 THEN - MulPolynom(res, tmp, res); - END; - MulPolynom(tmp, tmp, tmp); - exp := exp DIV 2; - END; - END InvertPolynom; + PROCEDURE MulTerm (p, term: Polynom; VAR r: Polynom); + (* multiply a polynomial with a single term; is used by MulPolynom *) + VAR + tmp : Polynom; + last : Polynom; - PROCEDURE EvalPolynom (p: Polynom; VAR res: CCMElement); - (* evaluate p; a precomputed list of all the powers of the argument can - be found in the global variable PreEvalArg *) + (* add two exponent vetors; addition is modulo M *) + PROCEDURE AddExp (exp1, exp2 : Exponent; VAR res: Exponent); VAR - i : SHORTINT; - pow, prod : CCMElement; - BEGIN - res := NullCCM; - IF p = NIL THEN - RETURN; - END; - WHILE p # NIL DO - prod := PreEvalArg[p.exp[0]].arg[0]; - i := 1; - REPEAT - pow := PreEvalArg[p.exp[i]].arg[i]; - MulCCM(prod, pow, prod); - INC(i); - UNTIL i >= MaxVar; - MulCCM(prod, p.koeff, prod); - AddCCM(res, prod, res); - p := p.next; - END; - END EvalPolynom; - - PROCEDURE CreateExp (VAR exp: Exponent); - (* creates a random vector of exponents *) - VAR - i : SHORTINT; - BEGIN + i : SHORTINT; + BEGIN i := 0; WHILE i 0 DO + IF (exp MOD 2) = 1 THEN + MulPolynom(res, tmp, res); END; + MulPolynom(tmp, tmp, tmp); + exp := exp DIV 2; + END; + END InvertPolynom; - NEW(p); - proot := p; (* save root of p *) - regkoeffs := 0; (* # of regular coeff. in p *) - i := 0; - WHILE i= MaxVar; + MulCCM(prod, p.koeff, prod); + AddCCM(res, prod, res); + p := p.next; + END; + END EvalPolynom; - (* the last term must be created manually so that the result is - regular/singular (depending on mode) *) - IF i # terms THEN - CreateCCM(p.koeff, random); - IF RegulaerCCM(p.koeff) THEN - INC(regkoeffs); - END; - NEW(p.next); - p := p.next; - END; + PROCEDURE CreateExp (VAR exp: Exponent); + (* creates a random vector of exponents *) + VAR + i : SHORTINT; + BEGIN + i := 0; + WHILE i 0 DO + IF (kk MOD 2) = 1 THEN + MulCCM(tmp, PreEvalArg[ii].arg[i], tmp); + END; + INC(ii,ii); + kk := kk DIV 2; + END; + PreEvalArg[k].arg[i] := tmp; + INC(k); + END; + INC(i); + END; + END PreComputeArgs; - (* E(n), n=1,...,Rounds, und sigma := psi *) - NEW(psi); - dy := 0; - WHILE dy < Dim DO - dx := 0; - WHILE dx < Dim DO - psi.initialmatrix[dy][dx] := E[0][dy][dx].koeff; - INC(dx); - END; - INC(dy); - END; - r := 0; - WHILE r < Rounds DO - d := 0; - WHILE d < Dim DO - psi.korrNum[r][d] := korrNum[r][d]; - INC(d); - END; - psi.korrDenom[r] := korrDenom[r]; - INC(r); + PROCEDURE EvaluatePhi (arg: TCryptInput; data: Phi) : TCryptTmp; + (* evaluate the public function phi (represented by data) with + argument arg *) + VAR + res : TCryptTmp; + r, d : SHORTINT; + BEGIN + NEW(res); + PreComputeArgs(arg); + r := 0; + WHILE r < Rounds DO + d := 0; + WHILE d < Dim DO + EvalPolynom(data.num[r][d], res.numerator[r][d]); + INC(d); END; + EvalPolynom(data.denom[r], res.denominator[r]); + INC(r); + END; + RETURN res; + END EvaluatePhi; - (* A(Rounds) := eta *) - NEW(eta); - r := 0; - idx := Rounds - LastRounds; - WHILE idx < Rounds DO - d := 0; - WHILE d < Dim DO - CopyPolynom(A[idx][d], eta.p[r][d]); - INC(d); - END; - INC(r); - INC(idx); - END; - END CreateMaps; - - PROCEDURE PreComputeArgs(arg: TCryptInput); - (* used for preevaluation of a polynomial argument *) - VAR - k, i, kk, ii : INTEGER; - tmp : CCMElement; - BEGIN - i := 0; - WHILE i < MaxVar DO - PreEvalArg[1].arg[i] := arg.arg[i]; - INC(i); - END; - i := 0; - WHILE i < MaxVar DO - k := 2; - tmp := arg.arg[i]; - WHILE k < M DO - MulCCM(tmp, tmp, tmp); - PreEvalArg[k].arg[i] := tmp; - INC(k,k); - END; - k := 3; - WHILE k < M DO - kk := k; - ii := 1; - tmp := EinsCCM; - WHILE kk > 0 DO - IF (kk MOD 2) = 1 THEN - MulCCM(tmp, PreEvalArg[ii].arg[i], tmp); - END; - INC(ii,ii); - kk := kk DIV 2; - END; - PreEvalArg[k].arg[i] := tmp; - INC(k); - END; - INC(i); - END; - END PreComputeArgs; - - PROCEDURE EvaluatePhi (arg: TCryptInput; data: Phi) : TCryptTmp; - (* evaluate the public function phi (represented by data) with - argument arg *) - VAR - res : TCryptTmp; - r, d : SHORTINT; - BEGIN - NEW(res); - PreComputeArgs(arg); - r := 0; - WHILE r < Rounds DO - d := 0; - WHILE d < Dim DO - EvalPolynom(data.num[r][d], res.numerator[r][d]); - INC(d); - END; - EvalPolynom(data.denom[r], res.denominator[r]); - INC(r); - END; - RETURN res; - END EvaluatePhi; - - PROCEDURE EvaluatePsi (arg: TCryptTmp; data: Psi) : TCryptRes; - (* evalute the private function psi *) - VAR - res : TCryptRes; - mat, prev : MatCCM; - num, denom, inv : CCMElement; - vek : VektorCCM; - A : ChainCCM; - r, d : SHORTINT; - BEGIN - (* first correct the input with the correlating inverts *) - MulCCM(arg.denominator[0], data.korrDenom[0], denom); + PROCEDURE EvaluatePsi (arg: TCryptTmp; data: Psi) : TCryptRes; + (* evalute the private function psi *) + VAR + res : TCryptRes; + mat, prev : MatCCM; + num, denom, inv : CCMElement; + vek : VektorCCM; + A : ChainCCM; + r, d : SHORTINT; + BEGIN + (* first correct the input with the correlating inverts *) + MulCCM(arg.denominator[0], data.korrDenom[0], denom); + PowerCCM(denom, M-1, inv); + MulCCM(arg.numerator[0][0], data.korrNum[0][0], num); + MulCCM(num, inv, vek[0]); + MulCCM(arg.numerator[0][1], data.korrNum[0][1], num); + MulCCM(num, inv, vek[1]); + MulMatrix(data.initialmatrix, vek, A[0]); + prev := data.initialmatrix; + r := 1; + WHILE r < Rounds DO + (* the matrix for the current round of the recursion must be computed + each round *) + BuildMatrix(mat, prev, A[r-1]); + prev := mat; + MulCCM(arg.denominator[r], data.korrDenom[r], denom); PowerCCM(denom, M-1, inv); - MulCCM(arg.numerator[0][0], data.korrNum[0][0], num); + MulCCM(arg.numerator[r][0], data.korrNum[r][0], num); MulCCM(num, inv, vek[0]); - MulCCM(arg.numerator[0][1], data.korrNum[0][1], num); + MulCCM(arg.numerator[r][1], data.korrNum[r][1], num); MulCCM(num, inv, vek[1]); - MulMatrix(data.initialmatrix, vek, A[0]); - prev := data.initialmatrix; - r := 1; - WHILE r < Rounds DO - (* the matrix for the current round of the recursion must be computed - each round *) - BuildMatrix(mat, prev, A[r-1]); - prev := mat; - MulCCM(arg.denominator[r], data.korrDenom[r], denom); - PowerCCM(denom, M-1, inv); - MulCCM(arg.numerator[r][0], data.korrNum[r][0], num); - MulCCM(num, inv, vek[0]); - MulCCM(arg.numerator[r][1], data.korrNum[r][1], num); - MulCCM(num, inv, vek[1]); - MulMatrix(mat, vek, A[r]); - INC(r); + MulMatrix(mat, vek, A[r]); + INC(r); + END; + NEW(res); + r := 0; + WHILE r < LastRounds DO + d := 0; + WHILE d < Dim DO + res.arg[r][d] := A[Rounds-LastRounds+r][d]; + INC(d); END; - NEW(res); - r := 0; - WHILE r < LastRounds DO - d := 0; - WHILE d < Dim DO - res.arg[r][d] := A[Rounds-LastRounds+r][d]; - INC(d); - END; - INC(r); - END; - RETURN res; - END EvaluatePsi; + INC(r); + END; + RETURN res; + END EvaluatePsi; - PROCEDURE EvaluateEta (arg: TCryptInput; data: Eta) : TCryptRes; - (* evaluate the public function eta (composition of phi and psi) *) - VAR - l, d : SHORTINT; - res : TCryptRes; - BEGIN - NEW(res); - PreComputeArgs(arg); - l := 0; - WHILE l < LastRounds DO - d := 0; - WHILE d < Dim DO - EvalPolynom(data.p[l][d], res.arg[l][d]); - INC(d); - END; - INC(l); + PROCEDURE EvaluateEta (arg: TCryptInput; data: Eta) : TCryptRes; + (* evaluate the public function eta (composition of phi and psi) *) + VAR + l, d : SHORTINT; + res : TCryptRes; + BEGIN + NEW(res); + PreComputeArgs(arg); + l := 0; + WHILE l < LastRounds DO + d := 0; + WHILE d < Dim DO + EvalPolynom(data.p[l][d], res.arg[l][d]); + INC(d); END; - RETURN res; - END EvaluateEta; + INC(l); + END; + RETURN res; + END EvaluateEta; - PROCEDURE Eof (s: Streams.Stream) : BOOLEAN; - (* returns TRUE if no bytes are left to read from stream s *) - VAR - b : SYS.BYTE; - BEGIN - RETURN ~Streams.ReadByte(s, b) OR ~Streams.Back(s); - END Eof; + PROCEDURE Eof (s: Streams.Stream) : BOOLEAN; + (* returns TRUE if no bytes are left to read from stream s *) + VAR + b : SYS.BYTE; + BEGIN + RETURN ~Streams.ReadByte(s, b) OR ~Streams.Back(s); + END Eof; - PROCEDURE Encrypt (msg: Streams.Stream; key: Ciphers.Cipher; - length: INTEGER; s: Streams.Stream) : BOOLEAN; - (* interface procedure for Ciphers.Encrypt *) - VAR - i, j : SHORTINT; - ccmarg : TCryptInput; - ccmres : TCryptTmp; - wholeStream : BOOLEAN; - BEGIN - (* check if the whole stream msg shall be encrypted or only a certain - amount of bytes *) - IF length <= 0 THEN - wholeStream := TRUE; - ELSE - wholeStream := FALSE - END; - NEW(ccmarg); - WHILE ~Eof(msg) & (wholeStream OR (length > 0)) DO - i := 0; - WHILE i < MaxVar DO - IF ~NetIO.ReadSet(msg, ccmarg.arg[i]) THEN - Error(msg, readSetFailed); - RETURN FALSE; - END; - IF ~RegulaerCCM(ccmarg.arg[i]) THEN - Error(msg, notRegular); - RETURN FALSE; - END; - INC(i); - END; - IF key IS PublicCipher THEN - ccmres := EvaluatePhi(ccmarg, key(PublicCipher).phi); - ELSE - ccmres := EvaluatePhi(ccmarg, key(PrivateCipher).phi); - END; - i := 0; - WHILE i < Rounds DO - j := 0; - WHILE j < Dim DO - IF ~NetIO.WriteSet(s, ccmres.numerator[i][j]) THEN - Error(s, writeSetFailed); - RETURN FALSE; - END; - INC(j); - END; - IF ~NetIO.WriteSet(s, ccmres.denominator[i]) THEN - Error(s, writeSetFailed); - RETURN FALSE; - END; - INC(i); - END; - DEC(length, MaxVar*(M DIV 8)); - END; - RETURN TRUE; - END Encrypt; - - PROCEDURE Decrypt (msg: Streams.Stream; key: Ciphers.Cipher; - length: INTEGER; s: Streams.Stream) : BOOLEAN; - (* interface procedure for Ciphers.Decrypt *) - VAR - i, j : SHORTINT; - inNum, inDenom, out : ARRAY (M DIV 8) OF SYS.BYTE; - ccmarg : TCryptTmp; - ccmres : TCryptRes; - wholeStream : BOOLEAN; - BEGIN - IF length < 0 THEN - wholeStream := TRUE; - ELSE - wholeStream := FALSE; - END; - WITH key:PrivateCipher DO - NEW(ccmarg); - WHILE ~Eof(msg) & (wholeStream OR (length > 0)) DO - i := 0; - WHILE i < Rounds DO - j := 0; - WHILE j < Dim DO - IF ~NetIO.ReadSet(msg, ccmarg.numerator[i][j]) THEN - Error(msg, readSetFailed); - RETURN FALSE; - END; - INC(j); - END; - IF ~NetIO.ReadSet(msg, ccmarg.denominator[i]) THEN - Error(msg, readSetFailed); - RETURN FALSE; - END; - INC(i); - END; - ccmres := EvaluatePsi(ccmarg, key.psi); - i := 0; - WHILE i < LastRounds DO - j := 0; - WHILE j < Dim DO - IF ~NetIO.WriteSet(s, ccmres.arg[i][j]) THEN - Error(s, writeSetFailed); - RETURN FALSE; - END; - INC(j); - END; - INC(i); - END; - DEC (length, Rounds*Dim*(M DIV 8)); - END; - END; - RETURN TRUE; - END Decrypt; - - PROCEDURE ComposedEncrypt (msg: Streams.Stream; key: Ciphers.Cipher; - length: INTEGER; s: Streams.Stream) : BOOLEAN; - (* interface procedure for AsymmetricCiphers.ComposedEncrypt *) - VAR - i, j : SHORTINT; - ccmarg : TCryptInput; - ccmres : TCryptRes; - in, out : ARRAY (M DIV 8) OF SYS.BYTE; - wholeStream : BOOLEAN; - BEGIN - IF length < 0 THEN - wholeStream := TRUE; - ELSE - wholeStream := FALSE; - END; - NEW(ccmarg); - WHILE ~Eof(msg) & (wholeStream OR (length > 0)) DO - i := 0; - WHILE i < MaxVar DO - IF ~NetIO.ReadSet(msg, ccmarg.arg[i]) THEN - Error(msg, readSetFailed); - RETURN FALSE; - END; - INC(i); - END; - IF key IS PublicCipher THEN - ccmres := EvaluateEta(ccmarg, key(PublicCipher).eta); - ELSE - ccmres := EvaluateEta(ccmarg, key(PrivateCipher).eta); - END; - i := 0; - WHILE i < LastRounds DO - j := 0; - WHILE j < Dim DO - IF ~NetIO.WriteSet(s, ccmres.arg[i][j]) THEN - Error(s, writeSetFailed); - RETURN FALSE; - END; - INC(j); - END; - INC(i); - END; - DEC (length, MaxVar*(M DIV 8)); - END; - RETURN TRUE; - END ComposedEncrypt; - - PROCEDURE RandomStream (s: Streams.Stream); - (* writes some random elements of CC(M) to the stream s which can then - be used as an input for Trautner's TCRYPT *) - VAR - ccm : CCMElement; - bytes : ARRAY M DIV 8 OF SYS.BYTE; - i : INTEGER; - BEGIN + PROCEDURE Encrypt (msg: Streams.Stream; key: Ciphers.Cipher; + length: INTEGER; s: Streams.Stream) : BOOLEAN; + (* interface procedure for Ciphers.Encrypt *) + VAR + i, j : SHORTINT; + ccmarg : TCryptInput; + ccmres : TCryptTmp; + wholeStream : BOOLEAN; + BEGIN + (* check if the whole stream msg shall be encrypted or only a certain + amount of bytes *) + IF length <= 0 THEN + wholeStream := TRUE; + ELSE + wholeStream := FALSE + END; + NEW(ccmarg); + WHILE ~Eof(msg) & (wholeStream OR (length > 0)) DO i := 0; WHILE i < MaxVar DO - CreateCCM(ccm, reg); - IF ~NetIO.WriteSet(s, ccm) THEN + IF ~NetIO.ReadSet(msg, ccmarg.arg[i]) THEN + Error(msg, readSetFailed); + RETURN FALSE; + END; + IF ~RegulaerCCM(ccmarg.arg[i]) THEN + Error(msg, notRegular); + RETURN FALSE; + END; + INC(i); + END; + IF key IS PublicCipher THEN + ccmres := EvaluatePhi(ccmarg, key(PublicCipher).phi); + ELSE + ccmres := EvaluatePhi(ccmarg, key(PrivateCipher).phi); + END; + i := 0; + WHILE i < Rounds DO + j := 0; + WHILE j < Dim DO + IF ~NetIO.WriteSet(s, ccmres.numerator[i][j]) THEN Error(s, writeSetFailed); - END; - INC(i); - END; - END RandomStream; - - PROCEDURE PublicCipherCreate (VAR obj: PersistentObjects.Object); - (* constructor for a public cipher *) - VAR - pub : PublicCipher; - if : AsymmetricCiphers.Interface; - caps : AsymmetricCiphers.CapabilitySet; - BEGIN - NEW(pub); NEW(pub.phi); NEW(pub.eta); - PersistentObjects.Init(pub, pubType); - NEW(if); if.encrypt := Encrypt; if.decrypt := NIL; - if.compencrypt := ComposedEncrypt; if.split := NIL; - if.randomStream := RandomStream; - caps := {AsymmetricCiphers.composed}; - AsymmetricCiphers.Init(pub, if, caps, M*MaxVar, M*Dim); - obj := pub; - END PublicCipherCreate; - - PROCEDURE Split (VAR public: AsymmetricCiphers.Cipher; - key: AsymmetricCiphers.Cipher); - (* interface procedure for asymmetric interface *) - VAR - pub: PublicCipher; - BEGIN - WITH key:PrivateCipher DO - PublicCipherCreate(SYS.VAL(PersistentObjects.Object, pub)); - pub.phi := key.phi; - pub.eta := key.eta; - public := pub; - END; - END Split; - - PROCEDURE CipherCreate (VAR obj: PersistentObjects.Object); - (* constructor for a private cipher *) - VAR - key : PrivateCipher; - if : AsymmetricCiphers.Interface; - caps : AsymmetricCiphers.CapabilitySet; - BEGIN - NEW(key); NEW(key.phi); NEW(key.psi); NEW(key.eta); - PersistentObjects.Init(key, privType); - NEW(if); if.encrypt := Encrypt; if.decrypt := Decrypt; - if.compencrypt := ComposedEncrypt; if.split := Split; - if.randomStream := RandomStream; - caps := {AsymmetricCiphers.composed, AsymmetricCiphers.isPrivateKey}; - AsymmetricCiphers.Init(key, if, caps, M*MaxVar, M*Dim); - obj := key; - END CipherCreate; - - PROCEDURE Create* (VAR key: Ciphers.Cipher); - (* creates a cipher for the use with Trautner's TCRYPT algorithm *) - VAR - tmpKey : PrivateCipher; - phi : Phi; - psi : Psi; - eta : Eta; - BEGIN - CipherCreate(SYS.VAL(PersistentObjects.Object, tmpKey)); - CreateMaps(tmpKey.phi, tmpKey.psi, tmpKey.eta); - key := tmpKey; - END Create; - - PROCEDURE WritePolynom (s: Streams.Stream; p: Polynom) : BOOLEAN; - (* writes the polynomial p onto the stream s *) - CONST - index = M DIV 8; - VAR - nrOfTerms, i : INTEGER; - bytes : ARRAY index OF SYS.BYTE; - BEGIN - nrOfTerms := LengthPolynom(p); - IF ~NetIO.WriteInteger(s, nrOfTerms) THEN - RETURN FALSE; - END; - WHILE nrOfTerms > 0 DO - IF ~NetIO.WriteSet(s, p.koeff) THEN RETURN FALSE; - END; - i := 0; - WHILE i < MaxVar DO - IF ~NetIO.WriteShortInt(s, p.exp[i]) THEN - RETURN FALSE; - END; - INC(i); - END; - p := p.next; - DEC(nrOfTerms); + END; + INC(j); + END; + IF ~NetIO.WriteSet(s, ccmres.denominator[i]) THEN + Error(s, writeSetFailed); + RETURN FALSE; + END; + INC(i); END; - RETURN TRUE; - END WritePolynom; + DEC(length, MaxVar*(M DIV 8)); + END; + RETURN TRUE; + END Encrypt; - PROCEDURE ReadPolynom (s: Streams.Stream; VAR p: Polynom) : BOOLEAN; - (* reads a polynomial from stream s *) - CONST - index = M DIV 8; - VAR - nrOfTerms, i : INTEGER; - pol : Polynom; - bytes : ARRAY index OF SYS.BYTE; - BEGIN - IF ~NetIO.ReadInteger(s, nrOfTerms) THEN - RETURN FALSE; - END; - NEW(p); - pol := p; - WHILE nrOfTerms > 0 DO - IF ~NetIO.ReadSet(s, pol.koeff) THEN + PROCEDURE Decrypt (msg: Streams.Stream; key: Ciphers.Cipher; + length: INTEGER; s: Streams.Stream) : BOOLEAN; + (* interface procedure for Ciphers.Decrypt *) + VAR + i, j : SHORTINT; + inNum, inDenom, out : ARRAY (M DIV 8) OF SYS.BYTE; + ccmarg : TCryptTmp; + ccmres : TCryptRes; + wholeStream : BOOLEAN; + BEGIN + IF length < 0 THEN + wholeStream := TRUE; + ELSE + wholeStream := FALSE; + END; + WITH key:PrivateCipher DO + NEW(ccmarg); + WHILE ~Eof(msg) & (wholeStream OR (length > 0)) DO + i := 0; + WHILE i < Rounds DO + j := 0; + WHILE j < Dim DO + IF ~NetIO.ReadSet(msg, ccmarg.numerator[i][j]) THEN + Error(msg, readSetFailed); + RETURN FALSE; + END; + INC(j); + END; + IF ~NetIO.ReadSet(msg, ccmarg.denominator[i]) THEN + Error(msg, readSetFailed); RETURN FALSE; - END; - i := 0; - WHILE i < MaxVar DO - IF ~NetIO.ReadShortInt(s, pol.exp[i]) THEN - RETURN FALSE; + END; + INC(i); + END; + ccmres := EvaluatePsi(ccmarg, key.psi); + i := 0; + WHILE i < LastRounds DO + j := 0; + WHILE j < Dim DO + IF ~NetIO.WriteSet(s, ccmres.arg[i][j]) THEN + Error(s, writeSetFailed); + RETURN FALSE; END; - INC(i); - END; - DEC(nrOfTerms); - IF nrOfTerms > 0 THEN - NEW(pol.next); - pol := pol.next; - END + INC(j); + END; + INC(i); + END; + DEC (length, Rounds*Dim*(M DIV 8)); END; - RETURN TRUE; - END ReadPolynom; + END; + RETURN TRUE; + END Decrypt; - PROCEDURE PhiWrite (s: Streams.Stream; data: Phi) : BOOLEAN; - (* writes the data structure for the public function phi onto a stream *) - VAR - r, d, k : INTEGER; - BEGIN - r := 0; - WHILE r < Rounds DO - d := 0; - WHILE d < Dim DO - IF ~WritePolynom(s, data.num[r][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - IF ~WritePolynom(s, data.denom[r]) THEN + PROCEDURE ComposedEncrypt (msg: Streams.Stream; key: Ciphers.Cipher; + length: INTEGER; s: Streams.Stream) : BOOLEAN; + (* interface procedure for AsymmetricCiphers.ComposedEncrypt *) + VAR + i, j : SHORTINT; + ccmarg : TCryptInput; + ccmres : TCryptRes; + in, out : ARRAY (M DIV 8) OF SYS.BYTE; + wholeStream : BOOLEAN; + BEGIN + IF length < 0 THEN + wholeStream := TRUE; + ELSE + wholeStream := FALSE; + END; + NEW(ccmarg); + WHILE ~Eof(msg) & (wholeStream OR (length > 0)) DO + i := 0; + WHILE i < MaxVar DO + IF ~NetIO.ReadSet(msg, ccmarg.arg[i]) THEN + Error(msg, readSetFailed); + RETURN FALSE; + END; + INC(i); + END; + IF key IS PublicCipher THEN + ccmres := EvaluateEta(ccmarg, key(PublicCipher).eta); + ELSE + ccmres := EvaluateEta(ccmarg, key(PrivateCipher).eta); + END; + i := 0; + WHILE i < LastRounds DO + j := 0; + WHILE j < Dim DO + IF ~NetIO.WriteSet(s, ccmres.arg[i][j]) THEN + Error(s, writeSetFailed); RETURN FALSE; - END; - INC(r); + END; + INC(j); + END; + INC(i); END; - RETURN TRUE; - END PhiWrite; + DEC (length, MaxVar*(M DIV 8)); + END; + RETURN TRUE; + END ComposedEncrypt; - PROCEDURE PhiRead (s: Streams.Stream; VAR data: Phi) : BOOLEAN; - (* reads the data structure for the public function phi from a stream *) - VAR - r, d, k : INTEGER; - BEGIN - NEW(data); - r := 0; - WHILE r < Rounds DO - d := 0; - WHILE d < Dim DO - IF ~ReadPolynom(s, data.num[r][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - IF ~ReadPolynom(s, data.denom[r]) THEN - RETURN FALSE; - END; - INC(r); + PROCEDURE RandomStream (s: Streams.Stream); + (* writes some random elements of CC(M) to the stream s which can then + be used as an input for Trautner's TCRYPT *) + VAR + ccm : CCMElement; + bytes : ARRAY M DIV 8 OF SYS.BYTE; + i : INTEGER; + BEGIN + i := 0; + WHILE i < MaxVar DO + CreateCCM(ccm, reg); + IF ~NetIO.WriteSet(s, ccm) THEN + Error(s, writeSetFailed); END; - RETURN TRUE; - END PhiRead; + INC(i); + END; + END RandomStream; - PROCEDURE PsiWrite (s: Streams.Stream; data: Psi) : BOOLEAN; - (* writes the data structure for the private function psi onto a stream *) - CONST - index = M DIV 8; - VAR - dx, dy, r, d : INTEGER; - bytes : ARRAY index OF SYS.BYTE; - BEGIN - dy := 0; - WHILE dy < Dim DO - dx := 0; - WHILE dx < Dim DO - IF ~NetIO.WriteSet(s, data.initialmatrix[dy][dx]) THEN - RETURN FALSE; - END; - INC(dx); - END; - INC(dy); - END; - r := 0; - WHILE r < Rounds DO - d := 0; - WHILE d < Dim DO - IF ~NetIO.WriteSet(s, data.korrNum[r][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - IF ~NetIO.WriteSet(s, data.korrDenom[r]) THEN - RETURN FALSE; - END; - INC(r); - END; - RETURN TRUE; - END PsiWrite; + PROCEDURE PublicCipherCreate (VAR obj: PersistentObjects.Object); + (* constructor for a public cipher *) + VAR + pub : PublicCipher; + if : AsymmetricCiphers.Interface; + caps : AsymmetricCiphers.CapabilitySet; + BEGIN + NEW(pub); NEW(pub.phi); NEW(pub.eta); + PersistentObjects.Init(pub, pubType); + NEW(if); if.encrypt := Encrypt; if.decrypt := NIL; + if.compencrypt := ComposedEncrypt; if.split := NIL; + if.randomStream := RandomStream; + caps := {AsymmetricCiphers.composed}; + AsymmetricCiphers.Init(pub, if, caps, M*MaxVar, M*Dim); + obj := pub; + END PublicCipherCreate; - PROCEDURE PsiRead (s: Streams.Stream; VAR data: Psi) : BOOLEAN; - (* reads the data structure for the private function psi from a stream *) - CONST - index = M DIV 8; - VAR - dy, dx, r, d : INTEGER; - bytes : ARRAY index OF SYS.BYTE; - BEGIN - dy := 0; - WHILE dy < Dim DO - dx := 0; - WHILE dx < Dim DO - IF ~NetIO.ReadSet(s, data.initialmatrix[dy][dx]) THEN - RETURN FALSE; - END; - INC(dx); - END; - INC(dy); - END; - r := 0; - WHILE r < Rounds DO - d := 0; - WHILE d < Dim DO - IF ~NetIO.ReadSet(s, data.korrNum[r][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - IF ~NetIO.ReadSet(s, data.korrDenom[r]) THEN - RETURN FALSE; - END; - INC(r); - END; - RETURN TRUE; - END PsiRead; + PROCEDURE Split (VAR public: AsymmetricCiphers.Cipher; + key: AsymmetricCiphers.Cipher); + (* interface procedure for asymmetric interface *) + VAR + pub: PublicCipher; + obj: PersistentObjects.Object; + BEGIN + WITH key:PrivateCipher DO + PublicCipherCreate(obj); pub := obj(PublicCipher); + pub.phi := key.phi; + pub.eta := key.eta; + public := pub; + END; + END Split; - PROCEDURE EtaWrite (s: Streams.Stream; data: Eta) : BOOLEAN; - (* writes the data structure for the public function eta onto a stream *) - VAR - l, d : INTEGER; - BEGIN - l := 0; - WHILE l < LastRounds DO - d := 0; - WHILE d < Dim DO - IF ~WritePolynom(s, data.p[l][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - INC(l); - END; - RETURN TRUE; - END EtaWrite; + PROCEDURE CipherCreate (VAR obj: PersistentObjects.Object); + (* constructor for a private cipher *) + VAR + key : PrivateCipher; + if : AsymmetricCiphers.Interface; + caps : AsymmetricCiphers.CapabilitySet; + BEGIN + NEW(key); NEW(key.phi); NEW(key.psi); NEW(key.eta); + PersistentObjects.Init(key, privType); + NEW(if); if.encrypt := Encrypt; if.decrypt := Decrypt; + if.compencrypt := ComposedEncrypt; if.split := Split; + if.randomStream := RandomStream; + caps := {AsymmetricCiphers.composed, AsymmetricCiphers.isPrivateKey}; + AsymmetricCiphers.Init(key, if, caps, M*MaxVar, M*Dim); + obj := key; + END CipherCreate; - PROCEDURE EtaRead (s: Streams.Stream; VAR data: Eta) : BOOLEAN; - (* reads the data structure for the public function eta from a stream *) - VAR - l, d : INTEGER; - BEGIN - NEW(data); - l := 0; - WHILE l < LastRounds DO - d := 0; - WHILE d < Dim DO - IF ~ReadPolynom(s, data.p[l][d]) THEN - RETURN FALSE; - END; - INC(d); - END; - INC(l); - END; - RETURN TRUE; - END EtaRead; + PROCEDURE Create* (VAR key: Ciphers.Cipher); + (* creates a cipher for the use with Trautner's TCRYPT algorithm *) + VAR + tmpKey : PrivateCipher; + obj : PersistentObjects.Object; + phi : Phi; + psi : Psi; + eta : Eta; + BEGIN + CipherCreate(obj); tmpKey := obj(PrivateCipher); + CreateMaps(tmpKey.phi, tmpKey.psi, tmpKey.eta); + key := tmpKey; + END Create; - PROCEDURE PubWrite (s: Streams.Stream; - obj: PersistentObjects.Object) : BOOLEAN; - (* interface procedure for PersistentObjects *) - BEGIN - WITH obj:PublicCipher DO - RETURN PhiWrite(s, obj.phi) & EtaWrite(s, obj.eta); + PROCEDURE WritePolynom (s: Streams.Stream; p: Polynom) : BOOLEAN; + (* writes the polynomial p onto the stream s *) + CONST + index = M DIV 8; + VAR + nrOfTerms, i : INTEGER; + bytes : ARRAY index OF SYS.BYTE; + BEGIN + nrOfTerms := LengthPolynom(p); + IF ~NetIO.WriteInteger(s, nrOfTerms) THEN + RETURN FALSE; + END; + WHILE nrOfTerms > 0 DO + IF ~NetIO.WriteSet(s, p.koeff) THEN + RETURN FALSE; END; - END PubWrite; + i := 0; + WHILE i < MaxVar DO + IF ~NetIO.WriteShortInt(s, p.exp[i]) THEN + RETURN FALSE; + END; + INC(i); + END; + p := p.next; + DEC(nrOfTerms); + END; + RETURN TRUE; + END WritePolynom; - PROCEDURE CipherWrite (s: Streams.Stream; - obj: PersistentObjects.Object) : BOOLEAN; - (* interface procedure for PersistentObjects *) - BEGIN - WITH obj:PrivateCipher DO - RETURN PhiWrite(s, obj.phi) & - PsiWrite(s, obj.psi) & - EtaWrite(s, obj.eta); + PROCEDURE ReadPolynom (s: Streams.Stream; VAR p: Polynom) : BOOLEAN; + (* reads a polynomial from stream s *) + CONST + index = M DIV 8; + VAR + nrOfTerms, i : INTEGER; + pol : Polynom; + bytes : ARRAY index OF SYS.BYTE; + BEGIN + IF ~NetIO.ReadInteger(s, nrOfTerms) THEN + RETURN FALSE; + END; + NEW(p); + pol := p; + WHILE nrOfTerms > 0 DO + IF ~NetIO.ReadSet(s, pol.koeff) THEN + RETURN FALSE; END; - END CipherWrite; + i := 0; + WHILE i < MaxVar DO + IF ~NetIO.ReadShortInt(s, pol.exp[i]) THEN + RETURN FALSE; + END; + INC(i); + END; + DEC(nrOfTerms); + IF nrOfTerms > 0 THEN + NEW(pol.next); + pol := pol.next; + END + END; + RETURN TRUE; + END ReadPolynom; - PROCEDURE PubRead (s: Streams.Stream; - obj: PersistentObjects.Object) : BOOLEAN; - (* interface procedure for PersistentObjects *) - BEGIN - WITH obj:PublicCipher DO - IF ~PhiRead(s, obj.phi) OR ~EtaRead(s, obj.eta) THEN - RETURN FALSE; - END; + PROCEDURE PhiWrite (s: Streams.Stream; data: Phi) : BOOLEAN; + (* writes the data structure for the public function phi onto a stream *) + VAR + r, d, k : INTEGER; + BEGIN + r := 0; + WHILE r < Rounds DO + d := 0; + WHILE d < Dim DO + IF ~WritePolynom(s, data.num[r][d]) THEN + RETURN FALSE; + END; + INC(d); END; - RETURN TRUE; - END PubRead; + IF ~WritePolynom(s, data.denom[r]) THEN + RETURN FALSE; + END; + INC(r); + END; + RETURN TRUE; + END PhiWrite; - PROCEDURE CipherRead (s: Streams.Stream; - obj: PersistentObjects.Object) : BOOLEAN; - (* interface procedure for PersistentObjects *) - BEGIN - WITH obj:PrivateCipher DO - IF ~PhiRead(s, obj.phi) OR - ~PsiRead(s, obj.psi) OR - ~EtaRead(s, obj.eta) THEN - RETURN FALSE; - END; + PROCEDURE PhiRead (s: Streams.Stream; VAR data: Phi) : BOOLEAN; + (* reads the data structure for the public function phi from a stream *) + VAR + r, d, k : INTEGER; + BEGIN + NEW(data); + r := 0; + WHILE r < Rounds DO + d := 0; + WHILE d < Dim DO + IF ~ReadPolynom(s, data.num[r][d]) THEN + RETURN FALSE; + END; + INC(d); END; - RETURN TRUE; - END CipherRead; + IF ~ReadPolynom(s, data.denom[r]) THEN + RETURN FALSE; + END; + INC(r); + END; + RETURN TRUE; + END PhiRead; + + PROCEDURE PsiWrite (s: Streams.Stream; data: Psi) : BOOLEAN; + (* writes the data structure for the private function psi onto a stream *) + CONST + index = M DIV 8; + VAR + dx, dy, r, d : INTEGER; + bytes : ARRAY index OF SYS.BYTE; + BEGIN + dy := 0; + WHILE dy < Dim DO + dx := 0; + WHILE dx < Dim DO + IF ~NetIO.WriteSet(s, data.initialmatrix[dy][dx]) THEN + RETURN FALSE; + END; + INC(dx); + END; + INC(dy); + END; + r := 0; + WHILE r < Rounds DO + d := 0; + WHILE d < Dim DO + IF ~NetIO.WriteSet(s, data.korrNum[r][d]) THEN + RETURN FALSE; + END; + INC(d); + END; + IF ~NetIO.WriteSet(s, data.korrDenom[r]) THEN + RETURN FALSE; + END; + INC(r); + END; + RETURN TRUE; + END PsiWrite; + + PROCEDURE PsiRead (s: Streams.Stream; VAR data: Psi) : BOOLEAN; + (* reads the data structure for the private function psi from a stream *) + CONST + index = M DIV 8; + VAR + dy, dx, r, d : INTEGER; + bytes : ARRAY index OF SYS.BYTE; + BEGIN + dy := 0; + WHILE dy < Dim DO + dx := 0; + WHILE dx < Dim DO + IF ~NetIO.ReadSet(s, data.initialmatrix[dy][dx]) THEN + RETURN FALSE; + END; + INC(dx); + END; + INC(dy); + END; + r := 0; + WHILE r < Rounds DO + d := 0; + WHILE d < Dim DO + IF ~NetIO.ReadSet(s, data.korrNum[r][d]) THEN + RETURN FALSE; + END; + INC(d); + END; + IF ~NetIO.ReadSet(s, data.korrDenom[r]) THEN + RETURN FALSE; + END; + INC(r); + END; + RETURN TRUE; + END PsiRead; + + PROCEDURE EtaWrite (s: Streams.Stream; data: Eta) : BOOLEAN; + (* writes the data structure for the public function eta onto a stream *) + VAR + l, d : INTEGER; + BEGIN + l := 0; + WHILE l < LastRounds DO + d := 0; + WHILE d < Dim DO + IF ~WritePolynom(s, data.p[l][d]) THEN + RETURN FALSE; + END; + INC(d); + END; + INC(l); + END; + RETURN TRUE; + END EtaWrite; + + PROCEDURE EtaRead (s: Streams.Stream; VAR data: Eta) : BOOLEAN; + (* reads the data structure for the public function eta from a stream *) + VAR + l, d : INTEGER; + BEGIN + NEW(data); + l := 0; + WHILE l < LastRounds DO + d := 0; + WHILE d < Dim DO + IF ~ReadPolynom(s, data.p[l][d]) THEN + RETURN FALSE; + END; + INC(d); + END; + INC(l); + END; + RETURN TRUE; + END EtaRead; + + PROCEDURE PubWrite (s: Streams.Stream; + obj: PersistentObjects.Object) : BOOLEAN; + (* interface procedure for PersistentObjects *) + BEGIN + WITH obj:PublicCipher DO + RETURN PhiWrite(s, obj.phi) & EtaWrite(s, obj.eta); + END; + END PubWrite; + + PROCEDURE CipherWrite (s: Streams.Stream; + obj: PersistentObjects.Object) : BOOLEAN; + (* interface procedure for PersistentObjects *) + BEGIN + WITH obj:PrivateCipher DO + RETURN PhiWrite(s, obj.phi) & + PsiWrite(s, obj.psi) & + EtaWrite(s, obj.eta); + END; + END CipherWrite; + + PROCEDURE PubRead (s: Streams.Stream; + obj: PersistentObjects.Object) : BOOLEAN; + (* interface procedure for PersistentObjects *) + BEGIN + WITH obj:PublicCipher DO + IF ~PhiRead(s, obj.phi) OR ~EtaRead(s, obj.eta) THEN + RETURN FALSE; + END; + END; + RETURN TRUE; + END PubRead; + + PROCEDURE CipherRead (s: Streams.Stream; + obj: PersistentObjects.Object) : BOOLEAN; + (* interface procedure for PersistentObjects *) + BEGIN + WITH obj:PrivateCipher DO + IF ~PhiRead(s, obj.phi) OR + ~PsiRead(s, obj.psi) OR + ~EtaRead(s, obj.eta) THEN + RETURN FALSE; + END; + END; + RETURN TRUE; + END CipherRead; BEGIN - (* init of the zero and unit of CC(M) *) - NullCCM := {}; - EinsCCM := {0}; + (* init of the zero and unit of CC(M) *) + NullCCM := {}; + EinsCCM := {0}; - (* init of the zero exponent *) - k := 0; - WHILE k Priorities.base THEN - desc.caps := desc.caps + {Conditions.select, Conditions.async}; - desc.internal := priorityOfClock < Priorities.interrupts; - END; - END; - NEW(domain); Conditions.InitDomain(domain, if, desc); - domain.clock := clock; - IF Clocks.timer IN Clocks.Capabilities(clock) THEN - Events.Define(domain.alarm); - Events.SetPriority(domain.alarm, priorityOfClock + 1); - Events.Handler(domain.alarm, Wakeup); - ELSE - domain.alarm := NIL; - END; - NEW(clockDisc); clockDisc.id := disciplineId; - clockDisc.domain := domain; - Disciplines.Add(clock, clockDisc); - domain.event := NIL; + TYPE + WakeupEvent = POINTER TO WakeupEventRec; + WakeupEventRec = + RECORD + (Events.EventRec) + condition: Condition; + awaked: BOOLEAN; (* set to true by Wakeup event handler *) END; - Conditions.Init(condition, domain); - FixTime(time, currentTime, clock); condition.time := time; - condition.domain := domain; - condition.passed := Clocks.Passed(clock, time); - condition.scheduled := FALSE; - IF ~condition.passed & - (domain.alarm # NIL) & (clock # Clocks.system) THEN - ScheduleEvent(condition); - END; - END Init; - PROCEDURE Create*(VAR condition: Conditions.Condition; - clock: Clocks.Clock; time: Times.Time); - (* create and initialize a time condition: - is the current time of the clock greater than or - equal to `time'; - if time is relative then it is taken relative to the current time - *) - VAR - timeCond: Condition; - BEGIN - NEW(timeCond); - Init(timeCond, clock, time); - condition := timeCond; - END Create; + VAR + if: Conditions.Interface; - (* ======== interface procedures ================================ *) - - PROCEDURE GetTime(clock: Clocks.Clock; - VAR currentTime: Times.Time; - errors: RelatedEvents.Object) : BOOLEAN; - (* get the current time of clock and check for errors *) - VAR - oldEvents, newEvents: RelatedEvents.Queue; - BEGIN - RelatedEvents.GetQueue(clock, oldEvents); + PROCEDURE FixTime(VAR time: Times.Time; + currentTime: Times.Time; + clock: Clocks.Clock); + (* convert relative time measures into absolute time specs *) + VAR op: Op.Operand; + BEGIN + IF Scales.IsRelative(time) THEN Clocks.GetTime(clock, currentTime); - RelatedEvents.GetQueue(clock, newEvents); - IF newEvents # NIL THEN - RelatedEvents.AppendQueue(errors, newEvents); - END; - IF oldEvents # NIL THEN - RelatedEvents.AppendQueue(clock, oldEvents); - END; - IF newEvents # NIL THEN - RelatedEvents.AppendQueue(clock, newEvents); - END; - RETURN newEvents = NIL - END GetTime; + op := time; Op.Add3(op, currentTime, time); time := op(Times.Time) + END; + END FixTime; - PROCEDURE Passed(clock: Clocks.Clock; - time: Times.Time; - VAR passed: BOOLEAN; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - oldEvents, newEvents: RelatedEvents.Queue; - BEGIN - RelatedEvents.GetQueue(clock, oldEvents); - passed := Clocks.Passed(clock, time); - RelatedEvents.GetQueue(clock, newEvents); - IF newEvents # NIL THEN - RelatedEvents.AppendQueue(errors, newEvents); + PROCEDURE Wakeup(event: Events.Event); + (* note that we strictly rely on the capability of the + underlying clock to raise this event at the appropriate + time; we are unable to verify it because that could + deadlock us in case of remote clocks + *) + VAR + condevent: Events.Event; (* event requested by SendEvent *) + BEGIN + WITH event: WakeupEvent DO + event.awaked := TRUE; + IF event.condition # NIL THEN + event.condition.passed := TRUE; + event.condition.scheduled := FALSE; + condevent := event.condition.domain.event; + IF condevent # NIL THEN + event.condition.domain.event := NIL; + Events.Raise(condevent); + END; END; - IF oldEvents # NIL THEN - RelatedEvents.AppendQueue(clock, oldEvents); - END; - IF newEvents # NIL THEN - RelatedEvents.AppendQueue(clock, newEvents); - END; - RETURN newEvents = NIL - END Passed; + END; + END Wakeup; - PROCEDURE Test(domain: Conditions.Domain; condition: Conditions.Condition; - errors: RelatedEvents.Object) : BOOLEAN; - VAR - currentTime: Times.Time; - BEGIN - WITH domain: Domain DO WITH condition: Condition DO - IF condition.passed THEN RETURN TRUE END; - IF condition.domain.event # NIL THEN RETURN FALSE END; - IF condition.scheduled THEN RETURN FALSE END; - IF ~Passed(domain.clock, condition.time, - condition.passed, errors) THEN - condition.passed := TRUE; - RETURN TRUE - END; - RETURN condition.passed - END; END; - END Test; + PROCEDURE ScheduleEvent(condition: Condition); + VAR + wakeup: WakeupEvent; + domain: Domain; + BEGIN + IF ~condition.scheduled THEN + domain := condition.domain; + ASSERT(domain.alarm # NIL); + NEW(wakeup); wakeup.type := domain.alarm; + wakeup.awaked := FALSE; wakeup.condition := condition; + condition.scheduled := TRUE; + Timers.Schedule(domain.clock, condition.time, wakeup); + END; + END ScheduleEvent; - PROCEDURE GetMinTime(conditionSet: Conditions.ConditionSet; - VAR minTime: Times.Time; - VAR minCond: Condition); + PROCEDURE Init*(condition: Condition; clock: Clocks.Clock; time: Times.Time); + (* like Create but without NEW *) + VAR + clockDisc: Discipline; + disc: Disciplines.Discipline; + domain: Domain; + desc: Conditions.Description; + priorityOfClock: Priorities.Priority; + currentTime: Times.Time; + BEGIN + IF Disciplines.Seek(clock, disciplineId, disc) THEN + domain := disc(Discipline).domain; + ELSE + (* create new domain *) + NEW(desc); desc.caps := {}; desc.internal := TRUE; + IF clock = Clocks.system THEN + desc.caps := desc.caps + + {Conditions.timelimit, Conditions.timecond}; + END; + IF Clocks.timer IN Clocks.Capabilities(clock) THEN + Clocks.GetPriority(clock, priorityOfClock); + IF priorityOfClock > Priorities.base THEN + desc.caps := desc.caps + {Conditions.select, Conditions.async}; + desc.internal := priorityOfClock < Priorities.interrupts; + END; + END; + NEW(domain); Conditions.InitDomain(domain, if, desc); + domain.clock := clock; + IF Clocks.timer IN Clocks.Capabilities(clock) THEN + Events.Define(domain.alarm); + Events.SetPriority(domain.alarm, priorityOfClock + 1); + Events.Handler(domain.alarm, Wakeup); + ELSE + domain.alarm := NIL; + END; + NEW(clockDisc); clockDisc.id := disciplineId; + clockDisc.domain := domain; + Disciplines.Add(clock, clockDisc); + domain.event := NIL; + END; + Conditions.Init(condition, domain); + FixTime(time, currentTime, clock); condition.time := time; + condition.domain := domain; + condition.passed := Clocks.Passed(clock, time); + condition.scheduled := FALSE; + IF ~condition.passed & + (domain.alarm # NIL) & (clock # Clocks.system) THEN + ScheduleEvent(condition); + END; + END Init; + + PROCEDURE Create*(VAR condition: Conditions.Condition; + clock: Clocks.Clock; time: Times.Time); + (* create and initialize a time condition: + is the current time of the clock greater than or + equal to `time'; + if time is relative then it is taken relative to the current time + *) + VAR + timeCond: Condition; + BEGIN + NEW(timeCond); + Init(timeCond, clock, time); + condition := timeCond; + END Create; + + (* ======== interface procedures ================================ *) + + PROCEDURE GetTime(clock: Clocks.Clock; + VAR currentTime: Times.Time; + errors: RelatedEvents.Object) : BOOLEAN; + (* get the current time of clock and check for errors *) + VAR + oldEvents, newEvents: RelatedEvents.Queue; + BEGIN + RelatedEvents.GetQueue(clock, oldEvents); + Clocks.GetTime(clock, currentTime); + RelatedEvents.GetQueue(clock, newEvents); + IF newEvents # NIL THEN + RelatedEvents.AppendQueue(errors, newEvents); + END; + IF oldEvents # NIL THEN + RelatedEvents.AppendQueue(clock, oldEvents); + END; + IF newEvents # NIL THEN + RelatedEvents.AppendQueue(clock, newEvents); + END; + RETURN newEvents = NIL + END GetTime; + + PROCEDURE Passed(clock: Clocks.Clock; + time: Times.Time; + VAR passed: BOOLEAN; + errors: RelatedEvents.Object) : BOOLEAN; + VAR + oldEvents, newEvents: RelatedEvents.Queue; + BEGIN + RelatedEvents.GetQueue(clock, oldEvents); + passed := Clocks.Passed(clock, time); + RelatedEvents.GetQueue(clock, newEvents); + IF newEvents # NIL THEN + RelatedEvents.AppendQueue(errors, newEvents); + END; + IF oldEvents # NIL THEN + RelatedEvents.AppendQueue(clock, oldEvents); + END; + IF newEvents # NIL THEN + RelatedEvents.AppendQueue(clock, newEvents); + END; + RETURN newEvents = NIL + END Passed; + + PROCEDURE Test(domain: Conditions.Domain; condition: Conditions.Condition; + errors: RelatedEvents.Object) : BOOLEAN; + VAR + currentTime: Times.Time; + BEGIN + WITH domain: Domain DO WITH condition: Condition DO + IF condition.passed THEN RETURN TRUE END; + IF condition.domain.event # NIL THEN RETURN FALSE END; + IF condition.scheduled THEN RETURN FALSE END; + IF ~Passed(domain.clock, condition.time, + condition.passed, errors) THEN + condition.passed := TRUE; + RETURN TRUE + END; + RETURN condition.passed + END; END; + END Test; + + PROCEDURE GetMinTime(conditionSet: Conditions.ConditionSet; + VAR minTime: Times.Time; + VAR minCond: Condition); + VAR + condition: Conditions.Condition; (* Condition *) + op: Op.Operand; + BEGIN + minTime := NIL; + Conditions.ExamineConditions(conditionSet); + WHILE Conditions.GetNextCondition(conditionSet, condition) DO + IF (minTime = NIL) OR (Op.Compare(condition(Condition).time, minTime) < 0) THEN + minTime := condition(Condition).time; minCond := condition(Condition) + END; + END; + op := minTime; Op.Assign(op, minTime); minTime := op(Times.Time) (* take a copy *) + END GetMinTime; + + PROCEDURE Select(domain: Conditions.Domain; + conditionSet: Conditions.ConditionSet; + time: Times.Time; + VAR setOfTrueConditions: Conditions.ConditionSet; + errors: RelatedEvents.Object; + retry: BOOLEAN; + VAR interrupted: BOOLEAN) : BOOLEAN; + VAR + minTime: Times.Time; + minCond: Condition; + currentTime: Times.Time; (* of Clocks.system *) + condition: Conditions.Condition; (* Condition *) + wakeup: WakeupEvent; + anythingTrue: BOOLEAN; + + PROCEDURE Failure; + (* we are unable to retrieve the time; + so we have to mark all conditions as passed + and to return the whole set + *) VAR - condition: Condition; - BEGIN - minTime := NIL; + condition: Conditions.Condition; (* Condition *) + BEGIN + Conditions.CreateSet(setOfTrueConditions); Conditions.ExamineConditions(conditionSet); - WHILE Conditions.GetNextCondition(conditionSet, SYSTEM.VAL(Conditions.Condition, condition)) DO - IF (minTime = NIL) OR (Op.Compare(condition.time, minTime) < 0) THEN - minTime := condition.time; minCond := condition; - END; + WHILE Conditions.GetNextCondition(conditionSet, condition) DO + condition(Condition).passed := TRUE; + Conditions.Incl(setOfTrueConditions, condition(Condition)); END; - Op.Assign(SYSTEM.VAL(Op.Operand, minTime), minTime); (* take a copy *) - END GetMinTime; + END Failure; - PROCEDURE Select(domain: Conditions.Domain; - conditionSet: Conditions.ConditionSet; - time: Times.Time; - VAR setOfTrueConditions: Conditions.ConditionSet; - errors: RelatedEvents.Object; - retry: BOOLEAN; - VAR interrupted: BOOLEAN) : BOOLEAN; - VAR - minTime: Times.Time; - minCond: Condition; - currentTime: Times.Time; (* of Clocks.system *) - condition: Condition; - wakeup: WakeupEvent; - anythingTrue: BOOLEAN; + BEGIN (* Select *) + WITH domain: Domain DO + GetMinTime(conditionSet, minTime, minCond); - PROCEDURE Failure; - (* we are unable to retrieve the time; - so we have to mark all conditions as passed - and to return the whole set - *) - VAR - condition: Condition; - BEGIN - Conditions.CreateSet(setOfTrueConditions); - Conditions.ExamineConditions(conditionSet); - WHILE Conditions.GetNextCondition(conditionSet, SYSTEM.VAL(Conditions.Condition, condition)) DO - condition.passed := TRUE; - Conditions.Incl(setOfTrueConditions, condition); - END; - END Failure; - - BEGIN (* Select *) - WITH domain: Domain DO - GetMinTime(conditionSet, minTime, minCond); - - (* block current process, if necessary *) - interrupted := FALSE; - IF time # NIL THEN - Clocks.GetTime(Clocks.system, currentTime); - FixTime(time, currentTime, Clocks.system); - NEW(wakeup); wakeup.type := domain.alarm; - wakeup.condition := NIL; wakeup.awaked := FALSE; - Timers.Schedule(Clocks.system, time, wakeup); - END; - IF ~GetTime(domain.clock, currentTime, errors) THEN - Failure; RETURN TRUE - END; - - IF ~minCond.passed THEN - LOOP (* goes only into loop if retry = TRUE & we get interrupted *) - Process.Pause; - IF wakeup.awaked THEN EXIT END; - interrupted := ~minCond.passed; - IF ~interrupted THEN EXIT END; - IF ~retry THEN RETURN FALSE END; - END; - END; - - anythingTrue := FALSE; - Conditions.CreateSet(setOfTrueConditions); - Conditions.ExamineConditions(conditionSet); - WHILE Conditions.GetNextCondition(conditionSet, SYSTEM.VAL(Conditions.Condition, condition)) DO - IF condition.passed THEN - Conditions.Incl(setOfTrueConditions, condition); - anythingTrue := TRUE; - END; - END; - RETURN anythingTrue + (* block current process, if necessary *) + interrupted := FALSE; + IF time # NIL THEN + Clocks.GetTime(Clocks.system, currentTime); + FixTime(time, currentTime, Clocks.system); + NEW(wakeup); wakeup.type := domain.alarm; + wakeup.condition := NIL; wakeup.awaked := FALSE; + Timers.Schedule(Clocks.system, time, wakeup); + END; + IF ~GetTime(domain.clock, currentTime, errors) THEN + Failure; RETURN TRUE END; - END Select; - PROCEDURE SendEvent(domain: Conditions.Domain; - condition: Conditions.Condition; - event: Events.Event; - errors: RelatedEvents.Object) : BOOLEAN; - BEGIN - WITH domain: Domain DO WITH condition: Condition DO - IF condition.passed THEN - RETURN FALSE - ELSE - domain.event := event; - ScheduleEvent(condition); - RETURN TRUE - END; - END; END; - END SendEvent; + IF ~minCond.passed THEN + LOOP (* goes only into loop if retry = TRUE & we get interrupted *) + Process.Pause; + IF wakeup.awaked THEN EXIT END; + interrupted := ~minCond.passed; + IF ~interrupted THEN EXIT END; + IF ~retry THEN RETURN FALSE END; + END; + END; - PROCEDURE GetNextTime(domain: Conditions.Domain; - conditionSet: Conditions.ConditionSet; - VAR nextTime: Times.Time; - VAR nextCond: Conditions.Condition; - errors: RelatedEvents.Object); - VAR - condition: Condition; - BEGIN - GetMinTime(conditionSet, nextTime, condition); - nextCond := condition; - END GetNextTime; + anythingTrue := FALSE; + Conditions.CreateSet(setOfTrueConditions); + Conditions.ExamineConditions(conditionSet); + WHILE Conditions.GetNextCondition(conditionSet, condition) DO + IF condition(Condition).passed THEN + Conditions.Incl(setOfTrueConditions, condition(Condition)); + anythingTrue := TRUE; + END; + END; + RETURN anythingTrue + END; + END Select; - PROCEDURE InitInterface; - BEGIN - NEW(if); - if.test := Test; - if.select := Select; - if.sendevent := SendEvent; - if.gettime := GetNextTime; - END InitInterface; + PROCEDURE SendEvent(domain: Conditions.Domain; + condition: Conditions.Condition; + event: Events.Event; + errors: RelatedEvents.Object) : BOOLEAN; + BEGIN + WITH domain: Domain DO WITH condition: Condition DO + IF condition.passed THEN + RETURN FALSE + ELSE + domain.event := event; + ScheduleEvent(condition); + RETURN TRUE + END; + END; END; + END SendEvent; + + PROCEDURE GetNextTime(domain: Conditions.Domain; + conditionSet: Conditions.ConditionSet; + VAR nextTime: Times.Time; + VAR nextCond: Conditions.Condition; + errors: RelatedEvents.Object); + VAR + condition: Condition; + BEGIN + GetMinTime(conditionSet, nextTime, condition); + nextCond := condition; + END GetNextTime; + + PROCEDURE InitInterface; + BEGIN + NEW(if); + if.test := Test; + if.select := Select; + if.sendevent := SendEvent; + if.gettime := GetNextTime; + END InitInterface; BEGIN - disciplineId := Disciplines.Unique(); - InitInterface; + disciplineId := Disciplines.Unique(); + InitInterface; END ulmTimeConditions. diff --git a/src/library/ulm/ulmTimers.Mod b/src/library/ulm/ulmTimers.Mod index 88ca1996..62c45e7f 100644 --- a/src/library/ulm/ulmTimers.Mod +++ b/src/library/ulm/ulmTimers.Mod @@ -1,336 +1,338 @@ (* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Timers.om,v 1.3 2001/04/30 14:58:18 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Timers.om,v $ - Revision 1.3 2001/04/30 14:58:18 borchert - bug fix: recursion via Clocks.TimerOn was not possible + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Timers.om,v 1.3 2001/04/30 14:58:18 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Timers.om,v $ + Revision 1.3 2001/04/30 14:58:18 borchert + bug fix: recursion via Clocks.TimerOn was not possible - Revision 1.2 1994/07/18 14:21:51 borchert - bug fix: CreateQueue took uninitialized priority variable instead of - queue.priority + Revision 1.2 1994/07/18 14:21:51 borchert + bug fix: CreateQueue took uninitialized priority variable instead of + queue.priority - Revision 1.1 1994/02/22 20:11:37 borchert - Initial revision + Revision 1.1 1994/02/22 20:11:37 borchert + Initial revision - ---------------------------------------------------------------------------- - AFB 1/92 - ---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- + AFB 1/92 + ---------------------------------------------------------------------------- *) MODULE ulmTimers; - IMPORT Clocks := ulmClocks, Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Op := ulmOperations, Priorities := ulmPriorities, - SYS := ulmSYSTEM, SYSTEM, RelatedEvents := ulmRelatedEvents, Scales := ulmScales, Times := ulmTimes; + IMPORT Clocks := ulmClocks, Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, Op := ulmOperations, Priorities := ulmPriorities, + SYS := ulmSYSTEM, RelatedEvents := ulmRelatedEvents, Scales := ulmScales, Times := ulmTimes; - TYPE - Queue = POINTER TO QueueRec; - Timer* = POINTER TO TimerRec; - TimerRec* = - RECORD - (Objects.ObjectRec) - valid: BOOLEAN; (* a valid timer entry? *) - queue: Queue; (* timer belongs to this queue *) - prev, next: Timer; (* double-linked and sorted list *) - time: Times.Time; (* key *) - event: Events.Event; (* raise this event at the given time *) - END; - QueueRec = - RECORD - (Disciplines.ObjectRec) - clock: Clocks.Clock; (* queue of this clock *) - priority: Priorities.Priority; (* priority of the clock *) - checkQueue: Events.EventType; (* check queue on this event *) - head, tail: Timer; (* sorted list of timers *) - lock: BOOLEAN; - END; - TYPE - CheckQueueEvent = POINTER TO CheckQueueEventRec; - CheckQueueEventRec = - RECORD - (Events.EventRec) - queue: Queue; - END; - TYPE - ClockDiscipline = POINTER TO ClockDisciplineRec; - ClockDisciplineRec = - RECORD - (Disciplines.DisciplineRec) - queue: Queue; - END; - VAR - clockDisciplineId: Disciplines.Identifier; - - CONST - invalidTimer* = 0; (* timer is no longer valid *) - queueLocked* = 1; (* the queue is currently locked *) - badClock* = 2; (* clock is unable to maintain a timer *) - errorcodes* = 3; - TYPE - ErrorEvent* = POINTER TO ErrorEventRec; - ErrorEventRec* = - RECORD - (Events.EventRec) - errorcode*: SHORTINT; - END; - VAR - errormsg*: ARRAY errorcodes OF Events.Message; - error*: Events.EventType; - - PROCEDURE InitErrorHandling; - BEGIN - errormsg[invalidTimer] := "invalid timer given to Timers.Remove"; - errormsg[queueLocked] := "the queue is currently locked"; - errormsg[badClock] := "clock is unable to maintain a timer"; - Events.Define(error); Events.SetPriority(error, Priorities.liberrors); - END InitErrorHandling; - - PROCEDURE Error(errors: RelatedEvents.Object; code: SHORTINT); - VAR - event: ErrorEvent; - BEGIN - NEW(event); - event.type := error; - event.message := errormsg[code]; - event.errorcode := code; - RelatedEvents.Raise(errors, event); - END Error; - - PROCEDURE CheckQueue(queue: Queue); - VAR - currentTime: Times.Time; - oldTimers: Timer; - p, prev: Timer; - checkQueueEvent: CheckQueueEvent; - nextTimer: Timer; - BEGIN - IF queue.head = NIL THEN queue.lock := FALSE; RETURN END; - - Clocks.GetTime(queue.clock, currentTime); - - (* remove old timers from queue *) - oldTimers := queue.head; - p := queue.head; prev := NIL; - WHILE (p # NIL) & (Op.Compare(currentTime, p.time) >= 0) DO - prev := p; p := p.next; + TYPE + Queue = POINTER TO QueueRec; + Timer* = POINTER TO TimerRec; + TimerRec* = + RECORD + (Objects.ObjectRec) + valid: BOOLEAN; (* a valid timer entry? *) + queue: Queue; (* timer belongs to this queue *) + prev, next: Timer; (* double-linked and sorted list *) + time: Times.Time; (* key *) + event: Events.Event; (* raise this event at the given time *) END; - IF p = NIL THEN - queue.head := NIL; queue.tail := NIL; - ELSE - queue.head := p; - p.prev := NIL; + QueueRec = + RECORD + (Disciplines.ObjectRec) + clock: Clocks.Clock; (* queue of this clock *) + priority: Priorities.Priority; (* priority of the clock *) + checkQueue: Events.EventType; (* check queue on this event *) + head, tail: Timer; (* sorted list of timers *) + lock: BOOLEAN; END; - IF prev = NIL THEN - oldTimers := NIL; - ELSE - prev.next := NIL; + TYPE + CheckQueueEvent = POINTER TO CheckQueueEventRec; + CheckQueueEventRec = + RECORD + (Events.EventRec) + queue: Queue; END; + TYPE + ClockDiscipline = POINTER TO ClockDisciplineRec; + ClockDisciplineRec = + RECORD + (Disciplines.DisciplineRec) + queue: Queue; + END; + VAR + clockDisciplineId: Disciplines.Identifier; - (* set up next check-queue-event, if necessary *) - nextTimer := queue.head; - queue.lock := FALSE; - (* unlock queue now to allow recursion via Clocks.TimerOn *) - IF nextTimer # NIL THEN - NEW(checkQueueEvent); - checkQueueEvent.type := queue.checkQueue; - checkQueueEvent.message := "check queue of timer"; - checkQueueEvent.queue := queue; - Clocks.TimerOn(queue.clock, nextTimer.time, checkQueueEvent); - ELSE - Clocks.TimerOff(queue.clock); + CONST + invalidTimer* = 0; (* timer is no longer valid *) + queueLocked* = 1; (* the queue is currently locked *) + badClock* = 2; (* clock is unable to maintain a timer *) + errorcodes* = 3; + TYPE + ErrorEvent* = POINTER TO ErrorEventRec; + ErrorEventRec* = + RECORD + (Events.EventRec) + errorcode*: SHORTINT; END; + VAR + errormsg*: ARRAY errorcodes OF Events.Message; + error*: Events.EventType; - (* process old timers *) - p := oldTimers; - WHILE p # NIL DO - p.valid := FALSE; - Events.Raise(p.event); - p := p.next; - END; - END CheckQueue; + PROCEDURE InitErrorHandling; + BEGIN + errormsg[invalidTimer] := "invalid timer given to Timers.Remove"; + errormsg[queueLocked] := "the queue is currently locked"; + errormsg[badClock] := "clock is unable to maintain a timer"; + Events.Define(error); Events.SetPriority(error, Priorities.liberrors); + END InitErrorHandling; - PROCEDURE CatchCheckQueueEvents(event: Events.Event); - BEGIN - WITH event: CheckQueueEvent DO - IF ~SYS.TAS(event.queue.lock) THEN - CheckQueue(event.queue); - (* event.queue.lock := FALSE; (* done by CheckQueue *) *) - END; - END; - END CatchCheckQueueEvents; + PROCEDURE Error(errors: RelatedEvents.Object; code: SHORTINT); + VAR + event: ErrorEvent; + BEGIN + NEW(event); + event.type := error; + event.message := errormsg[code]; + event.errorcode := code; + RelatedEvents.Raise(errors, event); + END Error; - PROCEDURE CreateQueue(errors: RelatedEvents.Object; - VAR queue: Queue; clock: Clocks.Clock) : BOOLEAN; - VAR - clockDiscipline: ClockDiscipline; - BEGIN - IF ~(Clocks.timer IN Clocks.Capabilities(clock)) THEN - Error(errors, badClock); RETURN FALSE - END; + PROCEDURE CheckQueue(queue: Queue); + VAR + currentTime: Times.Time; + oldTimers: Timer; + p, prev: Timer; + checkQueueEvent: CheckQueueEvent; + nextTimer: Timer; + BEGIN + IF queue.head = NIL THEN queue.lock := FALSE; RETURN END; - NEW(queue); - queue.clock := clock; + Clocks.GetTime(queue.clock, currentTime); + + (* remove old timers from queue *) + oldTimers := queue.head; + p := queue.head; prev := NIL; + WHILE (p # NIL) & (Op.Compare(currentTime, p.time) >= 0) DO + prev := p; p := p.next; + END; + IF p = NIL THEN queue.head := NIL; queue.tail := NIL; - queue.lock := FALSE; - Events.Define(queue.checkQueue); - Events.Handler(queue.checkQueue, CatchCheckQueueEvents); - Clocks.GetPriority(clock, queue.priority); - IF queue.priority > Priorities.base THEN - Events.SetPriority(queue.checkQueue, queue.priority + 1); + ELSE + queue.head := p; + p.prev := NIL; + END; + IF prev = NIL THEN + oldTimers := NIL; + ELSE + prev.next := NIL; + END; + + (* set up next check-queue-event, if necessary *) + nextTimer := queue.head; + queue.lock := FALSE; + (* unlock queue now to allow recursion via Clocks.TimerOn *) + IF nextTimer # NIL THEN + NEW(checkQueueEvent); + checkQueueEvent.type := queue.checkQueue; + checkQueueEvent.message := "check queue of timer"; + checkQueueEvent.queue := queue; + Clocks.TimerOn(queue.clock, nextTimer.time, checkQueueEvent); + ELSE + Clocks.TimerOff(queue.clock); + END; + + (* process old timers *) + p := oldTimers; + WHILE p # NIL DO + p.valid := FALSE; + Events.Raise(p.event); + p := p.next; + END; + END CheckQueue; + + PROCEDURE CatchCheckQueueEvents(event: Events.Event); + BEGIN + WITH event: CheckQueueEvent DO + IF ~SYS.TAS(event.queue.lock) THEN + CheckQueue(event.queue); + (* event.queue.lock := FALSE; (* done by CheckQueue *) *) + END; + END; + END CatchCheckQueueEvents; + + PROCEDURE CreateQueue(errors: RelatedEvents.Object; + VAR queue: Queue; clock: Clocks.Clock) : BOOLEAN; + VAR + clockDiscipline: ClockDiscipline; + BEGIN + IF ~(Clocks.timer IN Clocks.Capabilities(clock)) THEN + Error(errors, badClock); RETURN FALSE + END; + + NEW(queue); + queue.clock := clock; + queue.head := NIL; queue.tail := NIL; + queue.lock := FALSE; + Events.Define(queue.checkQueue); + Events.Handler(queue.checkQueue, CatchCheckQueueEvents); + Clocks.GetPriority(clock, queue.priority); + IF queue.priority > Priorities.base THEN + Events.SetPriority(queue.checkQueue, queue.priority + 1); + ELSE + queue.priority := Priorities.default; + END; + + NEW(clockDiscipline); clockDiscipline.id := clockDisciplineId; + clockDiscipline.queue := queue; + Disciplines.Add(clock, clockDiscipline); + RETURN TRUE + END CreateQueue; + + PROCEDURE Add*(clock: Clocks.Clock; time: Times.Time; event: Events.Event; + VAR timer: Timer); + VAR + queue: Queue; + clockDiscipline: Disciplines.Discipline; (* ClockDiscipline *) + p: Timer; + absTime: Times.Time; + op: Op.Operand; + BEGIN + IF Disciplines.Seek(clock, clockDisciplineId, clockDiscipline) THEN + queue := clockDiscipline(ClockDiscipline).queue; + ELSIF ~CreateQueue(clock, queue, clock) THEN + RETURN + END; + + IF SYS.TAS(queue.lock) THEN + Error(clock, queueLocked); RETURN + END; + Events.AssertPriority(queue.priority); + + IF Scales.IsRelative(time) THEN + (* take relative time to be relative to the current time *) + Clocks.GetTime(clock, absTime); + (* Op.Add2(SYSTEM.VAL(Op.Operand, absTime), time); *) + op := absTime; Op.Add2(op, time); absTime := op(Times.Time); + ELSE + (* create a copy of time *) + op := NIL; Op.Assign(op, time); absTime := op(Times.Time); + END; + time := absTime; + NEW(timer); timer.time := time; timer.event := event; + timer.queue := queue; timer.valid := TRUE; + + (* look for the insertion point *) + p := queue.head; + WHILE (p # NIL) & (Op.Compare(time, p.time) > 0) DO + p := p.next; + END; + + (* insert timer in front of p *) + timer.next := p; + IF p = NIL THEN + (* append timer at the end of the queue *) + timer.prev := queue.tail; + IF queue.tail = NIL THEN + queue.head := timer; ELSE - queue.priority := Priorities.default; + queue.tail.next := timer; END; - - NEW(clockDiscipline); clockDiscipline.id := clockDisciplineId; - clockDiscipline.queue := queue; - Disciplines.Add(clock, clockDiscipline); - RETURN TRUE - END CreateQueue; - - PROCEDURE Add*(clock: Clocks.Clock; time: Times.Time; event: Events.Event; - VAR timer: Timer); - VAR - queue: Queue; - clockDiscipline: ClockDiscipline; - p: Timer; - absTime: Times.Time; - BEGIN - IF Disciplines.Seek(clock, clockDisciplineId, SYSTEM.VAL(Disciplines.Discipline, clockDiscipline)) THEN - queue := clockDiscipline.queue; - ELSIF ~CreateQueue(clock, queue, clock) THEN - RETURN + queue.tail := timer; + ELSE + timer.prev := p.prev; + timer.next := p; + IF p = queue.head THEN + queue.head := timer; + ELSE + p.prev.next := timer; END; + p.prev := timer; + END; + CheckQueue(queue); + (* queue.lock := FALSE; (* done by CheckQueue *) *) + Events.ExitPriority; + END Add; + + PROCEDURE Remove*(timer: Timer); + VAR + queue: Queue; + BEGIN + IF timer.valid THEN + queue := timer.queue; IF SYS.TAS(queue.lock) THEN - Error(clock, queueLocked); RETURN + Error(queue.clock, queueLocked); RETURN END; Events.AssertPriority(queue.priority); - - IF Scales.IsRelative(time) THEN - (* take relative time to be relative to the current time *) - Clocks.GetTime(clock, absTime); - Op.Add2(SYSTEM.VAL(Op.Operand, absTime), time); + timer.valid := FALSE; + IF timer.prev = NIL THEN + queue.head := timer.next; ELSE - (* create a copy of time *) - absTime := NIL; Op.Assign(SYSTEM.VAL(Op.Operand, absTime), time); + timer.prev.next := timer.next; END; - time := absTime; - NEW(timer); timer.time := time; timer.event := event; - timer.queue := queue; timer.valid := TRUE; - - (* look for the insertion point *) - p := queue.head; - WHILE (p # NIL) & (Op.Compare(time, p.time) > 0) DO - p := p.next; - END; - - (* insert timer in front of p *) - timer.next := p; - IF p = NIL THEN - (* append timer at the end of the queue *) - timer.prev := queue.tail; - IF queue.tail = NIL THEN - queue.head := timer; - ELSE - queue.tail.next := timer; - END; - queue.tail := timer; + IF timer.next = NIL THEN + queue.tail := timer.prev; ELSE - timer.prev := p.prev; - timer.next := p; - IF p = queue.head THEN - queue.head := timer; - ELSE - p.prev.next := timer; - END; - p.prev := timer; + timer.next.prev := timer.prev; END; - CheckQueue(queue); (* queue.lock := FALSE; (* done by CheckQueue *) *) Events.ExitPriority; - END Add; + ELSE + Error(timer.queue.clock, invalidTimer); + END; + END Remove; - PROCEDURE Remove*(timer: Timer); - VAR - queue: Queue; - BEGIN - IF timer.valid THEN - queue := timer.queue; - IF SYS.TAS(queue.lock) THEN - Error(queue.clock, queueLocked); RETURN - END; - Events.AssertPriority(queue.priority); - timer.valid := FALSE; - IF timer.prev = NIL THEN - queue.head := timer.next; - ELSE - timer.prev.next := timer.next; - END; - IF timer.next = NIL THEN - queue.tail := timer.prev; - ELSE - timer.next.prev := timer.prev; - END; - CheckQueue(queue); - (* queue.lock := FALSE; (* done by CheckQueue *) *) - Events.ExitPriority; - ELSE - Error(timer.queue.clock, invalidTimer); - END; - END Remove; + PROCEDURE Schedule*(clock: Clocks.Clock; + time: Times.Time; event: Events.Event); + VAR + timer: Timer; + BEGIN + Add(clock, time, event, timer); + END Schedule; - PROCEDURE Schedule*(clock: Clocks.Clock; - time: Times.Time; event: Events.Event); - VAR - timer: Timer; - BEGIN - Add(clock, time, event, timer); - END Schedule; + PROCEDURE NextEvent*(clock: Clocks.Clock; VAR time: Times.Time) : BOOLEAN; + VAR + rval: BOOLEAN; + queue: Queue; + clockDiscipline: Disciplines.Discipline; (* ClockDiscipline *) + BEGIN + IF ~Disciplines.Seek(clock, clockDisciplineId, clockDiscipline) THEN + RETURN FALSE + END; + queue := clockDiscipline(ClockDiscipline).queue; - PROCEDURE NextEvent*(clock: Clocks.Clock; VAR time: Times.Time) : BOOLEAN; - VAR - rval: BOOLEAN; - queue: Queue; - clockDiscipline: ClockDiscipline; - BEGIN - IF ~Disciplines.Seek(clock, clockDisciplineId, SYSTEM.VAL(Disciplines.Discipline, clockDiscipline)) THEN - RETURN FALSE - END; - queue := clockDiscipline.queue; - - IF SYS.TAS(queue.lock) THEN - Error(clock, queueLocked); RETURN FALSE - END; - CheckQueue(queue); - IF queue.head # NIL THEN - time := queue.head.time; - rval := TRUE; - ELSE - rval := FALSE - END; - (* queue.lock := FALSE; (* done by CheckQueue *) *) - RETURN rval - END NextEvent; + IF SYS.TAS(queue.lock) THEN + Error(clock, queueLocked); RETURN FALSE + END; + CheckQueue(queue); + IF queue.head # NIL THEN + time := queue.head.time; + rval := TRUE; + ELSE + rval := FALSE + END; + (* queue.lock := FALSE; (* done by CheckQueue *) *) + RETURN rval + END NextEvent; BEGIN - InitErrorHandling; - clockDisciplineId := Disciplines.Unique(); + InitErrorHandling; + clockDisciplineId := Disciplines.Unique(); END ulmTimers. diff --git a/src/library/ulm/ulmTimes.Mod b/src/library/ulm/ulmTimes.Mod index e7dc122f..cf45c823 100644 --- a/src/library/ulm/ulmTimes.Mod +++ b/src/library/ulm/ulmTimes.Mod @@ -1,398 +1,401 @@ (* Ulm's Oberon Library - Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany - ---------------------------------------------------------------------------- - Ulm's Oberon Library is free software; you can redistribute it - and/or modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either version - 2 of the License, or (at your option) any later version. + Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany + ---------------------------------------------------------------------------- + Ulm's Oberon Library is free software; you can redistribute it + and/or modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either version + 2 of the License, or (at your option) any later version. - Ulm's Oberon Library is distributed in the hope that it will be - useful, but WITHOUT ANY WARRANTY; without even the implied warranty - of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. + Ulm's Oberon Library is distributed in the hope that it will be + useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - ---------------------------------------------------------------------------- - E-mail contact: oberon@mathematik.uni-ulm.de - ---------------------------------------------------------------------------- - $Id: Times.om,v 1.3 2001/04/30 14:54:44 borchert Exp $ - ---------------------------------------------------------------------------- - $Log: Times.om,v $ - Revision 1.3 2001/04/30 14:54:44 borchert - bug fix: base type is TimeRec instead of Times.TimeRec - (invalid self-reference) + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + ---------------------------------------------------------------------------- + E-mail contact: oberon@mathematik.uni-ulm.de + ---------------------------------------------------------------------------- + $Id: Times.om,v 1.3 2001/04/30 14:54:44 borchert Exp $ + ---------------------------------------------------------------------------- + $Log: Times.om,v $ + Revision 1.3 2001/04/30 14:54:44 borchert + bug fix: base type is TimeRec instead of Times.TimeRec + (invalid self-reference) - Revision 1.2 1995/04/07 13:25:07 borchert - fixes due to changed if of PersistentObjects + Revision 1.2 1995/04/07 13:25:07 borchert + fixes due to changed if of PersistentObjects - Revision 1.1 1994/02/22 20:12:02 borchert - Initial revision + Revision 1.1 1994/02/22 20:12:02 borchert + Initial revision - ---------------------------------------------------------------------------- - AFB 12/91 - ---------------------------------------------------------------------------- + ---------------------------------------------------------------------------- + AFB 12/91 + ---------------------------------------------------------------------------- *) MODULE ulmTimes; - IMPORT NetIO := ulmNetIO, Objects := ulmObjects, Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, Scales := ulmScales, - Services := ulmServices, Streams := ulmStreams, SYSTEM; + IMPORT NetIO := ulmNetIO, Objects := ulmObjects, Operations := ulmOperations, PersistentObjects := ulmPersistentObjects, Scales := ulmScales, + Services := ulmServices, Streams := ulmStreams; - CONST - relative* = Scales.relative; - absolute* = Scales.absolute; - TYPE - (* the common base type of all time measures *) - Time* = POINTER TO TimeRec; - TimeRec* = RECORD (Scales.MeasureRec) END; + CONST + relative* = Scales.relative; + absolute* = Scales.absolute; + TYPE + (* the common base type of all time measures *) + Time* = POINTER TO TimeRec; + TimeRec* = RECORD (Scales.MeasureRec) END; - CONST - usecsPerSec = 1000000; (* 10^6 *) - TYPE - (* units of the reference implementation: - epoch, second and usec - *) - TimeValueRec* = - RECORD - (Objects.ObjectRec) - (* epoch 0: Jan. 1, 1970; - each epoch has a length of MAX(Scales.Value) + 1 seconds; - epoch may be negative: - -1 is the epoch just before 1970 - *) - epoch*: Scales.Value; - (* seconds and ... *) - second*: Scales.Value; - (* ... microseconds since the beginning of the epoch *) - usec*: Scales.Value; - END; - - (* ==== private datatypes for the reference scale *) - TYPE - ReferenceTime = POINTER TO ReferenceTimeRec; - ReferenceTimeRec = - RECORD - (TimeRec) - timeval: TimeValueRec; - END; - VAR - absType, relType: Services.Type; - CONST - epochUnit = 0; secondUnit = 1; usecUnit = 2; - TYPE - Unit = POINTER TO UnitRec; - UnitRec = - RECORD - (Scales.UnitRec) - index: SHORTINT; (* epochUnit..usecUnit *) - END; - - VAR - scale*: Scales.Scale; (* reference scale *) - family*: Scales.Family; (* family of time scales *) - if: Scales.Interface; - - PROCEDURE Create*(VAR time: Time; type: SHORTINT); - (* type = absolute or relative *) - VAR - m: Scales.Measure; - BEGIN - Scales.CreateMeasure(scale, m, type); - time := m(Time); - END Create; - - PROCEDURE Normalize(VAR timeval: TimeValueRec); - (* make sure that second and usec >= 0 *) - VAR - toomanysecs: Scales.Value; - secs: Scales.Value; - BEGIN - IF timeval.second < 0 THEN - INC(timeval.second, 1); - INC(timeval.second, MAX(Scales.Value)); - DEC(timeval.epoch); + CONST + usecsPerSec = 1000000; (* 10^6 *) + TYPE + (* units of the reference implementation: + epoch, second and usec + *) + TimeValueRec* = + RECORD + (Objects.ObjectRec) + (* epoch 0: Jan. 1, 1970; + each epoch has a length of MAX(Scales.Value) + 1 seconds; + epoch may be negative: + -1 is the epoch just before 1970 + *) + epoch*: Scales.Value; + (* seconds and ... *) + second*: Scales.Value; + (* ... microseconds since the beginning of the epoch *) + usec*: Scales.Value; END; - IF timeval.usec < 0 THEN - toomanysecs := timeval.usec DIV usecsPerSec; - IF toomanysecs > timeval.second THEN - timeval.second := - toomanysecs + MAX(Scales.Value) + 1 + - timeval.second; - DEC(timeval.epoch); - ELSE - DEC(timeval.second, toomanysecs); - END; - timeval.usec := timeval.usec MOD usecsPerSec; - ELSIF timeval.usec >= usecsPerSec THEN - secs := timeval.usec DIV usecsPerSec; - IF MAX(Scales.Value) - timeval.second <= secs THEN - INC(timeval.second, secs); - ELSE - timeval.second := secs - (MAX(Scales.Value) - timeval.second); - INC(timeval.epoch); - END; - timeval.usec := timeval.usec MOD usecsPerSec; - END; - END Normalize; - PROCEDURE SetValue*(time: Time; value: TimeValueRec); - VAR - refTime: Time; - scaleOfTime: Scales.Scale; - BEGIN - Normalize(value); - IF time IS ReferenceTime THEN - WITH time: ReferenceTime DO - time.timeval := value; - END; + (* ==== private datatypes for the reference scale *) + TYPE + ReferenceTime = POINTER TO ReferenceTimeRec; + ReferenceTimeRec = + RECORD + (TimeRec) + timeval: TimeValueRec; + END; + VAR + absType, relType: Services.Type; + CONST + epochUnit = 0; secondUnit = 1; usecUnit = 2; + TYPE + Unit = POINTER TO UnitRec; + UnitRec = + RECORD + (Scales.UnitRec) + index: SHORTINT; (* epochUnit..usecUnit *) + END; + + VAR + scale*: Scales.Scale; (* reference scale *) + family*: Scales.Family; (* family of time scales *) + if: Scales.Interface; + + PROCEDURE Create*(VAR time: Time; type: SHORTINT); + (* type = absolute or relative *) + VAR + m: Scales.Measure; + BEGIN + Scales.CreateMeasure(scale, m, type); + time := m(Time); + END Create; + + PROCEDURE Normalize(VAR timeval: TimeValueRec); + (* make sure that second and usec >= 0 *) + VAR + toomanysecs: Scales.Value; + secs: Scales.Value; + BEGIN + IF timeval.second < 0 THEN + INC(timeval.second, 1); + INC(timeval.second, MAX(Scales.Value)); + DEC(timeval.epoch); + END; + IF timeval.usec < 0 THEN + toomanysecs := timeval.usec DIV usecsPerSec; + IF toomanysecs > timeval.second THEN + timeval.second := - toomanysecs + MAX(Scales.Value) + 1 + + timeval.second; + DEC(timeval.epoch); ELSE - Create(refTime, Scales.MeasureType(time)); - refTime(ReferenceTime).timeval := value; - Scales.GetScale(time, scaleOfTime); - Scales.ConvertMeasure(scaleOfTime, SYSTEM.VAL(Scales.Measure, refTime)); - Operations.Copy(refTime, time); + DEC(timeval.second, toomanysecs); END; - END SetValue; - - PROCEDURE CreateAndSet*(VAR time: Time; type: SHORTINT; - epoch, second, usec: Scales.Value); - VAR - timeval: TimeValueRec; - BEGIN - Create(time, type); - timeval.epoch := epoch; timeval.second := second; timeval.usec := usec; - SetValue(time, timeval); - END CreateAndSet; - - PROCEDURE GetValue*(time: Time; VAR value: TimeValueRec); - BEGIN - IF ~(time IS ReferenceTime) THEN - Scales.ConvertMeasure(scale, SYSTEM.VAL(Scales.Measure, time)); - END; - value := time(ReferenceTime).timeval; - END GetValue; - - (* ===== interface procedures =================================== *) - - PROCEDURE InternalCreate(scale: Scales.Scale; - VAR measure: Scales.Measure; abs: BOOLEAN); - VAR - time: ReferenceTime; - BEGIN - NEW(time); - time.timeval.epoch := 0; - time.timeval.second := 0; - time.timeval.usec := 0; - IF abs THEN - PersistentObjects.Init(time, absType); + timeval.usec := timeval.usec MOD usecsPerSec; + ELSIF timeval.usec >= usecsPerSec THEN + secs := timeval.usec DIV usecsPerSec; + IF MAX(Scales.Value) - timeval.second <= secs THEN + INC(timeval.second, secs); ELSE - PersistentObjects.Init(time, relType); + timeval.second := secs - (MAX(Scales.Value) - timeval.second); + INC(timeval.epoch); END; - measure := time; - END InternalCreate; + timeval.usec := timeval.usec MOD usecsPerSec; + END; + END Normalize; - PROCEDURE InternalGetValue(measure: Scales.Measure; unit: Scales.Unit; - VAR value: Scales.Value); - BEGIN - WITH measure: ReferenceTime DO WITH unit: Unit DO - CASE unit.index OF - | epochUnit: value := measure.timeval.epoch; - | secondUnit: value := measure.timeval.second; - | usecUnit: value := measure.timeval.usec; + PROCEDURE SetValue*(time: Time; value: TimeValueRec); + VAR + refTime: Time; + measure: Scales.Measure; + scaleOfTime: Scales.Scale; + BEGIN + Normalize(value); + IF time IS ReferenceTime THEN + WITH time: ReferenceTime DO + time.timeval := value; + END; ELSE - END; - END; END; - END InternalGetValue; + Create(refTime, Scales.MeasureType(time)); + refTime(ReferenceTime).timeval := value; + Scales.GetScale(time, scaleOfTime); + measure := refTime; + Scales.ConvertMeasure(scaleOfTime, measure); + Operations.Copy(measure, time); + END; + END SetValue; - PROCEDURE InternalSetValue(measure: Scales.Measure; unit: Scales.Unit; - value: Scales.Value); - BEGIN - WITH measure: ReferenceTime DO WITH unit: Unit DO - CASE unit.index OF - | epochUnit: measure.timeval.epoch := value; - | secondUnit: measure.timeval.second := value; - | usecUnit: measure.timeval.usec := value; + PROCEDURE CreateAndSet*(VAR time: Time; type: SHORTINT; + epoch, second, usec: Scales.Value); + VAR + timeval: TimeValueRec; + BEGIN + Create(time, type); + timeval.epoch := epoch; timeval.second := second; timeval.usec := usec; + SetValue(time, timeval); + END CreateAndSet; + + PROCEDURE GetValue*(time: Time; VAR value: TimeValueRec); + VAR mtime: Scales.Measure; + BEGIN + IF ~(time IS ReferenceTime) THEN + Scales.ConvertMeasure(scale, mtime); time := mtime(Time) + END; + value := time(ReferenceTime).timeval; + END GetValue; + + (* ===== interface procedures =================================== *) + + PROCEDURE InternalCreate(scale: Scales.Scale; + VAR measure: Scales.Measure; abs: BOOLEAN); + VAR + time: ReferenceTime; + BEGIN + NEW(time); + time.timeval.epoch := 0; + time.timeval.second := 0; + time.timeval.usec := 0; + IF abs THEN + PersistentObjects.Init(time, absType); ELSE - END; - Normalize(measure.timeval); - END; END; - END InternalSetValue; + PersistentObjects.Init(time, relType); + END; + measure := time; + END InternalCreate; - PROCEDURE Assign(target: Scales.Measure; source: Scales.Measure); - BEGIN - WITH target: ReferenceTime DO WITH source: ReferenceTime DO - target.timeval := source.timeval; - END; END; - END Assign; - - PROCEDURE Op(op: Scales.Operation; op1, op2, result: Scales.Measure); - - PROCEDURE Add(op1, op2: TimeValueRec; VAR result: TimeValueRec); - BEGIN - result.epoch := op1.epoch + op2.epoch; - IF op1.second > MAX(Scales.Value) - op2.second THEN - INC(result.epoch); - result.second := op1.second - MAX(Scales.Value) - 1 + - op2.second; - ELSE - result.second := op1.second + op2.second; - END; - result.usec := op1.usec + op2.usec; - IF result.usec > usecsPerSec THEN - DEC(result.usec, usecsPerSec); - IF result.second = MAX(Scales.Value) THEN - result.second := 0; INC(result.epoch); - ELSE - INC(result.second); - END; - END; - END Add; - - PROCEDURE Sub(op1, op2: TimeValueRec; VAR result: TimeValueRec); - BEGIN - result.epoch := op1.epoch - op2.epoch; - IF op1.second >= op2.second THEN - result.second := op1.second - op2.second; - ELSE - DEC(result.epoch); - result.second := - op2.second + MAX(Scales.Value) + 1 + op1.second; - END; - result.usec := op1.usec - op2.usec; - IF result.usec < 0 THEN - INC(result.usec, usecsPerSec); - IF result.second = 0 THEN - result.second := MAX(Scales.Value); - DEC(result.epoch); - ELSE - DEC(result.second); - END; - END; - END Sub; - - BEGIN - WITH op1: ReferenceTime DO WITH op2: ReferenceTime DO - WITH result: ReferenceTime DO - CASE op OF - | Scales.add: Add(op1.timeval, op2.timeval, result.timeval); - | Scales.sub: Sub(op1.timeval, op2.timeval, result.timeval); - ELSE - END; - END; - END; END; - END Op; - - PROCEDURE Compare(op1, op2: Scales.Measure) : INTEGER; - - PROCEDURE ReturnVal(val1, val2: Scales.Value) : INTEGER; - BEGIN - IF val1 < val2 THEN - RETURN -1 - ELSIF val1 > val2 THEN - RETURN 1 - ELSE - RETURN 0 - END; - END ReturnVal; - - BEGIN - WITH op1: ReferenceTime DO - WITH op2: ReferenceTime DO - IF op1.timeval.epoch # op2.timeval.epoch THEN - RETURN ReturnVal(op1.timeval.epoch, op2.timeval.epoch) - ELSIF op1.timeval.second # op2.timeval.second THEN - RETURN ReturnVal(op1.timeval.second, op2.timeval.second) - ELSE - RETURN ReturnVal(op1.timeval.usec, op2.timeval.usec) - END; - END; + PROCEDURE InternalGetValue(measure: Scales.Measure; unit: Scales.Unit; + VAR value: Scales.Value); + BEGIN + WITH measure: ReferenceTime DO WITH unit: Unit DO + CASE unit.index OF + | epochUnit: value := measure.timeval.epoch; + | secondUnit: value := measure.timeval.second; + | usecUnit: value := measure.timeval.usec; + ELSE END; - RETURN 0; - END Compare; + END; END; + END InternalGetValue; - (* ========= initialization procedures ========================== *) - - PROCEDURE InitInterface; - VAR - timeType: Services.Type; - BEGIN - NEW(if); - if.create := InternalCreate; - if.getvalue := InternalGetValue; if.setvalue := InternalSetValue; - if.assign := Assign; if.op := Op; if.compare := Compare; - (* conversion procedures are not necessary *) - - PersistentObjects.RegisterType(timeType, "Times.Time", "Scales.Measure", - NIL); - END InitInterface; - - PROCEDURE CreateAbs(VAR object: PersistentObjects.Object); - VAR - measure: Scales.Measure; - BEGIN - Scales.CreateAbsMeasure(scale, measure); - object := measure; - END CreateAbs; - - PROCEDURE CreateRel(VAR object: PersistentObjects.Object); - VAR - measure: Scales.Measure; - BEGIN - Scales.CreateRelMeasure(scale, measure); - object := measure; - END CreateRel; - - PROCEDURE Write(s: Streams.Stream; - object: PersistentObjects.Object) : BOOLEAN; - BEGIN - WITH object: ReferenceTime DO - RETURN NetIO.WriteLongInt(s, object.timeval.epoch) & - NetIO.WriteLongInt(s, object.timeval.second) & - NetIO.WriteLongInt(s, object.timeval.usec) + PROCEDURE InternalSetValue(measure: Scales.Measure; unit: Scales.Unit; + value: Scales.Value); + BEGIN + WITH measure: ReferenceTime DO WITH unit: Unit DO + CASE unit.index OF + | epochUnit: measure.timeval.epoch := value; + | secondUnit: measure.timeval.second := value; + | usecUnit: measure.timeval.usec := value; + ELSE END; - END Write; + Normalize(measure.timeval); + END; END; + END InternalSetValue; - PROCEDURE Read(s: Streams.Stream; - object: PersistentObjects.Object) : BOOLEAN; - BEGIN - WITH object: ReferenceTime DO - RETURN NetIO.ReadLongInt(s, object.timeval.epoch) & - NetIO.ReadLongInt(s, object.timeval.second) & - NetIO.ReadLongInt(s, object.timeval.usec) + PROCEDURE Assign(target: Scales.Measure; source: Scales.Measure); + BEGIN + WITH target: ReferenceTime DO WITH source: ReferenceTime DO + target.timeval := source.timeval; + END; END; + END Assign; + + PROCEDURE Op(op: Scales.Operation; op1, op2, result: Scales.Measure); + + PROCEDURE Add(op1, op2: TimeValueRec; VAR result: TimeValueRec); + BEGIN + result.epoch := op1.epoch + op2.epoch; + IF op1.second > MAX(Scales.Value) - op2.second THEN + INC(result.epoch); + result.second := op1.second - MAX(Scales.Value) - 1 + + op2.second; + ELSE + result.second := op1.second + op2.second; END; - END Read; + result.usec := op1.usec + op2.usec; + IF result.usec > usecsPerSec THEN + DEC(result.usec, usecsPerSec); + IF result.second = MAX(Scales.Value) THEN + result.second := 0; INC(result.epoch); + ELSE + INC(result.second); + END; + END; + END Add; - PROCEDURE InitRefScale; + PROCEDURE Sub(op1, op2: TimeValueRec; VAR result: TimeValueRec); + BEGIN + result.epoch := op1.epoch - op2.epoch; + IF op1.second >= op2.second THEN + result.second := op1.second - op2.second; + ELSE + DEC(result.epoch); + result.second := - op2.second + MAX(Scales.Value) + 1 + op1.second; + END; + result.usec := op1.usec - op2.usec; + IF result.usec < 0 THEN + INC(result.usec, usecsPerSec); + IF result.second = 0 THEN + result.second := MAX(Scales.Value); + DEC(result.epoch); + ELSE + DEC(result.second); + END; + END; + END Sub; + BEGIN + WITH op1: ReferenceTime DO WITH op2: ReferenceTime DO + WITH result: ReferenceTime DO + CASE op OF + | Scales.add: Add(op1.timeval, op2.timeval, result.timeval); + | Scales.sub: Sub(op1.timeval, op2.timeval, result.timeval); + ELSE + END; + END; + END; END; + END Op; + + PROCEDURE Compare(op1, op2: Scales.Measure) : INTEGER; + + PROCEDURE ReturnVal(val1, val2: Scales.Value) : INTEGER; + BEGIN + IF val1 < val2 THEN + RETURN -1 + ELSIF val1 > val2 THEN + RETURN 1 + ELSE + RETURN 0 + END; + END ReturnVal; + + BEGIN + WITH op1: ReferenceTime DO + WITH op2: ReferenceTime DO + IF op1.timeval.epoch # op2.timeval.epoch THEN + RETURN ReturnVal(op1.timeval.epoch, op2.timeval.epoch) + ELSIF op1.timeval.second # op2.timeval.second THEN + RETURN ReturnVal(op1.timeval.second, op2.timeval.second) + ELSE + RETURN ReturnVal(op1.timeval.usec, op2.timeval.usec) + END; + END; + END; + RETURN 0; + END Compare; + + (* ========= initialization procedures ========================== *) + + PROCEDURE InitInterface; + VAR + timeType: Services.Type; + BEGIN + NEW(if); + if.create := InternalCreate; + if.getvalue := InternalGetValue; if.setvalue := InternalSetValue; + if.assign := Assign; if.op := Op; if.compare := Compare; + (* conversion procedures are not necessary *) + + PersistentObjects.RegisterType(timeType, "Times.Time", "Scales.Measure", + NIL); + END InitInterface; + + PROCEDURE CreateAbs(VAR object: PersistentObjects.Object); + VAR + measure: Scales.Measure; + BEGIN + Scales.CreateAbsMeasure(scale, measure); + object := measure; + END CreateAbs; + + PROCEDURE CreateRel(VAR object: PersistentObjects.Object); + VAR + measure: Scales.Measure; + BEGIN + Scales.CreateRelMeasure(scale, measure); + object := measure; + END CreateRel; + + PROCEDURE Write(s: Streams.Stream; + object: PersistentObjects.Object) : BOOLEAN; + BEGIN + WITH object: ReferenceTime DO + RETURN NetIO.WriteLongInt(s, object.timeval.epoch) & + NetIO.WriteLongInt(s, object.timeval.second) & + NetIO.WriteLongInt(s, object.timeval.usec) + END; + END Write; + + PROCEDURE Read(s: Streams.Stream; + object: PersistentObjects.Object) : BOOLEAN; + BEGIN + WITH object: ReferenceTime DO + RETURN NetIO.ReadLongInt(s, object.timeval.epoch) & + NetIO.ReadLongInt(s, object.timeval.second) & + NetIO.ReadLongInt(s, object.timeval.usec) + END; + END Read; + + PROCEDURE InitRefScale; + + VAR + poif: PersistentObjects.Interface; + + PROCEDURE InitUnit(unitIndex: SHORTINT; name: Scales.UnitName); VAR - poif: PersistentObjects.Interface; + unit: Unit; + BEGIN + NEW(unit); unit.index := unitIndex; + Scales.InitUnit(scale, unit, name); + END InitUnit; - PROCEDURE InitUnit(unitIndex: SHORTINT; name: Scales.UnitName); - VAR - unit: Unit; - BEGIN - NEW(unit); unit.index := unitIndex; - Scales.InitUnit(scale, unit, name); - END InitUnit; + BEGIN + NEW(scale); Scales.Init(scale, NIL, if); + InitUnit(epochUnit, "epoch"); + InitUnit(secondUnit, "second"); + InitUnit(usecUnit, "usec"); - BEGIN - NEW(scale); Scales.Init(scale, NIL, if); - InitUnit(epochUnit, "epoch"); - InitUnit(secondUnit, "second"); - InitUnit(usecUnit, "usec"); - - NEW(poif); poif.read := Read; poif.write := Write; - poif.create := CreateAbs; poif.createAndRead := NIL; - PersistentObjects.RegisterType(absType, - "Times.AbsReferenceTime", "Times.Time", poif); - NEW(poif); poif.read := Read; poif.write := Write; - poif.create := CreateRel; poif.createAndRead := NIL; - PersistentObjects.RegisterType(relType, - "Times.RelReferenceTime", "Times.Time", poif); - END InitRefScale; + NEW(poif); poif.read := Read; poif.write := Write; + poif.create := CreateAbs; poif.createAndRead := NIL; + PersistentObjects.RegisterType(absType, + "Times.AbsReferenceTime", "Times.Time", poif); + NEW(poif); poif.read := Read; poif.write := Write; + poif.create := CreateRel; poif.createAndRead := NIL; + PersistentObjects.RegisterType(relType, + "Times.RelReferenceTime", "Times.Time", poif); + END InitRefScale; BEGIN - InitInterface; - InitRefScale; - NEW(family); Scales.InitFamily(family, scale); + InitInterface; + InitRefScale; + NEW(family); Scales.InitFamily(family, scale); END ulmTimes. diff --git a/src/library/ulm/ulmTypes.Mod b/src/library/ulm/ulmTypes.Mod index c9d6f4fe..93bab9fc 100644 --- a/src/library/ulm/ulmTypes.Mod +++ b/src/library/ulm/ulmTypes.Mod @@ -50,15 +50,8 @@ MODULE ulmTypes; IMPORT SYS := SYSTEM; TYPE - Address* = LONGINT (*SYS.ADDRESS*); - (* ulm compiler can accept - VAR p : SYSTEM.ADDRESS; // SYSTEM.PTR in ETH and V4 versions - ... - p := SYSTEM.ADR(something); - and this is how it is used in ulm oberon system library, - while SYSTEM.ADR returns LONGINT in ETH and V4 versions. - Thus I leave it as LONGINT for now, before coming up with better solution -- noch *) - + Address* = SYS.ADDRESS; + UntracedAddress* = POINTER[1] TO UntracedAddressDesc; (*SYS.UNTRACEDADDRESS;*) UntracedAddressDesc* = RECORD[1] END; diff --git a/src/system/Platformunix.Mod b/src/system/Platformunix.Mod index 1ef21940..288fc04b 100644 --- a/src/system/Platformunix.Mod +++ b/src/system/Platformunix.Mod @@ -75,6 +75,7 @@ PROCEDURE -ECONNREFUSED(): ErrorCode 'ECONNREFUSED'; PROCEDURE -ECONNABORTED(): ErrorCode 'ECONNABORTED'; PROCEDURE -ENETUNREACH(): ErrorCode 'ENETUNREACH'; PROCEDURE -EHOSTUNREACH(): ErrorCode 'EHOSTUNREACH'; +PROCEDURE -EINTR(): ErrorCode 'EINTR'; @@ -92,15 +93,18 @@ PROCEDURE Inaccessible*(e: ErrorCode): BOOLEAN; BEGIN RETURN (e = EACCES()) OR (e = EROFS()) OR (e = EAGAIN()) END Inaccessible; PROCEDURE Absent*(e: ErrorCode): BOOLEAN; -BEGIN RETURN (e = ENOENT()) END Absent; +BEGIN RETURN e = ENOENT() END Absent; PROCEDURE TimedOut*(e: ErrorCode): BOOLEAN; -BEGIN RETURN (e = ETIMEDOUT()) END TimedOut; +BEGIN RETURN e = ETIMEDOUT() END TimedOut; PROCEDURE ConnectionFailed*(e: ErrorCode): BOOLEAN; BEGIN RETURN (e = ECONNREFUSED()) OR (e = ECONNABORTED()) OR (e = ENETUNREACH()) OR (e = EHOSTUNREACH()) END ConnectionFailed; +PROCEDURE Interrupted*(e: ErrorCode): BOOLEAN; +BEGIN RETURN e = EINTR() END Interrupted; + diff --git a/src/system/Platformwindows.Mod b/src/system/Platformwindows.Mod index f91415c5..a538fdc5 100644 --- a/src/system/Platformwindows.Mod +++ b/src/system/Platformwindows.Mod @@ -72,6 +72,7 @@ PROCEDURE -ECONNREFUSED(): ErrorCode 'WSAECONNREFUSED'; PROCEDURE -ECONNABORTED(): ErrorCode 'WSAECONNABORTED'; PROCEDURE -ENETUNREACH(): ErrorCode 'WSAENETUNREACH'; PROCEDURE -EHOSTUNREACH(): ErrorCode 'WSAEHOSTUNREACH'; +PROCEDURE -EINTR(): ErrorCode 'WSAEINTR'; @@ -100,6 +101,9 @@ PROCEDURE ConnectionFailed*(e: ErrorCode): BOOLEAN; BEGIN RETURN (e = ECONNREFUSED()) OR (e = ECONNABORTED()) OR (e = ENETUNREACH()) OR (e = EHOSTUNREACH()) END ConnectionFailed; +PROCEDURE Interrupted*(e: ErrorCode): BOOLEAN; +BEGIN RETURN e = EINTR() END Interrupted; + (* OS memory allocaton *) diff --git a/src/tools/make/oberon.mk b/src/tools/make/oberon.mk index 1d3fd191..16311bd0 100644 --- a/src/tools/make/oberon.mk +++ b/src/tools/make/oberon.mk @@ -209,20 +209,20 @@ ooc: @printf "\nMaking ooc library\n" cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLowReal.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLowLReal.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocRealMath.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocOakMath.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLRealMath.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocRealMath.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocOakMath.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLRealMath.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLongInts.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocComplexMath.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLComplexMath.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocComplexMath.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLComplexMath.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocAscii.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocCharClass.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocStrings.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocConvTypes.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLRealConv.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLRealStr.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocRealConv.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocRealStr.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLRealConv.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocLRealStr.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocRealConv.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocRealStr.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocIntConv.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocIntStr.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocMsg.Mod @@ -232,7 +232,7 @@ ooc: cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocStrings2.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocRts.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocFilenames.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocTextRider.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocTextRider.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocBinaryRider.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocJulianDay.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ooc/oocFilenames.Mod @@ -255,52 +255,52 @@ ulm: cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSYSTEM.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmEvents.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmProcess.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmResources.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmForwarders.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmRelatedEvents.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmResources.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmForwarders.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmRelatedEvents.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmTypes.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmStreams.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmStrings.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmStreams.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmStrings.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSysTypes.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmTexts.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSysConversions.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmErrors.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSysErrors.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSysStat.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmTexts.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSysConversions.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmErrors.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSysErrors.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSysStat.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmASCII.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSets.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmIO.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmAssertions.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmIndirectDisciplines.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmStreamDisciplines.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmAssertions.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmIndirectDisciplines.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmStreamDisciplines.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmIEEE.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmMC68881.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmReals.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmPrint.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmWrite.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmConstStrings.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmPlotters.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSysIO.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmLoader.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmNetIO.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmPersistentObjects.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmPersistentDisciplines.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmOperations.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmScales.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmTimes.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmClocks.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmTimers.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmConditions.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmStreamConditions.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmTimeConditions.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmCiphers.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmCipherOps.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmBlockCiphers.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmAsymmetricCiphers.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmConclusions.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmRandomGenerators.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmTCrypt.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmIntOperations.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmPrint.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmWrite.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmConstStrings.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmPlotters.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmSysIO.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmLoader.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmNetIO.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmPersistentObjects.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmPersistentDisciplines.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmOperations.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmScales.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmTimes.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmClocks.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmTimers.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmConditions.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmStreamConditions.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmTimeConditions.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmCiphers.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmCipherOps.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmBlockCiphers.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmAsymmetricCiphers.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmConclusions.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmRandomGenerators.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmTCrypt.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/ulm/ulmIntOperations.Mod pow32: @printf "\nMaking pow library\n" @@ -311,7 +311,7 @@ misc: cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/system/Oberon.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/misc/crt.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/misc/Listen.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/misc/MersenneTwister.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/misc/MersenneTwister.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/misc/MultiArrays.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/misc/MultiArrayRiders.Mod @@ -327,13 +327,13 @@ s3: cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethZlibReaders.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethZlibWriters.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethZip.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethRandomNumbers.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethRandomNumbers.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethGZReaders.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethGZWriters.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethUnicode.Mod cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethDates.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethReals.Mod -# cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethStrings.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethReals.Mod + cd $(BUILDDIR); $(ROOTDIR)/$(OBECOMP) -Ffs -O$(MODEL) ../../src/library/s3/ethStrings.Mod librarybinary: @printf "\nMaking lib$(ONAME)\n"