123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506 |
- /* voc 2.1.0 [2017/07/20]. Bootstrapping compiler for address size 8, alignment 8. xtspaSF */
- #define SHORTINT INT8
- #define INTEGER INT16
- #define LONGINT INT32
- #define SET UINT32
- #include "SYSTEM.h"
- #include "Heap.h"
- #include "Platform.h"
- export INT16 Modules_res;
- export CHAR Modules_resMsg[256];
- export Heap_ModuleName Modules_imported, Modules_importing;
- export INT32 Modules_MainStackFrame;
- export INT16 Modules_ArgCount;
- export INT32 Modules_ArgVector;
- export CHAR Modules_BinaryDir[1024];
- static void Modules_Append (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len);
- static void Modules_AppendPart (CHAR c, CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len);
- export INT16 Modules_ArgPos (CHAR *s, ADDRESS s__len);
- export void Modules_AssertFail (INT32 code);
- static void Modules_Canonify (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len);
- static INT16 Modules_CharCount (CHAR *s, ADDRESS s__len);
- static void Modules_DisplayHaltCode (INT32 code);
- static void Modules_ExtractPart (CHAR *s, ADDRESS s__len, INT16 *i, CHAR *p, ADDRESS p__len, CHAR *d, ADDRESS d__len);
- static void Modules_FindBinaryDir (CHAR *binarydir, ADDRESS binarydir__len);
- export void Modules_Free (CHAR *name, ADDRESS name__len, BOOLEAN all);
- export void Modules_GetArg (INT16 n, CHAR *val, ADDRESS val__len);
- export void Modules_GetIntArg (INT16 n, INT32 *val);
- export void Modules_Halt (INT32 code);
- export void Modules_Init (INT32 argc, INT32 argvadr);
- static BOOLEAN Modules_IsAbsolute (CHAR *d, ADDRESS d__len);
- static BOOLEAN Modules_IsFilePresent (CHAR *s, ADDRESS s__len);
- static BOOLEAN Modules_IsOneOf (CHAR c, CHAR *s, ADDRESS s__len);
- export Heap_Command Modules_ThisCommand (Heap_Module mod, CHAR *name, ADDRESS name__len);
- export Heap_Module Modules_ThisMod (CHAR *name, ADDRESS name__len);
- static void Modules_Trim (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len);
- static void Modules_errch (CHAR c);
- static void Modules_errint (INT32 l);
- static void Modules_errstring (CHAR *s, ADDRESS s__len);
- extern void Heap_InitHeap();
- extern void *Modules__init(void);
- #define Modules_InitHeap() Heap_InitHeap()
- #define Modules_ModulesInit() Modules__init()
- #define Modules_modules() (Heap_Module)Heap_modules
- void Modules_Init (INT32 argc, INT32 argvadr)
- {
- Modules_MainStackFrame = argvadr;
- Modules_ArgCount = __VAL(INT16, argc);
- __GET(argvadr, Modules_ArgVector, INT32);
- Modules_InitHeap();
- Modules_ModulesInit();
- }
- typedef
- CHAR (*argptr__15)[1024];
- void Modules_GetArg (INT16 n, CHAR *val, ADDRESS val__len)
- {
- argptr__15 arg = NIL;
- if (n < Modules_ArgCount) {
- __GET(Modules_ArgVector + __ASHL(n, 2), arg, argptr__15);
- __COPY(*arg, val, val__len);
- }
- }
- void Modules_GetIntArg (INT16 n, INT32 *val)
- {
- CHAR s[64];
- INT32 k, d, i;
- s[0] = 0x00;
- Modules_GetArg(n, (void*)s, 64);
- i = 0;
- if (s[0] == '-') {
- i = 1;
- }
- k = 0;
- d = (INT16)s[__X(i, 64)] - 48;
- while ((d >= 0 && d <= 9)) {
- k = k * 10 + d;
- i += 1;
- d = (INT16)s[__X(i, 64)] - 48;
- }
- if (s[0] == '-') {
- k = -k;
- i -= 1;
- }
- if (i > 0) {
- *val = k;
- }
- }
- INT16 Modules_ArgPos (CHAR *s, ADDRESS s__len)
- {
- INT16 i;
- CHAR arg[256];
- __DUP(s, s__len, CHAR);
- i = 0;
- Modules_GetArg(i, (void*)arg, 256);
- while ((i < Modules_ArgCount && __STRCMP(s, arg) != 0)) {
- i += 1;
- Modules_GetArg(i, (void*)arg, 256);
- }
- __DEL(s);
- return i;
- }
- static INT16 Modules_CharCount (CHAR *s, ADDRESS s__len)
- {
- INT16 i;
- __DUP(s, s__len, CHAR);
- i = 0;
- while ((i < s__len && s[__X(i, s__len)] != 0x00)) {
- i += 1;
- }
- __DEL(s);
- return i;
- }
- static void Modules_Append (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len)
- {
- INT16 i, j;
- __DUP(s, s__len, CHAR);
- i = 0;
- j = Modules_CharCount(d, d__len);
- while (s[__X(i, s__len)] != 0x00) {
- d[__X(j, d__len)] = s[__X(i, s__len)];
- i += 1;
- j += 1;
- }
- d[__X(j, d__len)] = 0x00;
- __DEL(s);
- }
- static void Modules_AppendPart (CHAR c, CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len)
- {
- INT16 i, j;
- __DUP(s, s__len, CHAR);
- i = 0;
- j = Modules_CharCount(d, d__len);
- if ((j > 0 && d[__X(j - 1, d__len)] != c)) {
- d[__X(j, d__len)] = c;
- j += 1;
- }
- while (s[__X(i, s__len)] != 0x00) {
- d[__X(j, d__len)] = s[__X(i, s__len)];
- i += 1;
- j += 1;
- }
- d[__X(j, d__len)] = 0x00;
- __DEL(s);
- }
- static BOOLEAN Modules_IsOneOf (CHAR c, CHAR *s, ADDRESS s__len)
- {
- INT16 i;
- __DUP(s, s__len, CHAR);
- if (c == 0x00) {
- __DEL(s);
- return 0;
- }
- i = 0;
- while ((s[__X(i, s__len)] != c && s[__X(i, s__len)] != 0x00)) {
- i += 1;
- }
- __DEL(s);
- return s[__X(i, s__len)] == c;
- }
- static BOOLEAN Modules_IsAbsolute (CHAR *d, ADDRESS d__len)
- {
- __DUP(d, d__len, CHAR);
- if (d[0] == 0x00) {
- __DEL(d);
- return 0;
- }
- if (Modules_IsOneOf(d[0], (CHAR*)"/\\", 3)) {
- __DEL(d);
- return 1;
- }
- if (d[__X(1, d__len)] == ':') {
- __DEL(d);
- return 1;
- }
- __DEL(d);
- return 0;
- }
- static void Modules_Canonify (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len)
- {
- __DUP(s, s__len, CHAR);
- if (Modules_IsAbsolute(s, s__len)) {
- __COPY(s, d, d__len);
- } else {
- __COPY(Platform_CWD, d, d__len);
- Modules_AppendPart('/', s, s__len, (void*)d, d__len);
- }
- __DEL(s);
- }
- static BOOLEAN Modules_IsFilePresent (CHAR *s, ADDRESS s__len)
- {
- Platform_FileIdentity identity;
- __DUP(s, s__len, CHAR);
- __DEL(s);
- return Platform_IdentifyByName(s, s__len, &identity, Platform_FileIdentity__typ) == 0;
- }
- static void Modules_ExtractPart (CHAR *s, ADDRESS s__len, INT16 *i, CHAR *p, ADDRESS p__len, CHAR *d, ADDRESS d__len)
- {
- INT16 j;
- __DUP(s, s__len, CHAR);
- __DUP(p, p__len, CHAR);
- j = 0;
- while ((s[__X(*i, s__len)] != 0x00 && !Modules_IsOneOf(s[__X(*i, s__len)], p, p__len))) {
- d[__X(j, d__len)] = s[__X(*i, s__len)];
- *i += 1;
- j += 1;
- }
- d[__X(j, d__len)] = 0x00;
- while (Modules_IsOneOf(s[__X(*i, s__len)], p, p__len)) {
- *i += 1;
- }
- __DEL(s);
- __DEL(p);
- }
- static void Modules_Trim (CHAR *s, ADDRESS s__len, CHAR *d, ADDRESS d__len)
- {
- INT16 i, j;
- CHAR part[1024];
- __DUP(s, s__len, CHAR);
- i = 0;
- j = 0;
- while ((i < 2 && Modules_IsOneOf(s[__X(i, s__len)], (CHAR*)"/\\", 3))) {
- i += 1;
- d[__X(j, d__len)] = '/';
- j += 1;
- }
- d[__X(j, d__len)] = 0x00;
- while (s[__X(i, s__len)] != 0x00) {
- Modules_ExtractPart(s, s__len, &i, (CHAR*)"/\\", 3, (void*)part, 1024);
- if ((part[0] != 0x00 && __STRCMP(part, ".") != 0)) {
- Modules_AppendPart('/', part, 1024, (void*)d, d__len);
- }
- }
- __DEL(s);
- }
- typedef
- CHAR pathstring__12[4096];
- static void Modules_FindBinaryDir (CHAR *binarydir, ADDRESS binarydir__len)
- {
- pathstring__12 arg0, pathlist, pathdir, tempstr;
- INT16 i, j, k;
- BOOLEAN present;
- if (Modules_ArgCount < 1) {
- binarydir[0] = 0x00;
- return;
- }
- Modules_GetArg(0, (void*)arg0, 4096);
- i = 0;
- while ((((arg0[__X(i, 4096)] != 0x00 && arg0[__X(i, 4096)] != '/')) && arg0[__X(i, 4096)] != '\\')) {
- i += 1;
- }
- if (arg0[__X(i, 4096)] == '/' || arg0[__X(i, 4096)] == '\\') {
- Modules_Trim(arg0, 4096, (void*)tempstr, 4096);
- Modules_Canonify(tempstr, 4096, (void*)binarydir, binarydir__len);
- present = Modules_IsFilePresent(binarydir, binarydir__len);
- } else {
- Platform_GetEnv((CHAR*)"PATH", 5, (void*)pathlist, 4096);
- i = 0;
- present = 0;
- while ((!present && pathlist[__X(i, 4096)] != 0x00)) {
- Modules_ExtractPart(pathlist, 4096, &i, (CHAR*)":;", 3, (void*)pathdir, 4096);
- Modules_AppendPart('/', arg0, 4096, (void*)pathdir, 4096);
- Modules_Trim(pathdir, 4096, (void*)tempstr, 4096);
- Modules_Canonify(tempstr, 4096, (void*)binarydir, binarydir__len);
- present = Modules_IsFilePresent(binarydir, binarydir__len);
- }
- }
- if (present) {
- k = Modules_CharCount(binarydir, binarydir__len);
- while ((k > 0 && !Modules_IsOneOf(binarydir[__X(k - 1, binarydir__len)], (CHAR*)"/\\", 3))) {
- k -= 1;
- }
- if (k == 0) {
- binarydir[__X(k, binarydir__len)] = 0x00;
- } else {
- binarydir[__X(k - 1, binarydir__len)] = 0x00;
- }
- } else {
- binarydir[0] = 0x00;
- }
- }
- Heap_Module Modules_ThisMod (CHAR *name, ADDRESS name__len)
- {
- Heap_Module m = NIL;
- CHAR bodyname[64];
- Heap_Command body;
- __DUP(name, name__len, CHAR);
- m = Modules_modules();
- while ((m != NIL && __STRCMP(m->name, name) != 0)) {
- m = m->next;
- }
- if (m != NIL) {
- Modules_res = 0;
- Modules_resMsg[0] = 0x00;
- } else {
- Modules_res = 1;
- __COPY(name, Modules_importing, 20);
- __MOVE(" module \"", Modules_resMsg, 10);
- Modules_Append(name, name__len, (void*)Modules_resMsg, 256);
- Modules_Append((CHAR*)"\" not found", 12, (void*)Modules_resMsg, 256);
- }
- __DEL(name);
- return m;
- }
- Heap_Command Modules_ThisCommand (Heap_Module mod, CHAR *name, ADDRESS name__len)
- {
- Heap_Cmd c = NIL;
- __DUP(name, name__len, CHAR);
- c = mod->cmds;
- while ((c != NIL && __STRCMP(c->name, name) != 0)) {
- c = c->next;
- }
- if (c != NIL) {
- Modules_res = 0;
- Modules_resMsg[0] = 0x00;
- __DEL(name);
- return c->cmd;
- } else {
- Modules_res = 2;
- __MOVE(" command \"", Modules_resMsg, 11);
- __COPY(name, Modules_importing, 20);
- Modules_Append(mod->name, 20, (void*)Modules_resMsg, 256);
- Modules_Append((CHAR*)".", 2, (void*)Modules_resMsg, 256);
- Modules_Append(name, name__len, (void*)Modules_resMsg, 256);
- Modules_Append((CHAR*)"\" not found", 12, (void*)Modules_resMsg, 256);
- __DEL(name);
- return NIL;
- }
- __RETCHK;
- }
- void Modules_Free (CHAR *name, ADDRESS name__len, BOOLEAN all)
- {
- Heap_Module m = NIL, p = NIL;
- INT32 refcount;
- __DUP(name, name__len, CHAR);
- m = Modules_modules();
- if (all) {
- Modules_res = 1;
- __MOVE("unloading \"all\" not yet supported", Modules_resMsg, 34);
- } else {
- refcount = Heap_FreeModule(name, name__len);
- if (refcount == 0) {
- Modules_res = 0;
- } else {
- if (refcount < 0) {
- __MOVE("module not found", Modules_resMsg, 17);
- } else {
- __MOVE("clients of this module exist", Modules_resMsg, 29);
- }
- Modules_res = 1;
- }
- }
- __DEL(name);
- }
- static void Modules_errch (CHAR c)
- {
- INT16 e;
- e = Platform_Write(1, (ADDRESS)&c, 1);
- }
- static void Modules_errstring (CHAR *s, ADDRESS s__len)
- {
- INT32 i;
- __DUP(s, s__len, CHAR);
- i = 0;
- while ((i < s__len && s[__X(i, s__len)] != 0x00)) {
- Modules_errch(s[__X(i, s__len)]);
- i += 1;
- }
- __DEL(s);
- }
- static void Modules_errint (INT32 l)
- {
- if (l < 0) {
- Modules_errch('-');
- l = -l;
- }
- if (l >= 10) {
- Modules_errint(__DIV(l, 10));
- }
- Modules_errch((CHAR)((int)__MOD(l, 10) + 48));
- }
- static void Modules_DisplayHaltCode (INT32 code)
- {
- switch (code) {
- case -1:
- Modules_errstring((CHAR*)"Assertion failure.", 19);
- break;
- case -2:
- Modules_errstring((CHAR*)"Index out of range.", 20);
- break;
- case -3:
- Modules_errstring((CHAR*)"Reached end of function without reaching RETURN.", 49);
- break;
- case -4:
- Modules_errstring((CHAR*)"CASE statement: no matching label and no ELSE.", 47);
- break;
- case -5:
- Modules_errstring((CHAR*)"Type guard failed.", 19);
- break;
- case -6:
- Modules_errstring((CHAR*)"Implicit type guard in record assignment failed.", 49);
- break;
- case -7:
- Modules_errstring((CHAR*)"Invalid case in WITH statement.", 32);
- break;
- case -8:
- Modules_errstring((CHAR*)"Value out of range.", 20);
- break;
- case -9:
- Modules_errstring((CHAR*)"Heap interrupted while locked, but lockdepth = 0 at unlock.", 60);
- break;
- case -10:
- Modules_errstring((CHAR*)"NIL access.", 12);
- break;
- case -11:
- Modules_errstring((CHAR*)"Alignment error.", 17);
- break;
- case -12:
- Modules_errstring((CHAR*)"Divide by zero.", 16);
- break;
- case -13:
- Modules_errstring((CHAR*)"Arithmetic overflow/underflow.", 31);
- break;
- case -14:
- Modules_errstring((CHAR*)"Invalid function argument.", 27);
- break;
- case -15:
- Modules_errstring((CHAR*)"Internal error, e.g. Type descriptor size mismatch.", 52);
- break;
- case -20:
- Modules_errstring((CHAR*)"Too many, or negative number of, elements in dynamic array.", 60);
- break;
- default:
- break;
- }
- }
- void Modules_Halt (INT32 code)
- {
- Heap_FINALL();
- Modules_errstring((CHAR*)"Terminated by Halt(", 20);
- Modules_errint(code);
- Modules_errstring((CHAR*)"). ", 4);
- if (code < 0) {
- Modules_DisplayHaltCode(code);
- }
- Modules_errstring(Platform_NL, 3);
- Platform_Exit(code);
- }
- void Modules_AssertFail (INT32 code)
- {
- Heap_FINALL();
- Modules_errstring((CHAR*)"Assertion failure.", 19);
- if (code != 0) {
- Modules_errstring((CHAR*)" ASSERT code ", 14);
- Modules_errint(code);
- Modules_errstring((CHAR*)".", 2);
- }
- Modules_errstring(Platform_NL, 3);
- if (code > 0) {
- Platform_Exit(code);
- } else {
- Platform_Exit(-1);
- }
- }
- export void *Modules__init(void)
- {
- __DEFMOD;
- __MODULE_IMPORT(Heap);
- __MODULE_IMPORT(Platform);
- __REGMOD("Modules", 0);
- /* BEGIN */
- Modules_FindBinaryDir((void*)Modules_BinaryDir, 1024);
- __ENDMOD;
- }
|