From: DeaDDooMER Date: Sun, 9 Jun 2019 18:20:34 +0000 (+0300) Subject: first cpc release X-Git-Tag: v0.1 X-Git-Url: http://deadsoftware.ru/gitweb?a=commitdiff_plain;h=b86a4fb1483d42808207052ed405d250d1c8a577;p=cpc.git first cpc release --- 4de97bf7ae01a78248a15ff69031824c5b089e31 diff --git a/C/SYSTEM.c b/C/SYSTEM.c new file mode 100644 index 0000000..81f3ff6 --- /dev/null +++ b/C/SYSTEM.c @@ -0,0 +1,413 @@ +#include "SYSTEM.h" + +SYSTEM_MODDESC *SYSTEM_modlist = NIL; +SYSTEM_DLINK *SYSTEM_dlink = NIL; + +LONGINT SYSTEM_INF = 0x7FF0000000000000L; +INTEGER SYSTEM_INFS = 0x7F800000; + +CHAR SYSTEM_strBuf[32][256]; +INTEGER SYSTEM_actual; + +INTEGER SYSTEM_argCount; +void *SYSTEM_argVector; + +void SYSTEM_REGMOD(SYSTEM_MODDESC *mod) +{ + int i; + mod->next = SYSTEM_modlist; + SYSTEM_modlist = mod; + for (i = 0; i < mod->nofimps; i++) mod->imports[i]->refcnt++; +} + +typedef struct { + INTEGER gc[3], len[1]; +} Array; + +void *SYSTEM_NEWARR(INTEGER type, INTEGER n) +{ + int ptr = Kernel_NewArr(type, n, 1); + ((Array*)ptr)->len[0] = n; + return (void*)ptr; +} + +void *SYSTEM_NEWARR1(INTEGER type, INTEGER n0, INTEGER n) +{ + int ptr = Kernel_NewArr(type, n * n0, 1); + ((Array*)ptr)->len[0] = n0; + return (void*)ptr; +} + +void *SYSTEM_NEWARR2(INTEGER type, INTEGER n1, INTEGER n0, INTEGER n) +{ + int ptr = Kernel_NewArr(type, n * n0 * n1, 2); + ((Array*)ptr)->len[0] = n1; + ((Array*)ptr)->len[1] = n0; + return (void*)ptr; +} + +void *SYSTEM_NEWARR3(INTEGER type, INTEGER n2, INTEGER n1, INTEGER n0, INTEGER n) +{ + int ptr = Kernel_NewArr(type, n * n0 * n1 * n2, 3); + ((Array*)ptr)->len[0] = n2; + ((Array*)ptr)->len[1] = n1; + ((Array*)ptr)->len[2] = n0; + return (void*)ptr; +} + +void *SYSTEM_NEWARR4(INTEGER type, INTEGER n3, INTEGER n2, INTEGER n1, INTEGER n0, INTEGER n) +{ + int ptr = Kernel_NewArr(type, n * n0 * n1 * n2 * n3, 4); + ((Array*)ptr)->len[0] = n3; + ((Array*)ptr)->len[1] = n2; + ((Array*)ptr)->len[2] = n1; + ((Array*)ptr)->len[3] = n0; + return (void*)ptr; +} + +INTEGER SYSTEM_XCHK(INTEGER i, INTEGER ub) +{ + if ((unsigned)(i)>=(unsigned)(ub)) __HALT(-7); + return i; +} + + +CHAR* SYSTEM_LSTR(char *x) +{ + CHAR *str = SYSTEM_strBuf[SYSTEM_actual]; + int i = 0; + SYSTEM_actual = (SYSTEM_actual + 1) & 0x1F; + do { + if (i == 256) __HALT(-8); + str[i] = x[i]; + } while (x[i++] != 0); + return str; +} + +INTEGER SYSTEM_ASH(INTEGER x, INTEGER n) +{ + if (n >= 0) return x << n; + else return x >> (-n); +} + +LONGINT SYSTEM_ASHL(LONGINT x, INTEGER n) +{ + if (n >= 0) return x << n; + else return x >> (-n); +} + +INTEGER SYSTEM_ABS(INTEGER x) +{ + if (x<0) x=-x; + return x; +} + +LONGINT SYSTEM_ABSL(LONGINT x) +{ + if (x<0) x=-x; + return x; +} + +SHORTREAL SYSTEM_ABSF(SHORTREAL x) +{ + if (x<0) x=-x; + return x; +} + +REAL SYSTEM_ABSD(REAL x) +{ + if (x<0) x=-x; + return x; +} + +INTEGER SYSTEM_ENTIER(REAL x) +{ + INTEGER i; + i = (INTEGER)x; + if (i > x) i--; + return i; +} + +LONGINT SYSTEM_ENTIERL(REAL x) +{ + LONGINT i; + i = (LONGINT)x; + if (i > x) i--; + return i; +} + +INTEGER SYSTEM_DIV(INTEGER x, INTEGER y) +{ + if (y > 0) { + if (x < 0) return ~(~x / y); + else return x / y; + } else if (y < 0) { + if (x > 0) return ~((x - 1) / -y); + else return -x / -y; + } else { + __HALT(-5); + } +} + +LONGINT SYSTEM_DIVL(LONGINT x, LONGINT y) +{ + if (y > 0) { + if (x < 0) return ~(~x / y); + else return x / y; + } else if (y < 0) { + if (x > 0) return ~((x - 1) / -y); + else return -x / -y; + } else { + __HALT(-5); + } +} + +INTEGER SYSTEM_MOD(INTEGER x, INTEGER y) +{ + if (y > 0) { + if (x < 0) return y + ~(~x % y); + else return x % y; + } else if (y < 0) { + if (x > 0) return y + 1 + ((x - 1) % -y); + else return -(-x % -y); + } else { + __HALT(-5); + } +} + +LONGINT SYSTEM_MODL(LONGINT x, LONGINT y) +{ + if (y > 0) { + if (x < 0) return y + ~(~x % y); + else return x % y; + } else if (y < 0) { + if (x > 0) return y + 1 + ((x - 1) % -y); + else return -(-x % -y); + } else { + __HALT(-5); + } +} + +INTEGER SYSTEM_MIN(INTEGER x, INTEGER y) +{ + if (x > y) x = y; + return x; +} + +LONGINT SYSTEM_MINL(LONGINT x, LONGINT y) +{ + if (x > y) x = y; + return x; +} + +SHORTREAL SYSTEM_MINF(SHORTREAL x, SHORTREAL y) +{ + if (x > y) x = y; + return x; +} + +REAL SYSTEM_MIND(REAL x, REAL y) +{ + if (x > y) x = y; + return x; +} + +INTEGER SYSTEM_MAX(INTEGER x, INTEGER y) +{ + if (x < y) x = y; + return x; +} + +LONGINT SYSTEM_MAXL(LONGINT x, LONGINT y) +{ + if (x < y) x = y; + return x; +} + +SHORTREAL SYSTEM_MAXF(SHORTREAL x, SHORTREAL y) +{ + if (x < y) x = y; + return x; +} + +REAL SYSTEM_MAXD(REAL x, REAL y) +{ + if (x < y) x = y; + return x; +} + + +SHORTREAL SYSTEM_INT2SR(INTEGER x) +{ + return *(SHORTREAL*)&x; +} + +REAL SYSTEM_LONG2R(LONGINT x) +{ + return *(REAL*)&x; +} + +INTEGER SYSTEM_SR2INT(SHORTREAL x) +{ + return *(INTEGER*)&x; +} + +LONGINT SYSTEM_R2LONG(REAL x) +{ + return *(LONGINT*)&x; +} + + + + +INTEGER SYSTEM_STRLEN(CHAR x[]) /* LEN(lx$) */ +{ + int i = 0; + while (x[i] != 0) i++; + return i; +} + +INTEGER SYSTEM_STRLENS(SHORTCHAR x[]) /* LEN(sx$) */ +{ + int i = 0; + while (x[i] != 0) i++; + return i; +} + +INTEGER SYSTEM_STRCMPSS(SHORTCHAR x[], SHORTCHAR y[]) /* sx = sy */ +{ + int i = 0; + while (x[i] == y[i] && y[i] != 0) i++; + return x[i] - y[i]; +} + +INTEGER SYSTEM_STRCMPTS(CHAR x[], SHORTCHAR y[]) /* SHORT(lx) = sy */ +{ + int i = 0; + while ((x[i] & 0xff) == y[i] && y[i] != 0) i++; + return (x[i] & 0xff) - y[i]; +} + +INTEGER SYSTEM_STRCMPTT(CHAR x[], CHAR y[]) /* SHORT(lx) = SHORT(ly) */ +{ + int i = 0; + while ((x[i] & 0xff) == (y[i] & 0xff) && (y[i] & 0xff) != 0) i++; + return (x[i] & 0xff) - (y[i] & 0xff); +} + +INTEGER SYSTEM_STRCMPLL(CHAR x[], CHAR y[]) /* lx = ly */ +{ + int i = 0; + while (x[i] == y[i] && y[i] != 0) i++; + return x[i] - y[i]; +} + +INTEGER SYSTEM_STRCMPSL(SHORTCHAR x[], CHAR y[]) /* LONG(sx) = ly */ +{ + int i = 0; + while (x[i] == y[i] && y[i] != 0) i++; + return x[i] - y[i]; +} + +INTEGER SYSTEM_STRCMPTL(CHAR x[], CHAR y[]) /* LONG(SHORT(lx)) = ly */ +{ + int i = 0; + while ((x[i] & 0xff) == y[i] && y[i] != 0) i++; + return (x[i] & 0xff) - y[i]; +} + +void SYSTEM_STRCOPYSS(SHORTCHAR x[], SHORTCHAR y[], INTEGER n) /* sy := sx */ +{ + int i = 0; + do { + if (n-- == 0) __HALT(-8); + y[i] = x[i]; + } while (x[i++] != 0); +} + +void SYSTEM_STRCOPYTS(CHAR x[], SHORTCHAR y[], INTEGER n) /* sy := SHORT(lx) */ +{ + int i = 0; + do { + if (n-- == 0) __HALT(-8); + y[i] = (SHORTCHAR)x[i]; + } while ((x[i++] & 0xff) != 0); +} + +void SYSTEM_STRCOPYLL(CHAR x[], CHAR y[], INTEGER n) /* ly := lx */ +{ + int i = 0; + do { + if (n-- == 0) __HALT(-8); + y[i] = x[i]; + } while (x[i++] != 0); +} + +void SYSTEM_STRCOPYSL(SHORTCHAR x[], CHAR y[], INTEGER n) /* ly := LONG(sx) */ +{ + int i = 0; + do { + if (n-- == 0) __HALT(-8); + y[i] = x[i]; + } while (x[i++] != 0); +} + +void SYSTEM_STRCOPYTL(CHAR x[], CHAR y[], INTEGER n) /* ly := LONG(SHORT(lx)) */ +{ + int i = 0; + do { + if (n-- == 0) __HALT(-8); + y[i] = (x[i] & 0xff); + } while ((x[i++] & 0xff) != 0); +} + +void SYSTEM_STRAPNDSS(SHORTCHAR x[], SHORTCHAR y[], INTEGER n) /* sy := sy + sx */ +{ + int i = 0, j = 0; + while (y[j] != 0) j++; + do { + if (n-- == 0) __HALT(-8); + y[j++] = x[i]; + } while (x[i++] != 0); +} + +void SYSTEM_STRAPNDTS(CHAR x[], SHORTCHAR y[], INTEGER n) /* sy := sy + SHORT(lx) */ +{ + int i = 0, j = 0; + while (y[j] != 0) j++; + do { + if (n-- == 0) __HALT(-8); + y[j++] = (SHORTCHAR)x[i]; + } while ((x[i++] & 0xff) != 0); +} + +void SYSTEM_STRAPNDLL(CHAR x[], CHAR y[], INTEGER n) /* ly := ly + lx */ +{ + int i = 0, j = 0; + while (y[j] != 0) j++; + do { + if (n-- == 0) __HALT(-8); + y[j++] = x[i]; + } while (x[i++] != 0); +} + +void SYSTEM_STRAPNDSL(SHORTCHAR x[], CHAR y[], INTEGER n) /* ly := ly + LONG(sx) */ +{ + int i = 0, j = 0; + while (y[j] != 0) j++; + do { + if (n-- == 0) __HALT(-8); + y[j++] = x[i]; + } while (x[i++] != 0); +} + +void SYSTEM_STRAPNDTL(CHAR x[], CHAR y[], INTEGER n) /* ly := ly + LONG(SHORT(lx)) */ +{ + int i = 0, j = 0; + while (y[j] != 0) j++; + do { + if (n-- == 0) __HALT(-8); + y[j++] = (x[i] & 0xff); + } while ((x[i++] & 0xff) != 0); +} + diff --git a/C/SYSTEM.h b/C/SYSTEM.h new file mode 100644 index 0000000..183da76 --- /dev/null +++ b/C/SYSTEM.h @@ -0,0 +1,356 @@ +#ifndef SYSTEM__h +#define SYSTEM__h + +/* + +the CPfront runtime system interface and macro library +based on SYSTEM.h by Josef Templ +bh 20.12.1999 + +*/ + + +#pragma warning(disable:4101) // disable "unreferenced variable" warning + +#ifdef __GNUC__ +# include +#endif +#include +#include + +// extern char *memcpy(); + +#define export +#define import extern + +/* basic types */ +typedef unsigned char BOOLEAN; +typedef unsigned char SHORTCHAR; +typedef unsigned short CHAR; +typedef signed char BYTE; +typedef short SHORTINT; +typedef int INTEGER; +#if !defined(_WIN64) && ((__SIZEOF_POINTER__ == 8) || defined (_LP64) || defined(__LP64__)) + typedef long LONGINT; // LP64 + typedef unsigned long __U_LONGINT; +#else + typedef long long LONGINT; // ILP32 or LLP64 + typedef unsigned long long __U_LONGINT; +#endif +typedef float SHORTREAL; +typedef double REAL; +typedef unsigned int SET; +typedef void ANYREC; +typedef void *ANYPTR; +typedef void *SYSTEM_PTR; + +/* Unsigned variants are for use by shift and rotate macros */ +typedef unsigned char __U_SHORTCHAR; +typedef unsigned short __U_CHAR; +typedef unsigned char __U_BYTE; +typedef unsigned short __U_SHORTINT; +typedef unsigned int __U_INTEGER; +typedef unsigned int __U_SET; + +extern LONGINT SYSTEM_INF; +extern INTEGER SYSTEM_INFS; +extern INTEGER SYSTEM_argCount; +extern void *SYSTEM_argVector; + +/* constants */ +#define __MAXEXT 15 +#define NIL 0 +#define POINTER__typ (INTEGER*)1 /* not NIL and not a valid type */ +#define __INF (*(REAL*)&SYSTEM_INF) +#define __INFS (*(SHORTREAL*)&SYSTEM_INFS) + +#if defined _WIN32 || defined __CYGWIN__ +# ifdef __GNUC__ +# define __EXTERN __attribute__((dllimport)) +# else +# define __EXTERN __declspec(dllimport) +# endif +#else +# if __GNUC__ >= 4 && !defined(__OS2__) +# define __EXTERN __attribute__((visibility("default"))) +# else +# define __EXTERN +# endif +#endif +#define __CALLBACK __attribute__((__stdcall__)) + + +/* simple open array types */ + +typedef struct BOOLEAN_ARRAY { + INTEGER gc[3], len[1]; + BOOLEAN data[1]; +} BOOLEAN_ARRAY; +typedef struct CHAR_ARRAY { + INTEGER gc[3], len[1]; + CHAR data[1]; +} CHAR_ARRAY; +typedef struct SHORTCHAR_ARRAY { + INTEGER gc[3], len[1]; + SHORTCHAR data[1]; +} SHORTCHAR_ARRAY; +typedef struct BYTE_ARRAY { + INTEGER gc[3], len[1]; + BYTE data[1]; +} BYTE_ARRAY; +typedef struct SHORTINT_ARRAY { + INTEGER gc[3], len[1]; + SHORTINT data[1]; +} SHORTINT_ARRAY; +typedef struct INTEGER_ARRAY { + INTEGER gc[3], len[1]; + INTEGER data[1]; +} INTEGER_ARRAY; +typedef struct LONGINT_ARRAY { + INTEGER gc[3], len[1]; + LONGINT data[1]; +} LONGINT_ARRAY; +typedef struct REAL_ARRAY { + INTEGER gc[3], len[1]; + REAL data[1]; +} REAL_ARRAY; +typedef struct SHORTREAL_ARRAY { + INTEGER gc[3], len[1]; + SHORTREAL data[1]; +} SHORTREAL_ARRAY; +typedef struct SET_ARRAY { + INTEGER gc[3], len[1]; + SET data[1]; +} SET_ARRAY; + +/* meta info */ + +typedef struct SYSTEM_OBJDESC { + INTEGER fprint, offs, id, struc; +} SYSTEM_OBJDESC; +typedef struct SYSTEM_DIRECTORY { + INTEGER num; + struct SYSTEM_OBJDESC obj[1]; +} SYSTEM_DIRECTORY; +typedef struct SYSTEM_MODDESC { + struct SYSTEM_MODDESC *next; + SET opts; + INTEGER refcnt; + SHORTINT compTime[6], loadTime[6]; + void (*body) (); + void (*term) (); + INTEGER nofimps, nofptrs, size, dsize, rsize, code, data, refs, procBase, varBase; + char *names; + INTEGER *ptrs; + struct SYSTEM_MODDESC **imports; + struct SYSTEM_DIRECTORY *exp; + char name[256]; +} SYSTEM_MODDESC; +typedef struct SYSTEM_TYPEDESC { + INTEGER size; + struct SYSTEM_MODDESC *mod; + INTEGER id; + INTEGER base[16]; + struct SYSTEM_DIRECTORY *fields; + INTEGER ptroffs[1]; +} SYSTEM_TYPEDESC; + +/* dynamic link */ + +typedef struct SYSTEM_DLINK { + struct SYSTEM_DLINK *next; + char *name; +} SYSTEM_DLINK; +extern SYSTEM_DLINK *SYSTEM_dlink; + + +/* runtime system routines */ +extern CHAR* SYSTEM_LSTR(char *x); +extern INTEGER SYSTEM_DIV(INTEGER x, INTEGER y); +extern INTEGER SYSTEM_MOD(INTEGER x, INTEGER y); +extern INTEGER SYSTEM_MIN(INTEGER x, INTEGER y); +extern INTEGER SYSTEM_MAX(INTEGER x, INTEGER y); +extern INTEGER SYSTEM_ENTIER(REAL x); +extern INTEGER SYSTEM_ASH(INTEGER x, INTEGER n); +extern INTEGER SYSTEM_ABS(INTEGER x); +extern INTEGER SYSTEM_XCHK(INTEGER i, INTEGER ub); +extern void *SYSTEM_NEWARR(INTEGER type, INTEGER n); +extern void *SYSTEM_NEWARR1(INTEGER type, INTEGER n0, INTEGER n); +extern void *SYSTEM_NEWARR2(INTEGER type, INTEGER n1, INTEGER n0, INTEGER n); +extern void *SYSTEM_NEWARR3(INTEGER type, INTEGER n2, INTEGER n1, INTEGER n0, INTEGER n); +extern void *SYSTEM_NEWARR4(INTEGER type, INTEGER n3, INTEGER n2, INTEGER n1, INTEGER n0, INTEGER n); +extern void SYSTEM_REGMOD(struct SYSTEM_MODDESC *mod); +extern INTEGER SYSTEM_STRLEN(CHAR x[]); /* LEN(lx$) */ +extern INTEGER SYSTEM_STRLENS(SHORTCHAR x[]); /* LEN(sx$) */ +extern INTEGER SYSTEM_STRCMPSS(SHORTCHAR x[], SHORTCHAR y[]); /* sx = sy */ +extern INTEGER SYSTEM_STRCMPTS(CHAR x[], SHORTCHAR y[]); /* SHORT(lx) = sy */ +extern INTEGER SYSTEM_STRCMPTT(CHAR x[], CHAR y[]); /* SHORT(lx) = SHORT(ly) */ +extern INTEGER SYSTEM_STRCMPLL(CHAR x[], CHAR y[]); /* lx = ly */ +extern INTEGER SYSTEM_STRCMPSL(SHORTCHAR x[], CHAR y[]); /* LONG(sx) = ly */ +extern INTEGER SYSTEM_STRCMPTL(CHAR x[], CHAR y[]); /* LONG(SHORT(lx)) = ly */ +extern void SYSTEM_STRCOPYSS(SHORTCHAR x[], SHORTCHAR y[], INTEGER n); /* sy := sx */ +extern void SYSTEM_STRCOPYTS(CHAR x[], SHORTCHAR y[], INTEGER n); /* sy := SHORT(lx) */ +extern void SYSTEM_STRCOPYLL(CHAR x[], CHAR y[], INTEGER n); /* ly := lx */ +extern void SYSTEM_STRCOPYSL(SHORTCHAR x[], CHAR y[], INTEGER n); /* ly := LONG(sx) */ +extern void SYSTEM_STRCOPYTL(CHAR x[], CHAR y[], INTEGER n); /* ly := LONG(SHORT(lx)) */ +extern void SYSTEM_STRAPNDSS(SHORTCHAR x[], SHORTCHAR y[], INTEGER n); /* sy := sy + sx */ +extern void SYSTEM_STRAPNDTS(CHAR x[], SHORTCHAR y[], INTEGER n); /* sy := sy + SHORT(lx) */ +extern void SYSTEM_STRAPNDLL(CHAR x[], CHAR y[], INTEGER n); /* ly := ly + lx */ +extern void SYSTEM_STRAPNDSL(SHORTCHAR x[], CHAR y[], INTEGER n); /* ly := ly + LONG(sx) */ +extern void SYSTEM_STRAPNDTL(CHAR x[], CHAR y[], INTEGER n); /* ly := ly + LONG(SHORT(lx)) */ +extern LONGINT SYSTEM_DIVL(LONGINT x, LONGINT y); +extern LONGINT SYSTEM_MODL(LONGINT x, LONGINT y); +extern LONGINT SYSTEM_MINL(LONGINT x, LONGINT y); +extern LONGINT SYSTEM_MAXL(LONGINT x, LONGINT y); +extern LONGINT SYSTEM_ASHL(LONGINT x, INTEGER n); +extern LONGINT SYSTEM_ABSL(LONGINT x); +extern SHORTREAL SYSTEM_INT2SR(INTEGER x); +extern REAL SYSTEM_LONG2R(LONGINT x); +extern LONGINT SYSTEM_ENTIERL(REAL x); +extern INTEGER SYSTEM_SR2INT(SHORTREAL x); +extern LONGINT SYSTEM_R2LONG(REAL x); +extern SHORTREAL SYSTEM_ABSF(SHORTREAL x); +extern SHORTREAL SYSTEM_MINF(SHORTREAL x, SHORTREAL y); +extern SHORTREAL SYSTEM_MAXF(SHORTREAL x, SHORTREAL y); +extern REAL SYSTEM_ABSD(REAL x); +extern REAL SYSTEM_MIND(REAL x, REAL y); +extern REAL SYSTEM_MAXD(REAL x, REAL y); + +extern INTEGER Kernel_NewRec(INTEGER typ); +extern INTEGER Kernel_NewArr(INTEGER eltyp, INTEGER nofelem, INTEGER nofdim); +extern void Kernel_Trap(INTEGER n); + + +#define __INIT(argc, argv) SYSTEM_argCount = argc; SYSTEM_argVector = *(void**)&argv +#define __BEGREG(mod) if (mod.opts & 0x40000) return; mod.opts |= 0x40000; +#define __ENDREG +#define __REGMOD(mod) SYSTEM_REGMOD(&mod); +#define __BEGBODY(mod) if (mod.opts & 0x10000) return; mod.opts |= 0x10000; +#define __ENDBODY +#define __BEGCLOSE +#define __ENDCLOSE +#define __ENTER(name) SYSTEM_DLINK __dl = {SYSTEM_dlink, name}; SYSTEM_dlink = &__dl +#define __EXIT SYSTEM_dlink = __dl.next + +/* SYSTEM ops */ +#define __VAL(t, x) (*(t*)&(x)) +#define __VALSR(x) SYSTEM_INT2SR(x) +#define __VALR(x) SYSTEM_LONG2R(x) +#define __VALI(x) SYSTEM_SR2INT(x) +#define __VALL(x) SYSTEM_R2LONG(x) +#define __GET(a, x, t) x= *(t*)(a) +#define __PUT(a, x, t) *(t*)(a)=(t)x +#define __LSHL(x, n, t) ((t)((__U_##t)(x)<<(n))) +#define __LSHR(x, n, t) ((t)((__U_##t)(x)>>(n))) +#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t)) +#define __ROTL(x, n, t) ((t)((__U_##t)(x)<<(n)|(__U_##t)(x)>>(8*sizeof(t)-(n)))) +#define __ROTR(x, n, t) ((t)((__U_##t)(x)>>(n)|(__U_##t)(x)<<(8*sizeof(t)-(n)))) +#define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t)) +#define __BIT(x, n) (*(unsigned*)(x)>>(n)&1) +#define __MOVE(s, d, n) memcpy((char*)(d),(char*)(s),n) + +/* std procs and operator mappings */ +// #define __SHORT(x, y) ((int)((unsigned)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0))) +// #define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y))) +// #define __CHR(x) ((CHAR)__R(x, 256)) +// #define __CHRF(x) ((CHAR)__RF(x, 256)) +#define __DIV(x, y) ((x)>=0?(x)/(y):~(~(x)/(y))) +#define __DIVF(x, y) SYSTEM_DIV(x,y) +#define __DIVFL(x, y) SYSTEM_DIVL(x,y) +#define __MOD(x, y) ((x)>=0?(x)%(y):(y)+~(~(x)%(y))) +#define __MODF(x, y) SYSTEM_MOD(x,y) +#define __MODFL(x, y) SYSTEM_MODL(x,y) +#define __MIN(x, y) ((x)<(y)?(x):(y)) +#define __MINF(x, y) SYSTEM_MIN(x,y) +#define __MINFL(x, y) SYSTEM_MINL(x,y) +#define __MINFF(x, y) SYSTEM_MINF(x,y) +#define __MINFD(x, y) SYSTEM_MIND(x,y) +#define __MAX(x, y) ((x)>(y)?(x):(y)) +#define __MAXF(x, y) SYSTEM_MAX(x,y) +#define __MAXFL(x, y) SYSTEM_MAXL(x,y) +#define __MAXFF(x, y) SYSTEM_MAXF(x,y) +#define __MAXFD(x, y) SYSTEM_MAXD(x,y) +#define __NEW(t) (void*)Kernel_NewRec((INTEGER)t) +#define __NEWARR(t, n) (void*)SYSTEM_NEWARR(t, n) +#define __NEWARR0(t, n) (void*)Kernel_NewArr(t, n, 0) +#define __NEWARR1(t, n0, n) (void*)SYSTEM_NEWARR1(t, n0, n) +#define __NEWARR2(t, n1, n0, n) (void*)SYSTEM_NEWARR2(t, n1, n0, n) +#define __NEWARR3(t, n2, n1, n0, n) (void*)SYSTEM_NEWARR3(t, n2, n1, n0, n) +#define __NEWARR4(t, n3, n2, n1, n0, n) (void*)SYSTEM_NEWARR4(t, n3, n2, n1, n0, n) +#define __HALT(x) Kernel_Trap(x) +#define __ASSERT(cond, x) if (!(cond)) __HALT(x) +#define __ENTIER(x) SYSTEM_ENTIER(x) +#define __ENTIERL(x) SYSTEM_ENTIERL(x) +#define __ABS(x) (((x)<0)?-(x):(x)) +#define __ABSF(x) SYSTEM_ABS(x) +#define __ABSFL(x) SYSTEM_ABSL(x) +#define __ABSFF(x) SYSTEM_ABSF(x) +#define __ABSFD(x) SYSTEM_ABSD(x) +#define __CAP(ch) ((CHAR)((ch)&0x5f)) +#define __ODD(x) ((x)&1) +#define __IN(x, s) (((s)>>(x))&1) +#define __SETOF(x) ((SET)1<<(x)) +#define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h))) +#define __MASK(x, m) ((x)&~(m)) +#define __LSTR(x) SYSTEM_LSTR(x) + +#define __STRLEN(x) SYSTEM_STRLEN(x) /* LEN(lx$) */ +#define __STRLENS(x) SYSTEM_STRLENS(x) /* LEN(sx$) */ +#define __STRCMPSS(x, y) SYSTEM_STRCMPSS(x, y) /* sx = sy */ +#define __STRCMPTS(x, y) SYSTEM_STRCMPTS(x, y) /* SHORT(lx) = sy */ +#define __STRCMPTT(x, y) SYSTEM_STRCMPTT(x, y) /* SHORT(lx) = SHORT(ly) */ +#define __STRCMPLL(x, y) SYSTEM_STRCMPLL(x, y) /* lx = ly */ +#define __STRCMPSL(x, y) SYSTEM_STRCMPSL(x, y) /* LONG(sx) = ly */ +#define __STRCMPTL(x, y) SYSTEM_STRCMPTL(x, y) /* LONG(SHORT(lx)) = ly */ +#define __STRCOPYSS(x, y, n) SYSTEM_STRCOPYSS(x, y, n) /* sy := sx */ +#define __STRCOPYTS(x, y, n) SYSTEM_STRCOPYTS(x, y, n) /* sy := SHORT(lx) */ +#define __STRCOPYLL(x, y, n) SYSTEM_STRCOPYLL(x, y, n) /* ly := lx */ +#define __STRCOPYSL(x, y, n) SYSTEM_STRCOPYSL(x, y, n) /* ly := LONG(sx) */ +#define __STRCOPYTL(x, y, n) SYSTEM_STRCOPYTL(x, y, n) /* ly := LONG(SHORT(lx)) */ +#define __STRAPNDSS(x, y, n) SYSTEM_STRAPNDSS(x, y, n) /* sy := sy + sx */ +#define __STRAPNDTS(x, y, n) SYSTEM_STRAPNDTS(x, y, n) /* sy := sy + SHORT(lx) */ +#define __STRAPNDLL(x, y, n) SYSTEM_STRAPNDLL(x, y, n) /* ly := ly + lx */ +#define __STRAPNDSL(x, y, n) SYSTEM_STRAPNDSL(x, y, n) /* ly := ly + LONG(sx) */ +#define __STRAPNDTL(x, y, n) SYSTEM_STRAPNDTL(x, y, n) /* ly := ly + LONG(SHORT(lx)) */ + +#define __ASH(x, n, t) ((n)>=0?__ASHL(x,n,t):__ASHR(x,-(n),t)) +#define __ASHL(x, n, t) ((t)(x)<<(n)) +#define __ASHR(x, n, t) ((t)(x)>>(n)) +#define __ASHF(x, n, t) SYSTEM_ASH(x, n) +#define __ASHFL(x, n, t) SYSTEM_ASHL(x, n) +#define __DUP(x, l) x=(void*)memcpy(alloca(l*sizeof(*x)),x,l*sizeof(*x)) +#define __DUPARR(v) v=(void*)memcpy(v##__copy,v,sizeof(v##__copy)) +#define __DEL(x) /* DUP with alloca frees storage automatically */ +#define __IS(tag, typ, level) ((tag->base[level])==(INTEGER)typ) +#define __TYPEOF(p) (*(((SYSTEM_TYPEDESC**)(p))-1)) +#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level) + +/* runtime checks */ +#define __X(i, ub) (((unsigned)(i)<(unsigned)(ub))?i:(__HALT(-7),0)) +#define __XF(i, ub) SYSTEM_XCHK((INTEGER)(i), (INTEGER)(ub)) +// #define __RETCHK __retchk: __HALT(-3) +#define __RETCHK __HALT(-3) +#define __CASECHK __HALT(-2) +#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-4),p))) +#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-4),r)))) +#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-4),p))) +#define __WITHCHK __HALT(-1) + +/* Oberon-2 type bound procedures support */ +#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*((INTEGER*)typ-(num+1))))parlist + +/* runtime system variables */ +extern SYSTEM_MODDESC *SYSTEM_modlist; +extern LONGINT SYSTEM_argc; +extern LONGINT SYSTEM_argv; +extern void (*SYSTEM_Halt)(); +extern LONGINT SYSTEM_halt; +extern LONGINT SYSTEM_assert; +extern SYSTEM_PTR SYSTEM_modules; +extern LONGINT SYSTEM_heapsize; +extern LONGINT SYSTEM_allocated; +extern LONGINT SYSTEM_lock; +extern SHORTINT SYSTEM_gclock; +extern BOOLEAN SYSTEM_interrupted; + +#endif diff --git a/C/_windows.h b/C/_windows.h new file mode 100644 index 0000000..74a04c3 --- /dev/null +++ b/C/_windows.h @@ -0,0 +1,18 @@ +// windows.h wrapper +// Includes windows.h while avoiding conflicts with Component Pascal types. + +#define BOOLEAN _BOOLEAN +#define BYTE _BYTE +#define CHAR _CHAR + +#undef _WIN32_WINNT +// 0x0501 is for Windows XP (no service pack) +#define _WIN32_WINNT 0x0501 +#include + +#undef BOOLEAN +#undef BYTE +#undef CHAR + +typedef void *PtrVoid; +typedef CHAR *PtrWSTR; diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 index 0000000..78c9b44 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,5 @@ +v0.1: +* implemented true command line versions of DevCompiler, Dev2Linker and CPfront +* implemented new generic Host for POSIX-compatible systems +* implemented Kernel for CPfront +* implemented generic Int and 486-specific Long modules diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..f288702 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program 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 General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/README b/README new file mode 100644 index 0000000..bb2d483 --- /dev/null +++ b/README @@ -0,0 +1,33 @@ +CPC +--------- + +A command line Component Pascal Compiler + +Building +--------- + +Requirements: +* x86 CPU +* GNU/Linux +* GNU GCC +* installed multilib + +1. Run make-stage0.sh to bootstrap using BlackBox Cross Platform +(https://github.com/bbcb/bbcp) or run make-stage0c.sh to bootstrap from +prebuilded C source code produced by CPfront +2. Run make-stage1.sh +3. Run make-stage2.sh +4. Grab your binaries from stage2/i486 + +Directory crux is a good example how of package for linux distro. + +Bugs +_________ + +Contact to me if you found some bugs. :) + +Licensing +--------- + +Any code and patches under GPLv3+ (see LICENSE file). Contact to me (DEADDOOMER) if you want +to use some code in your BSD-licensed BlackBox/CPfront fork or project. diff --git a/crux/cpc-32/.32bit b/crux/cpc-32/.32bit new file mode 100644 index 0000000..e69de29 diff --git a/crux/cpc-32/Pkgfile b/crux/cpc-32/Pkgfile new file mode 100644 index 0000000..2d84da6 --- /dev/null +++ b/crux/cpc-32/Pkgfile @@ -0,0 +1,30 @@ +# Description: A command line Copmponent Pascal Compiler +# URL: https://deadsoftware.ru +# Maintainer: DeaDDooMER, deaddoomer@deadsoftware.ru + +name=cpc-32 +version=0.1 +release=1 +source=(https://deadsoftware.ru/projects/cpc/release/cpc-v${version}.src.tar.gz) + +build() { + cd bootstrap-src + + ./make-stage0c.sh + ./make-stage1.sh + ./make-stage2.sh + + install -d $PKG/usr/bin + install -D -m755 stage2/i486/{cpc486,cpl486,cpfront} $PKG/usr/bin/ + ln -s cpc486 $PKG/usr/bin/cpc + ln -s cpl486 $PKG/usr/bin/cpl + + install -d $PKG/usr/share/man/man1 + install -D -m644 man/cp{c,l}.1 $PKG/usr/share/man/man1 + ln -s cpc.1.gz $PKG/usr/share/man/man1/cpc486.1.gz + ln -s cpc.1.gz $PKG/usr/share/man/man1/cpfront.1.gz + ln -s cpl.1.gz $PKG/usr/share/man/man1/cpl486.1.gz + + install -d $PKG/usr/share/cpfront/C + install -D -m644 C/SYSTEM.{c,h} $PKG/usr/share/cpfront/C +} diff --git a/make-bootstrap.sh b/make-bootstrap.sh new file mode 100755 index 0000000..8fdb3fd --- /dev/null +++ b/make-bootstrap.sh @@ -0,0 +1,190 @@ +#! /bin/sh + +set -e + +THIS="$(dirname "$(readlink -f "$0")")" +OUT="$THIS/bootstrap/i486" + +cpc() { + "$THIS/stage2/i486/cpfront" -outcode CodeC -outsym SymC "$@" +} + +importlist() { + echo + while [ "$1" != "" ]; do + echo -n "\t\t$1" + shift + if [ "$1" != "" ]; then + echo "," + fi + done +} + +mainmodule() { +local name="$1" +shift +cat < "$name.cp" + shift + + cpc -main "$name.cp" + + local list="" + for mod in "$@" "$name"; do + list="$list CodeC/$mod.c" + done +} + +###^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^### +### Prepare bbdsw sources for LINUX/i486 ### +###______________________________________### + +rm -rf "$OUT" +mkdir -p "$OUT" +cp -r -- \ + "$THIS/src/generic/"* \ + "$THIS/src/posix/"* \ + "$THIS/src/cpfront/posix/"* \ + "$THIS/src/cpfront/linux/"* \ + "$OUT" +cd "$OUT" + +###^^^^^^^^^^^^^^^^^^^^^^^^### +### Compile POSIX bindings ### +###________________________### + +cpc C99/Mod/types.cp \ + C99/Mod/sys_types.cp \ + C99/Mod/stdlib.cp C99/Mod/stdio.cp C99/Mod/unistd.cp \ + C99/Mod/dirent.cp C99/Mod/locale.cp C99/Mod/time.cp \ + C99/Mod/sys_stat.cp C99/Mod/fcntl.cp C99/Mod/errno.cp \ + C99/Mod/iconv.cp C99/Mod/wctype.cp C99/Mod/sys_mman.cp \ + C99/Mod/dlfcn.cp C99/Mod/signal.cp C99/Mod/setjmp.cp \ + C99/Mod/libgen.cp \ + C99/Mod/macro.cp + +###^^^^^^^^^^^^^^^^^^^^^^^^^^^^### +### Compile BlackBox Framework ### +###____________________________### + +cpc System/Mod/Math.cp System/Mod/SMath.cp System/Mod/Kernel.cp \ + System/Mod/Console.odc System/Mod/Files.odc System/Mod/Dates.odc \ + System/Mod/Log.odc System/Mod/Strings.odc System/Mod/Services.odc \ + System/Mod/Int.odc System/Mod/Integers.odc + +###^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^### +### Compile Linux Host subsystem ### +###______________________________### + +cpc Host/Mod/Lang.cp Host/Mod/Dates.cp Host/Mod/Console.cp Host/Mod/Files.cp + +###^^^^^^^^^^^^^^^^^^^^^^^### +### Compile Dev subsystem ### +###_______________________### + +cpc Dev/Mod/CPM.cp Dev/Mod/CPT.odc Dev/Mod/CPS.odc Dev/Mod/CPB.odc \ + Dev/Mod/CPP.odc Dev/Mod/CPE.odc Dev/Mod/CPH.odc Dev/Mod/CPL486.odc \ + Dev/Mod/CPC486.odc Dev/Mod/CPV486.odc + +###^^^^^^^^^^^^^^^^^^^^^^^^### +### Compile Dev2 subsystem ### +###________________________### + +cpc Dev2/Mod/LnkBase.odc Dev2/Mod/LnkChmod.odc Dev2/Mod/LnkLoad.odc \ + Dev2/Mod/LnkWriteElf.odc Dev2/Mod/LnkWriteElfStatic.odc \ + Dev2/Mod/LnkWritePe.odc + +###^^^^^^^^^^^^^^^^^^^^^^^^^^^### +### Compile CPfront subsystem ### +###___________________________### + +cpc CPfront/Mod/CPG.odc CPfront/Mod/CPC.odc CPfront/Mod/CPV.odc + +###^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^### +### Compile bbdsw-specific modules ### +###________________________________### + +cpc Dsw/Mod/Documents.cp Dsw/Mod/Log.odc Dsw/Mod/Compiler486Main.cp \ + Dsw/Mod/CompilerCPfrontMain.cp Dsw/Mod/Linker486Main.cp + +###^^^^^^^^^^^^^^^^^^^^^^^^^### +### Compile other utilities ### +###_________________________### + +cpc Dsw/Mod/ListMain.cp Dsw/Mod/EchoMain.cp Dsw/Mod/LoopMain.cp + +###^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^### +### Link Standalone Component Pascl Compiler & Dev2 Linker ### +###________________________________________________________### + +linkall cpfront \ + C99types C99macro \ + Kernel Console Files Dates Math Strings Services Log \ + HostLang HostConsole HostFiles HostDates DswLog \ + DevCPM DevCPT DevCPS DevCPB DevCPP DevCPE DevCPH \ + CPfrontCPG CPfrontCPC CPfrontCPV\ + DswDocuments DswCompilerCPfrontMain + +linkall cpc486 \ + C99types C99macro \ + Kernel Console Files Dates Math Strings Services Log \ + HostLang HostConsole HostFiles HostDates DswLog \ + DevCPM DevCPT DevCPS DevCPB DevCPP DevCPE DevCPH \ + DevCPL486 DevCPC486 DevCPV486 \ + DswDocuments DswCompiler486Main + +linkall cpl486 \ + C99types C99macro \ + Kernel Console Files Math Strings Services Log \ + HostLang HostConsole HostFiles DswLog \ + Dev2LnkBase Dev2LnkChmod Dev2LnkLoad Dev2LnkWriteElf \ + Dev2LnkWriteElfStatic Dev2LnkWritePe \ + DswLinker486Main + +#linkall cplist \ +# C99types C99macro \ +# Kernel Console Files Math Strings Services Log \ +# HostLang HostConsole HostFiles DswLog \ +# DswListMain + +#linkall cpecho \ +# C99types C99macro \ +# Kernel Console Files Math Strings Services Log \ +# HostLang HostConsole HostFiles DswLog \ +# DswEchoMain + +#linkall cploop \ +# C99types C99macro \ +# Kernel Console Files Math Strings Services Log \ +# HostLang HostConsole HostFiles DswLog \ +# DswLoopMain + +rm -rf "$THIS/bootstrap-src" +mkdir -p "$THIS/bootstrap-src" +cp -r -t "$THIS/bootstrap-src" -- \ + "$THIS/CHANGELOG" \ + "$THIS/LICENSE" \ + "$THIS/README" \ + "$THIS/man" \ + "$THIS/crux" \ + "$THIS/make-bootstrap.sh" \ + "$THIS/make-stage0.sh" \ + "$THIS/make-stage0c.sh" \ + "$THIS/make-stage1.sh" \ + "$THIS/make-stage2.sh" \ + "$THIS/src" \ + "$THIS/C" \ + CodeC + +cd "$THIS" +tar czf cpc-v0.1.src.tar.gz bootstrap-src diff --git a/make-stage0.sh b/make-stage0.sh new file mode 100755 index 0000000..d6a9a3e --- /dev/null +++ b/make-stage0.sh @@ -0,0 +1,113 @@ +#! /bin/sh + +set -e + +THIS="$(dirname "$(readlink -f "$0")")" +OUT="$THIS/stage0/i486" + +###^^^^^^^^^^^^^^^^^^### +### Check BBCP files ### +###__________________### + +mkdir -p "$THIS/stage0" +if ! [ -e "$THIS/stage0/bbcp" ]; then + echo "Please, clone bbcp repo:" + echo "-> git clone --depth=1 -b crux https://git.deadsoftware.ru/bbcp.git '$(realpath --relative-to="$PWD" "$THIS/stage0/bbcp")'" + echo "Than retry building using make-stage0.sh" + exit 1 +fi +cd "$THIS/stage0/bbcp/BlackBox" + +###^^^^^^^^^^^^^^^^^^^### +### Build BBCP itself ### +###___________________### + +./switch-target Linux Interp +./build + +###^^^^^^^^^^^^^^^^^^^^^^^^^^^^### +### Copy minimal bbdsw sources ### +###____________________________### + +rm -rf "$OUT" +mkdir -p "$OUT" +cp -r -- \ + "$THIS/src/generic/"* \ + "$THIS/src/posix/"* \ + "$THIS/src/i486/generic/"* \ + "$THIS/src/i486/posix/"* \ + "$THIS/src/i486/linux/"* \ + "$OUT" + +###^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^### +### Compile Stage0 Compiler & Linker ### +###__________________________________### + +./blackbox < SYSTEM_DLINK *) + DLink = POINTER TO RECORD [untagged] + next: DLink; + name: StrPtr + END; + ArrStrPtr = POINTER TO ARRAY [untagged] OF StrPtr; + + ADDRESS* = types.Pvoid; + + VAR + baseStack: INTEGER; + root: Cluster; + modList-: Module; + trapCount-: INTEGER; + err-, pc-, sp-, fp-, stack-, val-: INTEGER; + + isTry: BOOLEAN; + startEnv: setjmp.sigjmp_buf; + tryEnv: setjmp.jmp_buf; + startDLink, tryDLink: DLink; + + argc-: INTEGER; + argv-: ArrStrPtr; + pagesize: unistd.long; + + free: ARRAY N OF FreeBlock; (* free list *) + sentinelBlock: FreeDesc; + sentinel: FreeBlock; + candidates: ARRAY 1024 OF INTEGER; + nofcand: INTEGER; + allocated: INTEGER; (* bytes allocated on BlackBox heap *) + total: INTEGER; (* current total size of BlackBox heap *) + used: INTEGER; (* bytes allocated on system heap *) + finalizers: FList; + hotFinalizers: FList; + cleaners: CList; + reducers: Reducer; + trapStack: TrapCleaner; + actual: Module; (* valid during module initialization *) + + trapViewer, trapChecker: Handler; + trapped, guarded, secondTrap: BOOLEAN; + interrupted: BOOLEAN; + static, inDll, terminating: BOOLEAN; + restart: Command; + + loader: LoaderHook; + loadres: INTEGER; + + wouldFinalize: BOOLEAN; + + watcher*: PROCEDURE (event: INTEGER); (* for debugging *) + + PROCEDURE Erase (adr, words: INTEGER); + BEGIN + ASSERT(words >= 0, 20); + WHILE words > 0 DO + S.PUT(adr, 0); + INC(adr, 4); + DEC(words) + END + END Erase; + + + PROCEDURE (VAR id: Identifier) Identified* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (r: Reducer) Reduce* (full: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (c: TrapCleaner) Cleanup*, NEW, EMPTY; + + (* meta extension suport *) + + PROCEDURE (e: ItemExt) Lookup* (name: ARRAY OF CHAR; VAR i: ANYREC), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Index* (index: INTEGER; VAR elem: ANYREC), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Deref* (VAR ref: ANYREC), NEW, ABSTRACT; + + PROCEDURE (e: ItemExt) Valid* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Size* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) BaseTyp* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Len* (): INTEGER, NEW, ABSTRACT; + + PROCEDURE (e: ItemExt) Call* (OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) BoolVal* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutBoolVal* (x: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) CharVal* (): CHAR, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutCharVal* (x: CHAR), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) IntVal* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutIntVal* (x: INTEGER), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) LongVal* (): LONGINT, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutLongVal* (x: LONGINT), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) RealVal* (): REAL, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutRealVal* (x: REAL), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) SetVal* (): SET, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutSetVal* (x: SET), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PtrVal* (): ANYPTR, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutPtrVal* (x: ANYPTR), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) GetSStringVal* (OUT x: ARRAY OF SHORTCHAR; + OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutSStringVal* (IN x: ARRAY OF SHORTCHAR; + OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) GetStringVal* (OUT x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutStringVal* (IN x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT; + + (* -------------------- miscellaneous tools -------------------- *) + + PROCEDURE IsUpper* (ch: CHAR): BOOLEAN; + BEGIN + RETURN wctype.iswupper(ORD(ch)) # 0 + END IsUpper; + + PROCEDURE Upper* (ch: CHAR): CHAR; + BEGIN + RETURN CHR(wctype.towupper(ORD(ch))) + END Upper; + + PROCEDURE IsLower* (ch: CHAR): BOOLEAN; + BEGIN + RETURN wctype.iswlower(ORD(ch)) # 0 + END IsLower; + + PROCEDURE Lower* (ch: CHAR): CHAR; + BEGIN + RETURN CHR(wctype.towlower(ORD(ch))) + END Lower; + + PROCEDURE IsAlpha* (ch: CHAR): BOOLEAN; + BEGIN + RETURN wctype.iswalpha(ORD(ch)) # 0 + END IsAlpha; + + PROCEDURE Utf8ToString* (IN in: ARRAY OF SHORTCHAR; OUT out: ARRAY OF CHAR; OUT res: INTEGER); + VAR i, j, val, max: INTEGER; ch: SHORTCHAR; + + PROCEDURE FormatError(); + BEGIN out := in$; res := 2 (*format error*) + END FormatError; + + BEGIN + ch := in[0]; i := 1; j := 0; max := LEN(out) - 1; + WHILE (ch # 0X) & (j < max) DO + IF ch < 80X THEN + out[j] := ch; INC(j) + ELSIF ch < 0E0X THEN + val := ORD(ch) - 192; + IF val < 0 THEN FormatError; RETURN END ; + ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128; + IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ; + out[j] := CHR(val); INC(j) + ELSIF ch < 0F0X THEN + val := ORD(ch) - 224; + ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128; + IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ; + ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128; + IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ; + out[j] := CHR(val); INC(j) + ELSE + FormatError; RETURN + END ; + ch := in[i]; INC(i) + END; + out[j] := 0X; + IF ch = 0X THEN res := 0 (*ok*) ELSE res := 1 (*truncated*) END + END Utf8ToString; + + PROCEDURE StringToUtf8* (IN in: ARRAY OF CHAR; OUT out: ARRAY OF SHORTCHAR; OUT res: INTEGER); + VAR i, j, val, max: INTEGER; + BEGIN + i := 0; j := 0; max := LEN(out) - 3; + WHILE (in[i] # 0X) & (j < max) DO + val := ORD(in[i]); INC(i); + IF val < 128 THEN + out[j] := SHORT(CHR(val)); INC(j) + ELSIF val < 2048 THEN + out[j] := SHORT(CHR(val DIV 64 + 192)); INC(j); + out[j] := SHORT(CHR(val MOD 64 + 128)); INC(j) + ELSE + out[j] := SHORT(CHR(val DIV 4096 + 224)); INC(j); + out[j] := SHORT(CHR(val DIV 64 MOD 64 + 128)); INC(j); + out[j] := SHORT(CHR(val MOD 64 + 128)); INC(j) + END; + END; + out[j] := 0X; + IF in[i] = 0X THEN res := 0 (*ok*) ELSE res := 1 (*truncated*) END + END StringToUtf8; + + PROCEDURE SplitName* (name: ARRAY OF CHAR; VAR head, tail: ARRAY OF CHAR); + (* portable *) + VAR i, j: INTEGER; ch, lch: CHAR; + BEGIN + i := 0; ch := name[0]; + IF ch # 0X THEN + REPEAT + head[i] := ch; lch := ch; INC(i); ch := name[i] + UNTIL (ch = 0X) OR (ch = ".") OR IsUpper(ch) & ~IsUpper(lch); + IF ch = "." THEN i := 0; ch := name[0] END; + head[i] := 0X; j := 0; + WHILE ch # 0X DO tail[j] := ch; INC(i); INC(j); ch := name[i] END; + tail[j] := 0X; + IF tail = "" THEN tail := head$; head := "" END + ELSE head := ""; tail := "" + END + END SplitName; + + PROCEDURE MakeFileName* (VAR name: ARRAY OF CHAR; type: ARRAY OF CHAR); + VAR i, j: INTEGER; ext: ARRAY 8 OF CHAR; ch: CHAR; + BEGIN + i := 0; + WHILE (name[i] # 0X) & (name[i] # ".") DO INC(i) END; + IF name[i] = "." THEN + IF name[i + 1] = 0X THEN name[i] := 0X END + ELSE + IF type = "" THEN ext := docType ELSE ext := type$ END; + IF i < LEN(name) - LEN(ext$) - 1 THEN + name[i] := "."; INC(i); j := 0; ch := ext[0]; + WHILE ch # 0X DO + name[i] := Lower(ch); INC(i); INC(j); ch := ext[j] + END; + name[i] := 0X + END + END + END MakeFileName; + + PROCEDURE Time* (): LONGINT; + VAR res: time.int; tp: time.struct_timespec; + BEGIN + ASSERT(timeResolution >= 1); + ASSERT(timeResolution <= 1000000000); + res := time.clock_gettime(time.CLOCK_MONOTONIC, tp); + ASSERT(res = 0, 100); + RETURN tp.tv_sec * LONG(timeResolution) + tp.tv_nsec DIV LONG(1000000000 DIV timeResolution) + END Time; + + PROCEDURE Beep*; + (* !!! *) + END Beep; + + PROCEDURE SearchProcVar* (var: INTEGER; VAR m: Module; VAR adr: INTEGER); + BEGIN + adr := var; m := NIL; + IF var # 0 THEN + m := modList; + WHILE (m # NIL) & ((var < m.code) OR (var >= m.code + m.csize)) DO m := m.next END; + IF m # NIL THEN DEC(adr, m.code) END + END + END SearchProcVar; + + (* -------------------- system memory management --------------------- *) + + PROCEDURE AllocMem (size: sysmman.size_t; VAR max: sysmman.size_t): ADDRESS; + VAR fd, flags, res: fcntl.int; ptr: ADDRESS; + BEGIN + max := (size + pagesize - 1) DIV pagesize * pagesize; + fd := fcntl.open("/dev/zero", fcntl.O_RDWR, 0); + IF fd # -1 THEN + flags := sysmman.PROT_READ + sysmman.PROT_WRITE; + ptr := sysmman.mmap(0, max, flags, sysmman.MAP_PRIVATE, fd, 0); + IF ptr = sysmman.MAP_FAILED THEN ptr := 0 END; + res := unistd.close(fd); + ASSERT(res = 0, 100) + ELSE + ptr := 0 + END; + RETURN ptr + END AllocMem; + + PROCEDURE FreeMem (adr: ADDRESS; size: sysmman.size_t); + VAR res: sysmman.int; + BEGIN + size := (size + pagesize - 1) DIV pagesize * pagesize; + res := sysmman.munmap(adr, size); + ASSERT(res = 0, 100) + END FreeMem; + + PROCEDURE AllocHeapMem (size: INTEGER; VAR c: Cluster); + CONST N = 65536; (* cluster size for dll *) + VAR adr, allocated: INTEGER; + BEGIN + INC(size, 16); + ASSERT(size > 0, 100); adr := 0; + IF size < N THEN adr := stdlib.malloc(N) END; + IF adr = 0 THEN adr := stdlib.malloc(size); allocated := size ELSE allocated := N END; + IF adr = 0 THEN c := NIL + ELSE + c := S.VAL(Cluster, (adr + 15) DIV 16 * 16); c.max := adr; + c.size := allocated - (S.VAL(INTEGER, c) - adr); + INC(used, c.size); INC(total, c.size) + END; + ASSERT((adr = 0) OR (adr MOD 16 = 0) & (c.size >= size), 101); + (* post: (c = NIL) OR (c MOD 16 = 0) & (c.size >= size) *) + END AllocHeapMem; + + PROCEDURE FreeHeapMem (c: Cluster); + BEGIN + DEC(used, c.size); DEC(total, c.size); + stdlib.free(S.VAL(ADDRESS, c.max)) + END FreeHeapMem; + + PROCEDURE HeapFull (size: INTEGER): BOOLEAN; + BEGIN + RETURN TRUE + END HeapFull; + + PROCEDURE AllocModMem* (descSize, modSize: INTEGER; VAR descAdr, modAdr: INTEGER); + BEGIN + descAdr := 0; modAdr := 0; + descAdr := AllocMem(descSize, descSize); + IF descAdr # 0 THEN + modAdr := AllocMem(modSize, modSize); + IF modAdr = 0 THEN + FreeMem(descAdr, descSize) + ELSE + INC(used, descSize + modSize) + END + END + END AllocModMem; + + PROCEDURE DeallocModMem* (descSize, modSize, descAdr, modAdr: INTEGER); + BEGIN + FreeMem(descAdr, descSize); + FreeMem(modAdr, modSize); + DEC(used, descSize + modSize) + END DeallocModMem; + + PROCEDURE InvalModMem (modSize, modAdr: INTEGER); + BEGIN + FreeMem(modAdr, modSize) + END InvalModMem; + + PROCEDURE TryRead (from, to, c: INTEGER); + VAR i: INTEGER; x: BYTE; + BEGIN + IF from <= to THEN + FOR i := from TO to DO + S.GET(i, x) + END + ELSE + FOR i := to TO from BY -1 DO + S.GET(i, x) + END + END; + END TryRead; + + PROCEDURE^ Try* (h: TryHandler; a, b, c: INTEGER); + + PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN; + VAR i: INTEGER; + BEGIN + i := trapCount; + Try(TryRead, from, to, 0); + RETURN trapCount = i + END IsReadable; + + (* --------------------- NEW implementation (portable) -------------------- *) + + PROCEDURE^ NewBlock (size: INTEGER): Block; + + PROCEDURE NewRec* (typ: INTEGER): INTEGER; (* implementation of NEW(ptr) *) + VAR size, adr: INTEGER; b: Block; tag: Type; l: FList; + BEGIN + IF ~ODD(typ) THEN + tag := S.VAL(Type, typ); + b := NewBlock(tag.size); + IF b # NIL THEN + b.tag := tag; + S.GET(typ - 4, size); + IF size # 0 THEN (* record uses a finalizer *) + l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *) + l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *) + l.blk := b; l.next := finalizers; finalizers := l + END; + adr := S.ADR(b.last) + ELSE + adr := 0 + END + ELSE + HALT(100) (* COM interface pointers not supported *) + END; + RETURN adr + END NewRec; + + PROCEDURE NewArr* (eltyp, nofelem, nofdim: INTEGER): INTEGER; (* impl. of NEW(ptr, dim0, dim1, ...) *) + VAR b: Block; size, headSize: INTEGER; t: Type; + BEGIN + CASE eltyp OF + | -1: HALT(100) (* COM interface pointers not supported *) + | 0: eltyp := S.ADR(PtrType) + | 1: eltyp := S.ADR(Char8Type) + | 2: eltyp := S.ADR(Int16Type) + | 3: eltyp := S.ADR(Int8Type) + | 4: eltyp := S.ADR(Int32Type) + | 5: eltyp := S.ADR(BoolType) + | 6: eltyp := S.ADR(SetType) + | 7: eltyp := S.ADR(Real32Type) + | 8: eltyp := S.ADR(Real64Type) + | 9: eltyp := S.ADR(Char16Type) + | 10: eltyp := S.ADR(Int64Type) + | 11: eltyp := S.ADR(ProcType) + | 12: HALT(101) (* COM interface pointers not supported *) + ELSE + ASSERT(~ODD(eltyp), 102) (* COM interface pointers not supported *) + END; + t := S.VAL(Type, eltyp); + headSize := 4 * nofdim + 12; + size := headSize + nofelem * t.size; + b := NewBlock(size); + IF b # NIL THEN + b.tag := S.VAL(Type, eltyp + 2); (* tag + array mark *) + b.last := S.ADR(b.last) + size - t.size; (* pointer to last elem *) + b.first := S.ADR(b.last) + headSize; (* pointer to first elem *) + RETURN S.ADR(b.last) + ELSE + RETURN 0 + END; + END NewArr; + + (* -------------------- handler installation (portable) --------------------- *) + + PROCEDURE ThisFinObj* (VAR id: Identifier): ANYPTR; + VAR l: FList; + BEGIN + ASSERT(id.typ # 0, 100); + l := finalizers; + WHILE l # NIL DO + IF S.VAL(INTEGER, l.blk.tag) = id.typ THEN + id.obj := S.VAL(ANYPTR, S.ADR(l.blk.last)); + IF id.Identified() THEN RETURN id.obj END + END; + l := l.next + END; + RETURN NIL + END ThisFinObj; + + PROCEDURE InstallReducer* (r: Reducer); + BEGIN + r.next := reducers; reducers := r + END InstallReducer; + + PROCEDURE InstallTrapViewer* (h: Handler); + BEGIN + trapViewer := h + END InstallTrapViewer; + + PROCEDURE InstallTrapChecker* (h: Handler); + BEGIN + trapChecker := h + END InstallTrapChecker; + + PROCEDURE PushTrapCleaner* (c: TrapCleaner); + VAR t: TrapCleaner; + BEGIN + t := trapStack; WHILE (t # NIL) & (t # c) DO t := t.next END; + ASSERT(t = NIL, 20); + c.next := trapStack; trapStack := c + END PushTrapCleaner; + + PROCEDURE PopTrapCleaner* (c: TrapCleaner); + VAR t: TrapCleaner; + BEGIN + t := NIL; + WHILE (trapStack # NIL) & (t # c) DO + t := trapStack; trapStack := trapStack.next + END + END PopTrapCleaner; + + PROCEDURE InstallCleaner* (p: Command); + VAR c: CList; + BEGIN + c := S.VAL(CList, NewRec(S.TYP(CList))); (* NEW(c) *) + c.do := p; c.trapped := FALSE; c.next := cleaners; cleaners := c + END InstallCleaner; + + PROCEDURE RemoveCleaner* (p: Command); + VAR c0, c: CList; + BEGIN + c := cleaners; c0 := NIL; + WHILE (c # NIL) & (c.do # p) DO c0 := c; c := c.next END; + IF c # NIL THEN + IF c0 = NIL THEN cleaners := cleaners.next ELSE c0.next := c.next END + END + END RemoveCleaner; + + PROCEDURE Cleanup*; + VAR c, c0: CList; + BEGIN + c := cleaners; c0 := NIL; + WHILE c # NIL DO + IF ~c.trapped THEN + c.trapped := TRUE; c.do; c.trapped := FALSE; c0 := c + ELSE + IF c0 = NIL THEN cleaners := cleaners.next + ELSE c0.next := c.next + END + END; + c := c.next + END + END Cleanup; + + (* -------------------- meta information (portable) --------------------- *) + + PROCEDURE (h: LoaderHook) ThisMod* (IN name: ARRAY OF CHAR): Module, NEW, ABSTRACT; + + PROCEDURE SetLoaderHook*(h: LoaderHook); + BEGIN + loader := h + END SetLoaderHook; + + PROCEDURE InitModule (mod: Module); (* initialize linked modules *) + VAR body: Command; + BEGIN + IF ~(dyn IN mod.opts) & (mod.next # NIL) & ~(init IN mod.next.opts) THEN InitModule(mod.next) END; + IF ~(init IN mod.opts) THEN + body := S.VAL(Command, mod.code); + INCL(mod.opts, init); + actual := mod; + body(); actual := NIL + END + END InitModule; + + PROCEDURE ThisLoadedMod* (IN name: ARRAY OF CHAR): Module; (* loaded modules only *) + VAR m: Module; res: INTEGER; n: Utf8Name; + BEGIN + StringToUtf8(name, n, res); ASSERT(res = 0); + loadres := done; + m := modList; + WHILE (m # NIL) & ((m.name # n) OR (m.refcnt < 0)) DO m := m.next END; + IF (m # NIL) & ~(init IN m.opts) THEN InitModule(m) END; + IF m = NIL THEN loadres := moduleNotFound END; + RETURN m + END ThisLoadedMod; + + PROCEDURE ThisMod* (IN name: ARRAY OF CHAR): Module; + BEGIN + IF loader # NIL THEN + loader.res := done; + RETURN loader.ThisMod(name) + ELSE + RETURN ThisLoadedMod(name) + END + END ThisMod; + + PROCEDURE LoadMod* (IN name: ARRAY OF CHAR); + VAR m: Module; + BEGIN + m := ThisMod(name) + END LoadMod; + + PROCEDURE GetLoaderResult* (OUT res: INTEGER; OUT importing, imported, object: ARRAY OF CHAR); + BEGIN + IF loader # NIL THEN + res := loader.res; + importing := loader.importing$; + imported := loader.imported$; + object := loader.object$ + ELSE + res := loadres; + importing := ""; + imported := ""; + object := "" + END + END GetLoaderResult; + + PROCEDURE ThisObject* (mod: Module; IN name: ARRAY OF CHAR): Object; + VAR l, r, m, res: INTEGER; p: StrPtr; n: Utf8Name; + BEGIN + StringToUtf8(name, n, res); ASSERT(res = 0); + l := 0; r := mod.export.num; + WHILE l < r DO (* binary search *) + m := (l + r) DIV 2; + p := S.VAL(StrPtr, S.ADR(mod.names[mod.export.obj[m].id DIV 256])); + IF p^ = n THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[m])) END; + IF p^ < n THEN l := m + 1 ELSE r := m END + END; + RETURN NIL + END ThisObject; + + PROCEDURE ThisDesc* (mod: Module; fprint: INTEGER): Object; + VAR i, n: INTEGER; + BEGIN + i := 0; n := mod.export.num; + WHILE (i < n) & (mod.export.obj[i].id DIV 256 = 0) DO + IF mod.export.obj[i].offs = fprint THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[i])) END; + INC(i) + END; + RETURN NIL + END ThisDesc; + + PROCEDURE ThisField* (rec: Type; IN name: ARRAY OF CHAR): Object; + VAR n, res: INTEGER; p: StrPtr; obj: Object; m: Module; nn: Utf8Name; + BEGIN + StringToUtf8(name, nn, res); ASSERT(res = 0); + m := rec.mod; + obj := S.VAL(Object, S.ADR(rec.fields.obj[0])); n := rec.fields.num; + WHILE n > 0 DO + p := S.VAL(StrPtr, S.ADR(m.names[obj.id DIV 256])); + IF p^ = nn THEN RETURN obj END; + DEC(n); INC(S.VAL(INTEGER, obj), 16) + END; + RETURN NIL + END ThisField; + + PROCEDURE ThisCommand* (mod: Module; IN name: ARRAY OF CHAR): Command; + VAR x: Object; sig: Signature; + BEGIN + x := ThisObject(mod, name); + IF (x # NIL) & (x.id MOD 16 = mProc) THEN + sig := S.VAL(Signature, x.struct); + IF (sig.retStruct = NIL) & (sig.num = 0) THEN RETURN S.VAL(Command, mod.procBase + x.offs) END + END; + RETURN NIL + END ThisCommand; + + PROCEDURE ThisType* (mod: Module; IN name: ARRAY OF CHAR): Type; + VAR x: Object; + BEGIN + x := ThisObject(mod, name); + IF (x # NIL) & (x.id MOD 16 = mTyp) & (S.VAL(INTEGER, x.struct) DIV 256 # 0) THEN + RETURN x.struct + ELSE + RETURN NIL + END + END ThisType; + + PROCEDURE TypeOf* (IN rec: ANYREC): Type; + BEGIN + RETURN S.VAL(Type, S.TYP(rec)) + END TypeOf; + + PROCEDURE LevelOf* (t: Type): SHORTINT; + BEGIN + RETURN SHORT(t.id DIV 16 MOD 16) + END LevelOf; + + PROCEDURE NewObj* (VAR o: S.PTR; t: Type); + VAR i: INTEGER; + BEGIN + IF t.size = -1 THEN o := NIL + ELSE + i := 0; WHILE t.ptroffs[i] >= 0 DO INC(i) END; + IF t.ptroffs[i+1] >= 0 THEN INC(S.VAL(INTEGER, t)) END; (* with interface pointers *) + o := S.VAL(S.PTR, NewRec(S.VAL(INTEGER, t))) (* generic NEW *) + END + END NewObj; + + PROCEDURE GetModName* (mod: Module; OUT name: Name); + VAR res: INTEGER; + BEGIN + Utf8ToString(mod.name, name, res); ASSERT(res = 0) + END GetModName; + + PROCEDURE GetObjName* (mod: Module; obj: Object; OUT name: Name); + VAR p: StrPtr; res: INTEGER; + BEGIN + p := S.VAL(StrPtr, S.ADR(mod.names[obj.id DIV 256])); + Utf8ToString(p^$, name, res); ASSERT(res = 0) + END GetObjName; + + PROCEDURE GetTypeName* (t: Type; OUT name: Name); + VAR p: StrPtr; res: INTEGER; + BEGIN + p := S.VAL(StrPtr, S.ADR(t.mod.names[t.id DIV 256])); + Utf8ToString(p^$, name, res); ASSERT(res = 0) + END GetTypeName; + + PROCEDURE RegisterMod* (mod: Module); + VAR i: INTEGER; epoch: time.time_t; tm: time.struct_tm; ptm: time.Pstruct_tm; + BEGIN + mod.next := modList; modList := mod; mod.refcnt := 0; INCL(mod.opts, dyn); i := 0; + WHILE i < mod.nofimps DO + IF mod.imports[i] # NIL THEN INC(mod.imports[i].refcnt) END; + INC(i) + END; + epoch := time.time(NIL); + ptm := time.localtime_r(epoch, tm); + IF ptm # NIL THEN + mod.loadTime[0] := SHORT(tm.tm_year + 1900); + mod.loadTime[1] := SHORT(tm.tm_mon + 1); + mod.loadTime[2] := SHORT(tm.tm_mday); + mod.loadTime[3] := SHORT(tm.tm_hour); + mod.loadTime[4] := SHORT(tm.tm_min); + mod.loadTime[5] := SHORT(tm.tm_sec) + ELSE + mod.loadTime[0] := 0; + mod.loadTime[1] := 0; + mod.loadTime[2] := 0; + mod.loadTime[3] := 0; + mod.loadTime[4] := 0; + mod.loadTime[5] := 0 + END; + IF ~(init IN mod.opts) THEN InitModule(mod) END + END RegisterMod; + + PROCEDURE^ Collect*; + + PROCEDURE UnloadMod* (mod: Module); + VAR i: INTEGER; t: Command; + BEGIN + IF mod.refcnt = 0 THEN + t := mod.term; mod.term := NIL; + IF t # NIL THEN t() END; (* terminate module *) + i := 0; + WHILE i < mod.nofptrs DO (* release global pointers *) + S.PUT(mod.varBase + mod.ptrs[i], 0); INC(i) + END; + Collect; (* call finalizers *) + i := 0; + WHILE i < mod.nofimps DO (* release imported modules *) + IF mod.imports[i] # NIL THEN DEC(mod.imports[i].refcnt) END; + INC(i) + END; + mod.refcnt := -1; + IF dyn IN mod.opts THEN (* release memory *) + InvalModMem(mod.data + mod.dsize - mod.refs, mod.refs) + END + END + END UnloadMod; + + (* -------------------- dynamic procedure call --------------------- *) + + PROCEDURE Call* (adr: INTEGER; sig: Signature; IN par: ARRAY OF INTEGER; n: INTEGER): LONGINT; + BEGIN + HALT(126); (* !!! *) + RETURN 0 + END Call; + + (* -------------------- reference information (portable) --------------------- *) + + PROCEDURE RefCh (VAR ref: INTEGER; OUT ch: SHORTCHAR); + BEGIN + S.GET(ref, ch); INC(ref) + END RefCh; + + PROCEDURE RefNum (VAR ref: INTEGER; OUT x: INTEGER); + VAR s, n: INTEGER; ch: SHORTCHAR; + BEGIN + s := 0; n := 0; RefCh(ref, ch); + WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); RefCh(ref, ch) END; + x := n + ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s) + END RefNum; + + PROCEDURE RefName (VAR ref: INTEGER; OUT n: Utf8Name); + VAR i: INTEGER; ch: SHORTCHAR; + BEGIN + i := 0; RefCh(ref, ch); + WHILE ch # 0X DO n[i] := ch; INC(i); RefCh(ref, ch) END; + n[i] := 0X + END RefName; + + PROCEDURE GetRefProc* (VAR ref: INTEGER; OUT adr: INTEGER; OUT name: Utf8Name); + VAR ch: SHORTCHAR; + BEGIN + S.GET(ref, ch); + WHILE ch >= 0FDX DO (* skip variables *) + INC(ref); RefCh(ref, ch); + IF ch = 10X THEN INC(ref, 4) END; + RefNum(ref, adr); RefName(ref, name); S.GET(ref, ch) + END; + WHILE (ch > 0X) & (ch < 0FCX) DO (* skip source refs *) + INC(ref); RefNum(ref, adr); S.GET(ref, ch) + END; + IF ch = 0FCX THEN INC(ref); RefNum(ref, adr); RefName(ref, name) + ELSE adr := 0 + END + END GetRefProc; + + PROCEDURE GetRefVar* (VAR ref: INTEGER; OUT mode, form: SHORTCHAR; OUT desc: Type; OUT adr: INTEGER; OUT name: Utf8Name); + BEGIN + S.GET(ref, mode); desc := NIL; + IF mode >= 0FDX THEN + mode := SHORT(CHR(ORD(mode) - 0FCH)); + INC(ref); RefCh(ref, form); + IF form = 10X THEN + S.GET(ref, desc); INC(ref, 4); form := SHORT(CHR(16 + desc.id MOD 4)) + END; + RefNum(ref, adr); RefName(ref, name) + ELSE + mode := 0X; form := 0X; adr := 0 + END + END GetRefVar; + + PROCEDURE SourcePos* (mod: Module; codePos: INTEGER): INTEGER; + VAR ref, pos, ad, d: INTEGER; ch: SHORTCHAR; name: Utf8Name; + BEGIN + IF mod # NIL THEN (* mf, 12.02.04 *) + ref := mod.refs; pos := 0; ad := 0; S.GET(ref, ch); + WHILE ch # 0X DO + WHILE (ch > 0X) & (ch < 0FCX) DO (* srcref: {dAdr,dPos} *) + INC(ad, ORD(ch)); INC(ref); RefNum(ref, d); + IF ad > codePos THEN RETURN pos END; + INC(pos, d); S.GET(ref, ch) + END; + IF ch = 0FCX THEN (* proc: 0FCX,Adr,Name *) + INC(ref); RefNum(ref, d); RefName(ref, name); S.GET(ref, ch); + IF (d > codePos) & (pos > 0) THEN RETURN pos END + END; + WHILE ch >= 0FDX DO (* skip variables: Mode, Form, adr, Name *) + INC(ref); RefCh(ref, ch); + IF ch = 10X THEN INC(ref, 4) END; + RefNum(ref, d); RefName(ref, name); S.GET(ref, ch) + END + END; + END; + RETURN -1 + END SourcePos; + + PROCEDURE LoadDll* (IN name: ARRAY OF CHAR; VAR ok: BOOLEAN); + VAR h: ADDRESS; file: Utf8Name; res: INTEGER; + BEGIN + StringToUtf8(name, file, res); + IF res = 0 THEN + h := dlfcn.dlopen(file, dlfcn.RTLD_LAZY + dlfcn.RTLD_GLOBAL); + ok := h # 0 + ELSE + ok := FALSE + END + END LoadDll; + + PROCEDURE ThisDllObj* (mode, fprint: INTEGER; IN dll, name: ARRAY OF CHAR): INTEGER; + VAR h, p: ADDRESS; file, sym: Utf8Name; res: INTEGER; err: dlfcn.int; + BEGIN + StringToUtf8(dll, file, res); + IF res = 0 THEN + h := dlfcn.dlopen(file, dlfcn.RTLD_LAZY + dlfcn.RTLD_GLOBAL); + IF h # 0 THEN + StringToUtf8(name, sym, res); + IF res = 0 THEN + p := dlfcn.dlsym(h, sym) + ELSE + p := 0 + END; + err := dlfcn.dlclose(h); + ASSERT(err = 0, 100) + ELSE + p := 0 + END + ELSE + p := 0 + END; + RETURN p + END ThisDllObj; + + (* -------------------- garbage collector (portable) --------------------- *) + + PROCEDURE Mark (this: Block); + VAR father, son: Block; tag: Type; flag, offset, actual: INTEGER; + BEGIN + IF ~ODD(S.VAL(INTEGER, this.tag)) THEN + father := NIL; + LOOP + INC(S.VAL(INTEGER, this.tag)); + flag := S.VAL(INTEGER, this.tag) MOD 4; + tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag); + IF flag >= 2 THEN actual := this.first; this.actual := actual + ELSE actual := S.ADR(this.last) + END; + LOOP + offset := tag.ptroffs[0]; + IF offset < 0 THEN + INC(S.VAL(INTEGER, tag), offset + 4); (* restore tag *) + IF (flag >= 2) & (actual < this.last) & (offset < -4) THEN (* next array element *) + INC(actual, tag.size); this.actual := actual + ELSE (* up *) + this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag); + IF father = NIL THEN RETURN END; + son := this; this := father; + flag := S.VAL(INTEGER, this.tag) MOD 4; + tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag); + offset := tag.ptroffs[0]; + IF flag >= 2 THEN actual := this.actual ELSE actual := S.ADR(this.last) END; + S.GET(actual + offset, father); S.PUT(actual + offset, S.ADR(son.last)); + INC(S.VAL(INTEGER, tag), 4) + END + ELSE + S.GET(actual + offset, son); + IF son # NIL THEN + DEC(S.VAL(INTEGER, son), 4); + IF ~ODD(S.VAL(INTEGER, son.tag)) THEN (* down *) + this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag); + S.PUT(actual + offset, father); father := this; this := son; + EXIT + END + END; + INC(S.VAL(INTEGER, tag), 4) + END + END + END + END + END Mark; + + PROCEDURE MarkGlobals; + VAR m: Module; i, p: INTEGER; + BEGIN + m := modList; + WHILE m # NIL DO + IF m.refcnt >= 0 THEN + i := 0; + WHILE i < m.nofptrs DO + S.GET(m.varBase + m.ptrs[i], p); INC(i); + IF p # 0 THEN Mark(S.VAL(Block, p - 4)) END + END + END; + m := m.next + END + END MarkGlobals; + + PROCEDURE Next (b: Block): Block; (* next block in same cluster *) + VAR size: INTEGER; + BEGIN + S.GET(S.VAL(INTEGER, b.tag) DIV 4 * 4, size); + IF ODD(S.VAL(INTEGER, b.tag) DIV 2) THEN INC(size, b.last - S.ADR(b.last)) END; + RETURN S.VAL(Block, S.VAL(INTEGER, b) + (size + 19) DIV 16 * 16) + END Next; + + PROCEDURE CheckCandidates; + (* pre: nofcand > 0 *) + VAR i, j, h, p, end: INTEGER; c: Cluster; blk, next: Block; + BEGIN + (* sort candidates (shellsort) *) + h := 1; REPEAT h := h*3 + 1 UNTIL h > nofcand; + REPEAT h := h DIV 3; i := h; + WHILE i < nofcand DO p := candidates[i]; j := i; + WHILE (j >= h) & (candidates[j-h] > p) DO + candidates[j] := candidates[j-h]; j := j-h + END; + candidates[j] := p; INC(i) + END + UNTIL h = 1; + (* sweep *) + c := root; i := 0; + WHILE c # NIL DO + blk := S.VAL(Block, S.VAL(INTEGER, c) + 12); + end := S.VAL(INTEGER, blk) + (c.size - 12) DIV 16 * 16; + WHILE candidates[i] < S.VAL(INTEGER, blk) DO + INC(i); + IF i = nofcand THEN RETURN END + END; + WHILE S.VAL(INTEGER, blk) < end DO + next := Next(blk); + IF candidates[i] < S.VAL(INTEGER, next) THEN + IF (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last)) (* not a free block *) + & (~strictStackSweep OR (candidates[i] = S.ADR(blk.last))) THEN + Mark(blk) + END; + REPEAT + INC(i); + IF i = nofcand THEN RETURN END + UNTIL candidates[i] >= S.VAL(INTEGER, next) + END; + IF (S.VAL(INTEGER, blk.tag) MOD 4 = 0) & (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last)) + & (blk.tag.base[0] = NIL) & (blk.actual > 0) THEN (* referenced interface record *) + Mark(blk) + END; + blk := next + END; + c := c.next + END + END CheckCandidates; + + PROCEDURE MarkLocals; + VAR sp, p, min, max: INTEGER; c: Cluster; + BEGIN + sp := S.ADR(sp); nofcand := 0; c := root; + WHILE c.next # NIL DO c := c.next END; + min := S.VAL(INTEGER, root); max := S.VAL(INTEGER, c) + c.size; + WHILE sp < baseStack DO + S.GET(sp, p); + IF (p > min) & (p < max) & (~strictStackSweep OR (p MOD 16 = 0)) THEN + candidates[nofcand] := p; INC(nofcand); + IF nofcand = LEN(candidates) - 1 THEN CheckCandidates; nofcand := 0 END + END; + INC(sp, 4) + END; + candidates[nofcand] := max; INC(nofcand); (* ensure complete scan for interface mark*) + IF nofcand > 0 THEN CheckCandidates END + END MarkLocals; + + PROCEDURE MarkFinObj; + VAR f: FList; + BEGIN + wouldFinalize := FALSE; + f := finalizers; + WHILE f # NIL DO + IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END; + Mark(f.blk); + f := f.next + END; + f := hotFinalizers; + WHILE f # NIL DO IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END; + Mark(f.blk); + f := f.next + END + END MarkFinObj; + + PROCEDURE CheckFinalizers; + VAR f, g, h, k: FList; + BEGIN + f := finalizers; g := NIL; + IF hotFinalizers = NIL THEN k := NIL + ELSE + k := hotFinalizers; + WHILE k.next # NIL DO k := k.next END + END; + WHILE f # NIL DO + h := f; f := f.next; + IF ~ODD(S.VAL(INTEGER, h.blk.tag)) THEN + IF g = NIL THEN finalizers := f ELSE g.next := f END; + IF k = NIL THEN hotFinalizers := h ELSE k.next := h END; + k := h; h.next := NIL + ELSE g := h + END + END; + h := hotFinalizers; + WHILE h # NIL DO Mark(h.blk); h := h.next END + END CheckFinalizers; + + PROCEDURE ExecFinalizer (a, b, c: INTEGER); + VAR f: FList; fin: PROCEDURE(this: ANYPTR); + BEGIN + f := S.VAL(FList, a); + S.GET(S.VAL(INTEGER, f.blk.tag) - 4, fin); (* method 0 *) + IF (fin # NIL) & (f.blk.tag.mod.refcnt >= 0) THEN fin(S.VAL(ANYPTR, S.ADR(f.blk.last))) END; + END ExecFinalizer; + + PROCEDURE^ Try* (h: TryHandler; a, b, c: INTEGER); (* COMPILER DEPENDENT *) + + PROCEDURE CallFinalizers; + VAR f: FList; + BEGIN + WHILE hotFinalizers # NIL DO + f := hotFinalizers; hotFinalizers := hotFinalizers.next; + Try(ExecFinalizer, S.VAL(INTEGER, f), 0, 0) + END; + wouldFinalize := FALSE + END CallFinalizers; + + PROCEDURE Insert (blk: FreeBlock; size: INTEGER); (* insert block in free list *) + VAR i: INTEGER; + BEGIN + blk.size := size - 4; blk.tag := S.VAL(Type, S.ADR(blk.size)); + i := MIN(N - 1, (blk.size DIV 16)); + blk.next := free[i]; free[i] := blk + END Insert; + + PROCEDURE Sweep (dealloc: BOOLEAN); + VAR cluster, last, c: Cluster; blk, next: Block; fblk, b, t: FreeBlock; end, i: INTEGER; + BEGIN + cluster := root; last := NIL; allocated := 0; + i := N; + REPEAT DEC(i); free[i] := sentinel UNTIL i = 0; + WHILE cluster # NIL DO + blk := S.VAL(Block, S.VAL(INTEGER, cluster) + 12); + end := S.VAL(INTEGER, blk) + (cluster.size - 12) DIV 16 * 16; + fblk := NIL; + WHILE S.VAL(INTEGER, blk) < end DO + next := Next(blk); + IF ODD(S.VAL(INTEGER, blk.tag)) THEN + IF fblk # NIL THEN + Insert(fblk, S.VAL(INTEGER, blk) - S.VAL(INTEGER, fblk)); + fblk := NIL + END; + DEC(S.VAL(INTEGER, blk.tag)); (* unmark *) + INC(allocated, S.VAL(INTEGER, next) - S.VAL(INTEGER, blk)) + ELSIF fblk = NIL THEN + fblk := S.VAL(FreeBlock, blk) + END; + blk := next + END; + IF dealloc & (S.VAL(INTEGER, fblk) = S.VAL(INTEGER, cluster) + 12) THEN (* deallocate cluster *) + c := cluster; cluster := cluster.next; + IF last = NIL THEN root := cluster ELSE last.next := cluster END; + FreeHeapMem(c) + ELSE + IF fblk # NIL THEN Insert(fblk, end - S.VAL(INTEGER, fblk)) END; + last := cluster; cluster := cluster.next + END + END; + (* reverse free list *) + i := N; + REPEAT + DEC(i); + b := free[i]; fblk := sentinel; + WHILE b # sentinel DO t := b; b := t.next; t.next := fblk; fblk := t END; + free[i] := fblk + UNTIL i = 0 + END Sweep; + + PROCEDURE Collect*; + BEGIN + IF root # NIL THEN + CallFinalizers; (* trap cleanup *) + MarkGlobals; + MarkLocals; + CheckFinalizers; + Sweep(TRUE); + CallFinalizers + END + END Collect; + + PROCEDURE FastCollect*; + BEGIN + IF root # NIL THEN + MarkGlobals; + MarkLocals; + MarkFinObj; + Sweep(FALSE) + END + END FastCollect; + + PROCEDURE WouldFinalize* (): BOOLEAN; + BEGIN + RETURN wouldFinalize + END WouldFinalize; + + (* --------------------- memory allocation (portable) -------------------- *) + + PROCEDURE OldBlock (size: INTEGER): FreeBlock; (* size MOD 16 = 0 *) + VAR b, l: FreeBlock; s, i: INTEGER; + BEGIN + s := size - 4; + i := MIN(N - 1, s DIV 16); + WHILE (i # N - 1) & (free[i] = sentinel) DO INC(i) END; + b := free[i]; l := NIL; + WHILE b.size < s DO l := b; b := b.next END; + IF b # sentinel THEN + IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END + ELSE b := NIL + END; + RETURN b + END OldBlock; + + PROCEDURE LastBlock (limit: INTEGER): FreeBlock; (* size MOD 16 = 0 *) + VAR b, l: FreeBlock; s, i: INTEGER; + BEGIN + s := limit - 4; + i := 0; + REPEAT + b := free[i]; l := NIL; + WHILE (b # sentinel) & (S.VAL(INTEGER, b) + b.size # s) DO l := b; b := b.next END; + IF b # sentinel THEN + IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END + ELSE b := NIL + END; + INC(i) + UNTIL (b # NIL) OR (i = N); + RETURN b + END LastBlock; + + PROCEDURE NewBlock (size: INTEGER): Block; + VAR tsize, a, s: INTEGER; b: FreeBlock; new, c: Cluster; r: Reducer; + BEGIN + ASSERT(size >= 0, 20); + IF size > MAX(INTEGER) - 19 THEN RETURN NIL END; + tsize := (size + 19) DIV 16 * 16; + b := OldBlock(tsize); (* 1) search for free block *) + IF b = NIL THEN + FastCollect; b := OldBlock(tsize); (* 2) collect *) + IF b = NIL THEN + Collect; b := OldBlock(tsize); (* 2a) fully collect *) + END; + IF b = NIL THEN + AllocHeapMem(tsize + 12, new); (* 3) allocate new cluster *) + IF new # NIL THEN + IF (root = NIL) OR (S.VAL(INTEGER, new) < S.VAL(INTEGER, root)) THEN + new.next := root; root := new + ELSE + c := root; + WHILE (c.next # NIL) & (S.VAL(INTEGER, new) > S.VAL(INTEGER, c.next)) DO c := c.next END; + new.next := c.next; c.next := new + END; + b := S.VAL(FreeBlock, S.VAL(INTEGER, new) + 12); + b.size := (new.size - 12) DIV 16 * 16 - 4 + ELSE + RETURN NIL (* 4) give up *) + END + END + END; + (* b # NIL *) + a := b.size + 4 - tsize; + IF a > 0 THEN Insert(S.VAL(FreeBlock, S.VAL(INTEGER, b) + tsize), a) END; + IF size > 0 THEN Erase(S.ADR(b.size), (size + 3) DIV 4) END; + INC(allocated, tsize); + RETURN S.VAL(Block, b) + END NewBlock; + + PROCEDURE Allocated* (): INTEGER; + BEGIN + RETURN allocated + END Allocated; + + PROCEDURE Used* (): INTEGER; + BEGIN + RETURN used + END Used; + + PROCEDURE Root* (): INTEGER; + BEGIN + RETURN S.VAL(INTEGER, root) + END Root; + + (* -------------------- Trap Handling --------------------- *) + + PROCEDURE [code] GetDLink (): DLink "(Kernel_DLink)SYSTEM_dlink"; + PROCEDURE [code] SetDLink (dl: DLink) "SYSTEM_dlink = (SYSTEM_DLINK*)dl"; + + PROCEDURE Start* (code: Command); + VAR res: setjmp.int; dl: DLink; + BEGIN + restart := code; + baseStack := S.ADR(code); (* XXX: expected that target uses one stack *) + startDLink := GetDLink(); + res := setjmp.sigsetjmp(startEnv, 1); + restart + END Start; + + PROCEDURE Quit* (exitCode: INTEGER); + VAR m: Module; term: Command; t: BOOLEAN; + BEGIN + trapViewer := NIL; trapChecker := NIL; restart := NIL; + t := terminating; terminating := TRUE; m := modList; + WHILE m # NIL DO (* call terminators *) + IF ~static OR ~t THEN + term := m.term; m.term := NIL; + IF term # NIL THEN term() END + END; + m := m.next + END; + CallFinalizers; + hotFinalizers := finalizers; finalizers := NIL; + CallFinalizers; + stdlib.exit(exitCode) + END Quit; + + PROCEDURE FatalError* (id: INTEGER; str: ARRAY OF CHAR); + VAR res: stdio.int; title: ARRAY 16 OF CHAR; text: ARRAY 256 OF SHORTCHAR; + BEGIN + title := "Error xy"; + title[6] := CHR(id DIV 10 + ORD("0")); + title[7] := CHR(id MOD 10 + ORD("0")); + res := unistd.write(2, S.ADR(title), 8); + stdlib.abort + END FatalError; + + PROCEDURE DefaultTrapViewer; + VAR out: ARRAY 256 OF SHORTCHAR; c, len: INTEGER; res: unistd.int; dl: DLink; + + PROCEDURE WriteString (IN s: ARRAY OF SHORTCHAR); + VAR i: INTEGER; + BEGIN + i := 0; + WHILE (len < LEN(out) - 1) & (s[i] # 0X) DO out[len] := s[i]; INC(i); INC(len) END + END WriteString; + + PROCEDURE WriteHex (x, n: INTEGER); + VAR i, y: INTEGER; + BEGIN + IF len + n < LEN(out) THEN + i := len + n - 1; + WHILE i >= len DO + y := x MOD 16; x := x DIV 16; + IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END; + out[i] := SHORT(CHR(y + ORD("0"))); DEC(i) + END; + INC(len, n) + END + END WriteHex; + + PROCEDURE WriteLn; + BEGIN + IF len < LEN(out) - 1 THEN out[len] := 0AX; INC(len) END + END WriteLn; + + BEGIN + len := 0; + WriteString("====== "); + IF err = 129 THEN WriteString("invalid with") + ELSIF err = 130 THEN WriteString("invalid case") + ELSIF err = 131 THEN WriteString("function without return") + ELSIF err = 132 THEN WriteString("type guard") + ELSIF err = 133 THEN WriteString("implied type guard") + ELSIF err = 134 THEN WriteString("value out of range") + ELSIF err = 135 THEN WriteString("index out of range") + ELSIF err = 136 THEN WriteString("string too long") + ELSIF err = 137 THEN WriteString("stack overflow") + ELSIF err = 138 THEN WriteString("integer overflow") + ELSIF err = 139 THEN WriteString("division by zero") + ELSIF err = 140 THEN WriteString("infinite real result") + ELSIF err = 141 THEN WriteString("real underflow") + ELSIF err = 142 THEN WriteString("real overflow") + ELSIF err = 143 THEN WriteString("undefined real result") + ELSIF err = 144 THEN WriteString("not a number") + ELSIF err = 200 THEN WriteString("keyboard interrupt") + ELSIF err = 201 THEN WriteString("NIL dereference") + ELSIF err = 202 THEN WriteString("illegal instruction: "); + WriteHex(val, 4) + ELSIF err = 203 THEN WriteString("illegal memory read [ad = "); + WriteHex(val, 8); WriteString("]") + ELSIF err = 204 THEN WriteString("illegal memory write [ad = "); + WriteHex(val, 8); WriteString("]") + ELSIF err = 205 THEN WriteString("illegal execution [ad = "); + WriteHex(val, 8); WriteString("]") + ELSIF err = 257 THEN WriteString("out of memory") + ELSIF err = 10001H THEN WriteString("bus error") + ELSIF err = 10002H THEN WriteString("address error") + ELSIF err = 10007H THEN WriteString("fpu error") + ELSIF err < 0 THEN WriteString("exception #"); WriteHex(-err, 2) + ELSE err := err DIV 100 * 256 + err DIV 10 MOD 10 * 16 + err MOD 10; + WriteString("trap #"); WriteHex(err, 3) + END; + WriteString(" ======"); + WriteLn; + dl := GetDLink(); + (* skip Kernel.DefaultTrapViewer & Kernel.Trap/Kernel.TrapHandler *) + c := 2; + WHILE (c > 0) & (dl # NIL) DO + dl := dl.next; + DEC(c) + END; + (* stack trace *) + c := 16; + WHILE (c > 0) & (dl # NIL) DO + WriteString("- "); WriteString(dl.name$); WriteLn; + dl := dl.next; + DEC(c) + END; + out[len] := 0X; + res := unistd.write(2, S.ADR(out), len) + END DefaultTrapViewer; + + PROCEDURE TrapCleanup; + VAR t: TrapCleaner; + BEGIN + WHILE trapStack # NIL DO + t := trapStack; trapStack := trapStack.next; t.Cleanup + END; + IF (trapChecker # NIL) & (err # 128) THEN trapChecker END + END TrapCleanup; + + PROCEDURE SetTrapGuard* (on: BOOLEAN); + BEGIN + guarded := on + END SetTrapGuard; + + PROCEDURE Try* (h: TryHandler; a, b, c: INTEGER); + VAR oldIsTry: BOOLEAN; oldTryEnv: setjmp.jmp_buf; oldTryDLink: DLink; res: setjmp.int; + BEGIN + oldIsTry := isTry; oldTryEnv := tryEnv; oldTryDLink := tryDLink; + isTry := TRUE; tryDLink := GetDLink(); + res := setjmp._setjmp(tryEnv); + IF res = 0 THEN h(a, b, c) END; + isTry := oldIsTry; tryEnv := oldTryEnv; tryDLink := oldTryDLink + END Try; + + PROCEDURE Trap* (n: INTEGER); + BEGIN + IF trapped THEN + DefaultTrapViewer; + IF ~secondTrap THEN trapped := FALSE; secondTrap := TRUE END + END; + IF n >= 0 THEN err := n + ELSE err := -n + 128 + END; + pc := 0; sp := 0; fp := 0; stack := 0; val := 0; + INC(trapCount); + (* !!! InitFPU *) + TrapCleanup; + IF isTry THEN + SetDLink(tryDLink); + setjmp._longjmp(tryEnv, 1) + END; + IF err = 128 THEN (* do nothing *) + ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN + trapped := TRUE; trapViewer() + ELSE DefaultTrapViewer + END; + trapped := FALSE; secondTrap := FALSE; + IF restart # NIL THEN + SetDLink(startDLink); + setjmp.siglongjmp(startEnv, 1) + END; + stdlib.abort + END Trap; + + PROCEDURE [ccall] TrapHandler (signo: signal.int; IN _info: signal.siginfo_t; context: ADDRESS); + TYPE SigInfo = POINTER [untagged] TO signal._siginfo_t; + VAR res: signal.int; info: SigInfo; + BEGIN + info := S.VAL(SigInfo, S.ADR(_info)); (* !!! hack for CPfront *) + IF trapped THEN + DefaultTrapViewer; + IF ~secondTrap THEN trapped := FALSE; secondTrap := TRUE END + END; + err := -signo; pc := 0; sp := 0; fp := 0; stack := 0; val := 0; + CASE signo OF + | signal.SIGFPE: + pc := info.si_addr; + val := info.si_code; + CASE info.si_code OF + | signal.FPE_INTDIV: err := 139 (* division by zero *) + | signal.FPE_INTOVF: err := 138 (* integer overflow *) + | signal.FPE_FLTDIV: err := 140 (* fpu: division by zero *) + | signal.FPE_FLTOVF: err := 142 (* fpu: overflow *) + | signal.FPE_FLTUND: err := 141 (* fpu: underflow *) + (* !!! | signal.FPE_FLTRES: err := ??? (* fpu: *) *) + | signal.FPE_FLTINV: err := 143 (* val := opcode *) (* fpu: invalid op *) + (* !!! | signal.FPE_FLTSUB: err := ??? (* fpu: *) *) + ELSE (* unknown *) + END + | signal.SIGINT: + val := info.si_code; + err := 200 (* keyboard interrupt *) + | signal.SIGSEGV: + val := info.si_addr; + err := 203 (* illigal read *) + | signal.SIGBUS: + val := info.si_addr; + err := 10001H (* bus error *) + | signal.SIGILL: + pc := info.si_addr; + err := 202; (* illigal instruction *) + IF IsReadable(pc, pc + 4) THEN + S.GET(pc, val) + (* !!! err := halt code *) + END; + ELSE (* unknown *) + END; + INC(trapCount); + (* !!! InitFPU *) + TrapCleanup; + IF isTry THEN + SetDLink(tryDLink); + setjmp._longjmp(tryEnv, 1) + END; + IF err = 128 THEN (* do nothing *) + ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN + trapped := TRUE; trapViewer() + ELSE DefaultTrapViewer + END; + trapped := FALSE; secondTrap := FALSE; + IF restart # NIL THEN + SetDLink(startDLink); + setjmp.siglongjmp(startEnv, 1) + END; + stdlib.abort + END TrapHandler; + + (* -------------------- Initialization --------------------- *) + + PROCEDURE InstallTrap (signo: signal.int); + VAR act: signal._struct_sigaction; (* !!! CPfront hack *) res: signal.int; + BEGIN + act.sa_handler := NIL; + res := signal.sigemptyset(act.sa_mask); + act.sa_flags := signal.SA_NODEFER + signal.SA_SIGINFO; + act.sa_sigaction := TrapHandler; + res := signal.sigaction(signo, S.VAL(signal.struct_sigaction, act), NIL); + END InstallTrap; + + PROCEDURE InstallTrapVectors; + BEGIN + InstallTrap(signal.SIGFPE); + InstallTrap(signal.SIGINT); + InstallTrap(signal.SIGSEGV); + InstallTrap(signal.SIGBUS); + InstallTrap(signal.SIGILL) + END InstallTrapVectors; + + PROCEDURE RemoveTrapVectors; + END RemoveTrapVectors; + + PROCEDURE Init; + VAR i: INTEGER; + BEGIN + baseStack := S.ADR(i); (* XXX *) + pagesize := unistd.sysconf(unistd._SC_PAGESIZE); + + (* init heap *) + allocated := 0; total := 0; used := 0; + sentinelBlock.size := MAX(INTEGER); + sentinel := S.ADR(sentinelBlock); + i := N; + REPEAT DEC(i); free[i] := sentinel UNTIL i = 0; + + IF ~inDll THEN + InstallTrapVectors + END; + + (* !!! InitFPU *) + IF ~static THEN + InitModule(modList); + IF ~inDll THEN Quit(1) END + END + END Init; + + PROCEDURE [code] SYSTEM_argCount (): INTEGER "SYSTEM_argCount"; + PROCEDURE [code] SYSTEM_argVector (): ArrStrPtr "(Kernel_ArrStrPtr)SYSTEM_argVector"; + PROCEDURE [code] SYSTEM_modlist (): Module "(Kernel_Module)SYSTEM_modlist"; + +BEGIN + IF modList = NIL THEN (* only once *) + argc := SYSTEM_argCount(); + argv := SYSTEM_argVector(); + modList := SYSTEM_modlist(); + static := init IN modList.opts; + inDll := dll IN modList.opts; + Init + END +CLOSE + IF ~terminating THEN + terminating := TRUE; + Quit(0) + END +END Kernel. diff --git a/src/cpfront/posix/System/Mod/Math.cp b/src/cpfront/posix/System/Mod/Math.cp new file mode 100644 index 0000000..494b12a --- /dev/null +++ b/src/cpfront/posix/System/Mod/Math.cp @@ -0,0 +1,231 @@ +MODULE Math; + + IMPORT SYSTEM; + + VAR + eps, e: REAL; + + PROCEDURE [code] IncludeMATH "#include "; + PROCEDURE [code] M_PI (): REAL "M_PI"; + PROCEDURE [code] sqrt (x: REAL): REAL "sqrt(x)"; + PROCEDURE [code] exp (x: REAL): REAL "exp(x)"; + PROCEDURE [code] log (x: REAL): REAL "log(x)"; + PROCEDURE [code] log10 (x: REAL): REAL "log10(x)"; + PROCEDURE [code] pow (x, y: REAL): REAL "pow(x, y)"; + PROCEDURE [code] sin (x: REAL): REAL "sin(x)"; + PROCEDURE [code] cos (x: REAL): REAL "cos(x)"; + PROCEDURE [code] tan (x: REAL): REAL "tan(x)"; + PROCEDURE [code] asin (x: REAL): REAL "asin(x)"; + PROCEDURE [code] acos (x: REAL): REAL "acos(x)"; + PROCEDURE [code] atan (x: REAL): REAL "atan(x)"; + PROCEDURE [code] atan2 (y, x: REAL): REAL "atan2(y, x)"; + PROCEDURE [code] sinh (x: REAL): REAL "sinh(x)"; + PROCEDURE [code] cosh (x: REAL): REAL "cosh(x)"; + PROCEDURE [code] tanh (x: REAL): REAL "tanh(x)"; + PROCEDURE [code] asinh (x: REAL): REAL "asinh(x)"; + PROCEDURE [code] acosh (x: REAL): REAL "acosh(x)"; + PROCEDURE [code] atanh (x: REAL): REAL "atanh(x)"; + PROCEDURE [code] floor (x: REAL): REAL "floor(x)"; + PROCEDURE [code] ceil (x: REAL): REAL "ceil(x)"; + PROCEDURE [code] round (x: REAL): REAL "round(x)"; + PROCEDURE [code] trunc (x: REAL): REAL "trunc(x)"; + PROCEDURE [code] copysign (x, y: REAL): REAL "copysign(x, y)"; + PROCEDURE [code] frexp (x: REAL; OUT exp: INTEGER): REAL "frexp(x, exp)"; + PROCEDURE [code] ldexp (x: REAL; exp: INTEGER): REAL "ldexp(x, exp)"; + + PROCEDURE Pi* (): REAL; + BEGIN + RETURN M_PI() + END Pi; + + PROCEDURE Eps* (): REAL; + BEGIN + RETURN eps + END Eps; + + PROCEDURE Sqrt* (x: REAL): REAL; + BEGIN + RETURN sqrt(x) + END Sqrt; + + PROCEDURE Exp* (x: REAL): REAL; + BEGIN + RETURN exp(x) + END Exp; + + PROCEDURE Ln* (x: REAL): REAL; + BEGIN + RETURN log(x) + END Ln; + + PROCEDURE Log* (x: REAL): REAL; + BEGIN + RETURN log10(x) + END Log; + + PROCEDURE Power* (x, y: REAL): REAL; + BEGIN + RETURN pow(x, y) + END Power; + + PROCEDURE IntPower* (x: REAL; n: INTEGER): REAL; + VAR y: REAL; + BEGIN + IF n = MIN(INTEGER) THEN RETURN IntPower(x, n + 1) / x END; + y := 1.0; + IF n < 0 THEN x := 1.0 / x; n := -n END; + WHILE n > 0 DO + IF ODD(n) THEN y := y * x; DEC(n) + ELSE x := x * x; n := n DIV 2 + END + END; + RETURN y + END IntPower; + + PROCEDURE Sin* (x: REAL): REAL; + BEGIN + RETURN sin(x) + END Sin; + + PROCEDURE Cos* (x: REAL): REAL; + BEGIN + RETURN cos(x) + END Cos; + + PROCEDURE Tan* (x: REAL): REAL; + BEGIN + RETURN tan(x) + END Tan; + + PROCEDURE SinCos* (x: REAL; OUT s, c: REAL); + BEGIN + s := sin(x); c := cos(x) + END SinCos; + + PROCEDURE ArcSin* (x: REAL): REAL; + BEGIN + RETURN asin(x) + END ArcSin; + + PROCEDURE ArcCos* (x: REAL): REAL; + BEGIN + RETURN acos(x) + END ArcCos; + + PROCEDURE ArcTan* (x: REAL): REAL; + BEGIN + RETURN atan(x) + END ArcTan; + + PROCEDURE ArcTan2* (y, x: REAL): REAL; + BEGIN + RETURN atan2(y, x) + END ArcTan2; + + PROCEDURE Sinh* (x: REAL): REAL; + BEGIN + RETURN sinh(x) + END Sinh; + + PROCEDURE Cosh* (x: REAL): REAL; + BEGIN + RETURN cosh(x) + END Cosh; + + PROCEDURE Tanh* (x: REAL): REAL; + BEGIN + RETURN tanh(x) + END Tanh; + + PROCEDURE ArcSinh* (x: REAL): REAL; + BEGIN + RETURN asinh(x) + END ArcSinh; + + PROCEDURE ArcCosh* (x: REAL): REAL; + BEGIN + RETURN acosh(x) + END ArcCosh; + + PROCEDURE ArcTanh* (x: REAL): REAL; + BEGIN + RETURN atanh(x) + END ArcTanh; + + PROCEDURE Floor* (x: REAL): REAL; + BEGIN + RETURN floor(x) + END Floor; + + PROCEDURE Ceiling* (x: REAL): REAL; + BEGIN + RETURN ceil(x) + END Ceiling; + + PROCEDURE Round* (x: REAL): REAL; + BEGIN + RETURN round(x) + END Round; + + PROCEDURE Trunc* (x: REAL): REAL; + BEGIN + RETURN trunc(x) + END Trunc; + + PROCEDURE Frac* (x: REAL): REAL; + BEGIN + IF x >= 0 THEN RETURN x - ENTIER(x) + ELSE RETURN x + ENTIER(-x) + END + END Frac; + + PROCEDURE Mod1* (x: REAL): REAL; + BEGIN + RETURN x - ENTIER(x) + END Mod1; + + PROCEDURE Sign* (x: REAL): REAL; + BEGIN + IF x > 0 THEN RETURN 1 + ELSIF x < 0 THEN RETURN -1 + ELSE RETURN x + END + END Sign; + + PROCEDURE SignBit* (x: REAL): BOOLEAN; + BEGIN + RETURN copysign(1.0, x) > 0 + END SignBit; + + PROCEDURE CopySign* (x, y: REAL): REAL; + BEGIN + RETURN copysign(x, y) + END CopySign; + + PROCEDURE Mantissa* (x: REAL): REAL; + VAR e: INTEGER; + BEGIN + RETURN frexp(x, e); + END Mantissa; + + PROCEDURE Exponent* (x: REAL): INTEGER; + VAR m: REAL; e: INTEGER; + BEGIN + m := frexp(x, e); + RETURN e + END Exponent; + + PROCEDURE Real* (m: REAL; e: INTEGER): REAL; + BEGIN + RETURN ldexp(m, e) + END Real; + +BEGIN + eps := 1.0E+0; + e := 2.0E+0; + WHILE e > 1.0E+0 DO + eps := eps/2.0E+0; + e := 1.0E+0 + eps + END; + eps := 2.0E+0 * eps +END Math. diff --git a/src/cpfront/posix/System/Mod/SMath.cp b/src/cpfront/posix/System/Mod/SMath.cp new file mode 100644 index 0000000..796ccc1 --- /dev/null +++ b/src/cpfront/posix/System/Mod/SMath.cp @@ -0,0 +1,231 @@ +MODULE SMath; + + IMPORT SYSTEM; + + VAR + eps, e: SHORTREAL; + + PROCEDURE [code] IncludeMATH "#include "; + PROCEDURE [code] M_PI (): SHORTREAL "M_PI"; + PROCEDURE [code] sqrtf (x: SHORTREAL): SHORTREAL "sqrtf(x)"; + PROCEDURE [code] expf (x: SHORTREAL): SHORTREAL "expf(x)"; + PROCEDURE [code] logf (x: SHORTREAL): SHORTREAL "logf(x)"; + PROCEDURE [code] log10f (x: SHORTREAL): SHORTREAL "log10f(x)"; + PROCEDURE [code] powf (x, y: SHORTREAL): SHORTREAL "powf(x, y)"; + PROCEDURE [code] sinf (x: SHORTREAL): SHORTREAL "sinf(x)"; + PROCEDURE [code] cosf (x: SHORTREAL): SHORTREAL "cosf(x)"; + PROCEDURE [code] tanf (x: SHORTREAL): SHORTREAL "tanf(x)"; + PROCEDURE [code] asinf (x: SHORTREAL): SHORTREAL "asinf(x)"; + PROCEDURE [code] acosf (x: SHORTREAL): SHORTREAL "acosf(x)"; + PROCEDURE [code] atanf (x: SHORTREAL): SHORTREAL "atanf(x)"; + PROCEDURE [code] atan2f (y, x: SHORTREAL): SHORTREAL "atan2f(y, x)"; + PROCEDURE [code] sinhf (x: SHORTREAL): SHORTREAL "sinhf(x)"; + PROCEDURE [code] coshf (x: SHORTREAL): SHORTREAL "coshf(x)"; + PROCEDURE [code] tanhf (x: SHORTREAL): SHORTREAL "tanhf(x)"; + PROCEDURE [code] asinhf (x: SHORTREAL): SHORTREAL "asinhf(x)"; + PROCEDURE [code] acoshf (x: SHORTREAL): SHORTREAL "acoshf(x)"; + PROCEDURE [code] atanhf (x: SHORTREAL): SHORTREAL "atanhf(x)"; + PROCEDURE [code] floorf (x: SHORTREAL): SHORTREAL "floorf(x)"; + PROCEDURE [code] ceilf (x: SHORTREAL): SHORTREAL "ceilf(x)"; + PROCEDURE [code] roundf (x: SHORTREAL): SHORTREAL "roundf(x)"; + PROCEDURE [code] truncf (x: SHORTREAL): SHORTREAL "truncf(x)"; + PROCEDURE [code] copysignf (x, y: SHORTREAL): SHORTREAL "copysignf(x, y)"; + PROCEDURE [code] frexpf (x: SHORTREAL; OUT exp: INTEGER): SHORTREAL "frexpf(x, exp)"; + PROCEDURE [code] ldexpf (x: SHORTREAL; exp: INTEGER): SHORTREAL "ldexpf(x, exp)"; + + PROCEDURE Pi* (): SHORTREAL; + BEGIN + RETURN M_PI() + END Pi; + + PROCEDURE Eps* (): SHORTREAL; + BEGIN + RETURN eps + END Eps; + + PROCEDURE Sqrt* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN sqrtf(x) + END Sqrt; + + PROCEDURE Exp* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN expf(x) + END Exp; + + PROCEDURE Ln* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN logf(x) + END Ln; + + PROCEDURE Log* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN log10f(x) + END Log; + + PROCEDURE Power* (x, y: SHORTREAL): SHORTREAL; + BEGIN + RETURN powf(x, y) + END Power; + + PROCEDURE IntPower* (x: SHORTREAL; n: INTEGER): SHORTREAL; + VAR y: SHORTREAL; + BEGIN + IF n = MIN(INTEGER) THEN RETURN IntPower(x, n + 1) / x END; + y := 1.0; + IF n < 0 THEN x := 1.0 / x; n := -n END; + WHILE n > 0 DO + IF ODD(n) THEN y := y * x; DEC(n) + ELSE x := x * x; n := n DIV 2 + END + END; + RETURN y + END IntPower; + + PROCEDURE Sin* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN sinf(x) + END Sin; + + PROCEDURE Cos* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN cosf(x) + END Cos; + + PROCEDURE Tan* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN tanf(x) + END Tan; + + PROCEDURE SinCos* (x: SHORTREAL; OUT s, c: SHORTREAL); + BEGIN + s := sinf(x); c := cosf(x) + END SinCos; + + PROCEDURE ArcSin* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN asinf(x) + END ArcSin; + + PROCEDURE ArcCos* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN acosf(x) + END ArcCos; + + PROCEDURE ArcTan* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN atanf(x) + END ArcTan; + + PROCEDURE ArcTan2* (y, x: SHORTREAL): SHORTREAL; + BEGIN + RETURN atan2f(y, x) + END ArcTan2; + + PROCEDURE Sinh* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN sinhf(x) + END Sinh; + + PROCEDURE Cosh* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN coshf(x) + END Cosh; + + PROCEDURE Tanh* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN tanhf(x) + END Tanh; + + PROCEDURE ArcSinh* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN asinhf(x) + END ArcSinh; + + PROCEDURE ArcCosh* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN acoshf(x) + END ArcCosh; + + PROCEDURE ArcTanh* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN atanhf(x) + END ArcTanh; + + PROCEDURE Floor* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN floorf(x) + END Floor; + + PROCEDURE Ceiling* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN ceilf(x) + END Ceiling; + + PROCEDURE Round* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN roundf(x) + END Round; + + PROCEDURE Trunc* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN truncf(x) + END Trunc; + + PROCEDURE Frac* (x: SHORTREAL): SHORTREAL; + BEGIN + IF x >= 0 THEN RETURN x - ENTIER(x) + ELSE RETURN x + ENTIER(-x) + END + END Frac; + + PROCEDURE Mod1* (x: SHORTREAL): SHORTREAL; + BEGIN + RETURN x - ENTIER(x) + END Mod1; + + PROCEDURE Sign* (x: SHORTREAL): SHORTREAL; + BEGIN + IF x > 0 THEN RETURN 1 + ELSIF x < 0 THEN RETURN -1 + ELSE RETURN x + END + END Sign; + + PROCEDURE SignBit* (x: SHORTREAL): BOOLEAN; + BEGIN + RETURN copysignf(1.0, x) > 0 + END SignBit; + + PROCEDURE CopySign* (x, y: SHORTREAL): SHORTREAL; + BEGIN + RETURN copysignf(x, y) + END CopySign; + + PROCEDURE Mantissa* (x: SHORTREAL): SHORTREAL; + VAR e: INTEGER; + BEGIN + RETURN frexpf(x, e); + END Mantissa; + + PROCEDURE Exponent* (x: SHORTREAL): INTEGER; + VAR m: SHORTREAL; e: INTEGER; + BEGIN + m := frexpf(x, e); + RETURN e + END Exponent; + + PROCEDURE Real* (m: SHORTREAL; e: INTEGER): SHORTREAL; + BEGIN + RETURN ldexpf(m, e) + END Real; + +BEGIN + eps := 1.0E+0; + e := 2.0E+0; + WHILE e > 1.0E+0 DO + eps := eps/2.0E+0; + e := 1.0E+0 + eps + END; + eps := 2.0E+0 * eps +END SMath. diff --git a/src/generic/CPfront/Mod/CPC.odc b/src/generic/CPfront/Mod/CPC.odc new file mode 100644 index 0000000..e4fe990 Binary files /dev/null and b/src/generic/CPfront/Mod/CPC.odc differ diff --git a/src/generic/CPfront/Mod/CPG.odc b/src/generic/CPfront/Mod/CPG.odc new file mode 100644 index 0000000..fd732b9 Binary files /dev/null and b/src/generic/CPfront/Mod/CPG.odc differ diff --git a/src/generic/CPfront/Mod/CPV.odc b/src/generic/CPfront/Mod/CPV.odc new file mode 100644 index 0000000..0fbf6c0 Binary files /dev/null and b/src/generic/CPfront/Mod/CPV.odc differ diff --git a/src/generic/Dev/Mod/CPB.odc b/src/generic/Dev/Mod/CPB.odc new file mode 100644 index 0000000..ef98324 Binary files /dev/null and b/src/generic/Dev/Mod/CPB.odc differ diff --git a/src/generic/Dev/Mod/CPC486.odc b/src/generic/Dev/Mod/CPC486.odc new file mode 100644 index 0000000..0898cd2 Binary files /dev/null and b/src/generic/Dev/Mod/CPC486.odc differ diff --git a/src/generic/Dev/Mod/CPE.odc b/src/generic/Dev/Mod/CPE.odc new file mode 100644 index 0000000..2ac4588 Binary files /dev/null and b/src/generic/Dev/Mod/CPE.odc differ diff --git a/src/generic/Dev/Mod/CPH.odc b/src/generic/Dev/Mod/CPH.odc new file mode 100644 index 0000000..014828b Binary files /dev/null and b/src/generic/Dev/Mod/CPH.odc differ diff --git a/src/generic/Dev/Mod/CPL486.odc b/src/generic/Dev/Mod/CPL486.odc new file mode 100644 index 0000000..eca6a68 Binary files /dev/null and b/src/generic/Dev/Mod/CPL486.odc differ diff --git a/src/generic/Dev/Mod/CPM.cp b/src/generic/Dev/Mod/CPM.cp new file mode 100644 index 0000000..38cfe53 --- /dev/null +++ b/src/generic/Dev/Mod/CPM.cp @@ -0,0 +1,1194 @@ +MODULE DevCPM; + + IMPORT SYSTEM, Kernel, Files, Console, Strings; + + CONST + ProcSize* = 4; (* PROCEDURE type *) + PointerSize* = 4; (* POINTER type *) + DArrSizeA* = 8; (* dyn array descriptor *) + DArrSizeB* = 4; (* size = A + B * typ.n *) + + MaxSet* = 31; + MaxIndex* = 7FFFFFFFH; (* maximal index value for array declaration *) + + MinReal32Pat = 0FF7FFFFFH; (* most positive, 32-bit pattern *) + MinReal64PatL = 0FFFFFFFFH; (* most negative, lower 32-bit pattern *) + MinReal64PatH = 0FFEFFFFFH; (* most negative, higher 32-bit pattern *) + MaxReal32Pat = 07F7FFFFFH; (* most positive, 32-bit pattern *) + MaxReal64PatL = 0FFFFFFFFH; (* most positive, lower 32-bit pattern *) + MaxReal64PatH = 07FEFFFFFH; (* most positive, higher 32-bit pattern *) + InfRealPat = 07F800000H; (* real infinity pattern *) + + + (* inclusive range of parameter of standard procedure HALT *) + MinHaltNr* = 0; + MaxHaltNr* = 128; + + (* inclusive range of register number of procedures SYSTEM.GETREG and SYSTEM.PUTREG *) + MinRegNr* = 0; + MaxRegNr* = 31; + + (* maximal value of flag used to mark interface structures *) + MaxSysFlag* = 127; (* shortint *) + CProcFlag* = 1; (* code procedures *) + + (* maximal condition value of parameter of SYSTEM.CC *) + MaxCC* = 15; + + (* initialization of constant address, must be different from any valid constant address *) + ConstNotAlloc* = -1; + + (* whether hidden pointer fields have to be nevertheless exported *) + ExpHdPtrFld* = TRUE; + HdPtrName* = "@ptr"; + + (* whether hidden untagged pointer fields have to be nevertheless exported *) + ExpHdUtPtrFld* = TRUE; + HdUtPtrName* = "@utptr"; + + (* whether hidden procedure fields have to be nevertheless exported (may be used for System.Free) *) + ExpHdProcFld* = TRUE; + HdProcName* = "@proc"; + + (* whether hidden bound procedures have to be nevertheless exported *) + ExpHdTProc* = FALSE; + HdTProcName* = "@tproc"; + + (* maximal number of exported stuctures: *) + MaxStruct* = 16000; (* must be < MAX(INTEGER) DIV 2 in object model *) + + (* maximal number of record extensions: *) + MaxExts* = 15; (* defined by type descriptor layout *) + + (* whether field leaf of pointer variable p has to be set to FALSE, when NEW(p) or SYSTEM.NEW(p, n) is used *) + NEWusingAdr* = FALSE; + + (* special character (< " ") returned by procedure Get, if end of text reached *) + Eot* = 0X; + + (* warnings *) + longreal* = 0; largeint* = 1; realConst* = 2; copy* = 3; lchr* = 4; lentier* = 5; invar* = 6; outvar* = 7; + + (* language options *) + interface* = 1; + com* = 2; comAware* = 3; + som* = 4; somAware* = 5; + oberon* = 6; + java* = 7; javaAware* = 8; + noCode* = 9; + allSysVal* = 14; + sysImp* = 15; + trap* = 31; + sys386 = 10; sys68k = 20; (* processor type in options if system imported *) + + CONST + SFdir = "Sym"; + OFdir = "Code"; + SYSdir = "System"; + SFtag = 6F4F5346H; (* symbol file tag *) + OFtag = 6F4F4346H; (* object file tag *) + maxErrors = 64; + errFile = "Errors"; + + TYPE + Directory* = POINTER TO RECORD + path*: Files.Name; + legacy*: BOOLEAN; + next*: Directory + END; + + VAR + LEHost*: BOOLEAN; (* little or big endian host *) + MinReal32*, MaxReal32*, InfReal*, + MinReal64*, MaxReal64*: REAL; + noerr*: BOOLEAN; (* no error found until now *) + curpos*, startpos*, errpos*: INTEGER; (* character, start, and error position in source file *) + searchpos*: INTEGER; (* search position in source file *) + errors*: INTEGER; + breakpc*: INTEGER; (* set by OPV.Init *) + options*: SET; (* language options *) + file*: Files.File; (* used for sym file import *) + legacy*: BOOLEAN; (* use BlackBox subsystems *) + symList*: Directory; + codePath*: Files.Name; + symPath*: Files.Name; + codeDir*: ARRAY 16 OF CHAR; + symDir*: ARRAY 16 OF CHAR; + name*: Files.Name; (* source name *) + checksum*: INTEGER; (* symbol file checksum *) + verbose*: INTEGER; + + lastpos: INTEGER; + ObjFName: Files.Name; + + in: POINTER TO ARRAY OF CHAR; + oldSymFile, symFile, objFile: Files.File; + inSym: Files.Reader; + outSym, outObj: Files.Writer; + + errNo, errPos: ARRAY maxErrors OF INTEGER; + + crc32tab: ARRAY 256 OF INTEGER; + + + PROCEDURE^ err* (n: INTEGER); + + PROCEDURE Init* (source: POINTER TO ARRAY OF CHAR); + BEGIN + in := source; + noerr := TRUE; options := {}; + curpos := 0; errpos := curpos; lastpos := curpos - 11; errors := 0; + codePath := ""; symPath := ""; name := ""; + codeDir := OFdir; symDir := SFdir; + END Init; + + PROCEDURE Close*; + BEGIN + oldSymFile := NIL; inSym := NIL; + symFile := NIL; outSym := NIL; + objFile := NIL; outObj := NIL; + in := NIL + END Close; + + PROCEDURE Get* (VAR ch: CHAR); + BEGIN + ch := in[curpos]; INC(curpos) + END Get; + + PROCEDURE LineColOf (pos: INTEGER; OUT line, col, beg, end: INTEGER); + VAR i: INTEGER; + BEGIN + i := 0; line := 1; col := 1; beg := 0; end := 0; + WHILE i < pos DO + IF in[i] = 0DX THEN + INC(i); + IF in[i] = 0AX THEN + INC(i) + END; + INC(line); + beg := i; + col := 1 + ELSIF in[i] = 0AX THEN + INC(i); + INC(line); + beg := i; + col := 1 + ELSIF in[i] = 09X THEN + INC(i); INC(col, 2) + ELSE + INC(i); INC(col) + END; + END; + WHILE (in[i] # 0DX) & (in[i] # 0AX) & (in[i] # 0X) DO + INC(i) + END; + end := i - 1 + END LineColOf; + + PROCEDURE LineOf* (pos: INTEGER): INTEGER; + VAR line, col, beg, end: INTEGER; + BEGIN + LineColOf(pos, line, col, beg, end); + RETURN line + END LineOf; + + PROCEDURE LoWord (r: REAL): INTEGER; + VAR x: INTEGER; + BEGIN + x := SYSTEM.ADR(r); + IF ~LEHost THEN INC(x, 4) END; + SYSTEM.GET(x, x); + RETURN x + END LoWord; + + PROCEDURE HiWord (r: REAL): INTEGER; + VAR x: INTEGER; + BEGIN + x := SYSTEM.ADR(r); + IF LEHost THEN INC(x, 4) END; + SYSTEM.GET(x, x); + RETURN x + END HiWord; + + PROCEDURE Compound (lo, hi: INTEGER): REAL; + VAR r: REAL; + BEGIN + IF LEHost THEN + SYSTEM.PUT(SYSTEM.ADR(r), lo); SYSTEM.PUT(SYSTEM.ADR(r) + 4, hi) + ELSE + SYSTEM.PUT(SYSTEM.ADR(r) + 4, lo); SYSTEM.PUT(SYSTEM.ADR(r), hi) + END; + RETURN r + END Compound; + + + (* sysflag control *) + + PROCEDURE ValidGuid* (IN str: ARRAY OF SHORTCHAR): BOOLEAN; + VAR i: INTEGER; ch: SHORTCHAR; + BEGIN + IF (LEN(str$) # 38) OR (str[0] # "{") & (str[37] # "}") THEN RETURN FALSE END; + i := 1; + WHILE i < 37 DO + ch := str[i]; + IF (i = 9) OR (i = 14) OR (i = 19) OR (i = 24) THEN + IF ch # "-" THEN RETURN FALSE END + ELSE + IF (ch < "0") OR (ch > "9") & (CAP(ch) < "A") OR (CAP(ch) > "Z") THEN RETURN FALSE END + END; + INC(i) + END; + RETURN TRUE + END ValidGuid; + + PROCEDURE GetProcSysFlag* (IN id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF id # "" THEN + IF id = "code" THEN num := 1 + ELSIF id = "callback" THEN num := 2 + ELSIF id = "nostkchk" THEN num := 4 + ELSIF id = "ccall" THEN num := -10 + ELSIF id = "ccall16" THEN num := -12 + ELSIF id = "guarded" THEN num := 8 + ELSIF id = "noframe" THEN num := 16 + ELSIF id = "native" THEN num := -33 + ELSIF id = "bytecode" THEN num := -35 + END + END; + IF (options * {sysImp, sys386, sys68k} # {}) & ((num = 1) OR (num = 2)) THEN INC(flag, num) + ELSIF (sys68k IN options) & (num = 4) THEN INC(flag, num) + ELSIF (options * {sys386, interface} # {}) & (num = -10) & (flag = 0) THEN flag := -10 + ELSIF (options * {sys386, interface} # {}) & (num = -12) & (flag = 0) THEN flag := -12 + ELSIF (options * {sys386, com} # {}) & (num = 8) & (flag = 0) THEN flag := 8 + ELSIF (options * {sysImp, sys386} # {}) & (num = 16) & (flag = 0) THEN flag := 16 + ELSIF ({sysImp, java} - options = {}) & ((num= -33) OR (num = -35)) & (flag = 0) THEN flag := num + ELSE err(225); flag := 0 + END + END GetProcSysFlag; + + PROCEDURE GetVarParSysFlag* (IN id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + VAR old: SHORTINT; + BEGIN + old := flag; flag := 0; + IF (options * {sys386, sys68k, interface, com} # {}) THEN + IF (num = 1) OR (id = "nil") THEN + IF ~ODD(old) THEN flag := SHORT(old + 1) END + ELSIF ((num = 2) OR (id = "in")) & (oberon IN options) THEN + IF old <= 1 THEN flag := SHORT(old + 2) END + ELSIF ((num = 4) OR (id = "out")) & (oberon IN options) THEN + IF old <= 1 THEN flag := SHORT(old + 4) END + ELSIF ((num = 8) OR (id = "new")) & (options * {com, interface} # {}) THEN + IF old <= 1 THEN flag := SHORT(old + 8) END + ELSIF ((num = 16) OR (id = "iid")) & (com IN options) THEN + IF old <= 1 THEN flag := SHORT(old + 16) END + END + END; + IF flag = 0 THEN err(225) END + END GetVarParSysFlag; + + PROCEDURE GetRecordSysFlag* (IN id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + VAR old: SHORTINT; + BEGIN + old := flag; flag := 0; + IF (num = 1) OR (id = "untagged") THEN + IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END + ELSIF (num = 3) OR (id = "noalign") THEN + IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 3 END + ELSIF (num = 4) OR (id = "align2") THEN + IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 4 END + ELSIF (num = 5) OR (id = "align4") THEN + IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 5 END + ELSIF (num = 6) OR (id = "align8") THEN + IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 6 END + ELSIF (num = 7) OR (id = "union") THEN + IF (options * {sys386, sys68k, interface, com} # {}) & (old = 0) THEN flag := 7 END + ELSIF (num = 10) OR (id = "interface") OR ValidGuid(id) THEN + IF (com IN options) & (old = 0) THEN flag := 10 END + ELSIF (num = -11) OR (id = "jint") THEN + IF (java IN options) & (old = 0) THEN flag := -11 END + ELSIF (num = -13) OR (id = "jstr") THEN + IF (java IN options) & (old = 0) THEN flag := -13 END + ELSIF (num = 20) OR (id = "som") THEN + IF (som IN options) & (old = 0) THEN flag := 20 END + END; + IF flag = 0 THEN err(225) END + END GetRecordSysFlag; + + PROCEDURE GetArraySysFlag* (IN id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + VAR old: SHORTINT; + BEGIN + old := flag; flag := 0; + IF (num = 1) OR (id = "untagged") THEN + IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END + ELSIF (num = -12) OR (id = "jarr") THEN + IF (java IN options) & (old = 0) THEN flag := -12 END + ELSIF (num = -13) OR (id = "jstr") THEN + IF (java IN options) & (old = 0) THEN flag := -13 END + END; + IF flag = 0 THEN err(225) END + END GetArraySysFlag; + + PROCEDURE GetPointerSysFlag* (IN id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + VAR old: SHORTINT; + BEGIN + old := flag; flag := 0; + IF (num = 1) OR (id = "untagged") THEN + IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END + ELSIF (num = 2) OR (id = "handle") THEN + IF (sys68k IN options) & (old = 0) THEN flag := 2 END + ELSIF (num = 10) OR (id = "interface") THEN + IF (com IN options) & (old = 0) THEN flag := 10 END + ELSIF (num = 20) OR (id = "som") THEN + IF (som IN options) & (old = 0) THEN flag := 20 END + END; + IF flag = 0 THEN err(225) END + END GetPointerSysFlag; + + PROCEDURE GetProcTypSysFlag* (IN id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF ((num = -10) OR (id = "ccall")) & (options * {sys386, interface} # {}) THEN flag := -10 + ELSIF ((num = -12) OR (id = "ccall16")) & (options * {sys386, interface} # {}) THEN flag := -12 + ELSE err(225); flag := 0 + END + END GetProcTypSysFlag; + + PROCEDURE PropagateRecordSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN (* propagate untagged .. union *) + IF flag = 0 THEN flag := baseFlag + ELSIF (flag = 6) & (baseFlag < 6) THEN (* OK *) (* special case for 8 byte aligned records *) + ELSIF flag # baseFlag THEN err(225); flag := 0 + END + ELSIF (baseFlag # 10) & (flag = 10) THEN err(225) + END + END PropagateRecordSysFlag; + + PROCEDURE PropagateRecPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN (* pointer to untagged .. union is untagged *) + IF flag = 0 THEN flag := 1 + ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0 + END + ELSIF baseFlag = 10 THEN (* pointer to interface is interface *) + IF flag = 0 THEN flag := 10 + ELSIF flag # 10 THEN err(225); flag := 0 + END + ELSIF baseFlag = -11 THEN (* pointer to java interface is java interface *) + IF flag # 0 THEN err(225) END; + flag := -11 + ELSIF baseFlag = -13 THEN (* pointer to java string is java string *) + IF flag # 0 THEN err(225) END; + flag := -13 + END + END PropagateRecPtrSysFlag; + + PROCEDURE PropagateArrPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF baseFlag = 1 THEN (* pointer to untagged or guid is untagged *) + IF flag = 0 THEN flag := 1 + ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0 + END + ELSIF baseFlag = -12 THEN (* pointer to java array is java array *) + IF flag # 0 THEN err(225) END; + flag := -12 + ELSIF baseFlag = -13 THEN (* pointer to java string is java string *) + IF flag # 0 THEN err(225) END; + flag := -13 + END + END PropagateArrPtrSysFlag; + + + (* utf8 strings *) + + PROCEDURE PutUtf8* (VAR str: ARRAY OF SHORTCHAR; val: INTEGER; VAR idx: INTEGER); + BEGIN + ASSERT((val >= 0) & (val < 65536)); + IF val < 128 THEN + str[idx] := SHORT(CHR(val)); INC(idx) + ELSIF val < 2048 THEN + str[idx] := SHORT(CHR(val DIV 64 + 192)); INC(idx); + str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx) + ELSE + str[idx] := SHORT(CHR(val DIV 4096 + 224)); INC(idx); + str[idx] := SHORT(CHR(val DIV 64 MOD 64 + 128)); INC(idx); + str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx) + END + END PutUtf8; + + PROCEDURE GetUtf8* (IN str: ARRAY OF SHORTCHAR; VAR val, idx: INTEGER); + VAR ch: SHORTCHAR; + BEGIN + ch := str[idx]; INC(idx); + IF ch < 80X THEN + val := ORD(ch) + ELSIF ch < 0E0X THEN + val := ORD(ch) - 192; + ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128 + ELSE + val := ORD(ch) - 224; + ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128; + ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128 + END + END GetUtf8; + + + (* log output *) + + PROCEDURE LogW* (ch: CHAR); + BEGIN + Console.WriteChar(ch) + END LogW; + + PROCEDURE LogWStr* (IN s: ARRAY OF CHAR); + BEGIN + Console.WriteStr(s) + END LogWStr; + + PROCEDURE LogWPar* (IN key: ARRAY OF CHAR; IN p0, p1: ARRAY OF SHORTCHAR); + VAR s, s0, s1: ARRAY 256 OF CHAR; i, res: INTEGER; + BEGIN + Kernel.Utf8ToString(p0, s0, res); + Kernel.Utf8ToString(p1, s1, res); + IF key = "#Dev:NotImplementedIn" THEN s := "^0 not implemented in ^1" + ELSIF key = "#Dev:NotImplemented" THEN s := "^0 not implemented" + ELSIF key = "#Dev:InconsistentImport" THEN s := "^0.^1 is not consistently imported" + ELSIF key = "#Dev:ChangedLibFlag" THEN s := "changed library flag" + ELSIF key = "#Dev:IsNoLongerInSymFile" THEN s := "^0 is no longer in symbol file" + ELSIF key = "#Dev:IsRedefinedInternally" THEN s := "^0 is redefined internally" + ELSIF key = "#Dev:IsRedefined" THEN s := "^0 is redefined" + ELSIF key = "#Dev:IsNewInSymFile" THEN s := "^0 is new in symbol file" + ELSIF key = "#Dev:NewSymFile" THEN s := "new symbol file" + ELSE s := key$ + END; + i := 0; + WHILE s[i] # 0X DO + IF s[i] = "^" THEN + CASE s[i + 1] OF + | "0": Console.WriteStr(s0) + | "1": Console.WriteStr(s1) + | "2": (* skip *) + ELSE Console.WriteChar("^") + END; + INC(i, 2) + ELSE + Console.WriteChar(s[i]); + INC(i) + END + END + END LogWPar; + + PROCEDURE LogWNum* (i, len: INTEGER); + VAR s: ARRAY 32 OF CHAR; + BEGIN + Strings.IntToStringForm(i, 10, len, " ", FALSE, s); + Console.WriteStr(s) + END LogWNum; + + PROCEDURE LogWLn*; + BEGIN + Console.WriteLn + END LogWLn; + + PROCEDURE Mark* (n, pos: INTEGER); + BEGIN + IF (n >= 0) & ~((oberon IN options) & (n >= 181) & (n <= 190)) THEN + noerr := FALSE; + IF pos < 0 THEN pos := 0 END; + IF (pos < lastpos) OR (lastpos + 9 < pos) THEN + lastpos := pos; + IF errors < maxErrors THEN + errNo[errors] := n; errPos[errors] := pos + END; + INC(errors) + END; + IF trap IN options THEN HALT(100) END; + ELSIF (n <= -700) & (errors < maxErrors) THEN + errNo[errors] := -n; errPos[errors] := pos; INC(errors) + END + END Mark; + + PROCEDURE err* (n: INTEGER); + BEGIN + Mark(n, errpos) + END err; + + PROCEDURE GetErrorMsg (err: INTEGER; OUT msg: ARRAY OF CHAR); + BEGIN + CASE err OF + | 0: msg := 'undeclared identifier' + | 1: msg := 'multiply defined identifier' + | 2: msg := 'illegal character in number' + | 3: msg := 'illegal character in string' + | 4: msg := 'identifier does not match procedure name' + | 5: msg := 'comment not closed' + | 9: msg := '"=" expected' + | 12: msg := 'type definition starts with incorrect symbol' + | 13: msg := 'factor starts with incorrect symbol' + | 14: msg := 'statement starts with incorrect symbol' + | 15: msg := 'declaration followed by incorrect symbol' + | 16: msg := 'MODULE expected' + | 19: msg := '"." missing' + | 20: msg := '"," missing' + | 21: msg := '":" missing' + | 23: msg := '")" missing' + | 24: msg := '"]" missing' + | 25: msg := '"}" missing' + | 26: msg := 'OF missing' + | 27: msg := 'THEN missing' + | 28: msg := 'DO missing' + | 29: msg := 'TO missing' + | 35: msg := '"," or OF expected' + | 36: msg := 'CONST, TYPE, VAR, PROCEDURE, BEGIN, or END missing' + | 37: msg := 'PROCEDURE, BEGIN, or END missing' + | 38: msg := 'BEGIN or END missing' + | 40: msg := '"(" missing' + | 41: msg := 'illegally marked identifier' + | 42: msg := 'constant not an integer' + | 43: msg := 'UNTIL missing' + | 44: msg := '":=" missing' + | 46: msg := 'EXIT not within loop statement' + | 47: msg := 'string expected' + | 48: msg := 'identifier expected' + | 49: msg := '";" missing' + | 50: msg := 'expression should be constant' + | 51: msg := 'END missing' + | 52: msg := 'identifier does not denote a type' + | 53: msg := 'identifier does not denote a record type' + | 54: msg := 'result type of procedure is not a basic type' + | 55: msg := 'procedure call of a function' + | 56: msg := 'assignment to non-variable' + | 57: msg := 'pointer not bound to record or array type' + | 58: msg := 'recursive type definition' + | 59: msg := 'illegal open array parameter' + | 60: msg := 'wrong type of case label' + | 61: msg := 'inadmissible type of case label' + | 62: msg := 'case label defined more than once' + | 63: msg := 'illegal value of constant' + | 64: msg := 'more actual than formal parameters' + | 65: msg := 'fewer actual than formal parameters' + | 66: msg := 'element types of actual array and formal open array differ' + | 67: msg := 'actual parameter corresponding to open array is not an array' + | 68: msg := 'control variable must be integer' + | 69: msg := 'parameter must be an integer constant' + | 70: msg := 'pointer or VAR / IN record required as formal receiver' + | 71: msg := 'pointer expected as actual receiver' + | 72: msg := 'procedure must be bound to a record of the same scope' + | 73: msg := 'procedure must have level 0' + | 74: msg := 'procedure unknown in base type' + | 75: msg := 'invalid call of base procedure' + | 76: msg := 'this variable (field) is read only' + | 77: msg := 'object is not a record' + | 78: msg := 'dereferenced object is not a variable' + | 79: msg := 'indexed object is not a variable' + | 80: msg := 'index expression is not an integer' + | 81: msg := 'index out of specified bounds' + | 82: msg := 'indexed variable is not an array' + | 83: msg := 'undefined record field' + | 84: msg := 'dereferenced variable is not a pointer' + | 85: msg := 'guard or test type is not an extension of variable type' + | 86: msg := 'guard or testtype is not a pointer' + | 87: msg := 'guarded or tested variable is neither a pointer nor a VAR- or IN-parameter record' + | 88: msg := 'open array not allowed as variable, record field or array element' + | 89: msg := 'ANYRECORD may not be allocated' + | 90: msg := 'dereferenced variable is not a character array' + | 92: msg := 'operand of IN not an integer, or not a set' + | 93: msg := 'set element type is not an integer' + | 94: msg := 'operand of & is not of type BOOLEAN' + | 95: msg := 'operand of OR is not of type BOOLEAN' + | 96: msg := 'operand not applicable to (unary) +' + | 97: msg := 'operand not applicable to (unary) -' + | 98: msg := 'operand of ~ is not of type BOOLEAN' + | 99: msg := 'ASSERT fault' + | 100: msg := 'incompatible operands of dyadic operator' + | 101: msg := 'operand type inapplicable to *' + | 102: msg := 'operand type inapplicable to /' + | 103: msg := 'operand type inapplicable to DIV' + | 104: msg := 'operand type inapplicable to MOD' + | 105: msg := 'operand type inapplicable to +' + | 106: msg := 'operand type inapplicable to -' + | 107: msg := 'operand type inapplicable to = or #' + | 108: msg := 'operand type inapplicable to relation' + | 109: msg := 'overriding method must be exported' + | 110: msg := 'operand is not a type' + | 111: msg := 'operand inapplicable to (this) function' + | 112: msg := 'operand is not a variable' + | 113: msg := 'incompatible assignment' + | 114: msg := 'string too long to be assigned' + | 115: msg := 'parameter does not match' + | 116: msg := 'number of parameters does not match' + | 117: msg := 'result type does not match' + | 118: msg := 'export mark does not match with forward declaration' + | 119: msg := 'redefinition textually precedes procedure bound to base type' + | 120: msg := 'type of expression following IF, WHILE, UNTIL or ASSERT is not BOOLEAN' + | 121: msg := 'called object is not a procedure' + | 122: msg := 'actual VAR-, IN-, or OUT-parameter is not a variable' + | 123: msg := 'type is not identical with that of formal VAR-, IN-, or OUT-parameter' + | 124: msg := 'type of result expression differs from that of procedure' + | 125: msg := 'type of case expression is neither INTEGER nor CHAR' + | 126: msg := 'this expression cannot be a type or a procedure' + | 127: msg := 'illegal use of object' + | 128: msg := 'unsatisfied forward reference' + | 129: msg := 'unsatisfied forward procedure' + | 130: msg := 'WITH clause does not specify a variable' + | 131: msg := 'LEN not applied to array' + | 132: msg := 'dimension in LEN too large or negative' + | 133: msg := 'function without RETURN' + | 135: msg := 'SYSTEM not imported' + | 136: msg := 'LEN applied to untagged array' + | 137: msg := 'unknown array length' + | 138: msg := 'NEW not allowed for untagged structures' + | 139: msg := 'Test applied to untagged record' + | 140: msg := 'untagged receiver' + | 141: msg := 'SYSTEM.NEW not implemented' + | 142: msg := 'tagged structures not allowed for NIL compatible var parameters' + | 143: msg := 'tagged pointer not allowed in untagged structure' + | 144: msg := 'no pointers allowed in BYTES argument' + | 145: msg := 'untagged open array not allowed as value parameter' + | 150: msg := 'key inconsistency of imported module' + | 151: msg := 'incorrect symbol file' + | 152: msg := 'symbol file of imported module not found' + | 153: msg := 'object or symbol file not opened (disk full?)' + | 154: msg := 'recursive import not allowed' + | 155: msg := 'generation of new symbol file not allowed' + | 160: msg := 'interfaces must be extensions of IUnknown' + | 161: msg := 'interfaces must not have fields' + | 162: msg := 'interface procedures must be abstract' + | 163: msg := 'interface records must be abstract' + | 164: msg := 'pointer must be extension of queried interface type' + | 165: msg := 'illegal guid constant' + | 166: msg := 'AddRef & Release may not be used' + | 167: msg := 'illegal assignment to [new] parameter' + | 168: msg := 'wrong [iid] - [new] pair' + | 169: msg := 'must be an interface pointer' + | 177: msg := 'IN only allowed for records and arrays' + | 178: msg := 'illegal attribute' + | 179: msg := 'abstract methods of exported records must be exported' + | 180: msg := 'illegal receiver type' + | 181: msg := 'base type is not extensible' + | 182: msg := 'base procedure is not extensible' + | 183: msg := 'non-matching export' + | 184: msg := 'Attribute does not match with forward declaration' + | 185: msg := 'missing NEW attribute' + | 186: msg := 'illegal NEW attribute' + | 187: msg := 'new empty procedure in non extensible record' + | 188: msg := 'extensible procedure in non extensible record' + | 189: msg := 'illegal attribute change' + | 190: msg := 'record must be abstract' + | 191: msg := 'base type must be abstract' + | 192: msg := 'unimplemented abstract procedures in base types' + | 193: msg := 'abstract or limited records may not be allocated' + | 194: msg := 'no supercall allowed to abstract or empty procedures' + | 195: msg := 'empty procedures may not have out parameters or return a value' + | 196: msg := 'procedure is implement-only exported' + | 197: msg := 'extension of limited type must be limited' + | 198: msg := 'obsolete oberon type' + | 199: msg := 'obsolete oberon function' + | 200: msg := 'not yet implemented' + | 201: msg := 'lower bound of set range greater than higher bound' + | 202: msg := 'set element greater than MAX(SET) or less than 0' + | 203: msg := 'number too large' + | 204: msg := 'product too large' + | 205: msg := 'division by zero' + | 206: msg := 'sum too large' + | 207: msg := 'difference too large' + | 208: msg := 'overflow in arithmetic shift' + | 209: msg := 'case range too large' + | 210: msg := 'code too long' + | 211: msg := 'jump distance too large' + | 212: msg := 'illegal real operation' + | 213: msg := 'too many cases in case statement' + | 214: msg := 'structure too large' + | 215: msg := 'not enough registers: simplify expression' + | 216: msg := 'not enough floating-point registers: simplify expression' + | 217: msg := 'unimplemented SYSTEM function' + | 218: msg := 'illegal value of parameter (0 <= p < 128)' + | 219: msg := 'illegal value of parameter (0 <= p < 16)' + | 220: msg := 'illegal value of parameter' + | 221: msg := 'too many pointers in a record' + | 222: msg := 'too many global pointers' + | 223: msg := 'too many record types' + | 224: msg := 'too many pointer types' + | 225: msg := 'illegal sys flag' + | 226: msg := 'too many exported procedures' + | 227: msg := 'too many imported modules' + | 228: msg := 'too many exported structures' + | 229: msg := 'too many nested records for import' + | 230: msg := 'too many constants (strings) in module' + | 231: msg := 'too many link table entries (external procedures)' + | 232: msg := 'too many commands in module' + | 233: msg := 'record extension hierarchy too high' + | 235: msg := 'too many modifiers ' + | 240: msg := 'identifier too long' + | 241: msg := 'string too long' + | 242: msg := 'too many meta names' + | 243: msg := 'too many imported variables' + | 249: msg := 'inconsistent import' + | 250: msg := 'code proc must not be exported' + | 251: msg := 'too many nested function calls' + | 254: msg := 'debug position not found' + | 255: msg := 'debug position' + | 260: msg := 'illegal LONGINT operation' + | 261: msg := 'unsupported mode or size of second argument of SYSTEM.VAL' + | 265: msg := 'unsupported string operation' + | 270: msg := 'interface pointer reference counting restriction violated' + | 301: msg := 'implicit type cast' + | 302: msg := 'guarded variable can be side-effected' + | 303: msg := 'open array (or pointer to array) containing pointers' + | 900: msg := 'never used' + | 901: msg := 'never set' + | 902: msg := 'used before set' + | 903: msg := 'set but never used' + | 904: msg := 'used as varpar, possibly not set' + | 905: msg := 'also declared in outer scope' + | 906: msg := 'access/assignment to intermediate' + | 907: msg := 'redefinition' + | 908: msg := 'new definition' + | 909: msg := 'statement after RETURN/EXIT' + | 910: msg := 'for loop variable set' + | 911: msg := 'implied type guard' + | 912: msg := 'superfluous type guard' + | 913: msg := 'call might depend on evaluation sequence of params.' + | 930: msg := 'superfluous semicolon' + | 401: msg := 'bytecode restriction: no structured assignment' + | 402: msg := 'bytecode restriction: no procedure types' + | 403: msg := 'bytecode restriction: no nested procedures' + | 404: msg := 'bytecode restriction: illegal SYSTEM function' + | 410: msg := 'variable may not have been assigned' + | 411: msg := 'no proofable return' + | 412: msg := 'illegal constructor call' + | 413: msg := 'missing constructor call' + ELSE Strings.IntToString(err, msg) + END + END GetErrorMsg; + + PROCEDURE InsertMarks*; + VAR i, j, x, y, n, line, col, beg, end: INTEGER; s: ARRAY 128 OF CHAR; + BEGIN + n := errors; + IF n > maxErrors THEN n := maxErrors END; + (* sort *) + i := 1; + WHILE i < n DO + x := errPos[i]; y := errNo[i]; j := i-1; + WHILE (j >= 0) & (errPos[j] < x) DO + errPos[j+1] := errPos[j]; + errNo[j+1] := errNo[j]; + DEC(j) + END; + errPos[j+1] := x; errNo[j+1] := y; INC(i) + END; + (* insert *) + IF n > 0 THEN + WHILE n > 0 DO DEC(n); + LineColOf(errPos[n], line, col, beg, end); + IF name = "" THEN Console.WriteStr("???") + ELSE Console.WriteStr(name) + END; + Console.WriteChar(":"); + Strings.IntToString(line, s); Console.WriteStr(s); + Console.WriteChar(":"); + Strings.IntToString(col, s); Console.WriteStr(s); + Console.WriteChar(":"); + Strings.IntToString(errPos[n], s); Console.WriteStr(s); + Console.WriteStr(": "); + GetErrorMsg(errNo[n], s); + Console.WriteStr(s); + Console.WriteLn; + Console.WriteStr(" "); + FOR i := beg TO end DO + IF in[i] = 09X THEN Console.WriteStr(" ") + ELSE Console.WriteChar(in[i]) + END + END; + Console.WriteLn; + Console.WriteStr(" "); + FOR i := 1 TO col - 2 DO + Console.WriteChar(" ") + END; + Console.WriteChar("^"); + Console.WriteLn; + Console.WriteLn + END; + END + END InsertMarks; + + + (* fingerprinting *) + + PROCEDURE InitCrcTab; + (* CRC32, high bit first, pre & post inverted *) + CONST poly = {0, 1, 2, 4, 5, 7, 8, 10, 11, 12, 16, 22, 23, 26}; (* CRC32 polynom *) + VAR x, c, i: INTEGER; + BEGIN + x := 0; + WHILE x < 256 DO + c := x * 1000000H; i := 0; + WHILE i < 8 DO + IF c < 0 THEN c := ORD(BITS(c * 2) / poly) + ELSE c := c * 2 + END; + INC(i) + END; + crc32tab[ORD(BITS(x) / BITS(255))] := ORD(BITS(c) / BITS(255)); + INC(x) + END + END InitCrcTab; + + PROCEDURE FPrint* (VAR fp: INTEGER; val: INTEGER); + VAR c: INTEGER; + BEGIN +(* + fp := SYSTEM.ROT(ORD(BITS(fp) / BITS(val)), 1) (* bad collision detection *) +*) + (* CRC32, high bit first, pre & post inverted *) + c := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val DIV 1000000H)) MOD 256])); + c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 10000H)) MOD 256])); + c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 100H)) MOD 256])); + fp := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val)) MOD 256])); + END FPrint; + + PROCEDURE FPrintSet* (VAR fp: INTEGER; set: SET); + BEGIN FPrint(fp, ORD(set)) + END FPrintSet; + + PROCEDURE FPrintReal* (VAR fp: INTEGER; real: SHORTREAL); + BEGIN FPrint(fp, SYSTEM.VAL(INTEGER, real)) + END FPrintReal; + + PROCEDURE FPrintLReal* (VAR fp: INTEGER; lr: REAL); + BEGIN + FPrint(fp, LoWord(lr)); FPrint(fp, HiWord(lr)) + END FPrintLReal; + + PROCEDURE ChkSum (VAR fp: INTEGER; val: INTEGER); (* symbolfile checksum *) + BEGIN + (* same as FPrint, 8 bit only *) + fp := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val)) MOD 256])) + END ChkSum; + + + + (* compact format *) + + PROCEDURE WriteLInt (w: Files.Writer; i: INTEGER); + BEGIN + ChkSum(checksum, i); + w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256; + ChkSum(checksum, i); + w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256; + ChkSum(checksum, i); + w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256; + ChkSum(checksum, i); + w.WriteByte(SHORT(SHORT(i MOD 256))) + END WriteLInt; + + PROCEDURE ReadLInt (r: Files.Reader; VAR i: INTEGER); + VAR b: BYTE; x: INTEGER; + BEGIN + r.ReadByte(b); x := b MOD 256; + ChkSum(checksum, b); + r.ReadByte(b); x := x + 100H * (b MOD 256); + ChkSum(checksum, b); + r.ReadByte(b); x := x + 10000H * (b MOD 256); + ChkSum(checksum, b); + r.ReadByte(b); i := x + 1000000H * b; + ChkSum(checksum, b) + END ReadLInt; + + PROCEDURE WriteNum (w: Files.Writer; i: INTEGER); + BEGIN (* old format of Oberon *) + WHILE (i < -64) OR (i > 63) DO ChkSum(checksum, i MOD 128 - 128); w.WriteByte(SHORT(SHORT(i MOD 128 - 128))); i := i DIV 128 END; + ChkSum(checksum, i MOD 128); + w.WriteByte(SHORT(SHORT(i MOD 128))) + END WriteNum; + + PROCEDURE ReadNum (r: Files.Reader; VAR i: INTEGER); + VAR b: BYTE; s, y: INTEGER; + BEGIN + s := 0; y := 0; r.ReadByte(b); + IF ~r.eof THEN ChkSum(checksum, b) END; + WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); r.ReadByte(b); ChkSum(checksum, b) END; + i := ASH((b + 64) MOD 128 - 64, s) + y; + END ReadNum; + + PROCEDURE WriteNumSet (w: Files.Writer; x: SET); + BEGIN + WriteNum(w, ORD(x)) + END WriteNumSet; + + PROCEDURE ReadNumSet (r: Files.Reader; VAR x: SET); + VAR i: INTEGER; + BEGIN + ReadNum(r, i); x := BITS(i) + END ReadNumSet; + + PROCEDURE WriteReal (w: Files.Writer; x: SHORTREAL); + BEGIN + WriteLInt(w, SYSTEM.VAL(INTEGER, x)) + END WriteReal; + + PROCEDURE ReadReal (r: Files.Reader; VAR x: SHORTREAL); + VAR i: INTEGER; + BEGIN + ReadLInt(r, i); x := SYSTEM.VAL(SHORTREAL, i) + END ReadReal; + + PROCEDURE WriteLReal (w: Files.Writer; x: REAL); + BEGIN + WriteLInt(w, LoWord(x)); WriteLInt(w, HiWord(x)) + END WriteLReal; + + PROCEDURE ReadLReal (r: Files.Reader; VAR x: REAL); + VAR h, l: INTEGER; + BEGIN + ReadLInt(r, l); ReadLInt(r, h); x := Compound(l, h) + END ReadLReal; + + + (* read symbol file *) + + PROCEDURE SymRCh* (VAR ch: SHORTCHAR); + VAR b: BYTE; + BEGIN + inSym.ReadByte(b); ch := SHORT(CHR(b)); + ChkSum(checksum, b) + END SymRCh; + + PROCEDURE SymRInt* (): INTEGER; + VAR k: INTEGER; + BEGIN + ReadNum(inSym, k); RETURN k + END SymRInt; + + PROCEDURE SymRSet* (VAR s: SET); + BEGIN + ReadNumSet(inSym, s) + END SymRSet; + + PROCEDURE SymRReal* (VAR r: SHORTREAL); + BEGIN + ReadReal(inSym, r) + END SymRReal; + + PROCEDURE SymRLReal* (VAR lr: REAL); + BEGIN + ReadLReal(inSym, lr) + END SymRLReal; + + PROCEDURE eofSF* (): BOOLEAN; + BEGIN + RETURN inSym.eof + END eofSF; + + PROCEDURE OldSym* (IN modName: ARRAY OF SHORTCHAR; VAR done: BOOLEAN); + VAR tag: INTEGER; d: Directory; + + PROCEDURE Old (IN path: Files.Name; IN modName: ARRAY OF SHORTCHAR; legacy: BOOLEAN): Files.File; + VAR f: Files.File; res: INTEGER; loc: Files.Locator; dir, name: Files.Name; + BEGIN + Kernel.Utf8ToString(modName, name, res); + loc := Files.dir.This(path); + IF legacy THEN + Kernel.SplitName(name, dir, name); + Kernel.MakeFileName(name, Kernel.symType); + loc := loc.This(dir).This(symDir); + f := Files.dir.Old(loc, name, Files.shared); + IF (f = NIL) & (dir = "") THEN + loc := Files.dir.This(path).This(SYSdir).This(symDir); + f := Files.dir.Old(loc, name, Files.shared) + END + ELSE + Kernel.MakeFileName(name, Kernel.symType); + f := Files.dir.Old(loc, name, Files.shared) + END; + RETURN f + END Old; + + BEGIN + done := FALSE; + IF modName = "@file" THEN + oldSymFile := file + ELSE + oldSymFile := Old(symPath, modName, legacy); + d := symList; + WHILE (oldSymFile = NIL) & (d # NIL) DO + oldSymFile := Old(d.path, modName, d.legacy); + d := d.next + END + END; + IF oldSymFile # NIL THEN + inSym := oldSymFile.NewReader(inSym); + IF inSym # NIL THEN + ReadLInt(inSym, tag); + IF tag = SFtag THEN done := TRUE ELSE err(151) END + END + END + END OldSym; + + PROCEDURE CloseOldSym*; + BEGIN + IF oldSymFile # NIL THEN oldSymFile.Close; oldSymFile := NIL END + END CloseOldSym; + + + (* write symbol file *) + + PROCEDURE SymWCh* (ch: SHORTCHAR); + BEGIN + ChkSum(checksum, ORD(ch)); + outSym.WriteByte(SHORT(ORD(ch))) + END SymWCh; + + PROCEDURE SymWInt* (i: INTEGER); + BEGIN + WriteNum(outSym, i) + END SymWInt; + + PROCEDURE SymWSet* (s: SET); + BEGIN + WriteNumSet(outSym, s) + END SymWSet; + + PROCEDURE SymWReal* (r: SHORTREAL); + BEGIN + WriteReal(outSym, r) + END SymWReal; + + PROCEDURE SymWLReal* (r: REAL); + BEGIN + WriteLReal(outSym, r) + END SymWLReal; + + PROCEDURE SymReset*; + BEGIN + outSym.SetPos(4) + END SymReset; + + PROCEDURE NewSym* (IN modName: ARRAY OF SHORTCHAR); + VAR res: INTEGER; loc: Files.Locator; dir: Files.Name; + BEGIN + Kernel.Utf8ToString(modName, ObjFName, res); + loc := Files.dir.This(symPath); + IF legacy THEN + Kernel.SplitName(ObjFName, dir, ObjFName); + loc := loc.This(dir).This(symDir) + END; + symFile := Files.dir.New(loc, Files.ask); + IF symFile # NIL THEN + outSym := symFile.NewWriter(NIL); + WriteLInt(outSym, SFtag) + ELSE + err(153) + END + END NewSym; + + PROCEDURE RegisterNewSym*; + VAR res: INTEGER; name: Files.Name; + BEGIN + IF symFile # NIL THEN + name := ObjFName$; + Kernel.MakeFileName(name, Kernel.symType); + symFile.Register(name, Kernel.symType, Files.ask, res); + symFile := NIL + END + END RegisterNewSym; + + PROCEDURE DeleteNewSym*; + BEGIN + IF symFile # NIL THEN symFile.Close; symFile := NIL END + END DeleteNewSym; + + + (* write object file *) + + PROCEDURE ObjW* (ch: SHORTCHAR); + BEGIN + outObj.WriteByte(SHORT(ORD(ch))) + END ObjW; + + PROCEDURE ObjWNum* (i: INTEGER); + BEGIN + WriteNum(outObj, i) + END ObjWNum; + + PROCEDURE ObjWInt (i: SHORTINT); + BEGIN + outObj.WriteByte(SHORT(SHORT(i MOD 256))); + outObj.WriteByte(SHORT(SHORT(i DIV 256))) + END ObjWInt; + + PROCEDURE ObjWLInt* (i: INTEGER); + BEGIN + ObjWInt(SHORT(i MOD 65536)); + ObjWInt(SHORT(i DIV 65536)) + END ObjWLInt; + + PROCEDURE ObjWBytes* (IN bytes: ARRAY OF SHORTCHAR; n: INTEGER); + TYPE P = POINTER TO ARRAY [untagged] 100000H OF BYTE; + VAR p: P; + BEGIN + p := SYSTEM.VAL(P, SYSTEM.ADR(bytes)); + outObj.WriteBytes(p^, 0, n) + END ObjWBytes; + + PROCEDURE ObjLen* (): INTEGER; + BEGIN + RETURN outObj.Pos() + END ObjLen; + + PROCEDURE ObjSet* (pos: INTEGER); + BEGIN + outObj.SetPos(pos) + END ObjSet; + + PROCEDURE NewObj* (IN modName: ARRAY OF SHORTCHAR); + VAR res: INTEGER; loc: Files.Locator; dir: Files.Name; + BEGIN + errpos := 0; + Kernel.Utf8ToString(modName, ObjFName, res); + loc := Files.dir.This(codePath); + IF legacy THEN + Kernel.SplitName(ObjFName, dir, ObjFName); + loc := loc.This(dir).This(codeDir) + END; + objFile := Files.dir.New(loc, Files.ask); + IF objFile # NIL THEN + outObj := objFile.NewWriter(NIL); + WriteLInt(outObj, OFtag) + ELSE + err(153) + END + END NewObj; + + PROCEDURE RegisterObj*; + VAR res: INTEGER; name: Files.Name; + BEGIN + IF objFile # NIL THEN + name := ObjFName$; + Kernel.MakeFileName(name, Kernel.objType); + objFile.Register(name, Kernel.objType, Files.ask, res); + objFile := NIL; outObj := NIL + END + END RegisterObj; + + PROCEDURE DeleteObj*; + BEGIN + IF objFile # NIL THEN objFile.Close; objFile := NIL END + END DeleteObj; + + + PROCEDURE InitHost; + VAR test: SHORTINT; lo: SHORTCHAR; + BEGIN + test := 1; SYSTEM.GET(SYSTEM.ADR(test), lo); LEHost := lo = 1X; + InfReal := SYSTEM.VAL(SHORTREAL, InfRealPat); + MinReal32 := SYSTEM.VAL(SHORTREAL, MinReal32Pat); + MaxReal32 := SYSTEM.VAL(SHORTREAL, MaxReal32Pat); + MinReal64 := Compound(MinReal64PatL, MinReal64PatH); + MaxReal64 := Compound(MaxReal64PatL, MaxReal64PatH) + END InitHost; + +BEGIN + InitCrcTab; + InitHost +END DevCPM. diff --git a/src/generic/Dev/Mod/CPP.odc b/src/generic/Dev/Mod/CPP.odc new file mode 100644 index 0000000..16801dd Binary files /dev/null and b/src/generic/Dev/Mod/CPP.odc differ diff --git a/src/generic/Dev/Mod/CPS.odc b/src/generic/Dev/Mod/CPS.odc new file mode 100644 index 0000000..0254946 Binary files /dev/null and b/src/generic/Dev/Mod/CPS.odc differ diff --git a/src/generic/Dev/Mod/CPT.odc b/src/generic/Dev/Mod/CPT.odc new file mode 100644 index 0000000..a1aba75 Binary files /dev/null and b/src/generic/Dev/Mod/CPT.odc differ diff --git a/src/generic/Dev/Mod/CPV486.odc b/src/generic/Dev/Mod/CPV486.odc new file mode 100644 index 0000000..f9004c8 Binary files /dev/null and b/src/generic/Dev/Mod/CPV486.odc differ diff --git a/src/generic/Dev2/Mod/LnkBase.odc b/src/generic/Dev2/Mod/LnkBase.odc new file mode 100644 index 0000000..08d4814 Binary files /dev/null and b/src/generic/Dev2/Mod/LnkBase.odc differ diff --git a/src/generic/Dev2/Mod/LnkChmod.odc b/src/generic/Dev2/Mod/LnkChmod.odc new file mode 100644 index 0000000..220b6b9 Binary files /dev/null and b/src/generic/Dev2/Mod/LnkChmod.odc differ diff --git a/src/generic/Dev2/Mod/LnkLoad.odc b/src/generic/Dev2/Mod/LnkLoad.odc new file mode 100644 index 0000000..4a2f790 Binary files /dev/null and b/src/generic/Dev2/Mod/LnkLoad.odc differ diff --git a/src/generic/Dev2/Mod/LnkWriteElf.odc b/src/generic/Dev2/Mod/LnkWriteElf.odc new file mode 100644 index 0000000..2db9dea Binary files /dev/null and b/src/generic/Dev2/Mod/LnkWriteElf.odc differ diff --git a/src/generic/Dev2/Mod/LnkWriteElfStatic.odc b/src/generic/Dev2/Mod/LnkWriteElfStatic.odc new file mode 100644 index 0000000..3ca7d6d Binary files /dev/null and b/src/generic/Dev2/Mod/LnkWriteElfStatic.odc differ diff --git a/src/generic/Dev2/Mod/LnkWritePe.odc b/src/generic/Dev2/Mod/LnkWritePe.odc new file mode 100644 index 0000000..16c4dcf Binary files /dev/null and b/src/generic/Dev2/Mod/LnkWritePe.odc differ diff --git a/src/generic/Dsw/Mod/Compiler486Main.cp b/src/generic/Dsw/Mod/Compiler486Main.cp new file mode 100644 index 0000000..77ded19 --- /dev/null +++ b/src/generic/Dsw/Mod/Compiler486Main.cp @@ -0,0 +1,320 @@ +MODULE DswCompiler486Main; + + IMPORT Kernel, HostFiles, Files, Console, Strings, DswDocuments, + DevCPM, DevCPT, DevCPB, DevCPP, DevCPE, DevCPV := DevCPV486, DevCPS, + DevCPH; + + CONST + (* compiler options: *) + checks = 0; allchecks = 1; assert = 2; obj = 3; ref = 4; allref = 5; + srcpos = 6; reallib = 7; signatures = 8; + hint = 29; oberon = 30; errorTrap = 31; + defopt = {checks, assert, obj, ref, allref, srcpos, signatures}; + + emulong = 0; + defopt2 = {}; + + TYPE + Elem = POINTER TO RECORD + dir, name, path: Files.Name; + outsym, outcode: Files.Name; (* dir *) + insym: DevCPM.Directory; + found: BOOLEAN; (* COM Aware *) + opts, opts2: SET; + next: Elem + END; + + VAR + u: Elem; + + PROCEDURE GetPath (IN path: ARRAY OF CHAR; OUT dir, name: Files.Name); + VAR i, j, len: INTEGER; + BEGIN + len := LEN(path$); + i := len - 1; + WHILE (i >= 0) & (path[i] # '/') DO DEC(i) END; + IF i >= 0 THEN + FOR i := 0 TO i - 1 DO + dir[i] := path[i] + END; + dir[i] := 0X + ELSE + dir := "" + END; + j := i + 1; i := 0; + WHILE path[j] # 0X DO + name[i] := path[j]; + INC(i); INC(j) + END; + name[i] := 0X + END GetPath; + + PROCEDURE InitOptions; + VAR + i: INTEGER; + found: BOOLEAN; + insym, sym: DevCPM.Directory; + outsym, outcode: Files.Name; + p: ARRAY 256 OF CHAR; + h, t: Elem; + opts, opts2: SET; + + PROCEDURE Check; + BEGIN + IF i >= Kernel.argc THEN + Console.WriteStr("required more parameters for "); + Console.WriteStr(p); Console.WriteLn; + Kernel.Quit(1) + END + END Check; + + BEGIN + outsym := ""; outcode := ""; + opts := defopt; opts2 := defopt2; found := FALSE; + h := NIL; t := NIL; insym := NIL; + i := 1; + WHILE i < Kernel.argc DO + IF Kernel.argv[i, 0] = "-" THEN + p := Kernel.argv[i]$; + INC(i); + IF p = "-legacy" THEN + DevCPM.legacy := TRUE + ELSIF p = "-outsym" THEN + Check; + outsym := Kernel.argv[i]$; + INC(i) + ELSIF p = "-outcode" THEN + Check; + outcode := Kernel.argv[i]$; + INC(i) + ELSIF p = "-symdir" THEN + Check; + sym := insym; + NEW(insym); + insym.path := Kernel.argv[i]$; + insym.legacy := FALSE; + insym.next := sym; + INC(i) + ELSIF p = "-legacysymdir" THEN + Check; + sym := insym; + NEW(insym); + insym.path := Kernel.argv[i]$; + insym.legacy := TRUE; + insym.next := sym; + INC(i) + ELSIF p = "-allchecks" THEN + INCL(opts, allchecks) + ELSIF p = "-no-allchecks" THEN + EXCL(opts, allchecks) + ELSIF p = "-srcpos" THEN + INCL(opts, srcpos) + ELSIF p = "-no-srcpos" THEN + EXCL(opts, srcpos) + ELSIF p = "-structref" THEN + INCL(opts, allref) + ELSIF p = "-no-structref" THEN + EXCL(opts, allref) + ELSIF p = "-ref" THEN + INCL(opts, ref) + ELSIF p = "-no-ref" THEN + EXCL(opts, ref) + ELSIF p = "-obj" THEN + INCL(opts, obj) + ELSIF p = "-no-obj" THEN + EXCL(opts, obj) + ELSIF p = "-assert" THEN + INCL(opts, assert) + ELSIF p = "-no-assert" THEN + EXCL(opts, assert) + ELSIF p = "-checks" THEN + INCL(opts, checks) + ELSIF p = "-no-checks" THEN + EXCL(opts, checks) + ELSIF p = "-hints" THEN + INCL(opts, hint) + ELSIF p = "-no-hints" THEN + EXCL(opts, hint) + ELSIF p = "-trap" THEN + INCL(opts, errorTrap) + ELSIF p = "-no-trap" THEN + EXCL(opts, errorTrap) + ELSIF p = "-oberon" THEN + INCL(opts, oberon) + ELSIF p = "-no-oberon" THEN + EXCL(opts, oberon) + ELSIF p = "-com-aware" THEN + found := TRUE + ELSIF p = "-no-com-aware" THEN + found := FALSE + ELSIF (p = "-v") OR (p = "-verbose") THEN + DevCPM.verbose := MIN(DevCPM.verbose + 1, 3); + ELSIF p = "-main" THEN + (* ignore *) + ELSIF p = "-no-main" THEN + (* ignore *) + ELSIF p = "-include0" THEN + (* ignore *) + ELSIF p = "-no-include0" THEN + (* ignore *) + ELSIF p = "-includedir" THEN + Check; + (* ignore *) + INC(i) + ELSIF p = "-long-calls" THEN + INCL(opts2, emulong) + ELSIF p = "-no-long-calls" THEN + EXCL(opts2, emulong) + ELSE + Console.WriteStr("unknown option "); + Console.WriteStr(p); Console.WriteLn; + Kernel.Quit(1) + END + ELSE + IF h = NIL THEN NEW(h); t := h + ELSE NEW(t.next); t := t.next + END; + t.path := Kernel.argv[i]$; + t.outcode := outcode; + t.outsym := outsym; + t.insym := insym; + t.found := found; + t.opts := opts; + t.opts2 := opts2; + GetPath(t.path, t.dir, t.name); + IF t.name = "" THEN + Console.WriteStr("specified path to directory"); Console.WriteLn; + Kernel.Quit(1) + END; + INC(i) + END + END; + u := h + END InitOptions; + + PROCEDURE Module (source: POINTER TO ARRAY OF CHAR; m: Elem; OUT error: BOOLEAN); + VAR ext, new: BOOLEAN; p: DevCPT.Node; + BEGIN + DevCPM.Init(source); + DevCPM.symList := m.insym; + DevCPM.codePath := m.outcode; + DevCPM.symPath := m.outsym; + DevCPM.name := m.path; + IF m.found THEN INCL(DevCPM.options, DevCPM.comAware) END; + IF errorTrap IN m.opts THEN INCL(DevCPM.options, DevCPM.trap) END; + IF oberon IN m.opts THEN INCL(DevCPM.options, DevCPM.oberon) END; + DevCPT.Init(m.opts); + DevCPB.typSize := DevCPV.TypeSize; + DevCPT.processor := DevCPV.processor; + DevCPP.Module(p); + IF DevCPM.noerr THEN + IF DevCPT.libName # "" THEN EXCL(m.opts, obj) END; + DevCPV.Init(m.opts); DevCPV.Allocate; DevCPT.Export(ext, new); + IF DevCPM.noerr & (obj IN m.opts) THEN + IF emulong IN m.opts2 THEN + DevCPH.UseCalls(p, {DevCPH.longMop, DevCPH.longDop}) + END; + DevCPV.Module(p) + END; + DevCPV.Close + END; + IF DevCPM.noerr & (new OR ext) THEN DevCPM.RegisterNewSym + ELSE DevCPM.DeleteNewSym + END; + DevCPT.Close; + error := ~DevCPM.noerr; + IF error THEN + DevCPM.InsertMarks; + IF DevCPM.verbose > 0 THEN DevCPM.LogWStr(" ") END; + IF DevCPM.errors = 1 THEN + DevCPM.LogWStr("one error detected") + ELSE + DevCPM.LogWNum(DevCPM.errors, 0); DevCPM.LogWStr(" errors detected") + END; + DevCPM.LogWLn + ELSE + IF hint IN m.opts THEN DevCPM.InsertMarks END + END; + DevCPM.Close; + p := NIL; + Kernel.FastCollect + END Module; + + PROCEDURE ReadText (s: Elem): POINTER TO ARRAY OF CHAR; + VAR + i, len, res: INTEGER; + text: DswDocuments.Text; + loc: Files.Locator; f: Files.File; r: Files.Reader; + ssrc: POINTER TO ARRAY OF SHORTCHAR; + src: POINTER TO ARRAY OF CHAR; + x: POINTER TO ARRAY OF BYTE; + num: ARRAY 32 OF CHAR; + BEGIN + src := NIL; + loc := Files.dir.This(s.dir); + DswDocuments.Import(loc, s.name, text, res); + Strings.IntToString(res, num); + IF res = 0 THEN + src := text.t + ELSIF res = 2 THEN + f := Files.dir.Old(loc, s.name, Files.shared); + IF f # NIL THEN + len := f.Length(); + r := f.NewReader(NIL); + NEW(x, len + 1); + r.ReadBytes(x, 0, len); + NEW(ssrc, len + 1); + FOR i := 0 TO len - 1 DO + ssrc[i] := SHORT(CHR(x[i])) + END; + ssrc[i] := 0X; + x := NIL; + NEW(src, len + 1); + Kernel.Utf8ToString(ssrc, src, res); + ssrc := NIL; + f.Close + END + ELSE + IF DevCPM.verbose > 0 THEN + Console.WriteStr("document error "); + Console.WriteStr(num); + Console.WriteLn + END + END; + IF src = NIL THEN + Console.WriteStr("unable to open file "); + Console.WriteStr(s.path); + Console.WriteLn; + Kernel.Quit(1) + END; + RETURN src + END ReadText; + + PROCEDURE CompileAll; + VAR loc: Files.Locator; m: Elem; error: BOOLEAN; src: POINTER TO ARRAY OF CHAR; + BEGIN + m := u; + WHILE m # NIL DO + IF DevCPM.verbose > 0 THEN + Console.WriteStr("compiling "); Console.WriteStr(m.path); Console.WriteLn + END; + src := ReadText(m); + Module(src, m, error); + IF error THEN Kernel.Quit(1) END; + m := m.next + END + END CompileAll; + + PROCEDURE Init; + BEGIN + IF Kernel.trapCount # 0 THEN Kernel.Quit(1) END; + HostFiles.SetRootDir("."); + InitOptions; + CompileAll; + Kernel.Quit(0) + END Init; + +BEGIN + Kernel.Start(Init) +END DswCompiler486Main. + diff --git a/src/generic/Dsw/Mod/CompilerCPfrontMain.cp b/src/generic/Dsw/Mod/CompilerCPfrontMain.cp new file mode 100644 index 0000000..672ca76 --- /dev/null +++ b/src/generic/Dsw/Mod/CompilerCPfrontMain.cp @@ -0,0 +1,338 @@ +MODULE DswCompilerCPfrontMain; + + IMPORT Kernel, HostFiles, Files, Console, Strings, DswDocuments, + DevCPM, DevCPT, DevCPB, DevCPP, DevCPE, DevCPH, DevCPV := CPfrontCPV, DevCPG := CPfrontCPG; + + CONST + (* compiler options: *) + checks = 0; allchecks = 1; assert = 2; obj = 3; ref = 4; allref = 5; + srcpos = 6; reallib = 7; signatures = 8; + mainprog = 20; include0 = 21; + hint = 29; oberon = 30; errorTrap = 31; + (* defopt = {checks, assert, obj, ref, allref, srcpos, signatures}; *) + defopt = {checks, assert, obj}; + + emulong = 0; + defopt2 = {}; + + TYPE + Elem = POINTER TO RECORD + dir, name, path: Files.Name; + outsym, outcode: Files.Name; (* dir *) + insym: DevCPM.Directory; + found: BOOLEAN; (* COM Aware *) + opts, opts2: SET; + next: Elem + END; + + VAR + u: Elem; + + PROCEDURE GetPath (IN path: ARRAY OF CHAR; OUT dir, name: Files.Name); + VAR i, j, len: INTEGER; + BEGIN + len := LEN(path$); + i := len - 1; + WHILE (i >= 0) & (path[i] # '/') DO DEC(i) END; + IF i >= 0 THEN + FOR i := 0 TO i - 1 DO + dir[i] := path[i] + END; + dir[i] := 0X + ELSE + dir := "" + END; + j := i + 1; i := 0; + WHILE path[j] # 0X DO + name[i] := path[j]; + INC(i); INC(j) + END; + name[i] := 0X + END GetPath; + + PROCEDURE InitOptions; + VAR + i: INTEGER; + found: BOOLEAN; + insym, sym: DevCPM.Directory; + outsym, outcode: Files.Name; + p: ARRAY 256 OF CHAR; + h, t: Elem; + opts, opts2: SET; + + PROCEDURE Check; + BEGIN + IF i >= Kernel.argc THEN + Console.WriteStr("required more parameters for "); + Console.WriteStr(p); Console.WriteLn; + Kernel.Quit(1) + END + END Check; + + BEGIN + outsym := ""; outcode := ""; + opts := defopt; opts2 := defopt2; found := FALSE; + h := NIL; t := NIL; insym := NIL; + i := 1; + WHILE i < Kernel.argc DO + IF Kernel.argv[i, 0] = "-" THEN + p := Kernel.argv[i]$; + INC(i); + IF p = "-legacy" THEN + DevCPM.legacy := TRUE + ELSIF p = "-outsym" THEN + Check; + outsym := Kernel.argv[i]$; + INC(i) + ELSIF p = "-outcode" THEN + Check; + outcode := Kernel.argv[i]$; + INC(i) + ELSIF p = "-symdir" THEN + Check; + sym := insym; + NEW(insym); + insym.path := Kernel.argv[i]$; + insym.legacy := FALSE; + insym.next := sym; + INC(i) + ELSIF p = "-legacysymdir" THEN + Check; + sym := insym; + NEW(insym); + insym.path := Kernel.argv[i]$; + insym.legacy := TRUE; + insym.next := sym; + INC(i) + ELSIF p = "-allchecks" THEN + INCL(opts, allchecks) + ELSIF p = "-no-allchecks" THEN + EXCL(opts, allchecks) + ELSIF p = "-srcpos" THEN + INCL(opts, srcpos) + ELSIF p = "-no-srcpos" THEN + EXCL(opts, srcpos) + ELSIF p = "-structref" THEN + INCL(opts, allref) + ELSIF p = "-no-structref" THEN + EXCL(opts, allref) + ELSIF p = "-ref" THEN + INCL(opts, ref) + ELSIF p = "-no-ref" THEN + EXCL(opts, ref) + ELSIF p = "-obj" THEN + INCL(opts, obj) + ELSIF p = "-no-obj" THEN + EXCL(opts, obj) + ELSIF p = "-assert" THEN + INCL(opts, assert) + ELSIF p = "-no-assert" THEN + EXCL(opts, assert) + ELSIF p = "-checks" THEN + INCL(opts, checks) + ELSIF p = "-no-checks" THEN + EXCL(opts, checks) + ELSIF p = "-hints" THEN + INCL(opts, hint) + ELSIF p = "-no-hints" THEN + EXCL(opts, hint) + ELSIF p = "-trap" THEN + INCL(opts, errorTrap) + ELSIF p = "-no-trap" THEN + EXCL(opts, errorTrap) + ELSIF p = "-oberon" THEN + INCL(opts, oberon) + ELSIF p = "-no-oberon" THEN + EXCL(opts, oberon) + ELSIF p = "-com-aware" THEN + found := TRUE + ELSIF p = "-no-com-aware" THEN + found := FALSE + ELSIF (p = "-v") OR (p = "-verbose") THEN + DevCPM.verbose := MIN(DevCPM.verbose + 1, 3) + ELSIF p = "-main" THEN + INCL(opts, mainprog) + ELSIF p = "-no-main" THEN + EXCL(opts, mainprog) + ELSIF p = "-include0" THEN + INCL(opts, include0) + ELSIF p = "-no-include0" THEN + EXCL(opts, include0) + ELSIF p = "-includedir" THEN + Check; + DevCPG.includePath := Kernel.argv[i]$; + INC(i) + ELSIF p = "-long-calls" THEN + INCL(opts2, emulong) + ELSIF p = "-no-long-calls" THEN + EXCL(opts2, emulong) + ELSE + Console.WriteStr("unknown option "); + Console.WriteStr(p); Console.WriteLn; + Kernel.Quit(1) + END + ELSE + IF h = NIL THEN NEW(h); t := h + ELSE NEW(t.next); t := t.next + END; + t.path := Kernel.argv[i]$; + t.outcode := outcode; + t.outsym := outsym; + t.insym := insym; + t.found := found; + t.opts := opts; + t.opts2 := opts2; + GetPath(t.path, t.dir, t.name); + IF t.name = "" THEN + Console.WriteStr("specified path to directory"); Console.WriteLn; + Kernel.Quit(1) + END; + INC(i) + END + END; + u := h + END InitOptions; + + PROCEDURE Module (source: POINTER TO ARRAY OF CHAR; m: Elem; OUT error: BOOLEAN); + VAR ext, new: BOOLEAN; p: DevCPT.Node; + BEGIN + DevCPG.opt := {}; (* !!! *) + DevCPM.Init(source); + DevCPM.symList := m.insym; + DevCPM.codePath := m.outcode; + DevCPM.symPath := m.outsym; + DevCPM.name := m.path; + INCL(DevCPM.options, 10); (* !!! allow [ccall] *) + INCL(DevCPM.options, DevCPM.allSysVal); (* !!! make nodes for all SYSTEM.VAL *) + INCL(DevCPG.opt, DevCPG.ansi); (* !!! *) + IF m.found THEN INCL(DevCPM.options, DevCPM.comAware) END; + IF errorTrap IN m.opts THEN INCL(DevCPM.options, DevCPM.trap) END; + IF oberon IN m.opts THEN INCL(DevCPM.options, DevCPM.oberon) END; + IF mainprog IN m.opts THEN INCL(DevCPG.opt, DevCPG.mainprog) END; + IF include0 IN m.opts THEN INCL(DevCPG.opt, DevCPG.include0) END; + DevCPT.Init(m.opts); + (* DevCPB.typSize := DevCPV.TypeSize; *) + DevCPB.typSize := DevCPV.TypSize; + DevCPT.processor := DevCPV.processor; + DevCPP.Module(p); + IF DevCPM.noerr THEN + IF DevCPT.libName # "" THEN EXCL(m.opts, obj) END; + DevCPV.Init(m.opts); DevCPV.AdrAndSize(DevCPT.topScope); DevCPT.Export(ext, new); + IF DevCPM.noerr & (obj IN m.opts) THEN + DevCPG.OpenFiles(DevCPT.SelfName); + IF emulong IN m.opts2 THEN + DevCPH.UseCalls(p, {DevCPH.longMop, DevCPH.longDop, DevCPH.longConv, DevCPH.longOdd}); + END; + DevCPV.Module(p) + END; + (* DevCPV.Close *) + END; + IF DevCPM.noerr & (DevCPG.mainprog IN DevCPG.opt) & (DevCPG.modName # "SYSTEM") THEN + DevCPM.DeleteNewSym; + IF DevCPM.verbose > 0 THEN + DevCPM.LogWStr(" main program"); DevCPM.LogWLn + END + ELSIF DevCPM.noerr & (new OR ext) THEN + DevCPM.RegisterNewSym + ELSE + DevCPM.DeleteNewSym + END; + IF obj IN m.opts THEN + DevCPG.CloseFiles + END; + DevCPT.Close; + error := ~DevCPM.noerr; + IF error THEN + DevCPM.InsertMarks; + IF DevCPM.verbose > 0 THEN DevCPM.LogWStr(" ") END; + IF DevCPM.errors = 1 THEN + DevCPM.LogWStr("one error detected"); + ELSE + DevCPM.LogWNum(DevCPM.errors, 0); DevCPM.LogWStr(" errors detected") + END; + DevCPM.LogWLn + ELSE + IF hint IN m.opts THEN DevCPM.InsertMarks END + END; + DevCPM.Close; + p := NIL; + Kernel.FastCollect + END Module; + + PROCEDURE ReadText (s: Elem): POINTER TO ARRAY OF CHAR; + VAR + i, len, res: INTEGER; + text: DswDocuments.Text; + loc: Files.Locator; f: Files.File; r: Files.Reader; + ssrc: POINTER TO ARRAY OF SHORTCHAR; + src: POINTER TO ARRAY OF CHAR; + x: POINTER TO ARRAY OF BYTE; + num: ARRAY 32 OF CHAR; + BEGIN + src := NIL; + loc := Files.dir.This(s.dir); + DswDocuments.Import(loc, s.name, text, res); + Strings.IntToString(res, num); + IF res = 0 THEN + src := text.t + ELSIF res = 2 THEN + f := Files.dir.Old(loc, s.name, Files.shared); + IF f # NIL THEN + len := f.Length(); + r := f.NewReader(NIL); + NEW(x, len + 1); + r.ReadBytes(x, 0, len); + NEW(ssrc, len + 1); + FOR i := 0 TO len - 1 DO + ssrc[i] := SHORT(CHR(x[i])) + END; + ssrc[i] := 0X; + x := NIL; + NEW(src, len + 1); + Kernel.Utf8ToString(ssrc, src, res); + ssrc := NIL; + f.Close + END + ELSE + IF DevCPM.verbose > 0 THEN + Console.WriteStr("document error "); + Console.WriteStr(num); + Console.WriteLn + END + END; + IF src = NIL THEN + Console.WriteStr("unable to open file "); + Console.WriteStr(s.path); + Console.WriteLn; + Kernel.Quit(1) + END; + RETURN src + END ReadText; + + PROCEDURE CompileAll; + VAR loc: Files.Locator; m: Elem; error: BOOLEAN; src: POINTER TO ARRAY OF CHAR; + BEGIN + m := u; + WHILE m # NIL DO + IF DevCPM.verbose > 0 THEN + Console.WriteStr("compiling "); Console.WriteStr(m.path); Console.WriteLn + END; + src := ReadText(m); + Module(src, m, error); + IF error THEN Kernel.Quit(1) END; + m := m.next + END + END CompileAll; + + PROCEDURE Init; + BEGIN + IF Kernel.trapCount # 0 THEN Kernel.Quit(1) END; + HostFiles.SetRootDir("."); + InitOptions; + CompileAll; + Kernel.Quit(0) + END Init; + +BEGIN + Kernel.Start(Init) +END DswCompilerCPfrontMain. diff --git a/src/generic/Dsw/Mod/Debug.odc b/src/generic/Dsw/Mod/Debug.odc new file mode 100644 index 0000000..743e205 Binary files /dev/null and b/src/generic/Dsw/Mod/Debug.odc differ diff --git a/src/generic/Dsw/Mod/Documents.cp b/src/generic/Dsw/Mod/Documents.cp new file mode 100644 index 0000000..12cb6b5 --- /dev/null +++ b/src/generic/Dsw/Mod/Documents.cp @@ -0,0 +1,233 @@ +MODULE DswDocuments; + + IMPORT Files; + + (* !!! make better store type and version checking *) + + TYPE + Name = ARRAY 256 OF SHORTCHAR; + + Store = RECORD + (* type: Name; *) + next, down, len: INTEGER; + pos, end: INTEGER; + isElem: BOOLEAN; + END; + + Text* = POINTER TO RECORD + t*: POINTER TO ARRAY OF CHAR; + END; + + PROCEDURE Import* (loc: Files.Locator; IN name: Files.Name; OUT text: Text; OUT res: INTEGER); + CONST + docTag = 6F4F4443H; docVersion = 0; + Step = 256; + VAR f: Files.File; r: Files.Reader; tag, version, chid: INTEGER; s: Store; + + PROCEDURE AddChar (ch: CHAR); + VAR i, len: INTEGER; t: POINTER TO ARRAY OF CHAR; + BEGIN + IF text = NIL THEN + NEW(text); NEW(text.t, Step); chid := 0 + END; + len := LEN(text.t); + IF chid + 1 >= len THEN + NEW(t, len + Step); + FOR i := 0 TO len - 1 DO + t[i] := text.t[i] + END; + text.t := t + END; + text.t[chid] := ch; INC(chid); + text.t[chid] := 0X; + END AddChar; + + PROCEDURE ReadSChar (OUT x: SHORTCHAR); + VAR i: BYTE; + BEGIN + r.ReadByte(i); + x := SHORT(CHR(i MOD 256)) + END ReadSChar; + + PROCEDURE ReadInt (OUT x: INTEGER); + VAR i: ARRAY 4 OF BYTE; + BEGIN + r.ReadBytes(i, 0, 4); + x := i[0] MOD 256 + i[1] MOD 256 * 256 + i[2] MOD 256 * 65536 + i[3] MOD 256 * 16777216 + END ReadInt; + + PROCEDURE ReadBool (OUT x: BOOLEAN); + VAR i: SHORTCHAR; + BEGIN + ReadSChar(i); + x := i # 0X + END ReadBool; + + PROCEDURE ReadStore (OUT s: Store); + CONST + storeVersion = 0X; + newBase = 0F0X; newExt = 0F1X; oldType = 0F2X; + nil = 80X; link = 81X; store = 82X; elem = 83X; newlink = 84X; + elemTName = "Stores.ElemDesc"; modelTName = "Models.ModelDesc"; (* from pre-1.3 *) + VAR + tag, version, ch: SHORTCHAR; i, x: INTEGER; + BEGIN + ReadSChar(tag); s.isElem := tag = elem; + ASSERT((tag = store) OR (tag = elem), 100); + ReadSChar(tag); + WHILE tag = newExt DO + REPEAT ReadSChar(ch) UNTIL ch = 0X; + ReadSChar(tag) + END; + IF tag = newBase THEN (* !!! get base types *) + REPEAT ReadSChar(ch) UNTIL ch = 0X; + ELSIF tag = oldType THEN + ReadInt(x) (* !!! get from dictionary *) + ELSE + HALT(102) + END; + ReadInt(x); (* extension hook = 00000000 *) + ReadInt(s.next); s.next := s.next + r.Pos(); + ReadInt(s.down); s.down := s.down + r.Pos(); + ReadInt(s.len); s.pos := r.Pos(); s.end := s.pos + s.len; + ReadSChar(version); (* version *) + ASSERT(version = storeVersion, 103); + IF s.isElem THEN + ReadSChar(version); + ASSERT(version = storeVersion, 104) + END + END ReadStore; + + PROCEDURE ReadStdTextModel; + CONST + dictSize = 32; + noLCharStdModelVersion = 0; stdModelVersion = 1; + VAR + s: Store; + version, ano: BYTE; + org, len, dictlen, i, w, h: INTEGER; + R: Files.Reader; + x: ARRAY 2 OF BYTE; + ch: CHAR; + BEGIN + r.ReadByte(version); + IF version IN {noLCharStdModelVersion, stdModelVersion} THEN + ReadInt(org); org := org + r.Pos(); R := f.NewReader(NIL); R.SetPos(org); + r.ReadByte(ano); dictlen := 0; + WHILE ano # -1 DO + IF ano = dictlen THEN + ReadStore(s); r.SetPos(s.end); (* attr IS TextModels.AttributesDesc *) + IF dictlen < dictSize THEN (* dictattr[dictlen] := attr *) INC(dictlen) END + ELSE + (* attr := dictattr[ano] *) + END; + ReadInt(len); + IF len > 0 THEN (* pice *) + FOR i := 0 TO len - 1 DO + R.ReadByte(x[0]); ch := CHR(x[0] MOD 256); AddChar(ch) + END + ELSIF len < 0 THEN (* longchar pice *) + ASSERT(len MOD 2 = 0); + FOR i := 0 TO (-len) DIV 2 - 1 DO + R.ReadBytes(x, 0, 2); ch := CHR(x[0] MOD 256 + x[1] MOD 256 * 256); AddChar(ch) + END + ELSE (* len = 0 => embedded view *) + ReadInt(w); ReadInt(h); R.ReadByte(x[0]); (* viewcode!!! *) AddChar(02X); + ReadStore(s); r.SetPos(s.end) (* random view type *) + END; + r.ReadByte(ano) + END; + res := 0 (* ok *) + ELSE + res := 4 (* unsupported text model version *) + END + END ReadStdTextModel; + + PROCEDURE ReadTextModel; + CONST + modelVersion = 0; + conteinerVersion = 0; + textModelVersion = 0; + VAR + s: Store; + version: BYTE; + BEGIN + ReadStore(s); + IF TRUE (*s.type = "TextModels.StdModelDesc"*) THEN + r.ReadByte(version); + IF version = modelVersion THEN (* Models.Model *) + r.ReadByte(version); + IF version = conteinerVersion THEN (* Containers.Container *) + r.ReadByte(version); + IF version = textModelVersion THEN (* TextModels.Model *) + ReadStdTextModel + ELSE + res := 4 (* unsupported text model version *) + END + ELSE + res := 4 (* unsupported text model version *) + END + ELSE + res := 4 (* unsupported text model version *) + END + ELSE + res := 3 (* unsupported version *) + END + END ReadTextModel; + + PROCEDURE ReadDocument; + VAR s: Store; + BEGIN + ReadStore(s); + IF TRUE (*s.type = "Documents.StdDocumentDesc"*) THEN + r.SetPos(s.down); (* !!! *) + ReadStore(s); + IF TRUE (*s.type = "Documents.ModelDesc"*) THEN + r.SetPos(s.down); (* !!! *) + ReadStore(s); + IF TRUE (*s.type = "TextViews.StdViewDesc"*) THEN + r.SetPos(s.down); (* !!! *) + ReadTextModel + ELSE + res := 3 (* unsupported version *) + END + ELSE + res := 3 (* unsupported version *) + END + ELSE + res := 3 (* unsupported version *) + END + END ReadDocument; + + BEGIN + ASSERT(loc # NIL, 20); + ASSERT(name # "", 21); + text := NIL; + f := Files.dir.Old(loc, name, Files.shared); + IF f # NIL THEN + IF f.Length() > 8 THEN (* !!! calculate minimal document size *) + r := f.NewReader(NIL); + ReadInt(tag); + IF tag = docTag THEN + ReadInt(version); + IF version = docVersion THEN + ReadDocument; + f.Close + ELSE + f.Close; + res := 3 (* unsupported version *) + END + ELSE + f.Close; + res := 2 (* not document *) + END + ELSE + f.Close; + res := 2 (* not document *) + END + ELSE + res := 1 (* unable to open *) + END + END Import; + +END DswDocuments. diff --git a/src/generic/Dsw/Mod/EchoMain.cp b/src/generic/Dsw/Mod/EchoMain.cp new file mode 100644 index 0000000..ecfb334 --- /dev/null +++ b/src/generic/Dsw/Mod/EchoMain.cp @@ -0,0 +1,44 @@ +MODULE DswEchoMain; + + (* encoding converter test *) + + IMPORT Kernel, HostLang, Console, Strings; + + PROCEDURE Init; + CONST maxBuf = 256; + VAR i, j, res: INTEGER; p, x: ARRAY maxBuf OF CHAR; + BEGIN + IF Kernel.trapCount # 0 THEN Kernel.Quit(1) END; + i := 1; + WHILE i < Kernel.argc DO + HostLang.HostToString(Kernel.argv[i]$, p, TRUE, res); + Console.WriteStr(p); + IF res # 0 THEN + Console.WriteLn; + Console.WriteStr("Error: "); Console.WriteChar(CHR(ORD("0") + res MOD 10)); + Console.WriteLn; + Kernel.Quit(1) + END; + INC(i) + END; + IF i > 1 THEN Console.WriteLn END; + + i := 1; + WHILE i < Kernel.argc DO + HostLang.HostToString(Kernel.argv[i]$, p, TRUE, res); + j := 0; + WHILE p[j] # 0X DO + Strings.IntToStringForm(ORD(p[j]), 16, 4, "0", FALSE, x); + Console.WriteStr(x); + Console.WriteStr(" "); + INC(j) + END; + INC(i) + END; + IF i > 1 THEN Console.WriteLn END; + Kernel.Quit(0) + END Init; + +BEGIN + Kernel.Start(Init) +END DswEchoMain. diff --git a/src/generic/Dsw/Mod/Linker486Main.cp b/src/generic/Dsw/Mod/Linker486Main.cp new file mode 100644 index 0000000..27997e2 --- /dev/null +++ b/src/generic/Dsw/Mod/Linker486Main.cp @@ -0,0 +1,259 @@ +MODULE DswLinker486Main; + + IMPORT Kernel, HostFiles, Files, Console, Strings, + LB := Dev2LnkBase, Load := Dev2LnkLoad, WrPe := Dev2LnkWritePe, + WrElf := Dev2LnkWriteElf, WrElfS := Dev2LnkWriteElfStatic; + + CONST + tgtElfStatic = 0; tgtElfExe = 1; tgtElfDll = 2; tgtPeExe = 3; tgtPeDll = 4; + + TYPE + Elem = POINTER TO RECORD + name: ARRAY 256 OF CHAR; + next: Elem + END; + + VAR + u: Elem; + inobj: LB.Directory; + outdir, outname: Files.Name; + os, interp, main, kernel: ARRAY 256 OF CHAR; + static, dll, sinit: BOOLEAN; + + PROCEDURE GetPath (IN path: ARRAY OF CHAR; OUT dir, name: Files.Name); + VAR i, j, len: INTEGER; + BEGIN + len := LEN(path$); + i := len - 1; + WHILE (i >= 0) & (path[i] # '/') DO DEC(i) END; + IF i >= 0 THEN + FOR i := 0 TO i - 1 DO + dir[i] := path[i] + END; + dir[i] := 0X + ELSE + dir := "" + END; + j := i + 1; i := 0; + WHILE path[j] # 0X DO + name[i] := path[j]; + INC(i); INC(j) + END; + name[i] := 0X + END GetPath; + + PROCEDURE InitOptions; + VAR i: INTEGER; h, t: Elem; obj: LB.Directory; p: ARRAY 256 OF CHAR; + + PROCEDURE Check; + BEGIN + IF i >= Kernel.argc THEN + Console.WriteStr("required more parameters for "); + Console.WriteStr(p); Console.WriteLn; + Kernel.Quit(1) + END + END Check; + + BEGIN + i := 1; + WHILE i < Kernel.argc DO + IF Kernel.argv[i, 0] = "-" THEN + p := Kernel.argv[i]$; + INC(i); + IF p = "-os" THEN + Check; + Strings.ToLower(Kernel.argv[i]$, os); + INC(i) + ELSIF p = "-interp" THEN + Check; + interp := Kernel.argv[i]$; + INC(i) + ELSIF p = "-o" THEN + Check; + GetPath(Kernel.argv[i]$, outdir, outname); + INC(i) + ELSIF p = "-static" THEN + static := TRUE + ELSIF p = "-dll" THEN + dll := TRUE + ELSIF p = "-sinit" THEN + sinit := TRUE + ELSIF (p = "-m") OR (p = "-main") THEN + Check; + main := Kernel.argv[i]$; + INC(i) + ELSIF (p = "-k") OR (p = "-kernel") THEN + Check; + kernel := Kernel.argv[i]$; + INC(i) + ELSIF p = "-codedir" THEN + Check; + obj := inobj; + NEW(inobj); + inobj.path := Kernel.argv[i]$; + inobj.legacy := FALSE; + inobj.next := obj; + INC(i) + ELSIF p = "-legacycodedir" THEN + Check; + obj := inobj; + NEW(inobj); + inobj.path := Kernel.argv[i]$; + inobj.legacy := TRUE; + inobj.next := obj; + INC(i) + ELSIF p = "-trap" THEN + LB.trap := TRUE + ELSE + Console.WriteStr("unknown option "); + Console.WriteStr(p); Console.WriteLn; + Kernel.Quit(1) + END + ELSE + IF h = NIL THEN NEW(h); t := h + ELSE NEW(t.next); t := t.next + END; + t.name := Kernel.argv[i]$; + INC(i) + END + END; + u := h + END InitOptions; + + PROCEDURE CheckOptions; + BEGIN + IF (os = "linux") OR (os = "freebsd") OR (os = "openbsd") THEN + IF dll THEN LB.Init(tgtElfDll) + ELSIF static THEN LB.Init(tgtElfStatic) + ELSE LB.Init(tgtElfExe) + END; + LB.dynaInit := ~sinit; + IF os = "linux" THEN + LB.opt.OSABI := WrElf.ELFOSABI_NONE; + IF interp = "" THEN LB.opt.elfInterpreter := WrElf.linuxInterpreter + ELSE LB.opt.elfInterpreter := SHORT(interp$) + END + ELSIF os = "freebsd" THEN + LB.opt.OSABI := WrElf.ELFOSABI_FREEBSD; + IF interp = "" THEN LB.opt.elfInterpreter := WrElf.freeBSDInterpreter + ELSE LB.opt.elfInterpreter := SHORT(interp$) + END + ELSIF os = "openbsd" THEN + LB.opt.OSABI := WrElf.ELFOSABI_NONE; + IF interp = "" THEN LB.opt.elfInterpreter := WrElf.openBSDInterpreter + ELSE LB.opt.elfInterpreter := SHORT(interp$) + END + ELSE + HALT(100) + END; + IF outname = "" THEN + Files.dir.GetFileName("a", "out", outname) + END + ELSIF os = "win32" THEN + IF dll THEN LB.Init(tgtPeDll) + ELSE LB.Init(tgtPeExe) + END; + LB.dynaInit := ~sinit; + IF outname = "" THEN + Files.dir.GetFileName("a", "exe", outname) + END; + IF static THEN + Console.WriteStr("-static not supported for win32"); Console.WriteLn; + Kernel.Quit(1) + END; + IF interp # "" THEN + Console.WriteStr("-interp not supported for win32"); Console.WriteLn; + Kernel.Quit(1) + END + ELSIF os = "" THEN + Console.WriteStr("os not specified"); Console.WriteLn; + Kernel.Quit(1) + ELSE + Console.WriteStr("unknown os "); Console.WriteStr(os); Console.WriteLn; + Kernel.Quit(1) + END; + IF main = "" THEN + Console.WriteStr("main module not specified"); Console.WriteLn; + Kernel.Quit(1) + END; + IF outname = "" THEN + Console.WriteStr("required path to output file"); Console.WriteLn; + Kernel.Quit(1) + END; + IF inobj = NIL THEN + Console.WriteStr("required path to input objects"); Console.WriteLn; + Kernel.Quit(1) + END; + LB.objList := inobj; + LB.outputPath := outdir; + LB.outputName := SHORT(outname$); + LB.KernelName := SHORT(kernel$); + LB.mainName := SHORT(main$); + IF u = NIL THEN + Console.WriteStr("no input specified"); Console.WriteLn; + Kernel.Quit(1) + END; + END CheckOptions; + + PROCEDURE LinkAll; + VAR m: Elem; codeBase, dataBase, varsBase: INTEGER; + BEGIN + m := u; + WHILE m # NIL DO + CASE LB.target OF + | tgtElfStatic, tgtElfExe, tgtPeExe: Load.AddModule(m.name) + | tgtElfDll, tgtPeDll: Load.ExportModule(m.name) + END; + m := m.next + END; + CASE LB.target OF + | tgtElfStatic, tgtElfDll, tgtPeDll: (* ok *) + | tgtElfExe: + IF os = "freebsd" THEN + Load.ExportVariable(LB.KernelName$, "__progname"); + Load.ExportVariable(LB.KernelName$, "environ") + END; + Load.ExportAll + | tgtPeExe: + Load.ExportAll + END; + codeBase := 0; dataBase := 0; varsBase := 0; + LB.BeginLinking; + IF LB.outPe THEN + WrPe.Init; + WrPe.GetBases(codeBase, dataBase, varsBase); + LB.SetAddr(codeBase, dataBase, varsBase); + LB.DoFixups; + WrPe.WriteOut + ELSIF LB.outElf & LB.opt.elfStatic THEN + WrElfS.Init; + WrElfS.GetBases(codeBase, dataBase, varsBase); + LB.SetAddr(codeBase, dataBase, varsBase); + LB.DoFixups; + WrElfS.WriteOut + ELSIF LB.outElf THEN + WrElf.Init; + WrElf.GetBases(codeBase, dataBase, varsBase); + LB.SetAddr(codeBase, dataBase, varsBase); + LB.DoFixups; + WrElf.WriteOut + END; + IF LB.error THEN + Console.WriteStr("link failed"); Console.WriteLn; + Kernel.Quit(1) + END + END LinkAll; + + PROCEDURE Init; + BEGIN + IF Kernel.trapCount # 0 THEN Kernel.Quit(1) END; + HostFiles.SetRootDir("."); + InitOptions; + CheckOptions; + LinkAll; + Kernel.Quit(0) + END Init; + +BEGIN + Kernel.Start(Init) +END DswLinker486Main. diff --git a/src/generic/Dsw/Mod/ListMain.cp b/src/generic/Dsw/Mod/ListMain.cp new file mode 100644 index 0000000..d1daf15 --- /dev/null +++ b/src/generic/Dsw/Mod/ListMain.cp @@ -0,0 +1,48 @@ +MODULE DswListMain; + + (* file list test *) + + IMPORT Kernel, HostFiles, Files, Console, Strings; + + PROCEDURE Init; + VAR i, res: INTEGER; loc: Files.Locator; f: Files.FileInfo; d: Files.LocInfo; s: ARRAY 20 OF CHAR; + BEGIN + IF Kernel.trapCount > 0 THEN Kernel.Quit(1) END; + HostFiles.SetRootDir("."); + i := 1; res := 0; + WHILE i < Kernel.argc DO + loc := Files.dir.This(Kernel.argv[i]$); + d := Files.dir.LocList(loc); + IF loc.res = 0 THEN + WHILE d # NIL DO + Console.WriteStr(d.name + "/"); + Console.WriteLn; + d := d.next + END; + f := Files.dir.FileList(loc); + IF loc.res = 0 THEN + WHILE f # NIL DO + Console.WriteStr(f.name); + Console.WriteLn; + f := f.next + END + END + END; + IF loc.res # 0 THEN + Console.WriteStr(Kernel.argv[i] + ': error '); + Strings.IntToString(loc.res, s); + Console.WriteStr(s); + Console.WriteLn; + INC(res); + END; + INC(i) + END; + IF res = 0 THEN Kernel.Quit(0) + ELSIF res = 1 THEN Kernel.Quit(1) + ELSE Kernel.Quit(2) + END + END Init; + +BEGIN + Kernel.Start(Init) +END DswListMain. diff --git a/src/generic/Dsw/Mod/Log.odc b/src/generic/Dsw/Mod/Log.odc new file mode 100644 index 0000000..1e08e84 Binary files /dev/null and b/src/generic/Dsw/Mod/Log.odc differ diff --git a/src/generic/Dsw/Mod/LoopMain.cp b/src/generic/Dsw/Mod/LoopMain.cp new file mode 100644 index 0000000..ad030df --- /dev/null +++ b/src/generic/Dsw/Mod/LoopMain.cp @@ -0,0 +1,45 @@ +MODULE DswLoopMain; + + (* file locking test *) + + IMPORT Kernel, Files, Console, Strings, Log; + + VAR + mode: BOOLEAN; + + PROCEDURE Init; + VAR i: INTEGER; s: ARRAY 16 OF CHAR; f: Files.File; loc: Files.Locator; + BEGIN + IF (Kernel.trapCount > 0) & (Kernel.err # 128) THEN + IF Kernel.err = 200 THEN Console.WriteStr("Keyboard Interrupt") + ELSE Console.WriteStr("Trap "); Strings.IntToString(Kernel.err, s); Console.WriteStr(s) + END; + Console.WriteLn; + Kernel.Quit(1) + END; + i := 1; + mode := Files.shared; + loc := Files.dir.This(""); + WHILE i < Kernel.argc DO + IF Kernel.argv[i]$ = "-" THEN mode := Files.shared + ELSIF Kernel.argv[i]$ = "+" THEN mode := Files.exclusive + ELSIF Kernel.argv[i]$ = "!" THEN + IF f # NIL THEN f.Close; f := NIL END + ELSE + f := Files.dir.Old(loc, Kernel.argv[i]$, mode); + Log.Int(i); Log.String(": "); + IF f = NIL THEN Log.String("~open") + ELSE Log.String("ok") + END; + Log.Int(loc.res); + Log.Ln + END; + INC(i) + END; + LOOP END; + Kernel.Quit(0) + END Init; + +BEGIN + Kernel.Start(Init) +END DswLoopMain. diff --git a/src/generic/System/Mod/Console.odc b/src/generic/System/Mod/Console.odc new file mode 100644 index 0000000..27cfe44 Binary files /dev/null and b/src/generic/System/Mod/Console.odc differ diff --git a/src/generic/System/Mod/Dates.odc b/src/generic/System/Mod/Dates.odc new file mode 100644 index 0000000..db6753b Binary files /dev/null and b/src/generic/System/Mod/Dates.odc differ diff --git a/src/generic/System/Mod/Files.odc b/src/generic/System/Mod/Files.odc new file mode 100644 index 0000000..bb52b5c Binary files /dev/null and b/src/generic/System/Mod/Files.odc differ diff --git a/src/generic/System/Mod/Int.odc b/src/generic/System/Mod/Int.odc new file mode 100644 index 0000000..9adb645 Binary files /dev/null and b/src/generic/System/Mod/Int.odc differ diff --git a/src/generic/System/Mod/Integers.odc b/src/generic/System/Mod/Integers.odc new file mode 100644 index 0000000..bd9d450 Binary files /dev/null and b/src/generic/System/Mod/Integers.odc differ diff --git a/src/generic/System/Mod/Log.odc b/src/generic/System/Mod/Log.odc new file mode 100644 index 0000000..6844660 Binary files /dev/null and b/src/generic/System/Mod/Log.odc differ diff --git a/src/generic/System/Mod/Services.odc b/src/generic/System/Mod/Services.odc new file mode 100644 index 0000000..9a36129 Binary files /dev/null and b/src/generic/System/Mod/Services.odc differ diff --git a/src/generic/System/Mod/Strings.odc b/src/generic/System/Mod/Strings.odc new file mode 100644 index 0000000..d4aafc8 Binary files /dev/null and b/src/generic/System/Mod/Strings.odc differ diff --git a/src/i486/generic/System/Mod/Long.odc b/src/i486/generic/System/Mod/Long.odc new file mode 100644 index 0000000..f50db60 Binary files /dev/null and b/src/i486/generic/System/Mod/Long.odc differ diff --git a/src/i486/generic/System/Mod/Math.odc b/src/i486/generic/System/Mod/Math.odc new file mode 100644 index 0000000..8adb3e1 Binary files /dev/null and b/src/i486/generic/System/Mod/Math.odc differ diff --git a/src/i486/generic/System/Mod/SMath.odc b/src/i486/generic/System/Mod/SMath.odc new file mode 100644 index 0000000..719a3f3 Binary files /dev/null and b/src/i486/generic/System/Mod/SMath.odc differ diff --git a/src/i486/linux/C99/Mod/dirent.cp b/src/i486/linux/C99/Mod/dirent.cp new file mode 100644 index 0000000..974ffd2 --- /dev/null +++ b/src/i486/linux/C99/Mod/dirent.cp @@ -0,0 +1,66 @@ +MODULE C99dirent ['libc.so.6']; + + (* generated by genposix.sh, do not modify *) + + IMPORT SYSTEM, C99types, C99sys_types; + + TYPE + char* = C99types.char; + signed_char* = C99types.signed_char; + unsigned_char* = C99types.unsigned_char; + short* = C99types.short; + short_int* = C99types.short_int; + signed_short* = C99types.signed_short; + signed_short_int* = C99types.signed_short_int; + unsigned_short* = C99types.unsigned_short; + unsigned_short_int* = C99types.unsigned_short_int; + int* = C99types.int; + signed* = C99types.signed; + signed_int* = C99types.signed_int; + unsigned* = C99types.unsigned; + unsigned_int* = C99types.unsigned_int; + long* = C99types.long; + long_int* = C99types.long_int; + signed_long* = C99types.signed_long; + signed_long_int* = C99types.signed_long_int; + unsigned_long* = C99types.unsigned_long; + unsigned_long_int* = C99types.unsigned_long_int; + long_long* = C99types.long_long; + long_long_int* = C99types.long_long_int; + signed_long_long* = C99types.signed_long_long; + signed_long_long_int* = C99types.signed_long_long_int; + unsigned_long_long* = C99types.unsigned_long_long; + unsigned_long_long_int* = C99types.unsigned_long_long_int; + float* = C99types.float; + double* = C99types.double; + long_double* = C99types.long_double; + + TYPE + PDIR* = POINTER TO DIR; + DIR = LIMITED RECORD [untagged] END; + + TYPE + Pstruct_dirent* = POINTER TO struct_dirent; + struct_dirent* = RECORD [noalign] (* 268 *) + d_ino*: ino_t; (* 0+4 *) + _____align0_____: ARRAY 7 OF BYTE; + d_name*: ARRAY [untagged] 256 OF SHORTCHAR; (* 11+256 *) + _____align1_____: ARRAY 1 OF BYTE; + END; + + TYPE + ino_t* = C99sys_types.ino_t; + + PROCEDURE [ccall] alphasort* (IN a, b: Pstruct_dirent): int; + PROCEDURE [ccall] closedir* (dirp: PDIR): int; + PROCEDURE [ccall] dirfd* (dirp: PDIR): int; + PROCEDURE [ccall] fdopendir* (fd: int): PDIR; + PROCEDURE [ccall] opendir* (IN name: ARRAY [untagged] OF SHORTCHAR): PDIR; + PROCEDURE [ccall] readdir* (dirp: PDIR): Pstruct_dirent; + PROCEDURE [ccall] readdir_r* (dirp: PDIR; entry: Pstruct_dirent; VAR result: Pstruct_dirent): int; + PROCEDURE [ccall] rewinddir* (dirp: PDIR); + PROCEDURE [ccall] scandir* (IN dirp: ARRAY [untagged] OF SHORTCHAR; filter: PROCEDURE [ccall] (IN d: struct_dirent): int; compar: PROCEDURE [ccall] (IN a, b: Pstruct_dirent): int): int; + PROCEDURE [ccall] seekdir* (dirp: PDIR; loc: long); + PROCEDURE [ccall] telldir* (dirp: PDIR): long; + +END C99dirent. diff --git a/src/i486/linux/C99/Mod/dlfcn.cp b/src/i486/linux/C99/Mod/dlfcn.cp new file mode 100644 index 0000000..e308262 --- /dev/null +++ b/src/i486/linux/C99/Mod/dlfcn.cp @@ -0,0 +1,49 @@ +MODULE C99dlfcn ['libdl.so.2']; + + (* generated by genposix.sh, do not modify *) + + IMPORT SYSTEM, C99types; + + TYPE + char* = C99types.char; + signed_char* = C99types.signed_char; + unsigned_char* = C99types.unsigned_char; + short* = C99types.short; + short_int* = C99types.short_int; + signed_short* = C99types.signed_short; + signed_short_int* = C99types.signed_short_int; + unsigned_short* = C99types.unsigned_short; + unsigned_short_int* = C99types.unsigned_short_int; + int* = C99types.int; + signed* = C99types.signed; + signed_int* = C99types.signed_int; + unsigned* = C99types.unsigned; + unsigned_int* = C99types.unsigned_int; + long* = C99types.long; + long_int* = C99types.long_int; + signed_long* = C99types.signed_long; + signed_long_int* = C99types.signed_long_int; + unsigned_long* = C99types.unsigned_long; + unsigned_long_int* = C99types.unsigned_long_int; + long_long* = C99types.long_long; + long_long_int* = C99types.long_long_int; + signed_long_long* = C99types.signed_long_long; + signed_long_long_int* = C99types.signed_long_long_int; + unsigned_long_long* = C99types.unsigned_long_long; + unsigned_long_long_int* = C99types.unsigned_long_long_int; + float* = C99types.float; + double* = C99types.double; + long_double* = C99types.long_double; + + CONST + RTLD_LAZY* = 1; + RTLD_NOW* = 2; + RTLD_GLOBAL* = 256; + RTLD_LOCAL* = 0; + + PROCEDURE [ccall] dlclose* (handle: C99types.Pvoid): int; + PROCEDURE [ccall] dlerror* (): POINTER TO ARRAY [untagged] OF SHORTCHAR; + PROCEDURE [ccall] dlopen* (IN [nil] filename: ARRAY [untagged] OF SHORTCHAR; flags: int): C99types.Pvoid; + PROCEDURE [ccall] dlsym* (handle: C99types.Pvoid; IN symbol: ARRAY [untagged] OF SHORTCHAR): C99types.Pvoid; + +END C99dlfcn. diff --git a/src/i486/linux/C99/Mod/errno.cp b/src/i486/linux/C99/Mod/errno.cp new file mode 100644 index 0000000..3646dff --- /dev/null +++ b/src/i486/linux/C99/Mod/errno.cp @@ -0,0 +1,123 @@ +MODULE C99errno ['libc.so.6']; + + (* generated by genposix.sh, do not modify *) + + IMPORT SYSTEM, C99types; + + TYPE + char* = C99types.char; + signed_char* = C99types.signed_char; + unsigned_char* = C99types.unsigned_char; + short* = C99types.short; + short_int* = C99types.short_int; + signed_short* = C99types.signed_short; + signed_short_int* = C99types.signed_short_int; + unsigned_short* = C99types.unsigned_short; + unsigned_short_int* = C99types.unsigned_short_int; + int* = C99types.int; + signed* = C99types.signed; + signed_int* = C99types.signed_int; + unsigned* = C99types.unsigned; + unsigned_int* = C99types.unsigned_int; + long* = C99types.long; + long_int* = C99types.long_int; + signed_long* = C99types.signed_long; + signed_long_int* = C99types.signed_long_int; + unsigned_long* = C99types.unsigned_long; + unsigned_long_int* = C99types.unsigned_long_int; + long_long* = C99types.long_long; + long_long_int* = C99types.long_long_int; + signed_long_long* = C99types.signed_long_long; + signed_long_long_int* = C99types.signed_long_long_int; + unsigned_long_long* = C99types.unsigned_long_long; + unsigned_long_long_int* = C99types.unsigned_long_long_int; + float* = C99types.float; + double* = C99types.double; + long_double* = C99types.long_double; + + CONST + E2BIG* = 7; + EACCES* = 13; + EADDRINUSE* = 98; + EADDRNOTAVAIL* = 99; + EAFNOSUPPORT* = 97; + EAGAIN* = 11; + EALREADY* = 114; + EBADF* = 9; + EBADMSG* = 74; + EBUSY* = 16; + ECANCELED* = 125; + ECHILD* = 10; + ECONNABORTED* = 103; + ECONNREFUSED* = 111; + ECONNRESET* = 104; + EDEADLK* = 35; + EDESTADDRREQ* = 89; + EDOM* = 33; + EDQUOT* = 122; + EEXIST* = 17; + EFAULT* = 14; + EFBIG* = 27; + EHOSTUNREACH* = 113; + EIDRM* = 43; + EILSEQ* = 84; + EINPROGRESS* = 115; + EINTR* = 4; + EINVAL* = 22; + EIO* = 5; + EISCONN* = 106; + EISDIR* = 21; + ELOOP* = 40; + EMFILE* = 24; + EMLINK* = 31; + EMSGSIZE* = 90; + EMULTIHOP* = 72; + ENAMETOOLONG* = 36; + ENETDOWN* = 100; + ENETRESET* = 102; + ENETUNREACH* = 101; + ENFILE* = 23; + ENOBUFS* = 105; + ENODATA* = 61; + ENODEV* = 19; + ENOENT* = 2; + ENOEXEC* = 8; + ENOLCK* = 37; + ENOLINK* = 67; + ENOMEM* = 12; + ENOMSG* = 42; + ENOPROTOOPT* = 92; + ENOSPC* = 28; + ENOSR* = 63; + ENOSTR* = 60; + ENOSYS* = 38; + ENOTCONN* = 107; + ENOTDIR* = 20; + ENOTEMPTY* = 39; + ENOTRECOVERABLE* = 131; + ENOTSOCK* = 88; + ENOTSUP* = 95; + ENOTTY* = 25; + ENXIO* = 6; + EOPNOTSUPP* = 95; + EOVERFLOW* = 75; + EOWNERDEAD* = 130; + EPERM* = 1; + EPIPE* = 32; + EPROTO* = 71; + EPROTONOSUPPORT* = 93; + EPROTOTYPE* = 91; + ERANGE* = 34; + EROFS* = 30; + ESPIPE* = 29; + ESRCH* = 3; + ESTALE* = 116; + ETIME* = 62; + ETIMEDOUT* = 110; + ETXTBSY* = 26; + EWOULDBLOCK* = 11; + EXDEV* = 18; + + PROCEDURE [ccall] __errno_location* (): POINTER TO ARRAY [untagged] 1 OF int; + +END C99errno. diff --git a/src/i486/linux/C99/Mod/fcntl.cp b/src/i486/linux/C99/Mod/fcntl.cp new file mode 100644 index 0000000..1402977 --- /dev/null +++ b/src/i486/linux/C99/Mod/fcntl.cp @@ -0,0 +1,119 @@ +MODULE C99fcntl ['libc.so.6']; + + (* generated by genposix.sh, do not modify *) + + IMPORT SYSTEM, C99types, C99sys_types; + + TYPE + char* = C99types.char; + signed_char* = C99types.signed_char; + unsigned_char* = C99types.unsigned_char; + short* = C99types.short; + short_int* = C99types.short_int; + signed_short* = C99types.signed_short; + signed_short_int* = C99types.signed_short_int; + unsigned_short* = C99types.unsigned_short; + unsigned_short_int* = C99types.unsigned_short_int; + int* = C99types.int; + signed* = C99types.signed; + signed_int* = C99types.signed_int; + unsigned* = C99types.unsigned; + unsigned_int* = C99types.unsigned_int; + long* = C99types.long; + long_int* = C99types.long_int; + signed_long* = C99types.signed_long; + signed_long_int* = C99types.signed_long_int; + unsigned_long* = C99types.unsigned_long; + unsigned_long_int* = C99types.unsigned_long_int; + long_long* = C99types.long_long; + long_long_int* = C99types.long_long_int; + signed_long_long* = C99types.signed_long_long; + signed_long_long_int* = C99types.signed_long_long_int; + unsigned_long_long* = C99types.unsigned_long_long; + unsigned_long_long_int* = C99types.unsigned_long_long_int; + float* = C99types.float; + double* = C99types.double; + long_double* = C99types.long_double; + + CONST + F_DUPFD* = 0; + F_DUPFD_CLOEXEC* = 1030; + F_GETFD* = 1; + F_SETFD* = 2; + F_GETFL* = 3; + F_SETFL* = 4; + F_GETLK* = 5; + F_SETLK* = 6; + F_SETLKW* = 7; + F_GETOWN* = 9; + F_SETOWN* = 8; + + CONST + FD_CLOEXEC* = 1; + + CONST + F_RDLCK* = 0; + F_UNLCK* = 2; + F_WRLCK* = 1; + + CONST + SEEK_SET* = 0; + SEEK_CUR* = 1; + SEEK_END* = 2; + + CONST + O_CLOEXEC* = 524288; + O_CREAT* = 64; + O_DIRECTORY* = 65536; + O_EXCL* = 128; + O_NOCTTY* = 256; + O_NOFOLLOW* = 131072; + O_TRUNC* = 512; + O_APPEND* = 1024; + O_DSYNC* = 4096; + O_NONBLOCK* = 2048; + O_RSYNC* = 1052672; + O_SYNC* = 1052672; + O_ACCMODE* = 3; + O_RDONLY* = 0; + O_RDWR* = 2; + O_WRONLY* = 1; + + CONST + AT_FDCWD* = -100; + AT_EACCESS* = 512; + AT_SYMLINK_NOFOLLOW* = 256; + AT_SYMLINK_FOLLOW* = 1024; + AT_REMOVEDIR* = 512; + + CONST + POSIX_FADV_DONTNEED* = 4; + POSIX_FADV_NOREUSE* = 5; + POSIX_FADV_NORMAL* = 0; + POSIX_FADV_RANDOM* = 1; + POSIX_FADV_SEQUENTIAL* = 2; + POSIX_FADV_WILLNEED* = 3; + + TYPE + Pstruct_flock* = POINTER TO struct_flock; + struct_flock* = RECORD [noalign] (* 16 *) + l_type*: short; (* 0+2 *) + l_whence*: short; (* 2+2 *) + l_start*: off_t; (* 4+4 *) + l_len*: off_t; (* 8+4 *) + l_pid*: pid_t; (* 12+4 *) + END; + + TYPE + mode_t* = C99sys_types.mode_t; + off_t* = C99sys_types.off_t; + pid_t* = C99sys_types.pid_t; + + PROCEDURE [ccall] creat* (IN pathname: ARRAY [untagged] OF SHORTCHAR; mode: mode_t): int; + PROCEDURE [ccall] fcntl* (fildes, cmd, arg: int): int; + PROCEDURE [ccall] open* (IN pathname: ARRAY [untagged] OF SHORTCHAR; flags: int; mode: mode_t): int; + PROCEDURE [ccall] openat* (fddir: int; IN pathname: ARRAY [untagged] OF SHORTCHAR; flags: int; mode: mode_t): int; + PROCEDURE [ccall] posix_fadvise* (fd: int; offset, len: off_t; advice: int): int; + PROCEDURE [ccall] posix_fallocate* (fd: int; offset, len: off_t): int; + +END C99fcntl. diff --git a/src/i486/linux/C99/Mod/iconv.cp b/src/i486/linux/C99/Mod/iconv.cp new file mode 100644 index 0000000..4726629 --- /dev/null +++ b/src/i486/linux/C99/Mod/iconv.cp @@ -0,0 +1,48 @@ +MODULE C99iconv ['libc.so.6']; + + (* generated by genposix.sh, do not modify *) + + IMPORT SYSTEM, C99types, C99sys_types; + + TYPE + char* = C99types.char; + signed_char* = C99types.signed_char; + unsigned_char* = C99types.unsigned_char; + short* = C99types.short; + short_int* = C99types.short_int; + signed_short* = C99types.signed_short; + signed_short_int* = C99types.signed_short_int; + unsigned_short* = C99types.unsigned_short; + unsigned_short_int* = C99types.unsigned_short_int; + int* = C99types.int; + signed* = C99types.signed; + signed_int* = C99types.signed_int; + unsigned* = C99types.unsigned; + unsigned_int* = C99types.unsigned_int; + long* = C99types.long; + long_int* = C99types.long_int; + signed_long* = C99types.signed_long; + signed_long_int* = C99types.signed_long_int; + unsigned_long* = C99types.unsigned_long; + unsigned_long_int* = C99types.unsigned_long_int; + long_long* = C99types.long_long; + long_long_int* = C99types.long_long_int; + signed_long_long* = C99types.signed_long_long; + signed_long_long_int* = C99types.signed_long_long_int; + unsigned_long_long* = C99types.unsigned_long_long; + unsigned_long_long_int* = C99types.unsigned_long_long_int; + float* = C99types.float; + double* = C99types.double; + long_double* = C99types.long_double; + + TYPE + iconv_t* = INTEGER; + + TYPE + size_t* = C99sys_types.size_t; + + PROCEDURE [ccall] iconv* (cd: iconv_t; VAR [nil] inbuf: C99types.Pvoid; VAR inbytesleft: size_t; VAR [nil] outbuf: C99types.Pvoid; VAR outbytesleft: size_t): size_t; + PROCEDURE [ccall] iconv_open* (IN tocode, fromcode: ARRAY [untagged] OF SHORTCHAR): iconv_t; + PROCEDURE [ccall] iconv_close* (cd: iconv_t): int; + +END C99iconv. diff --git a/src/i486/linux/C99/Mod/libgen.cp b/src/i486/linux/C99/Mod/libgen.cp new file mode 100644 index 0000000..32ab7c9 --- /dev/null +++ b/src/i486/linux/C99/Mod/libgen.cp @@ -0,0 +1,41 @@ +MODULE C99libgen ['libc.so.6']; + + (* generated by genposix.sh, do not modify *) + + IMPORT SYSTEM, C99types; + + TYPE + char* = C99types.char; + signed_char* = C99types.signed_char; + unsigned_char* = C99types.unsigned_char; + short* = C99types.short; + short_int* = C99types.short_int; + signed_short* = C99types.signed_short; + signed_short_int* = C99types.signed_short_int; + unsigned_short* = C99types.unsigned_short; + unsigned_short_int* = C99types.unsigned_short_int; + int* = C99types.int; + signed* = C99types.signed; + signed_int* = C99types.signed_int; + unsigned* = C99types.unsigned; + unsigned_int* = C99types.unsigned_int; + long* = C99types.long; + long_int* = C99types.long_int; + signed_long* = C99types.signed_long; + signed_long_int* = C99types.signed_long_int; + unsigned_long* = C99types.unsigned_long; + unsigned_long_int* = C99types.unsigned_long_int; + long_long* = C99types.long_long; + long_long_int* = C99types.long_long_int; + signed_long_long* = C99types.signed_long_long; + signed_long_long_int* = C99types.signed_long_long_int; + unsigned_long_long* = C99types.unsigned_long_long; + unsigned_long_long_int* = C99types.unsigned_long_long_int; + float* = C99types.float; + double* = C99types.double; + long_double* = C99types.long_double; + + PROCEDURE [ccall] basename* (path: POINTER TO ARRAY [untagged] OF SHORTCHAR): POINTER TO ARRAY [untagged] OF SHORTCHAR; + PROCEDURE [ccall] dirname* (path: POINTER TO ARRAY [untagged] OF SHORTCHAR): POINTER TO ARRAY [untagged] OF SHORTCHAR; + +END C99libgen. diff --git a/src/i486/linux/C99/Mod/locale.cp b/src/i486/linux/C99/Mod/locale.cp new file mode 100644 index 0000000..376d726 --- /dev/null +++ b/src/i486/linux/C99/Mod/locale.cp @@ -0,0 +1,75 @@ +MODULE C99locale ['libc.so.6']; + + (* generated by genposix.sh, do not modify *) + + IMPORT SYSTEM, C99types; + + TYPE + char* = C99types.char; + signed_char* = C99types.signed_char; + unsigned_char* = C99types.unsigned_char; + short* = C99types.short; + short_int* = C99types.short_int; + signed_short* = C99types.signed_short; + signed_short_int* = C99types.signed_short_int; + unsigned_short* = C99types.unsigned_short; + unsigned_short_int* = C99types.unsigned_short_int; + int* = C99types.int; + signed* = C99types.signed; + signed_int* = C99types.signed_int; + unsigned* = C99types.unsigned; + unsigned_int* = C99types.unsigned_int; + long* = C99types.long; + long_int* = C99types.long_int; + signed_long* = C99types.signed_long; + signed_long_int* = C99types.signed_long_int; + unsigned_long* = C99types.unsigned_long; + unsigned_long_int* = C99types.unsigned_long_int; + long_long* = C99types.long_long; + long_long_int* = C99types.long_long_int; + signed_long_long* = C99types.signed_long_long; + signed_long_long_int* = C99types.signed_long_long_int; + unsigned_long_long* = C99types.unsigned_long_long; + unsigned_long_long_int* = C99types.unsigned_long_long_int; + float* = C99types.float; + double* = C99types.double; + long_double* = C99types.long_double; + + TYPE + Pstruct_lconv* = POINTER TO struct_lconv; + struct_lconv = LIMITED RECORD [untagged] END; + + CONST + LC_ALL* = 6; + LC_COLLATE* = 3; + LC_CTYPE* = 0; + LC_MESSAGES* = 5; + LC_MONETARY* = 4; + LC_NUMERIC* = 1; + LC_TIME* = 2; + + CONST + LC_COLLATE_MASK* = 8; + LC_CTYPE_MASK* = 1; + LC_MESSAGES_MASK* = 32; + LC_MONETARY_MASK* = 16; + LC_NUMERIC_MASK* = 2; + LC_TIME_MASK* = 4; + + CONST + LC_ALL_MASK* = 8127; + + CONST + LC_GLOBAL_LOCALE* = -1; + + TYPE + locale_t* = INTEGER; + + PROCEDURE [ccall] duplocale* (locobj: locale_t): locale_t; + PROCEDURE [ccall] freelocale* (locobj: locale_t); + PROCEDURE [ccall] localeconv* (): Pstruct_lconv; + PROCEDURE [ccall] newlocale* (category_mask: int; IN locale: ARRAY [untagged] OF SHORTCHAR; base: locale_t): locale_t; + PROCEDURE [ccall] setlocale* (category: int; IN [nil] locale: ARRAY [untagged] OF SHORTCHAR): POINTER TO ARRAY [untagged] OF SHORTCHAR; + PROCEDURE [ccall] uselocale* (newloc: locale_t): locale_t; + +END C99locale. diff --git a/src/i486/linux/C99/Mod/macro.cp b/src/i486/linux/C99/Mod/macro.cp new file mode 100644 index 0000000..212fbb1 --- /dev/null +++ b/src/i486/linux/C99/Mod/macro.cp @@ -0,0 +1,15 @@ +MODULE C99macro; + + IMPORT SYSTEM, C99errno, C99sys_stat; + + PROCEDURE errno* (): C99errno.int; + BEGIN + RETURN C99errno.__errno_location()[0] + END errno; + + PROCEDURE stat* (IN path: ARRAY [untagged] OF SHORTCHAR; VAR buf: C99sys_stat.struct_stat): C99sys_stat.int; + BEGIN + RETURN C99sys_stat.__xstat(C99sys_stat._STAT_VER, path, buf) + END stat; + +END C99macro. diff --git a/src/i486/linux/C99/Mod/setjmp.cp b/src/i486/linux/C99/Mod/setjmp.cp new file mode 100644 index 0000000..0794ac4 --- /dev/null +++ b/src/i486/linux/C99/Mod/setjmp.cp @@ -0,0 +1,49 @@ +MODULE C99setjmp ['libc.so.6']; + + (* generated by genposix.sh, do not modify *) + + IMPORT SYSTEM, C99types; + + TYPE + char* = C99types.char; + signed_char* = C99types.signed_char; + unsigned_char* = C99types.unsigned_char; + short* = C99types.short; + short_int* = C99types.short_int; + signed_short* = C99types.signed_short; + signed_short_int* = C99types.signed_short_int; + unsigned_short* = C99types.unsigned_short; + unsigned_short_int* = C99types.unsigned_short_int; + int* = C99types.int; + signed* = C99types.signed; + signed_int* = C99types.signed_int; + unsigned* = C99types.unsigned; + unsigned_int* = C99types.unsigned_int; + long* = C99types.long; + long_int* = C99types.long_int; + signed_long* = C99types.signed_long; + signed_long_int* = C99types.signed_long_int; + unsigned_long* = C99types.unsigned_long; + unsigned_long_int* = C99types.unsigned_long_int; + long_long* = C99types.long_long; + long_long_int* = C99types.long_long_int; + signed_long_long* = C99types.signed_long_long; + signed_long_long_int* = C99types.signed_long_long_int; + unsigned_long_long* = C99types.unsigned_long_long; + unsigned_long_long_int* = C99types.unsigned_long_long_int; + float* = C99types.float; + double* = C99types.double; + long_double* = C99types.long_double; + + TYPE + jmp_buf* = ARRAY [untagged] 156 OF BYTE; + sigjmp_buf* = ARRAY [untagged] 156 OF BYTE; + + PROCEDURE [ccall] _longjmp* (IN env: jmp_buf; val: int); + PROCEDURE [ccall] longjmp* (IN env: jmp_buf; val: int); + PROCEDURE [ccall] siglongjmp* (IN env: sigjmp_buf; val: int); + PROCEDURE [ccall] _setjmp* (VAR env: jmp_buf): int; + PROCEDURE [ccall] setjmp* (VAR env: jmp_buf): int; + PROCEDURE [ccall] sigsetjmp* ['__sigsetjmp'] (VAR env: sigjmp_buf; savesigs: int): int; + +END C99setjmp. diff --git a/src/i486/linux/C99/Mod/signal.cp b/src/i486/linux/C99/Mod/signal.cp new file mode 100644 index 0000000..343afcb --- /dev/null +++ b/src/i486/linux/C99/Mod/signal.cp @@ -0,0 +1,316 @@ +MODULE C99signal ['libc.so.6']; + + (* generated by genposix.sh, do not modify *) + + IMPORT SYSTEM, C99types, C99sys_types, C99time; + + TYPE + char* = C99types.char; + signed_char* = C99types.signed_char; + unsigned_char* = C99types.unsigned_char; + short* = C99types.short; + short_int* = C99types.short_int; + signed_short* = C99types.signed_short; + signed_short_int* = C99types.signed_short_int; + unsigned_short* = C99types.unsigned_short; + unsigned_short_int* = C99types.unsigned_short_int; + int* = C99types.int; + signed* = C99types.signed; + signed_int* = C99types.signed_int; + unsigned* = C99types.unsigned; + unsigned_int* = C99types.unsigned_int; + long* = C99types.long; + long_int* = C99types.long_int; + signed_long* = C99types.signed_long; + signed_long_int* = C99types.signed_long_int; + unsigned_long* = C99types.unsigned_long; + unsigned_long_int* = C99types.unsigned_long_int; + long_long* = C99types.long_long; + long_long_int* = C99types.long_long_int; + signed_long_long* = C99types.signed_long_long; + signed_long_long_int* = C99types.signed_long_long_int; + unsigned_long_long* = C99types.unsigned_long_long; + unsigned_long_long_int* = C99types.unsigned_long_long_int; + float* = C99types.float; + double* = C99types.double; + long_double* = C99types.long_double; + + CONST + SIG_DFL* = 0; + SIG_ERR* = -1; + SIG_IGN* = 1; + + TYPE + pthread_t* = C99sys_types.pthread_t; + pthread_attr_t* = C99sys_types.pthread_attr_t; + size_t* = C99sys_types.size_t; + uid_t* = C99sys_types.uid_t; + pid_t* = C99sys_types.pid_t; + + TYPE + struct_timespec* = C99time.struct_timespec; + + TYPE + sig_atomic_t* = INTEGER; + sigset_t* = RECORD [noalign] _: ARRAY [untagged] 128 OF BYTE END; + + TYPE + Pstruct_sigevent* = POINTER TO struct_sigevent; + struct_sigevent* = RECORD [noalign] (* 64 *) + sigev_value*: union_sigval; (* 0+4 *) + sigev_signo*: int; (* 4+4 *) + sigev_notify*: int; (* 8+4 *) + sigev_notify_function*: PROCEDURE [ccall] (x: union_sigval); (* 12+4 *) + _____align0_____: ARRAY 48 OF BYTE; + END; + + CONST + SIGEV_NONE* = 1; + SIGEV_SIGNAL* = 0; + SIGEV_THREAD* = 2; + + TYPE + Punion_sigval* = POINTER TO union_sigval; + union_sigval* = RECORD [union] (* 4 *) + sival_int*: int; (* 0+4 *) + sival_ptr*: C99types.Pvoid; (* 0+4 *) + END; + + CONST + SIGRTMIN* = 34; + SIGRTMAX* = 64; + RTSIG_MAX* = 32; + + CONST + SIGABRT* = 6; + SIGALRM* = 14; + SIGBUS* = 7; + SIGCHLD* = 17; + SIGCONT* = 18; + SIGFPE* = 8; + SIGHUP* = 1; + SIGILL* = 4; + SIGINT* = 2; + SIGKILL* = 9; + SIGPIPE* = 13; + SIGQUIT* = 3; + SIGSEGV* = 11; + SIGSTOP* = 19; + SIGTERM* = 15; + SIGTSTP* = 20; + SIGTTIN* = 21; + SIGTTOU* = 22; + SIGUSR1* = 10; + SIGUSR2* = 12; + SIGPOLL* = 29; + SIGPROF* = 27; + SIGSYS* = 31; + SIGTRAP* = 5; + SIGURG* = 23; + SIGVTALRM* = 26; + SIGXCPU* = 24; + SIGXFSZ* = 25; + + TYPE + Pstruct_sigaction* = POINTER TO struct_sigaction; + struct_sigaction* = RECORD [noalign] (* 140 *) + handler*: RECORD [union] (* 4 *) + sa_handler*: PROCEDURE [ccall] (sig: int); (* 0+4 *) + sa_sigaction*: PROCEDURE [ccall] (sig: int; IN siginfo: siginfo_t; context: C99types.Pvoid); (* 0+4 *) + END; (* 0+4 *) + sa_mask*: sigset_t; (* 4+128 *) + sa_flags*: int; (* 132+4 *) + _____align0_____: ARRAY 4 OF BYTE; + END; + + CONST + SIG_BLOCK* = 0; + SIG_UNBLOCK* = 1; + SIG_SETMASK* = 2; + + CONST + SA_NOCLDSTOP* = 1; + SA_ONSTACK* = 134217728; + SA_RESETHAND* = -2147483648; + SA_RESTART* = 268435456; + SA_SIGINFO* = 4; + SA_NOCLDWAIT* = 2; + SA_NODEFER* = 1073741824; + SS_ONSTACK* = 1; + SS_DISABLE* = 2; + MINSIGSTKSZ* = 2048; + SIGSTKSZ* = 8192; + + CONST + __NGREG* = 19; + + TYPE + greg_t* = INTEGER; + + TYPE gregset_t* = ARRAY [untagged] __NGREG OF greg_t; + + TYPE + Pstruct__libc_fpreg* = POINTER TO struct__libc_fpreg; + struct__libc_fpreg* = RECORD [noalign] (* 10 *) + significand*: INTEGER; (* 0+8 *) + exponent*: unsigned_short_int; (* 8+2 *) + END; + + TYPE + Pstruct__libc_fpstate* = POINTER TO struct__libc_fpstate; + struct__libc_fpstate* = RECORD [noalign] (* 112 *) + cw*: unsigned_long_int; (* 0+4 *) + sw*: unsigned_long_int; (* 4+4 *) + tag*: unsigned_long_int; (* 8+4 *) + ipoff*: unsigned_long_int; (* 12+4 *) + cssel*: unsigned_long_int; (* 16+4 *) + dataoff*: unsigned_long_int; (* 20+4 *) + datasel*: unsigned_long_int; (* 24+4 *) + _st*: ARRAY [untagged] 8 OF struct__libc_fpreg; (* 28+80 *) + status*: unsigned_long_int; (* 108+4 *) + END; + + TYPE fpregset_t* = Pstruct__libc_fpstate; + + TYPE + Pmcontext_t* = POINTER TO mcontext_t; + mcontext_t* = RECORD [noalign] (* 88 *) + gregs*: gregset_t; (* 0+76 *) + fpregs*: fpregset_t; (* 76+4 *) + oldmask*: unsigned_long_int; (* 80+4 *) + cr2*: unsigned_long_int; (* 84+4 *) + END; + + TYPE + Pucontext_t* = POINTER TO ucontext_t; + ucontext_t* = RECORD [noalign] (* 348 *) + uc_flags*: unsigned_long_int; (* 0+4 *) + uc_link*: Pucontext_t; (* 4+4 *) + uc_stack*: stack_t; (* 8+12 *) + uc_mcontext*: mcontext_t; (* 20+88 *) + uc_sigmask*: sigset_t; (* 108+128 *) + __fpregs_mem*: struct__libc_fpstate; (* 236+112 *) + END; + + TYPE + Pstack_t* = POINTER TO stack_t; + stack_t* = RECORD [noalign] (* 12 *) + ss_sp*: C99types.Pvoid; (* 0+4 *) + ss_flags*: int; (* 4+4 *) + ss_size*: size_t; (* 8+4 *) + END; + + TYPE + Psiginfo_t* = POINTER TO siginfo_t; + siginfo_t* = RECORD [noalign] (* 128 *) + si_signo*: int; (* 0+4 *) + si_errno*: int; (* 4+4 *) + si_code*: int; (* 8+4 *) + info*: RECORD [union] (* 12 *) + sigill*: RECORD [noalign] (* 4 *) + si_addr*: C99types.Pvoid; (* 0+4 *) + END; (* 0+4 *) + sigfpe*: RECORD [noalign] (* 4 *) + si_addr*: C99types.Pvoid; (* 0+4 *) + END; (* 0+4 *) + sigsegv*: RECORD [noalign] (* 4 *) + si_addr*: C99types.Pvoid; (* 0+4 *) + END; (* 0+4 *) + sigbus*: RECORD [noalign] (* 4 *) + si_addr*: C99types.Pvoid; (* 0+4 *) + END; (* 0+4 *) + sigchld*: RECORD [noalign] (* 12 *) + si_pid*: pid_t; (* 0+4 *) + si_uid*: uid_t; (* 4+4 *) + si_status*: int; (* 8+4 *) + END; (* 0+12 *) + sigpoll*: RECORD [noalign] (* 4 *) + si_band*: long; (* 0+4 *) + END; (* 0+4 *) + other*: RECORD [noalign] (* 4 *) + si_value*: union_sigval; (* 0+4 *) + END; (* 8+4 *) + END; (* 12+12 *) + _____align0_____: ARRAY 104 OF BYTE; + END; + + CONST + ILL_ILLOPC* = 1; + ILL_ILLOPN* = 2; + ILL_ILLADR* = 3; + ILL_ILLTRP* = 4; + ILL_PRVOPC* = 5; + ILL_PRVREG* = 6; + ILL_COPROC* = 7; + ILL_BADSTK* = 8; + + CONST + FPE_INTDIV* = 1; + FPE_INTOVF* = 2; + FPE_FLTDIV* = 3; + FPE_FLTOVF* = 4; + FPE_FLTUND* = 5; + FPE_FLTRES* = 6; + FPE_FLTINV* = 7; + FPE_FLTSUB* = 8; + + CONST + SEGV_MAPERR* = 1; + SEGV_ACCERR* = 2; + + CONST + BUS_ADRALN* = 1; + BUS_ADRERR* = 2; + BUS_OBJERR* = 3; + + CONST + CLD_EXITED* = 1; + CLD_KILLED* = 2; + CLD_DUMPED* = 3; + CLD_TRAPPED* = 4; + CLD_STOPPED* = 5; + CLD_CONTINUED* = 6; + + CONST + POLL_IN* = 1; + POLL_OUT* = 2; + POLL_MSG* = 3; + POLL_ERR* = 4; + POLL_PRI* = 5; + POLL_HUP* = 6; + + CONST + SI_USER* = 0; + SI_QUEUE* = -1; + SI_TIMER* = -2; + SI_ASYNCIO* = -4; + SI_MESGQ* = -3; + + PROCEDURE [ccall] kill* (pid: pid_t; sig: int): int; + PROCEDURE [ccall] killpg* (pgrp, sig: int): int; + PROCEDURE [ccall] psiginfo* (IN pinfo: siginfo_t; IN [nil] s: ARRAY [untagged] OF SHORTCHAR); + PROCEDURE [ccall] psignal* (sig: int; IN [nil] s: ARRAY [untagged] OF SHORTCHAR); + PROCEDURE [ccall] pthread_kill* (thread: pthread_t; sig: int): int; + PROCEDURE [ccall] pthread_sigmask* (how: int; IN [nil] set: sigset_t; VAR [nil] oldset: sigset_t): int; + PROCEDURE [ccall] raise* (sig: int): int; + PROCEDURE [ccall] sigaction* (sig: int; IN [nil] act: struct_sigaction; VAR [nil] oact: struct_sigaction): int; + PROCEDURE [ccall] sigaddset* (VAR set: sigset_t; signum: int): int; + PROCEDURE [ccall] sigaltstack* (IN [nil] ss: stack_t; VAR [nil] oss: stack_t): int; + PROCEDURE [ccall] sigdelset* (VAR set: sigset_t; signum: int): int; + PROCEDURE [ccall] sigemptyset* (VAR set: sigset_t): int; + PROCEDURE [ccall] sigfillset* (VAR set: sigset_t): int; + PROCEDURE [ccall] sighold* (sig: int): int; + PROCEDURE [ccall] sigignore* (sig: int): int; + PROCEDURE [ccall] siginterrupt* (sig, flag: int): int; + PROCEDURE [ccall] sigismember* (IN set: sigset_t; signum: int): int; + PROCEDURE [ccall] sigpause* (sig: int): int; + PROCEDURE [ccall] sigpending* (VAR set: sigset_t): int; + PROCEDURE [ccall] sigprocmask* (how: int; IN [nil] set: sigset_t; VAR [nil] oset: sigset_t): int; + PROCEDURE [ccall] sigqueue* (pid: pid_t; sig: int; IN value: union_sigval): int; + PROCEDURE [ccall] sigrelse* (sig: int): int; + PROCEDURE [ccall] sigsuspend* (IN sigmask: sigset_t): int; + PROCEDURE [ccall] sigtimedwait* (IN set: sigset_t; VAR [nil] info: siginfo_t; IN timeout: struct_timespec): int; + PROCEDURE [ccall] sigwait* (IN set: sigset_t; VAR sig: int): int; + PROCEDURE [ccall] sigwaitinfo* (IN set: sigset_t; VAR [nil] info: siginfo_t): int; + +END C99signal. diff --git a/src/i486/linux/C99/Mod/stdio.cp b/src/i486/linux/C99/Mod/stdio.cp new file mode 100644 index 0000000..a39efb0 --- /dev/null +++ b/src/i486/linux/C99/Mod/stdio.cp @@ -0,0 +1,91 @@ +MODULE C99stdio ['libc.so.6']; + + (* generated by genposix.sh, do not modify *) + + IMPORT SYSTEM, C99types, C99sys_types; + + TYPE + char* = C99types.char; + signed_char* = C99types.signed_char; + unsigned_char* = C99types.unsigned_char; + short* = C99types.short; + short_int* = C99types.short_int; + signed_short* = C99types.signed_short; + signed_short_int* = C99types.signed_short_int; + unsigned_short* = C99types.unsigned_short; + unsigned_short_int* = C99types.unsigned_short_int; + int* = C99types.int; + signed* = C99types.signed; + signed_int* = C99types.signed_int; + unsigned* = C99types.unsigned; + unsigned_int* = C99types.unsigned_int; + long* = C99types.long; + long_int* = C99types.long_int; + signed_long* = C99types.signed_long; + signed_long_int* = C99types.signed_long_int; + unsigned_long* = C99types.unsigned_long; + unsigned_long_int* = C99types.unsigned_long_int; + long_long* = C99types.long_long; + long_long_int* = C99types.long_long_int; + signed_long_long* = C99types.signed_long_long; + signed_long_long_int* = C99types.signed_long_long_int; + unsigned_long_long* = C99types.unsigned_long_long; + unsigned_long_long_int* = C99types.unsigned_long_long_int; + float* = C99types.float; + double* = C99types.double; + long_double* = C99types.long_double; + + TYPE + PFILE* = POINTER TO FILE; + FILE = LIMITED RECORD [untagged] END; + + TYPE + fpos_t* = RECORD [noalign] _: ARRAY [untagged] 12 OF BYTE END; + + TYPE + off_t* = C99sys_types.off_t; + ssize_t* = C99sys_types.ssize_t; + + TYPE + size_t* = INTEGER; + + TYPE + va_list* = INTEGER; + + CONST + BUFSIZ* = 8192; + L_ctermid* = 9; + L_tmpnam* = 20; + + CONST + _IOFBF* = 0; + _IOLBF* = 1; + _IONBF* = 2; + + CONST + SEEK_CUR* = 1; + SEEK_END* = 2; + SEEK_SET* = 0; + + CONST + FILENAME_MAX* = 4096; + FOPEN_MAX* = 16; + TMP_MAX* = 238328; + + CONST + EOF* = -1; + + PROCEDURE [ccall] fclose* (stream: PFILE): int; + PROCEDURE [ccall] ferror* (stream: PFILE): int; + PROCEDURE [ccall] fflush* (stream: PFILE): int; + PROCEDURE [ccall] fopen* (IN pathname, mode: ARRAY [untagged] OF SHORTCHAR): PFILE; + PROCEDURE [ccall] fread* (ptr: C99types.Pvoid; size, n: size_t; stream: PFILE): size_t; + PROCEDURE [ccall] fseek* (stream: PFILE; offset: long; whence: int): int; + PROCEDURE [ccall] ftell* (stream: PFILE): long; + PROCEDURE [ccall] fwrite* (ptr: C99types.Pvoid; size, n: size_t; stream: PFILE): size_t; + PROCEDURE [ccall] feof* (stream: PFILE): int; + PROCEDURE [ccall] remove* (IN pathname: ARRAY [untagged] OF SHORTCHAR): int; + PROCEDURE [ccall] rename* (IN old, new: ARRAY [untagged] OF SHORTCHAR): int; + PROCEDURE [ccall] tmpfile* (): PFILE; + +END C99stdio. diff --git a/src/i486/linux/C99/Mod/stdlib.cp b/src/i486/linux/C99/Mod/stdlib.cp new file mode 100644 index 0000000..cde4dd2 --- /dev/null +++ b/src/i486/linux/C99/Mod/stdlib.cp @@ -0,0 +1,66 @@ +MODULE C99stdlib ['libc.so.6']; + + (* generated by genposix.sh, do not modify *) + + IMPORT SYSTEM, C99types; + + TYPE + char* = C99types.char; + signed_char* = C99types.signed_char; + unsigned_char* = C99types.unsigned_char; + short* = C99types.short; + short_int* = C99types.short_int; + signed_short* = C99types.signed_short; + signed_short_int* = C99types.signed_short_int; + unsigned_short* = C99types.unsigned_short; + unsigned_short_int* = C99types.unsigned_short_int; + int* = C99types.int; + signed* = C99types.signed; + signed_int* = C99types.signed_int; + unsigned* = C99types.unsigned; + unsigned_int* = C99types.unsigned_int; + long* = C99types.long; + long_int* = C99types.long_int; + signed_long* = C99types.signed_long; + signed_long_int* = C99types.signed_long_int; + unsigned_long* = C99types.unsigned_long; + unsigned_long_int* = C99types.unsigned_long_int; + long_long* = C99types.long_long; + long_long_int* = C99types.long_long_int; + signed_long_long* = C99types.signed_long_long; + signed_long_long_int* = C99types.signed_long_long_int; + unsigned_long_long* = C99types.unsigned_long_long; + unsigned_long_long_int* = C99types.unsigned_long_long_int; + float* = C99types.float; + double* = C99types.double; + long_double* = C99types.long_double; + + CONST + EXIT_FAILURE* = 1; + EXIT_SUCCESS* = 0; + RAND_MAX* = 2147483647; + + CONST + MB_CUR_MAX* = 1; + + TYPE + div_t* = RECORD [noalign] _: ARRAY [untagged] 8 OF BYTE END; + ldiv_t* = RECORD [noalign] _: ARRAY [untagged] 8 OF BYTE END; + lldiv_t* = RECORD [noalign] _: ARRAY [untagged] 16 OF BYTE END; + + TYPE + size_t* = INTEGER; + wchar_t* = INTEGER; + + PROCEDURE [ccall] _Exit* (status: int); + PROCEDURE [ccall] abort* ; + PROCEDURE [ccall] atexit* (function: PROCEDURE [ccall]): int; + PROCEDURE [ccall] exit* (status: int); + PROCEDURE [ccall] free* (ptr: C99types.Pvoid); + PROCEDURE [ccall] getenv* (IN name: ARRAY [untagged] OF SHORTCHAR): POINTER TO ARRAY [untagged] OF SHORTCHAR; + PROCEDURE [ccall] malloc* (size: size_t): C99types.Pvoid; + PROCEDURE [ccall] system* (IN command: ARRAY [untagged] OF SHORTCHAR): int; + PROCEDURE [ccall] mkstemp* (VAR template: ARRAY [untagged] OF SHORTCHAR): int; + PROCEDURE [ccall] realpath* (IN path: ARRAY [untagged] OF SHORTCHAR; VAR [nil] resolved_path: ARRAY [untagged] OF SHORTCHAR): POINTER TO ARRAY [untagged] OF SHORTCHAR; + +END C99stdlib. diff --git a/src/i486/linux/C99/Mod/sys_mman.cp b/src/i486/linux/C99/Mod/sys_mman.cp new file mode 100644 index 0000000..4e08026 --- /dev/null +++ b/src/i486/linux/C99/Mod/sys_mman.cp @@ -0,0 +1,86 @@ +MODULE C99sys_mman ['libc.so.6']; + + (* generated by genposix.sh, do not modify *) + + IMPORT SYSTEM, C99types, C99sys_types; + + TYPE + char* = C99types.char; + signed_char* = C99types.signed_char; + unsigned_char* = C99types.unsigned_char; + short* = C99types.short; + short_int* = C99types.short_int; + signed_short* = C99types.signed_short; + signed_short_int* = C99types.signed_short_int; + unsigned_short* = C99types.unsigned_short; + unsigned_short_int* = C99types.unsigned_short_int; + int* = C99types.int; + signed* = C99types.signed; + signed_int* = C99types.signed_int; + unsigned* = C99types.unsigned; + unsigned_int* = C99types.unsigned_int; + long* = C99types.long; + long_int* = C99types.long_int; + signed_long* = C99types.signed_long; + signed_long_int* = C99types.signed_long_int; + unsigned_long* = C99types.unsigned_long; + unsigned_long_int* = C99types.unsigned_long_int; + long_long* = C99types.long_long; + long_long_int* = C99types.long_long_int; + signed_long_long* = C99types.signed_long_long; + signed_long_long_int* = C99types.signed_long_long_int; + unsigned_long_long* = C99types.unsigned_long_long; + unsigned_long_long_int* = C99types.unsigned_long_long_int; + float* = C99types.float; + double* = C99types.double; + long_double* = C99types.long_double; + + CONST + PROT_EXEC* = 4; + PROT_NONE* = 0; + PROT_READ* = 1; + PROT_WRITE* = 2; + + CONST + MAP_FIXED* = 16; + MAP_PRIVATE* = 2; + MAP_SHARED* = 1; + + CONST + MS_ASYNC* = 1; + MS_INVALIDATE* = 2; + MS_SYNC* = 4; + + CONST + MCL_CURRENT* = 1; + MCL_FUTURE* = 2; + + CONST + MAP_FAILED* = -1; + + CONST + POSIX_MADV_DONTNEED* = 4; + POSIX_MADV_NORMAL* = 0; + POSIX_MADV_RANDOM* = 1; + POSIX_MADV_SEQUENTIAL* = 2; + POSIX_MADV_WILLNEED* = 3; + + TYPE + mode_t* = C99sys_types.mode_t; + off_t* = C99sys_types.off_t; + size_t* = C99sys_types.size_t; + + PROCEDURE [ccall] mlock* (addr: C99types.Pvoid; len: size_t): int; + PROCEDURE [ccall] mlockall* (flags: int): int; + PROCEDURE [ccall] mmap* (addr: C99types.Pvoid; len: size_t; prot, flags, fildes: int; off: off_t): C99types.Pvoid; + PROCEDURE [ccall] mprotect* (addr: C99types.Pvoid; len: size_t; prot: int): int; + PROCEDURE [ccall] msync* (addr: C99types.Pvoid; len: size_t; flags: int): int; + PROCEDURE [ccall] munlock* (addr: C99types.Pvoid; len: size_t): int; + PROCEDURE [ccall] munlockall* (): int; + PROCEDURE [ccall] munmap* (addr: C99types.Pvoid; len: size_t): int; + PROCEDURE [ccall] posix_madvise* (addr: C99types.Pvoid; len: size_t; advice: int): int; + PROCEDURE [ccall] posix_mem_offset* (addr: C99types.Pvoid; len: size_t; VAR off: off_t; VAR contng_len: size_t; VAR fildes: int): int; + PROCEDURE [ccall] shm_open* (IN name: ARRAY [untagged] OF SHORTCHAR; oflag, mode: int): int; + PROCEDURE [ccall] shm_unlink* (IN name: ARRAY [untagged] OF SHORTCHAR): int; + +END C99sys_mman. diff --git a/src/i486/linux/C99/Mod/sys_stat.cp b/src/i486/linux/C99/Mod/sys_stat.cp new file mode 100644 index 0000000..a0b745b --- /dev/null +++ b/src/i486/linux/C99/Mod/sys_stat.cp @@ -0,0 +1,125 @@ +MODULE C99sys_stat ['libc.so.6']; + + (* generated by genposix.sh, do not modify *) + + IMPORT SYSTEM, C99types, C99time, C99sys_types; + + TYPE + char* = C99types.char; + signed_char* = C99types.signed_char; + unsigned_char* = C99types.unsigned_char; + short* = C99types.short; + short_int* = C99types.short_int; + signed_short* = C99types.signed_short; + signed_short_int* = C99types.signed_short_int; + unsigned_short* = C99types.unsigned_short; + unsigned_short_int* = C99types.unsigned_short_int; + int* = C99types.int; + signed* = C99types.signed; + signed_int* = C99types.signed_int; + unsigned* = C99types.unsigned; + unsigned_int* = C99types.unsigned_int; + long* = C99types.long; + long_int* = C99types.long_int; + signed_long* = C99types.signed_long; + signed_long_int* = C99types.signed_long_int; + unsigned_long* = C99types.unsigned_long; + unsigned_long_int* = C99types.unsigned_long_int; + long_long* = C99types.long_long; + long_long_int* = C99types.long_long_int; + signed_long_long* = C99types.signed_long_long; + signed_long_long_int* = C99types.signed_long_long_int; + unsigned_long_long* = C99types.unsigned_long_long; + unsigned_long_long_int* = C99types.unsigned_long_long_int; + float* = C99types.float; + double* = C99types.double; + long_double* = C99types.long_double; + + CONST + S_IFMT* = 61440; + S_IFBLK* = 24576; + S_IFCHR* = 8192; + S_IFIFO* = 4096; + S_IFREG* = 32768; + S_IFDIR* = 16384; + S_IFLNK* = 40960; + S_IFSOCK* = 49152; + + CONST + S_IRWXU* = 448; + S_IRUSR* = 256; + S_IWUSR* = 128; + S_IXUSR* = 64; + S_IRWXG* = 56; + S_IRGRP* = 32; + S_IWGRP* = 16; + S_IXGRP* = 8; + S_IRWXO* = 7; + S_IROTH* = 4; + S_IWOTH* = 2; + S_IXOTH* = 1; + S_ISUID* = 2048; + S_ISGID* = 1024; + S_ISVTX* = 512; + + CONST + UTIME_NOW* = 1073741823; + UTIME_OMIT* = 1073741822; + + TYPE + blkcnt_t* = C99sys_types.blkcnt_t; + blksize_t* = C99sys_types.blksize_t; + dev_t* = C99sys_types.dev_t; + ino_t* = C99sys_types.ino_t; + mode_t* = C99sys_types.mode_t; + nlink_t* = C99sys_types.nlink_t; + uid_t* = C99sys_types.uid_t; + gid_t* = C99sys_types.gid_t; + off_t* = C99sys_types.off_t; + time_t* = C99sys_types.time_t; + + TYPE + struct_timespec* = C99time.struct_timespec; + + TYPE + Pstruct_stat* = POINTER TO struct_stat; + struct_stat* = RECORD [noalign] (* 88 *) + st_dev*: dev_t; (* 0+8 *) + _____align0_____: ARRAY 4 OF BYTE; + st_ino*: ino_t; (* 12+4 *) + st_mode*: mode_t; (* 16+4 *) + st_nlink*: nlink_t; (* 20+4 *) + st_uid*: uid_t; (* 24+4 *) + st_gid*: gid_t; (* 28+4 *) + st_rdev*: dev_t; (* 32+8 *) + _____align1_____: ARRAY 4 OF BYTE; + st_size*: off_t; (* 44+4 *) + st_blksize*: blksize_t; (* 48+4 *) + st_blocks*: blkcnt_t; (* 52+4 *) + st_atim*: struct_timespec; (* 56+8 *) + st_mtim*: struct_timespec; (* 64+8 *) + st_ctim*: struct_timespec; (* 72+8 *) + _____align2_____: ARRAY 8 OF BYTE; + END; + + CONST + _STAT_VER* = 3; + + PROCEDURE [ccall] chmod* (IN path: ARRAY [untagged] OF SHORTCHAR; mode: mode_t): int; + PROCEDURE [ccall] fchmod* (fd: int; IN path: ARRAY [untagged] OF SHORTCHAR; mode: mode_t): int; + PROCEDURE [ccall] fchmodat* (fd: int; IN path: ARRAY [untagged] OF SHORTCHAR; mode: mode_t; flag: int): int; + PROCEDURE [ccall] fstat* (fd: int; VAR buf: struct_stat): int; + PROCEDURE [ccall] fstatat* (fd: int; IN path: ARRAY [untagged] OF SHORTCHAR; VAR buf: struct_stat; flag: int): int; + PROCEDURE [ccall] futimens* (fd: int; IN times: ARRAY [untagged] 2 OF struct_timespec): int; + PROCEDURE [ccall] lstat* (IN path: ARRAY [untagged] OF SHORTCHAR; VAR buf: struct_stat): int; + PROCEDURE [ccall] mkdir* (IN path: ARRAY [untagged] OF SHORTCHAR; mode: mode_t): int; + PROCEDURE [ccall] mkdirat* (fd: int; IN path: ARRAY [untagged] OF SHORTCHAR; mode: mode_t): int; + PROCEDURE [ccall] mkfifo* (IN pathname: ARRAY [untagged] OF SHORTCHAR; mode: mode_t): int; + PROCEDURE [ccall] mkfifoat* (dirfd: int; IN pathname: ARRAY [untagged] OF SHORTCHAR; mode: mode_t): int; + PROCEDURE [ccall] mknod* (IN path: ARRAY [untagged] OF SHORTCHAR; mode: mode_t; dev: dev_t): int; + PROCEDURE [ccall] mknodat* (df: int; IN path: ARRAY [untagged] OF SHORTCHAR; mode: mode_t; dev: dev_t): int; + PROCEDURE [ccall] __xstat* (version: int; IN path: ARRAY [untagged] OF SHORTCHAR; VAR buf: struct_stat): int; + PROCEDURE [ccall] umask* (mode: mode_t): mode_t; + PROCEDURE [ccall] utimensat* (dirfd: int; IN pathname: ARRAY [untagged] OF SHORTCHAR; IN times: ARRAY [untagged] 2 OF struct_timespec; flags: int): int; + +END C99sys_stat. diff --git a/src/i486/linux/C99/Mod/sys_types.cp b/src/i486/linux/C99/Mod/sys_types.cp new file mode 100644 index 0000000..728a8ce --- /dev/null +++ b/src/i486/linux/C99/Mod/sys_types.cp @@ -0,0 +1,75 @@ +MODULE C99sys_types ['libc.so.6']; + + (* generated by genposix.sh, do not modify *) + + IMPORT SYSTEM, C99types; + + TYPE + char* = C99types.char; + signed_char* = C99types.signed_char; + unsigned_char* = C99types.unsigned_char; + short* = C99types.short; + short_int* = C99types.short_int; + signed_short* = C99types.signed_short; + signed_short_int* = C99types.signed_short_int; + unsigned_short* = C99types.unsigned_short; + unsigned_short_int* = C99types.unsigned_short_int; + int* = C99types.int; + signed* = C99types.signed; + signed_int* = C99types.signed_int; + unsigned* = C99types.unsigned; + unsigned_int* = C99types.unsigned_int; + long* = C99types.long; + long_int* = C99types.long_int; + signed_long* = C99types.signed_long; + signed_long_int* = C99types.signed_long_int; + unsigned_long* = C99types.unsigned_long; + unsigned_long_int* = C99types.unsigned_long_int; + long_long* = C99types.long_long; + long_long_int* = C99types.long_long_int; + signed_long_long* = C99types.signed_long_long; + signed_long_long_int* = C99types.signed_long_long_int; + unsigned_long_long* = C99types.unsigned_long_long; + unsigned_long_long_int* = C99types.unsigned_long_long_int; + float* = C99types.float; + double* = C99types.double; + long_double* = C99types.long_double; + + TYPE + blkcnt_t* = INTEGER; + blksize_t* = INTEGER; + clock_t* = INTEGER; + clockid_t* = INTEGER; + dev_t* = LONGINT; + fsblkcnt_t* = INTEGER; + fsfilcnt_t* = INTEGER; + gid_t* = INTEGER; + id_t* = INTEGER; + ino_t* = INTEGER; + key_t* = INTEGER; + mode_t* = INTEGER; + nlink_t* = INTEGER; + off_t* = INTEGER; + pid_t* = INTEGER; + pthread_attr_t* = RECORD [noalign] _: ARRAY [untagged] 36 OF BYTE END; + pthread_barrier_t* = RECORD [noalign] _: ARRAY [untagged] 20 OF BYTE END; + pthread_barrierattr_t* = INTEGER; + pthread_cond_t* = RECORD [noalign] _: ARRAY [untagged] 48 OF BYTE END; + pthread_condattr_t* = INTEGER; + pthread_key_t* = INTEGER; + pthread_mutex_t* = RECORD [noalign] _: ARRAY [untagged] 24 OF BYTE END; + pthread_mutexattr_t* = INTEGER; + pthread_once_t* = INTEGER; + pthread_rwlock_t* = RECORD [noalign] _: ARRAY [untagged] 32 OF BYTE END; + pthread_rwlockattr_t* = RECORD [noalign] _: ARRAY [untagged] 8 OF BYTE END; + pthread_spinlock_t* = INTEGER; + pthread_t* = INTEGER; + size_t* = INTEGER; + ssize_t* = INTEGER; + suseconds_t* = INTEGER; + time_t* = INTEGER; + timer_t* = INTEGER; + uid_t* = INTEGER; + + +END C99sys_types. diff --git a/src/i486/linux/C99/Mod/time.cp b/src/i486/linux/C99/Mod/time.cp new file mode 100644 index 0000000..5ff122e --- /dev/null +++ b/src/i486/linux/C99/Mod/time.cp @@ -0,0 +1,118 @@ +MODULE C99time ['librt.so.1']; + + (* generated by genposix.sh, do not modify *) + + IMPORT SYSTEM, C99types, C99sys_types, C99locale; + + TYPE + char* = C99types.char; + signed_char* = C99types.signed_char; + unsigned_char* = C99types.unsigned_char; + short* = C99types.short; + short_int* = C99types.short_int; + signed_short* = C99types.signed_short; + signed_short_int* = C99types.signed_short_int; + unsigned_short* = C99types.unsigned_short; + unsigned_short_int* = C99types.unsigned_short_int; + int* = C99types.int; + signed* = C99types.signed; + signed_int* = C99types.signed_int; + unsigned* = C99types.unsigned; + unsigned_int* = C99types.unsigned_int; + long* = C99types.long; + long_int* = C99types.long_int; + signed_long* = C99types.signed_long; + signed_long_int* = C99types.signed_long_int; + unsigned_long* = C99types.unsigned_long; + unsigned_long_int* = C99types.unsigned_long_int; + long_long* = C99types.long_long; + long_long_int* = C99types.long_long_int; + signed_long_long* = C99types.signed_long_long; + signed_long_long_int* = C99types.signed_long_long_int; + unsigned_long_long* = C99types.unsigned_long_long; + unsigned_long_long_int* = C99types.unsigned_long_long_int; + float* = C99types.float; + double* = C99types.double; + long_double* = C99types.long_double; + + TYPE + clock_t* = C99sys_types.clock_t; + size_t* = C99sys_types.size_t; + time_t* = C99sys_types.time_t; + clockid_t* = C99sys_types.clockid_t; + timer_t* = C99sys_types.timer_t; + pid_t* = C99sys_types.pid_t; + + TYPE + locale_t* = C99locale.locale_t; + + TYPE + Pstruct_tm* = POINTER TO struct_tm; + struct_tm* = RECORD [noalign] (* 44 *) + tm_sec*: int; (* 0+4 *) + tm_min*: int; (* 4+4 *) + tm_hour*: int; (* 8+4 *) + tm_mday*: int; (* 12+4 *) + tm_mon*: int; (* 16+4 *) + tm_year*: int; (* 20+4 *) + tm_wday*: int; (* 24+4 *) + tm_yday*: int; (* 28+4 *) + tm_isdst*: int; (* 32+4 *) + _____align0_____: ARRAY 8 OF BYTE; + END; + + TYPE + Pstruct_timespec* = POINTER TO struct_timespec; + struct_timespec* = RECORD [noalign] (* 8 *) + tv_sec*: time_t; (* 0+4 *) + tv_nsec*: long; (* 4+4 *) + END; + + TYPE + Pstruct_itimerspec* = POINTER TO struct_itimerspec; + struct_itimerspec* = RECORD [noalign] (* 16 *) + it_interval*: struct_timespec; (* 0+8 *) + it_value*: struct_timespec; (* 8+8 *) + END; + + CONST + CLOCKS_PER_SEC* = 1000000; + + CONST + CLOCK_MONOTONIC* = 1; + CLOCK_PROCESS_CPUTIME_ID* = 2; + CLOCK_REALTIME* = 0; + CLOCK_THREAD_CPUTIME_ID* = 3; + + CONST + TIMER_ABSTIME* = 1; + + PROCEDURE [ccall] asctime* (IN tm: struct_tm): POINTER TO ARRAY [untagged] OF SHORTCHAR; + PROCEDURE [ccall] asctime_r* (IN tm: struct_tm; buf: POINTER TO ARRAY [untagged] OF SHORTCHAR): POINTER TO ARRAY [untagged] OF SHORTCHAR; + PROCEDURE [ccall] clock* (): clock_t; + PROCEDURE [ccall] clock_getcpuclockid* (pid: pid_t; VAR clock_id: clockid_t): int; + PROCEDURE [ccall] clock_getres* (clk_id: clockid_t; VAR res: struct_timespec): int; + PROCEDURE [ccall] clock_gettime* (clk_id: clockid_t; VAR res: struct_timespec): int; + PROCEDURE [ccall] clock_nanosleep* (clock_id: clockid_t; falgs: int; IN [nil] rqtp: struct_timespec; VAR [nil] rmtp: struct_timespec): int; + PROCEDURE [ccall] clock_settime* (clk_id: clockid_t; IN res: struct_timespec): int; + PROCEDURE [ccall] ctime* (VAR timep: time_t): POINTER TO ARRAY [untagged] OF SHORTCHAR; + PROCEDURE [ccall] ctime_r* (VAR timep: time_t; buf: POINTER TO ARRAY [untagged] OF SHORTCHAR): POINTER TO ARRAY [untagged] OF SHORTCHAR; + PROCEDURE [ccall] difftime* (time0, time1: time_t): double; + PROCEDURE [ccall] getdate* (IN string: ARRAY [untagged] OF SHORTCHAR): Pstruct_tm; + PROCEDURE [ccall] gmtime* (VAR timep: time_t): Pstruct_tm; + PROCEDURE [ccall] gmtime_r* (VAR timep: time_t; VAR result: struct_tm): Pstruct_tm; + PROCEDURE [ccall] localtime* (VAR timep: time_t): Pstruct_tm; + PROCEDURE [ccall] localtime_r* (VAR timep: time_t; VAR result: struct_tm): Pstruct_tm; + PROCEDURE [ccall] mktime* (VAR tm: struct_tm): time_t; + PROCEDURE [ccall] nanosleep* (IN [nil] rqtp: struct_timespec; VAR [nil] rmtp: struct_timespec): int; + PROCEDURE [ccall] strftime* (VAR s: ARRAY [untagged] OF SHORTCHAR; max: size_t; IN format: ARRAY [untagged] OF SHORTCHAR; IN tm: struct_tm): size_t; + PROCEDURE [ccall] strftime_l* (VAR s: ARRAY [untagged] OF SHORTCHAR; max: size_t; IN format: ARRAY [untagged] OF SHORTCHAR; IN tm: struct_tm; locale: locale_t): size_t; + PROCEDURE [ccall] strptime* (IN s, format: ARRAY [untagged] OF SHORTCHAR; VAR tm: struct_tm): POINTER TO ARRAY [untagged] OF SHORTCHAR; + PROCEDURE [ccall] time* (VAR [nil] tloc: time_t): time_t; + PROCEDURE [ccall] timer_delete* (timerid: timer_t): int; + PROCEDURE [ccall] timer_getoverrun* (timerid: timer_t): int; + PROCEDURE [ccall] timer_gettime* (timerid: timer_t; VAR value: struct_itimerspec): int; + PROCEDURE [ccall] timer_settime* (timerid: timer_t; flags: int; IN value: struct_itimerspec; VAR [nil] ovalue: struct_itimerspec): int; + PROCEDURE [ccall] tzset* ; + +END C99time. diff --git a/src/i486/linux/C99/Mod/types.cp b/src/i486/linux/C99/Mod/types.cp new file mode 100644 index 0000000..8c86e26 --- /dev/null +++ b/src/i486/linux/C99/Mod/types.cp @@ -0,0 +1,40 @@ +MODULE C99types; + + (* generated by genposix.sh, do not modify *) + +IMPORT SYSTEM; + + TYPE + char* = BYTE; + signed_char* = BYTE; + unsigned_char* = BYTE; + short* = SHORTINT; + short_int* = SHORTINT; + signed_short* = SHORTINT; + signed_short_int* = SHORTINT; + unsigned_short* = SHORTINT; + unsigned_short_int* = SHORTINT; + int* = INTEGER; + signed* = INTEGER; + signed_int* = INTEGER; + unsigned* = INTEGER; + unsigned_int* = INTEGER; + long* = INTEGER; + long_int* = INTEGER; + signed_long* = INTEGER; + signed_long_int* = INTEGER; + unsigned_long* = INTEGER; + unsigned_long_int* = INTEGER; + long_long* = LONGINT; + long_long_int* = LONGINT; + signed_long_long* = LONGINT; + signed_long_long_int* = LONGINT; + unsigned_long_long* = LONGINT; + unsigned_long_long_int* = LONGINT; + float* = SHORTREAL; + double* = REAL; + long_double* = RECORD [noalign] _: ARRAY [untagged] 12 OF BYTE END; + Pvoid* = INTEGER; + + +END C99types. diff --git a/src/i486/linux/C99/Mod/unistd.cp b/src/i486/linux/C99/Mod/unistd.cp new file mode 100644 index 0000000..47ee6c4 --- /dev/null +++ b/src/i486/linux/C99/Mod/unistd.cp @@ -0,0 +1,430 @@ +MODULE C99unistd ['libc.so.6']; + + (* generated by genposix.sh, do not modify *) + + IMPORT SYSTEM, C99types, C99sys_types; + + TYPE + char* = C99types.char; + signed_char* = C99types.signed_char; + unsigned_char* = C99types.unsigned_char; + short* = C99types.short; + short_int* = C99types.short_int; + signed_short* = C99types.signed_short; + signed_short_int* = C99types.signed_short_int; + unsigned_short* = C99types.unsigned_short; + unsigned_short_int* = C99types.unsigned_short_int; + int* = C99types.int; + signed* = C99types.signed; + signed_int* = C99types.signed_int; + unsigned* = C99types.unsigned; + unsigned_int* = C99types.unsigned_int; + long* = C99types.long; + long_int* = C99types.long_int; + signed_long* = C99types.signed_long; + signed_long_int* = C99types.signed_long_int; + unsigned_long* = C99types.unsigned_long; + unsigned_long_int* = C99types.unsigned_long_int; + long_long* = C99types.long_long; + long_long_int* = C99types.long_long_int; + signed_long_long* = C99types.signed_long_long; + signed_long_long_int* = C99types.signed_long_long_int; + unsigned_long_long* = C99types.unsigned_long_long; + unsigned_long_long_int* = C99types.unsigned_long_long_int; + float* = C99types.float; + double* = C99types.double; + long_double* = C99types.long_double; + + CONST + _POSIX_VERSION* = 200809; + _POSIX2_VERSION* = 200809; + _XOPEN_VERSION* = 700; + + CONST + _POSIX_ADVISORY_INFO* = 200809; + _POSIX_ASYNCHRONOUS_IO* = 200809; + _POSIX_BARRIERS* = 200809; + _POSIX_CHOWN_RESTRICTED* = 0; + _POSIX_CLOCK_SELECTION* = 200809; + _POSIX_CPUTIME* = 0; + _POSIX_FSYNC* = 200809; + _POSIX_IPV6* = 200809; + _POSIX_JOB_CONTROL* = 1; + _POSIX_MAPPED_FILES* = 200809; + _POSIX_MEMLOCK* = 200809; + _POSIX_MEMLOCK_RANGE* = 200809; + _POSIX_MEMORY_PROTECTION* = 200809; + _POSIX_MESSAGE_PASSING* = 200809; + _POSIX_MONOTONIC_CLOCK* = 0; + _POSIX_NO_TRUNC* = 1; + _POSIX_PRIORITIZED_IO* = 200809; + _POSIX_PRIORITY_SCHEDULING* = 200809; + _POSIX_RAW_SOCKETS* = 200809; + _POSIX_READER_WRITER_LOCKS* = 200809; + _POSIX_REALTIME_SIGNALS* = 200809; + _POSIX_REGEXP* = 1; + _POSIX_SAVED_IDS* = 1; + _POSIX_SEMAPHORES* = 200809; + _POSIX_SHARED_MEMORY_OBJECTS* = 200809; + _POSIX_SHELL* = 1; + _POSIX_SPAWN* = 200809; + _POSIX_SPIN_LOCKS* = 200809; + _POSIX_SPORADIC_SERVER* = -1; + _POSIX_SYNCHRONIZED_IO* = 200809; + _POSIX_THREAD_ATTR_STACKADDR* = 200809; + _POSIX_THREAD_ATTR_STACKSIZE* = 200809; + _POSIX_THREAD_CPUTIME* = 0; + _POSIX_THREAD_PRIO_INHERIT* = 200809; + _POSIX_THREAD_PRIO_PROTECT* = 200809; + _POSIX_THREAD_PRIORITY_SCHEDULING* = 200809; + _POSIX_THREAD_PROCESS_SHARED* = 200809; + _POSIX_THREAD_ROBUST_PRIO_INHERIT* = 200809; + _POSIX_THREAD_ROBUST_PRIO_PROTECT* = -1; + _POSIX_THREAD_SAFE_FUNCTIONS* = 200809; + _POSIX_THREAD_SPORADIC_SERVER* = -1; + _POSIX_THREADS* = 200809; + _POSIX_TIMEOUTS* = 200809; + _POSIX_TIMERS* = 200809; + _POSIX_TRACE* = -1; + _POSIX_TRACE_EVENT_FILTER* = -1; + _POSIX_TRACE_INHERIT* = -1; + _POSIX_TRACE_LOG* = -1; + _POSIX_TYPED_MEMORY_OBJECTS* = -1; + _POSIX_V6_ILP32_OFF32* = 1; + _POSIX_V6_ILP32_OFFBIG* = 1; + _POSIX_V6_LP64_OFF64* = -1; + _POSIX_V6_LPBIG_OFFBIG* = -1; + _POSIX_V7_ILP32_OFF32* = 1; + _POSIX_V7_ILP32_OFFBIG* = 1; + _POSIX_V7_LP64_OFF64* = -1; + _POSIX_V7_LPBIG_OFFBIG* = -1; + _POSIX2_C_BIND* = 200809; + _POSIX2_C_DEV* = 200809; + _POSIX2_CHAR_TERM* = 200809; + _POSIX2_FORT_DEV* = -1; + _POSIX2_FORT_RUN* = -1; + _POSIX2_LOCALEDEF* = 200809; + _POSIX2_PBS* = -1; + _POSIX2_PBS_ACCOUNTING* = -1; + _POSIX2_PBS_CHECKPOINT* = -1; + _POSIX2_PBS_LOCATE* = -1; + _POSIX2_PBS_MESSAGE* = -1; + _POSIX2_PBS_TRACK* = -1; + _POSIX2_SW_DEV* = 200809; + _POSIX2_UPE* = -1; + _XOPEN_CRYPT* = 1; + _XOPEN_ENH_I18N* = 1; + _XOPEN_REALTIME* = 1; + _XOPEN_REALTIME_THREADS* = 1; + _XOPEN_SHM* = 1; + _XOPEN_STREAMS* = -1; + _XOPEN_UNIX* = 1; + _XOPEN_UUCP* = -1; + + CONST + _POSIX_ASYNC_IO* = 1; + _POSIX_PRIO_IO* = -1; + _POSIX_SYNC_IO* = -1; + _POSIX_TIMESTAMP_RESOLUTION* = -1; + _POSIX2_SYMLINKS* = -1; + + CONST + F_OK* = 0; + R_OK* = 4; + W_OK* = 2; + X_OK* = 1; + + CONST + _CS_PATH* = 0; + _CS_POSIX_V7_ILP32_OFF32_CFLAGS* = 1132; + _CS_POSIX_V7_ILP32_OFF32_LDFLAGS* = 1133; + _CS_POSIX_V7_ILP32_OFF32_LIBS* = 1134; + _CS_POSIX_V7_ILP32_OFFBIG_CFLAGS* = 1136; + _CS_POSIX_V7_ILP32_OFFBIG_LDFLAGS* = 1137; + _CS_POSIX_V7_ILP32_OFFBIG_LIBS* = 1138; + _CS_POSIX_V7_LP64_OFF64_CFLAGS* = 1140; + _CS_POSIX_V7_LP64_OFF64_LDFLAGS* = 1141; + _CS_POSIX_V7_LP64_OFF64_LIBS* = 1142; + _CS_POSIX_V7_LPBIG_OFFBIG_CFLAGS* = 1144; + _CS_POSIX_V7_LPBIG_OFFBIG_LDFLAGS* = 1145; + _CS_POSIX_V7_LPBIG_OFFBIG_LIBS* = 1146; + _CS_POSIX_V7_THREADS_CFLAGS* = -1; + _CS_POSIX_V7_THREADS_LDFLAGS* = -1; + _CS_POSIX_V7_WIDTH_RESTRICTED_ENVS* = 5; + _CS_V7_ENV* = 1149; + _CS_POSIX_V6_ILP32_OFF32_CFLAGS* = 1116; + _CS_POSIX_V6_ILP32_OFF32_LDFLAGS* = 1117; + _CS_POSIX_V6_ILP32_OFF32_LIBS* = 1118; + _CS_POSIX_V6_ILP32_OFFBIG_CFLAGS* = 1120; + _CS_POSIX_V6_ILP32_OFFBIG_LDFLAGS* = 1121; + _CS_POSIX_V6_ILP32_OFFBIG_LIBS* = 1122; + _CS_POSIX_V6_LP64_OFF64_CFLAGS* = 1124; + _CS_POSIX_V6_LP64_OFF64_LDFLAGS* = 1125; + _CS_POSIX_V6_LP64_OFF64_LIBS* = 1126; + _CS_POSIX_V6_LPBIG_OFFBIG_CFLAGS* = 1128; + _CS_POSIX_V6_LPBIG_OFFBIG_LDFLAGS* = 1129; + _CS_POSIX_V6_LPBIG_OFFBIG_LIBS* = 1130; + _CS_POSIX_V6_WIDTH_RESTRICTED_ENVS* = 1; + _CS_V6_ENV* = 1148; + + CONST + SEEK_CUR* = 1; + SEEK_END* = 2; + SEEK_SET* = 0; + + CONST + F_LOCK* = 1; + F_TEST* = 3; + F_TLOCK* = 2; + F_ULOCK* = 0; + + CONST + _PC_2_SYMLINKS* = 20; + _PC_ALLOC_SIZE_MIN* = 18; + _PC_ASYNC_IO* = 10; + _PC_CHOWN_RESTRICTED* = 6; + _PC_FILESIZEBITS* = 13; + _PC_LINK_MAX* = 0; + _PC_MAX_CANON* = 1; + _PC_MAX_INPUT* = 2; + _PC_NAME_MAX* = 3; + _PC_NO_TRUNC* = 7; + _PC_PATH_MAX* = 4; + _PC_PIPE_BUF* = 5; + _PC_PRIO_IO* = 11; + _PC_REC_INCR_XFER_SIZE* = 14; + _PC_REC_MAX_XFER_SIZE* = 15; + _PC_REC_MIN_XFER_SIZE* = 16; + _PC_REC_XFER_ALIGN* = 17; + _PC_SYMLINK_MAX* = 19; + _PC_SYNC_IO* = 9; + _PC_TIMESTAMP_RESOLUTION* = -1; + _PC_VDISABLE* = 8; + + CONST + _SC_2_C_BIND* = 47; + _SC_2_C_DEV* = 48; + _SC_2_CHAR_TERM* = 95; + _SC_2_FORT_DEV* = 49; + _SC_2_FORT_RUN* = 50; + _SC_2_LOCALEDEF* = 52; + _SC_2_PBS* = 168; + _SC_2_PBS_ACCOUNTING* = 169; + _SC_2_PBS_CHECKPOINT* = 175; + _SC_2_PBS_LOCATE* = 170; + _SC_2_PBS_MESSAGE* = 171; + _SC_2_PBS_TRACK* = 172; + _SC_2_SW_DEV* = 51; + _SC_2_UPE* = 97; + _SC_2_VERSION* = 46; + _SC_ADVISORY_INFO* = 132; + _SC_AIO_LISTIO_MAX* = 23; + _SC_AIO_MAX* = 24; + _SC_AIO_PRIO_DELTA_MAX* = 25; + _SC_ARG_MAX* = 0; + _SC_ASYNCHRONOUS_IO* = 12; + _SC_ATEXIT_MAX* = 87; + _SC_BARRIERS* = 133; + _SC_BC_BASE_MAX* = 36; + _SC_BC_DIM_MAX* = 37; + _SC_BC_SCALE_MAX* = 38; + _SC_BC_STRING_MAX* = 39; + _SC_CHILD_MAX* = 1; + _SC_CLK_TCK* = 2; + _SC_CLOCK_SELECTION* = 137; + _SC_COLL_WEIGHTS_MAX* = 40; + _SC_CPUTIME* = 138; + _SC_DELAYTIMER_MAX* = 26; + _SC_EXPR_NEST_MAX* = 42; + _SC_FSYNC* = 15; + _SC_GETGR_R_SIZE_MAX* = 69; + _SC_GETPW_R_SIZE_MAX* = 70; + _SC_HOST_NAME_MAX* = 180; + _SC_IOV_MAX* = 60; + _SC_IPV6* = 235; + _SC_JOB_CONTROL* = 7; + _SC_LINE_MAX* = 43; + _SC_LOGIN_NAME_MAX* = 71; + _SC_MAPPED_FILES* = 16; + _SC_MEMLOCK* = 17; + _SC_MEMLOCK_RANGE* = 18; + _SC_MEMORY_PROTECTION* = 19; + _SC_MESSAGE_PASSING* = 20; + _SC_MONOTONIC_CLOCK* = 149; + _SC_MQ_OPEN_MAX* = 27; + _SC_MQ_PRIO_MAX* = 28; + _SC_NGROUPS_MAX* = 3; + _SC_OPEN_MAX* = 4; + _SC_PAGE_SIZE* = 30; + _SC_PAGESIZE* = 30; + _SC_PRIORITIZED_IO* = 13; + _SC_PRIORITY_SCHEDULING* = 10; + _SC_RAW_SOCKETS* = 236; + _SC_RE_DUP_MAX* = 44; + _SC_READER_WRITER_LOCKS* = 153; + _SC_REALTIME_SIGNALS* = 9; + _SC_REGEXP* = 155; + _SC_RTSIG_MAX* = 31; + _SC_SAVED_IDS* = 8; + _SC_SEM_NSEMS_MAX* = 32; + _SC_SEM_VALUE_MAX* = 33; + _SC_SEMAPHORES* = 21; + _SC_SHARED_MEMORY_OBJECTS* = 22; + _SC_SHELL* = 157; + _SC_SIGQUEUE_MAX* = 34; + _SC_SPAWN* = 159; + _SC_SPIN_LOCKS* = 154; + _SC_SPORADIC_SERVER* = 160; + _SC_SS_REPL_MAX* = 241; + _SC_STREAM_MAX* = 5; + _SC_SYMLOOP_MAX* = 173; + _SC_SYNCHRONIZED_IO* = 14; + _SC_THREAD_ATTR_STACKADDR* = 77; + _SC_THREAD_ATTR_STACKSIZE* = 78; + _SC_THREAD_CPUTIME* = 139; + _SC_THREAD_DESTRUCTOR_ITERATIONS* = 73; + _SC_THREAD_KEYS_MAX* = 74; + _SC_THREAD_PRIO_INHERIT* = 80; + _SC_THREAD_PRIO_PROTECT* = 81; + _SC_THREAD_PRIORITY_SCHEDULING* = 79; + _SC_THREAD_PROCESS_SHARED* = 82; + _SC_THREAD_ROBUST_PRIO_INHERIT* = 247; + _SC_THREAD_ROBUST_PRIO_PROTECT* = 248; + _SC_THREAD_SAFE_FUNCTIONS* = 68; + _SC_THREAD_SPORADIC_SERVER* = 161; + _SC_THREAD_STACK_MIN* = 75; + _SC_THREAD_THREADS_MAX* = 76; + _SC_THREADS* = 67; + _SC_TIMEOUTS* = 164; + _SC_TIMER_MAX* = 35; + _SC_TIMERS* = 11; + _SC_TRACE* = 181; + _SC_TRACE_EVENT_FILTER* = 182; + _SC_TRACE_EVENT_NAME_MAX* = 242; + _SC_TRACE_INHERIT* = 183; + _SC_TRACE_LOG* = 184; + _SC_TRACE_NAME_MAX* = 243; + _SC_TRACE_SYS_MAX* = 244; + _SC_TRACE_USER_EVENT_MAX* = 245; + _SC_TTY_NAME_MAX* = 72; + _SC_TYPED_MEMORY_OBJECTS* = 165; + _SC_TZNAME_MAX* = 6; + _SC_V7_ILP32_OFF32* = 237; + _SC_V7_ILP32_OFFBIG* = 238; + _SC_V7_LP64_OFF64* = 239; + _SC_V7_LPBIG_OFFBIG* = 240; + _SC_V6_ILP32_OFF32* = 176; + _SC_V6_ILP32_OFFBIG* = 177; + _SC_V6_LP64_OFF64* = 178; + _SC_V6_LPBIG_OFFBIG* = 179; + _SC_VERSION* = 29; + _SC_XOPEN_CRYPT* = 92; + _SC_XOPEN_ENH_I18N* = 93; + _SC_XOPEN_REALTIME* = 130; + _SC_XOPEN_REALTIME_THREADS* = 131; + _SC_XOPEN_SHM* = 94; + _SC_XOPEN_STREAMS* = 246; + _SC_XOPEN_UNIX* = 91; + _SC_XOPEN_UUCP* = -1; + _SC_XOPEN_VERSION* = 89; + + CONST + STDERR_FILENO* = 2; + STDIN_FILENO* = 0; + STDOUT_FILENO* = 1; + + CONST + _POSIX_VDISABLE* = 0; + + TYPE + size_t* = C99sys_types.size_t; + ssize_t* = C99sys_types.ssize_t; + uid_t* = C99sys_types.uid_t; + gid_t* = C99sys_types.gid_t; + off_t* = C99sys_types.off_t; + pid_t* = C99sys_types.pid_t; + + TYPE + intptr_t* = INTEGER; + + PROCEDURE [ccall] access* (IN path: ARRAY [untagged] OF SHORTCHAR; amode: int): int; + PROCEDURE [ccall] alarm* (seconds: unsigned): unsigned; + PROCEDURE [ccall] chdir* (IN path: ARRAY [untagged] OF SHORTCHAR): int; + PROCEDURE [ccall] chown* (IN path: ARRAY [untagged] OF SHORTCHAR; owner: uid_t; group: gid_t): int; + PROCEDURE [ccall] close* (fd: int): int; + PROCEDURE [ccall] confstr* (name: int; VAR buf: ARRAY [untagged] OF SHORTCHAR; len: size_t); + PROCEDURE [ccall] crypt* (IN key, salt: ARRAY [untagged] OF SHORTCHAR); + PROCEDURE [ccall] dup* (oldfd: int): int; + PROCEDURE [ccall] dup2* (oldfd, newfd: int): int; + PROCEDURE [ccall] _exit* (status: int); + PROCEDURE [ccall] encrypt* (VAR block: ARRAY [untagged] 64 OF SHORTCHAR; edflag: int); + PROCEDURE [ccall] execv* (IN path: ARRAY [untagged] OF SHORTCHAR; IN argv: ARRAY [untagged] OF POINTER TO ARRAY [untagged] OF SHORTCHAR): int; + PROCEDURE [ccall] execve* (IN path: ARRAY [untagged] OF SHORTCHAR; IN argv, envp: ARRAY [untagged] OF POINTER TO ARRAY [untagged] OF SHORTCHAR): int; + PROCEDURE [ccall] execvp* (IN file: ARRAY [untagged] OF SHORTCHAR; IN argv, envp: ARRAY [untagged] OF POINTER TO ARRAY [untagged] OF SHORTCHAR): int; + PROCEDURE [ccall] faccessat* (fd: int; IN path: ARRAY [untagged] OF SHORTCHAR; amode, flag: int): int; + PROCEDURE [ccall] fchdir* (fildes: int): int; + PROCEDURE [ccall] fchown* (fildes: int; owner: uid_t; group: gid_t): int; + PROCEDURE [ccall] fchownat* (fd: int; IN path: ARRAY [untagged] OF SHORTCHAR; owner: uid_t; group: gid_t; flag: int): int; + PROCEDURE [ccall] fdatasync* (fildes: int): int; + PROCEDURE [ccall] fexecve* (fd: int; IN argv, envp: ARRAY [untagged] OF POINTER TO ARRAY [untagged] OF SHORTCHAR): int; + PROCEDURE [ccall] fork* (): pid_t; + PROCEDURE [ccall] fpathconf* (fd, name: int): long; + PROCEDURE [ccall] fsync* (fildes: int): int; + PROCEDURE [ccall] ftruncate* (fildes: int; length: off_t): int; + PROCEDURE [ccall] getcwd* (VAR [nil] buf: ARRAY [untagged] OF SHORTCHAR; size: size_t): POINTER TO ARRAY [untagged] OF SHORTCHAR; + PROCEDURE [ccall] getegid* (): gid_t; + PROCEDURE [ccall] geteuid* (): uid_t; + PROCEDURE [ccall] getgid* (): gid_t; + PROCEDURE [ccall] getgroups* (gidsetsize: int; VAR grouplist: ARRAY [untagged] OF gid_t): int; + PROCEDURE [ccall] gethostid* (): long; + PROCEDURE [ccall] gethostname* (VAR name: ARRAY [untagged] OF SHORTCHAR; namelen: size_t): int; + PROCEDURE [ccall] getlogin* (): POINTER TO ARRAY [untagged] OF SHORTCHAR; + PROCEDURE [ccall] getlogin_r* (VAR buf: ARRAY [untagged] OF SHORTCHAR; bufsize: size_t): int; + PROCEDURE [ccall] getopt* (argc: int; IN argv: ARRAY [untagged] OF POINTER TO ARRAY [untagged] OF SHORTCHAR; IN optstring: ARRAY [untagged] OF SHORTCHAR): int; + PROCEDURE [ccall] getpgid* (pid: pid_t): pid_t; + PROCEDURE [ccall] getpgrp* (): pid_t; + PROCEDURE [ccall] getpid* (): pid_t; + PROCEDURE [ccall] getppid* (): pid_t; + PROCEDURE [ccall] getsid* (): pid_t; + PROCEDURE [ccall] getuid* (): uid_t; + PROCEDURE [ccall] isatty* (fd: int): int; + PROCEDURE [ccall] lchown* (IN path: ARRAY [untagged] OF SHORTCHAR; owner: uid_t; group: gid_t): int; + PROCEDURE [ccall] link* (IN path1, path2: ARRAY [untagged] OF SHORTCHAR): int; + PROCEDURE [ccall] linkat* (fd1: int; IN path1: ARRAY [untagged] OF SHORTCHAR; fd2: int; IN path2: ARRAY [untagged] OF SHORTCHAR; flag: int): int; + PROCEDURE [ccall] lockf* (fd, cmd: int; len: off_t): int; + PROCEDURE [ccall] lseek* (fildes: int; offset: off_t; whence: int): off_t; + PROCEDURE [ccall] nice* (incr: int): int; + PROCEDURE [ccall] pathconf* (IN path: ARRAY [untagged] OF SHORTCHAR; name: int): long; + PROCEDURE [ccall] pause* (): int; + PROCEDURE [ccall] pipe* (VAR fildes: ARRAY [untagged] 2 OF int): int; + PROCEDURE [ccall] pread* (fildes: int; buf: C99types.Pvoid; nbyte: size_t; offset: off_t): ssize_t; + PROCEDURE [ccall] pwrite* (fildes: int; buf: C99types.Pvoid; nbyte: size_t; offset: off_t): ssize_t; + PROCEDURE [ccall] read* (fildes: int; buf: C99types.Pvoid; nbyte: size_t): ssize_t; + PROCEDURE [ccall] readlink* (IN path: ARRAY [untagged] OF SHORTCHAR; VAR buf: ARRAY [untagged] OF SHORTCHAR; bufsize: size_t): ssize_t; + PROCEDURE [ccall] readlinkat* (fd: int; IN path: ARRAY [untagged] OF SHORTCHAR; VAR buf: ARRAY [untagged] OF SHORTCHAR; bufsize: size_t): ssize_t; + PROCEDURE [ccall] rmdir* (IN path: ARRAY [untagged] OF SHORTCHAR): int; + PROCEDURE [ccall] setegid* (gid: gid_t): int; + PROCEDURE [ccall] seteuid* (uid: uid_t): int; + PROCEDURE [ccall] setgid* (gid: gid_t): int; + PROCEDURE [ccall] setpgid* (pid, pgid: pid_t): int; + PROCEDURE [ccall] setpgrp* (): pid_t; + PROCEDURE [ccall] setregid* (rgid, egid: pid_t): int; + PROCEDURE [ccall] setreuid* (ruid, euid: uid_t): int; + PROCEDURE [ccall] setsid* (): pid_t; + PROCEDURE [ccall] setuid* (uid: uid_t): int; + PROCEDURE [ccall] sleep* (seconds: unsigned): unsigned; + PROCEDURE [ccall] swab* (from, to: C99types.Pvoid; n: ssize_t); + PROCEDURE [ccall] symlink* (IN path1, path2: ARRAY [untagged] OF SHORTCHAR): int; + PROCEDURE [ccall] symlinkat* (IN path1: ARRAY [untagged] OF SHORTCHAR; fd: int; IN path2: ARRAY [untagged] OF SHORTCHAR): int; + PROCEDURE [ccall] sync* ; + PROCEDURE [ccall] sysconf* (name: int): long; + PROCEDURE [ccall] tcgetpgrp* (fd: int): pid_t; + PROCEDURE [ccall] tcsetpgrp* (fd: int; pgrp: pid_t): int; + PROCEDURE [ccall] truncate* (IN path: ARRAY [untagged] OF SHORTCHAR; length: off_t): int; + PROCEDURE [ccall] ttyname* (fd: int): POINTER TO ARRAY [untagged] OF SHORTCHAR; + PROCEDURE [ccall] ttyname_r* (fd: int; VAR buf: ARRAY [untagged] OF SHORTCHAR; buflen: size_t): int; + PROCEDURE [ccall] unlink* (IN path: ARRAY [untagged] OF SHORTCHAR): int; + PROCEDURE [ccall] unlinkat* (fd: int; IN path: ARRAY [untagged] OF SHORTCHAR; flag: int): int; + PROCEDURE [ccall] write* (fildes: int; buf: C99types.Pvoid; nbyte: size_t): int; + +END C99unistd. diff --git a/src/i486/linux/C99/Mod/wctype.cp b/src/i486/linux/C99/Mod/wctype.cp new file mode 100644 index 0000000..4f290c6 --- /dev/null +++ b/src/i486/linux/C99/Mod/wctype.cp @@ -0,0 +1,58 @@ +MODULE C99wctype ['libc.so.6']; + + (* generated by genposix.sh, do not modify *) + + IMPORT SYSTEM, C99types, C99locale; + + TYPE + char* = C99types.char; + signed_char* = C99types.signed_char; + unsigned_char* = C99types.unsigned_char; + short* = C99types.short; + short_int* = C99types.short_int; + signed_short* = C99types.signed_short; + signed_short_int* = C99types.signed_short_int; + unsigned_short* = C99types.unsigned_short; + unsigned_short_int* = C99types.unsigned_short_int; + int* = C99types.int; + signed* = C99types.signed; + signed_int* = C99types.signed_int; + unsigned* = C99types.unsigned; + unsigned_int* = C99types.unsigned_int; + long* = C99types.long; + long_int* = C99types.long_int; + signed_long* = C99types.signed_long; + signed_long_int* = C99types.signed_long_int; + unsigned_long* = C99types.unsigned_long; + unsigned_long_int* = C99types.unsigned_long_int; + long_long* = C99types.long_long; + long_long_int* = C99types.long_long_int; + signed_long_long* = C99types.signed_long_long; + signed_long_long_int* = C99types.signed_long_long_int; + unsigned_long_long* = C99types.unsigned_long_long; + unsigned_long_long_int* = C99types.unsigned_long_long_int; + float* = C99types.float; + double* = C99types.double; + long_double* = C99types.long_double; + + TYPE + wint_t* = INTEGER; + wctype_t* = INTEGER; + + TYPE + wctrans_t* = INTEGER; + + TYPE + locale_t* = C99locale.locale_t; + + CONST + WEOF* = -1; + + PROCEDURE [ccall] iswalpha* (wc: wint_t): int; + PROCEDURE [ccall] iswdigit* (wc: wint_t): int; + PROCEDURE [ccall] iswlower* (wc: wint_t): int; + PROCEDURE [ccall] iswupper* (wc: wint_t): int; + PROCEDURE [ccall] towlower* (wc: wint_t): wint_t; + PROCEDURE [ccall] towupper* (wc: wint_t): wint_t; + +END C99wctype. diff --git a/src/i486/linux/System/Mod/Kernel.cp b/src/i486/linux/System/Mod/Kernel.cp new file mode 100644 index 0000000..a9b755a --- /dev/null +++ b/src/i486/linux/System/Mod/Kernel.cp @@ -0,0 +1,1708 @@ +MODULE Kernel; + + IMPORT S := SYSTEM, stdlib := C99stdlib, stdio := C99stdio, + time := C99time, wctype := C99wctype, sysmman := C99sys_mman, + dlfcn := C99dlfcn, types := C99types, fcntl := C99fcntl, + unistd := C99unistd, signal := C99signal, setjmp := C99setjmp; + + (* init fpu? *) + (* add signal blocking to avoid race conditions in Try/Trap/TrapHandler *) + (* add BeepHook for Beep *) + (* implement Call using libffi *) + + CONST + nameLen* = 256; + + littleEndian* = TRUE; + timeResolution* = 1000; (* ticks per second *) + + processor* = 1; (* generic c *) + + objType* = "ocf"; (* file types *) + symType* = "osf"; + docType* = "odc"; + + (* loader constants *) + done* = 0; + fileNotFound* = 1; + syntaxError* = 2; + objNotFound* = 3; + illegalFPrint* = 4; + cyclicImport* = 5; + noMem* = 6; + commNotFound* = 7; + commSyntaxError* = 8; + moduleNotFound* = 9; + + any = 1000000; + + CX = 1; + SP = 4; (* register number of stack pointer *) + FP = 5; (* register number of frame pointer *) + ML = 3; (* register which holds the module list at program start *) + + strictStackSweep = FALSE; + N = 128 DIV 16; (* free lists *) + + (* kernel flags in module desc *) + init = 16; dyn = 17; dll = 24; iptrs = 30; + + (* meta interface consts *) + mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5; + + TYPE + Name* = ARRAY nameLen OF CHAR; + Utf8Name* = ARRAY nameLen OF SHORTCHAR; + Command* = PROCEDURE; + + Module* = POINTER TO RECORD [untagged] + next-: Module; + opts-: SET; (* 0..15: compiler opts, 16..31: kernel flags *) + refcnt-: INTEGER; (* <0: module invalidated *) + compTime-, loadTime-: ARRAY 6 OF SHORTINT; + ext-: INTEGER; (* currently not used *) + term-: Command; (* terminator *) + nofimps-, nofptrs-: INTEGER; + csize-, dsize-, rsize-: INTEGER; + code-, data-, refs-: INTEGER; + procBase-, varBase-: INTEGER; (* meta base addresses *) + names-: POINTER TO ARRAY [untagged] OF SHORTCHAR; (* names[0] = 0X *) + ptrs-: POINTER TO ARRAY [untagged] OF INTEGER; + imports-: POINTER TO ARRAY [untagged] OF Module; + export-: Directory; (* exported objects (name sorted) *) + name-: Utf8Name + END; + + Type* = POINTER TO RECORD [untagged] + (* record: ptr to method n at offset - 4 * (n+1) *) + size-: INTEGER; (* record: size, array: #elem, dyn array: 0, proc: sigfp *) + mod-: Module; + id-: INTEGER; (* name idx * 256 + lev * 16 + attr * 4 + form *) + base-: ARRAY 16 OF Type; (* signature if form = ProcTyp *) + fields-: Directory; (* new fields (declaration order) *) + ptroffs-: ARRAY any OF INTEGER (* array of any length *) + END; + + Object* = POINTER TO ObjDesc; + + ObjDesc* = RECORD [untagged] + fprint-: INTEGER; + offs-: INTEGER; (* pvfprint for record types *) + id-: INTEGER; (* name idx * 256 + vis * 16 + mode *) + struct-: Type (* id of basic type or pointer to typedesc/signature *) + END; + + Directory* = POINTER TO RECORD [untagged] + num-: INTEGER; (* number of entries *) + obj-: ARRAY any OF ObjDesc (* array of any length *) + END; + + Signature* = POINTER TO RECORD [untagged] + retStruct-: Type; (* id of basic type or pointer to typedesc or 0 *) + num-: INTEGER; (* number of parameters *) + par-: ARRAY any OF RECORD [untagged] (* parameters *) + id-: INTEGER; (* name idx * 256 + kind *) + struct-: Type (* id of basic type or pointer to typedesc *) + END + END; + + Handler* = PROCEDURE; + + Reducer* = POINTER TO ABSTRACT RECORD + next: Reducer + END; + + Identifier* = ABSTRACT RECORD + typ*: INTEGER; + obj-: ANYPTR + END; + + TrapCleaner* = POINTER TO ABSTRACT RECORD + next: TrapCleaner + END; + + TryHandler* = PROCEDURE (a, b, c: INTEGER); + + (* meta extension suport *) + + ItemExt* = POINTER TO ABSTRACT RECORD END; + + ItemAttr* = RECORD + obj*, vis*, typ*, adr*: INTEGER; + mod*: Module; + desc*: Type; + ptr*: S.PTR; + ext*: ItemExt + END; + + Hook* = POINTER TO ABSTRACT RECORD END; + + LoaderHook* = POINTER TO ABSTRACT RECORD (Hook) + res*: INTEGER; + importing*, imported*, object*: ARRAY 256 OF CHAR + END; + + Block = POINTER TO RECORD [untagged] + tag: Type; + last: INTEGER; (* arrays: last element *) + actual: INTEGER; (* arrays: used during mark phase *) + first: INTEGER (* arrays: first element *) + END; + + FreeBlock = POINTER TO FreeDesc; + + FreeDesc = RECORD [untagged] + tag: Type; (* f.tag = ADR(f.size) *) + size: INTEGER; + next: FreeBlock + END; + + Cluster = POINTER TO RECORD [untagged] + size: INTEGER; (* total size *) + next: Cluster; + max: INTEGER (* exe: reserved size, dll: original address *) + (* start of first block *) + END; + + FList = POINTER TO RECORD + next: FList; + blk: Block; + iptr, aiptr: BOOLEAN + END; + + CList = POINTER TO RECORD + next: CList; + do: Command; + trapped: BOOLEAN + END; + + + PtrType = RECORD v: S.PTR END; (* used for array of pointer *) + Char8Type = RECORD v: SHORTCHAR END; + Char16Type = RECORD v: CHAR END; + Int8Type = RECORD v: BYTE END; + Int16Type = RECORD v: SHORTINT END; + Int32Type = RECORD v: INTEGER END; + Int64Type = RECORD v: LONGINT END; + BoolType = RECORD v: BOOLEAN END; + SetType = RECORD v: SET END; + Real32Type = RECORD v: SHORTREAL END; + Real64Type = RECORD v: REAL END; + ProcType = RECORD v: PROCEDURE END; + UPtrType = RECORD v: INTEGER END; + StrPtr = POINTER TO ARRAY [untagged] OF SHORTCHAR; + + ArrStrPtr = POINTER TO ARRAY [untagged] OF StrPtr; + + ADDRESS* = types.Pvoid; + + VAR + baseStack: INTEGER; + root: Cluster; + modList-: Module; + trapCount-: INTEGER; + err-, pc-, sp-, fp-, stack-, val-: INTEGER; + + isTry, testRead: BOOLEAN; + startEnv: setjmp.sigjmp_buf; + tryEnv, readEnv: setjmp.jmp_buf; + + argc-: INTEGER; + argv-: ArrStrPtr; + pagesize: unistd.long; + + free: ARRAY N OF FreeBlock; (* free list *) + sentinelBlock: FreeDesc; + sentinel: FreeBlock; + candidates: ARRAY 1024 OF INTEGER; + nofcand: INTEGER; + allocated: INTEGER; (* bytes allocated on BlackBox heap *) + total: INTEGER; (* current total size of BlackBox heap *) + used: INTEGER; (* bytes allocated on system heap *) + finalizers: FList; + hotFinalizers: FList; + cleaners: CList; + reducers: Reducer; + trapStack: TrapCleaner; + actual: Module; (* valid during module initialization *) + + trapViewer, trapChecker: Handler; + trapped, guarded, secondTrap: BOOLEAN; + interrupted: BOOLEAN; + static, inDll, terminating: BOOLEAN; + restart: Command; + + loader: LoaderHook; + loadres: INTEGER; + + wouldFinalize: BOOLEAN; + + watcher*: PROCEDURE (event: INTEGER); (* for debugging *) + + PROCEDURE Erase (adr, words: INTEGER); + BEGIN + ASSERT(words >= 0, 20); + WHILE words > 0 DO + S.PUT(adr, 0); + INC(adr, 4); + DEC(words) + END + END Erase; + + + PROCEDURE (VAR id: Identifier) Identified* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (r: Reducer) Reduce* (full: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (c: TrapCleaner) Cleanup*, NEW, EMPTY; + + (* meta extension suport *) + + PROCEDURE (e: ItemExt) Lookup* (name: ARRAY OF CHAR; VAR i: ANYREC), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Index* (index: INTEGER; VAR elem: ANYREC), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Deref* (VAR ref: ANYREC), NEW, ABSTRACT; + + PROCEDURE (e: ItemExt) Valid* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Size* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) BaseTyp* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Len* (): INTEGER, NEW, ABSTRACT; + + PROCEDURE (e: ItemExt) Call* (OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) BoolVal* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutBoolVal* (x: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) CharVal* (): CHAR, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutCharVal* (x: CHAR), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) IntVal* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutIntVal* (x: INTEGER), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) LongVal* (): LONGINT, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutLongVal* (x: LONGINT), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) RealVal* (): REAL, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutRealVal* (x: REAL), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) SetVal* (): SET, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutSetVal* (x: SET), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PtrVal* (): ANYPTR, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutPtrVal* (x: ANYPTR), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) GetSStringVal* (OUT x: ARRAY OF SHORTCHAR; + OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutSStringVal* (IN x: ARRAY OF SHORTCHAR; + OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) GetStringVal* (OUT x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutStringVal* (IN x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT; + + (* -------------------- miscellaneous tools -------------------- *) + + PROCEDURE IsUpper* (ch: CHAR): BOOLEAN; + BEGIN + RETURN wctype.iswupper(ORD(ch)) # 0 + END IsUpper; + + PROCEDURE Upper* (ch: CHAR): CHAR; + BEGIN + RETURN CHR(wctype.towupper(ORD(ch))) + END Upper; + + PROCEDURE IsLower* (ch: CHAR): BOOLEAN; + BEGIN + RETURN wctype.iswlower(ORD(ch)) # 0 + END IsLower; + + PROCEDURE Lower* (ch: CHAR): CHAR; + BEGIN + RETURN CHR(wctype.towlower(ORD(ch))) + END Lower; + + PROCEDURE IsAlpha* (ch: CHAR): BOOLEAN; + BEGIN + RETURN wctype.iswalpha(ORD(ch)) # 0 + END IsAlpha; + + PROCEDURE Utf8ToString* (IN in: ARRAY OF SHORTCHAR; OUT out: ARRAY OF CHAR; OUT res: INTEGER); + VAR i, j, val, max: INTEGER; ch: SHORTCHAR; + + PROCEDURE FormatError(); + BEGIN out := in$; res := 2 (*format error*) + END FormatError; + + BEGIN + ch := in[0]; i := 1; j := 0; max := LEN(out) - 1; + WHILE (ch # 0X) & (j < max) DO + IF ch < 80X THEN + out[j] := ch; INC(j) + ELSIF ch < 0E0X THEN + val := ORD(ch) - 192; + IF val < 0 THEN FormatError; RETURN END ; + ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128; + IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ; + out[j] := CHR(val); INC(j) + ELSIF ch < 0F0X THEN + val := ORD(ch) - 224; + ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128; + IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ; + ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128; + IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ; + out[j] := CHR(val); INC(j) + ELSE + FormatError; RETURN + END ; + ch := in[i]; INC(i) + END; + out[j] := 0X; + IF ch = 0X THEN res := 0 (*ok*) ELSE res := 1 (*truncated*) END + END Utf8ToString; + + PROCEDURE StringToUtf8* (IN in: ARRAY OF CHAR; OUT out: ARRAY OF SHORTCHAR; OUT res: INTEGER); + VAR i, j, val, max: INTEGER; + BEGIN + i := 0; j := 0; max := LEN(out) - 3; + WHILE (in[i] # 0X) & (j < max) DO + val := ORD(in[i]); INC(i); + IF val < 128 THEN + out[j] := SHORT(CHR(val)); INC(j) + ELSIF val < 2048 THEN + out[j] := SHORT(CHR(val DIV 64 + 192)); INC(j); + out[j] := SHORT(CHR(val MOD 64 + 128)); INC(j) + ELSE + out[j] := SHORT(CHR(val DIV 4096 + 224)); INC(j); + out[j] := SHORT(CHR(val DIV 64 MOD 64 + 128)); INC(j); + out[j] := SHORT(CHR(val MOD 64 + 128)); INC(j) + END; + END; + out[j] := 0X; + IF in[i] = 0X THEN res := 0 (*ok*) ELSE res := 1 (*truncated*) END + END StringToUtf8; + + PROCEDURE SplitName* (name: ARRAY OF CHAR; VAR head, tail: ARRAY OF CHAR); + (* portable *) + VAR i, j: INTEGER; ch, lch: CHAR; + BEGIN + i := 0; ch := name[0]; + IF ch # 0X THEN + REPEAT + head[i] := ch; lch := ch; INC(i); ch := name[i] + UNTIL (ch = 0X) OR (ch = ".") OR IsUpper(ch) & ~IsUpper(lch); + IF ch = "." THEN i := 0; ch := name[0] END; + head[i] := 0X; j := 0; + WHILE ch # 0X DO tail[j] := ch; INC(i); INC(j); ch := name[i] END; + tail[j] := 0X; + IF tail = "" THEN tail := head$; head := "" END + ELSE head := ""; tail := "" + END + END SplitName; + + PROCEDURE MakeFileName* (VAR name: ARRAY OF CHAR; type: ARRAY OF CHAR); + VAR i, j: INTEGER; ext: ARRAY 8 OF CHAR; ch: CHAR; + BEGIN + i := 0; + WHILE (name[i] # 0X) & (name[i] # ".") DO INC(i) END; + IF name[i] = "." THEN + IF name[i + 1] = 0X THEN name[i] := 0X END + ELSE + IF type = "" THEN ext := docType ELSE ext := type$ END; + IF i < LEN(name) - LEN(ext$) - 1 THEN + name[i] := "."; INC(i); j := 0; ch := ext[0]; + WHILE ch # 0X DO + name[i] := Lower(ch); INC(i); INC(j); ch := ext[j] + END; + name[i] := 0X + END + END + END MakeFileName; + + PROCEDURE Time* (): LONGINT; + VAR res: time.int; tp: time.struct_timespec; + BEGIN + ASSERT(timeResolution >= 1); + ASSERT(timeResolution <= 1000000000); + res := time.clock_gettime(time.CLOCK_MONOTONIC, tp); + ASSERT(res = 0, 100); + RETURN tp.tv_sec * LONG(timeResolution) + tp.tv_nsec DIV LONG(1000000000 DIV timeResolution) + END Time; + + PROCEDURE Beep*; + (* !!! *) + END Beep; + + PROCEDURE SearchProcVar* (var: INTEGER; VAR m: Module; VAR adr: INTEGER); + BEGIN + adr := var; m := NIL; + IF var # 0 THEN + m := modList; + WHILE (m # NIL) & ((var < m.code) OR (var >= m.code + m.csize)) DO m := m.next END; + IF m # NIL THEN DEC(adr, m.code) END + END + END SearchProcVar; + + (* -------------------- system memory management --------------------- *) + + PROCEDURE AllocMem (size: sysmman.size_t; VAR max: sysmman.size_t): ADDRESS; + VAR fd, flags, res: fcntl.int; ptr: ADDRESS; + BEGIN + max := (size + pagesize - 1) DIV pagesize * pagesize; + fd := fcntl.open("/dev/zero", fcntl.O_RDWR, 0); + IF fd # -1 THEN + flags := sysmman.PROT_READ + sysmman.PROT_WRITE; + ptr := sysmman.mmap(0, max, flags, sysmman.MAP_PRIVATE, fd, 0); + IF ptr = sysmman.MAP_FAILED THEN ptr := 0 END; + res := unistd.close(fd); + ASSERT(res = 0, 100) + ELSE + ptr := 0 + END; + RETURN ptr + END AllocMem; + + PROCEDURE FreeMem (adr: ADDRESS; size: sysmman.size_t); + VAR res: types.int; + BEGIN + size := (size + pagesize - 1) DIV pagesize * pagesize; + res := sysmman.munmap(adr, size); + ASSERT(res = 0, 100) + END FreeMem; + + PROCEDURE AllocHeapMem (size: INTEGER; VAR c: Cluster); + CONST N = 65536; (* cluster size for dll *) + VAR adr, allocated: INTEGER; + BEGIN + INC(size, 16); + ASSERT(size > 0, 100); adr := 0; + IF size < N THEN adr := stdlib.malloc(N) END; + IF adr = 0 THEN adr := stdlib.malloc(size); allocated := size ELSE allocated := N END; + IF adr = 0 THEN c := NIL + ELSE + c := S.VAL(Cluster, (adr + 15) DIV 16 * 16); c.max := adr; + c.size := allocated - (S.VAL(INTEGER, c) - adr); + INC(used, c.size); INC(total, c.size) + END; + ASSERT((adr = 0) OR (adr MOD 16 = 0) & (c.size >= size), 101); + (* post: (c = NIL) OR (c MOD 16 = 0) & (c.size >= size) *) + END AllocHeapMem; + + PROCEDURE FreeHeapMem (c: Cluster); + BEGIN + DEC(used, c.size); DEC(total, c.size); + stdlib.free(S.VAL(ADDRESS, c.max)) + END FreeHeapMem; + + PROCEDURE HeapFull (size: INTEGER): BOOLEAN; + BEGIN + RETURN TRUE + END HeapFull; + + PROCEDURE AllocModMem* (descSize, modSize: INTEGER; VAR descAdr, modAdr: INTEGER); + BEGIN + descAdr := 0; modAdr := 0; + descAdr := AllocMem(descSize, descSize); + IF descAdr # 0 THEN + modAdr := AllocMem(modSize, modSize); + IF modAdr = 0 THEN + FreeMem(descAdr, descSize) + ELSE + INC(used, descSize + modSize) + END + END + END AllocModMem; + + PROCEDURE DeallocModMem* (descSize, modSize, descAdr, modAdr: INTEGER); + BEGIN + FreeMem(descAdr, descSize); + FreeMem(modAdr, modSize); + DEC(used, descSize + modSize) + END DeallocModMem; + + PROCEDURE InvalModMem (modSize, modAdr: INTEGER); + BEGIN + FreeMem(modAdr, modSize) + END InvalModMem; + + PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN; + VAR i: INTEGER; x: BYTE; res: setjmp.int; + BEGIN + testRead := TRUE; + res := setjmp.setjmp(readEnv); + IF res = 0 THEN + IF from <= to THEN + FOR i := from TO to - 1 DO + S.GET(i, x) + END + ELSE + FOR i := to - 1 TO from BY -1 DO + S.GET(i, x) + END + END; + END; + testRead := FALSE; + RETURN res = 0 + END IsReadable; + + (* --------------------- NEW implementation (portable) -------------------- *) + + PROCEDURE^ NewBlock (size: INTEGER): Block; + + PROCEDURE NewRec* (typ: INTEGER): INTEGER; (* implementation of NEW(ptr) *) + VAR size, adr: INTEGER; b: Block; tag: Type; l: FList; + BEGIN + IF ~ODD(typ) THEN + tag := S.VAL(Type, typ); + b := NewBlock(tag.size); + IF b # NIL THEN + b.tag := tag; + S.GET(typ - 4, size); + IF size # 0 THEN (* record uses a finalizer *) + l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *) + l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *) + l.blk := b; l.next := finalizers; finalizers := l + END; + adr := S.ADR(b.last) + ELSE + adr := 0 + END + ELSE + HALT(100) (* COM interface pointers not supported *) + END; + RETURN adr + END NewRec; + + PROCEDURE NewArr* (eltyp, nofelem, nofdim: INTEGER): INTEGER; (* impl. of NEW(ptr, dim0, dim1, ...) *) + VAR b: Block; size, headSize: INTEGER; t: Type; + BEGIN + CASE eltyp OF + | -1: HALT(100) (* COM interface pointers not supported *) + | 0: eltyp := S.ADR(PtrType) + | 1: eltyp := S.ADR(Char8Type) + | 2: eltyp := S.ADR(Int16Type) + | 3: eltyp := S.ADR(Int8Type) + | 4: eltyp := S.ADR(Int32Type) + | 5: eltyp := S.ADR(BoolType) + | 6: eltyp := S.ADR(SetType) + | 7: eltyp := S.ADR(Real32Type) + | 8: eltyp := S.ADR(Real64Type) + | 9: eltyp := S.ADR(Char16Type) + | 10: eltyp := S.ADR(Int64Type) + | 11: eltyp := S.ADR(ProcType) + | 12: HALT(101) (* COM interface pointers not supported *) + ELSE + ASSERT(~ODD(eltyp), 102) (* COM interface pointers not supported *) + END; + t := S.VAL(Type, eltyp); + headSize := 4 * nofdim + 12; + size := headSize + nofelem * t.size; + b := NewBlock(size); + IF b # NIL THEN + b.tag := S.VAL(Type, eltyp + 2); (* tag + array mark *) + b.last := S.ADR(b.last) + size - t.size; (* pointer to last elem *) + b.first := S.ADR(b.last) + headSize; (* pointer to first elem *) + RETURN S.ADR(b.last) + ELSE + RETURN 0 + END; + END NewArr; + + (* -------------------- handler installation (portable) --------------------- *) + + PROCEDURE ThisFinObj* (VAR id: Identifier): ANYPTR; + VAR l: FList; + BEGIN + ASSERT(id.typ # 0, 100); + l := finalizers; + WHILE l # NIL DO + IF S.VAL(INTEGER, l.blk.tag) = id.typ THEN + id.obj := S.VAL(ANYPTR, S.ADR(l.blk.last)); + IF id.Identified() THEN RETURN id.obj END + END; + l := l.next + END; + RETURN NIL + END ThisFinObj; + + PROCEDURE InstallReducer* (r: Reducer); + BEGIN + r.next := reducers; reducers := r + END InstallReducer; + + PROCEDURE InstallTrapViewer* (h: Handler); + BEGIN + trapViewer := h + END InstallTrapViewer; + + PROCEDURE InstallTrapChecker* (h: Handler); + BEGIN + trapChecker := h + END InstallTrapChecker; + + PROCEDURE PushTrapCleaner* (c: TrapCleaner); + VAR t: TrapCleaner; + BEGIN + t := trapStack; WHILE (t # NIL) & (t # c) DO t := t.next END; + ASSERT(t = NIL, 20); + c.next := trapStack; trapStack := c + END PushTrapCleaner; + + PROCEDURE PopTrapCleaner* (c: TrapCleaner); + VAR t: TrapCleaner; + BEGIN + t := NIL; + WHILE (trapStack # NIL) & (t # c) DO + t := trapStack; trapStack := trapStack.next + END + END PopTrapCleaner; + + PROCEDURE InstallCleaner* (p: Command); + VAR c: CList; + BEGIN + c := S.VAL(CList, NewRec(S.TYP(CList))); (* NEW(c) *) + c.do := p; c.trapped := FALSE; c.next := cleaners; cleaners := c + END InstallCleaner; + + PROCEDURE RemoveCleaner* (p: Command); + VAR c0, c: CList; + BEGIN + c := cleaners; c0 := NIL; + WHILE (c # NIL) & (c.do # p) DO c0 := c; c := c.next END; + IF c # NIL THEN + IF c0 = NIL THEN cleaners := cleaners.next ELSE c0.next := c.next END + END + END RemoveCleaner; + + PROCEDURE Cleanup*; + VAR c, c0: CList; + BEGIN + c := cleaners; c0 := NIL; + WHILE c # NIL DO + IF ~c.trapped THEN + c.trapped := TRUE; c.do; c.trapped := FALSE; c0 := c + ELSE + IF c0 = NIL THEN cleaners := cleaners.next + ELSE c0.next := c.next + END + END; + c := c.next + END + END Cleanup; + + (* -------------------- meta information (portable) --------------------- *) + + PROCEDURE (h: LoaderHook) ThisMod* (IN name: ARRAY OF CHAR): Module, NEW, ABSTRACT; + + PROCEDURE SetLoaderHook*(h: LoaderHook); + BEGIN + loader := h + END SetLoaderHook; + + PROCEDURE InitModule (mod: Module); (* initialize linked modules *) + VAR body: Command; + BEGIN + IF ~(dyn IN mod.opts) & (mod.next # NIL) & ~(init IN mod.next.opts) THEN InitModule(mod.next) END; + IF ~(init IN mod.opts) THEN + body := S.VAL(Command, mod.code); + INCL(mod.opts, init); + actual := mod; + body(); actual := NIL + END + END InitModule; + + PROCEDURE ThisLoadedMod* (IN name: ARRAY OF CHAR): Module; (* loaded modules only *) + VAR m: Module; res: INTEGER; n: Utf8Name; + BEGIN + StringToUtf8(name, n, res); ASSERT(res = 0); + loadres := done; + m := modList; + WHILE (m # NIL) & ((m.name # n) OR (m.refcnt < 0)) DO m := m.next END; + IF (m # NIL) & ~(init IN m.opts) THEN InitModule(m) END; + IF m = NIL THEN loadres := moduleNotFound END; + RETURN m + END ThisLoadedMod; + + PROCEDURE ThisMod* (IN name: ARRAY OF CHAR): Module; + BEGIN + IF loader # NIL THEN + loader.res := done; + RETURN loader.ThisMod(name) + ELSE + RETURN ThisLoadedMod(name) + END + END ThisMod; + + PROCEDURE LoadMod* (IN name: ARRAY OF CHAR); + VAR m: Module; + BEGIN + m := ThisMod(name) + END LoadMod; + + PROCEDURE GetLoaderResult* (OUT res: INTEGER; OUT importing, imported, object: ARRAY OF CHAR); + BEGIN + IF loader # NIL THEN + res := loader.res; + importing := loader.importing$; + imported := loader.imported$; + object := loader.object$ + ELSE + res := loadres; + importing := ""; + imported := ""; + object := "" + END + END GetLoaderResult; + + PROCEDURE ThisObject* (mod: Module; IN name: ARRAY OF CHAR): Object; + VAR l, r, m, res: INTEGER; p: StrPtr; n: Utf8Name; + BEGIN + StringToUtf8(name, n, res); ASSERT(res = 0); + l := 0; r := mod.export.num; + WHILE l < r DO (* binary search *) + m := (l + r) DIV 2; + p := S.VAL(StrPtr, S.ADR(mod.names[mod.export.obj[m].id DIV 256])); + IF p^ = n THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[m])) END; + IF p^ < n THEN l := m + 1 ELSE r := m END + END; + RETURN NIL + END ThisObject; + + PROCEDURE ThisDesc* (mod: Module; fprint: INTEGER): Object; + VAR i, n: INTEGER; + BEGIN + i := 0; n := mod.export.num; + WHILE (i < n) & (mod.export.obj[i].id DIV 256 = 0) DO + IF mod.export.obj[i].offs = fprint THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[i])) END; + INC(i) + END; + RETURN NIL + END ThisDesc; + + PROCEDURE ThisField* (rec: Type; IN name: ARRAY OF CHAR): Object; + VAR n, res: INTEGER; p: StrPtr; obj: Object; m: Module; nn: Utf8Name; + BEGIN + StringToUtf8(name, nn, res); ASSERT(res = 0); + m := rec.mod; + obj := S.VAL(Object, S.ADR(rec.fields.obj[0])); n := rec.fields.num; + WHILE n > 0 DO + p := S.VAL(StrPtr, S.ADR(m.names[obj.id DIV 256])); + IF p^ = nn THEN RETURN obj END; + DEC(n); INC(S.VAL(INTEGER, obj), 16) + END; + RETURN NIL + END ThisField; + + PROCEDURE ThisCommand* (mod: Module; IN name: ARRAY OF CHAR): Command; + VAR x: Object; sig: Signature; + BEGIN + x := ThisObject(mod, name); + IF (x # NIL) & (x.id MOD 16 = mProc) THEN + sig := S.VAL(Signature, x.struct); + IF (sig.retStruct = NIL) & (sig.num = 0) THEN RETURN S.VAL(Command, mod.procBase + x.offs) END + END; + RETURN NIL + END ThisCommand; + + PROCEDURE ThisType* (mod: Module; IN name: ARRAY OF CHAR): Type; + VAR x: Object; + BEGIN + x := ThisObject(mod, name); + IF (x # NIL) & (x.id MOD 16 = mTyp) & (S.VAL(INTEGER, x.struct) DIV 256 # 0) THEN + RETURN x.struct + ELSE + RETURN NIL + END + END ThisType; + + PROCEDURE TypeOf* (IN rec: ANYREC): Type; + BEGIN + RETURN S.VAL(Type, S.TYP(rec)) + END TypeOf; + + PROCEDURE LevelOf* (t: Type): SHORTINT; + BEGIN + RETURN SHORT(t.id DIV 16 MOD 16) + END LevelOf; + + PROCEDURE NewObj* (VAR o: S.PTR; t: Type); + VAR i: INTEGER; + BEGIN + IF t.size = -1 THEN o := NIL + ELSE + i := 0; WHILE t.ptroffs[i] >= 0 DO INC(i) END; + IF t.ptroffs[i+1] >= 0 THEN INC(S.VAL(INTEGER, t)) END; (* with interface pointers *) + o := S.VAL(S.PTR, NewRec(S.VAL(INTEGER, t))) (* generic NEW *) + END + END NewObj; + + PROCEDURE GetModName* (mod: Module; OUT name: Name); + VAR res: INTEGER; + BEGIN + Utf8ToString(mod.name, name, res); ASSERT(res = 0) + END GetModName; + + PROCEDURE GetObjName* (mod: Module; obj: Object; OUT name: Name); + VAR p: StrPtr; res: INTEGER; + BEGIN + p := S.VAL(StrPtr, S.ADR(mod.names[obj.id DIV 256])); + Utf8ToString(p^$, name, res); ASSERT(res = 0) + END GetObjName; + + PROCEDURE GetTypeName* (t: Type; OUT name: Name); + VAR p: StrPtr; res: INTEGER; + BEGIN + p := S.VAL(StrPtr, S.ADR(t.mod.names[t.id DIV 256])); + Utf8ToString(p^$, name, res); ASSERT(res = 0) + END GetTypeName; + + PROCEDURE RegisterMod* (mod: Module); + VAR i: INTEGER; epoch: time.time_t; tm: time.struct_tm; ptm: time.Pstruct_tm; + BEGIN + mod.next := modList; modList := mod; mod.refcnt := 0; INCL(mod.opts, dyn); i := 0; + WHILE i < mod.nofimps DO + IF mod.imports[i] # NIL THEN INC(mod.imports[i].refcnt) END; + INC(i) + END; + epoch := time.time(NIL); + ptm := time.localtime_r(epoch, tm); + IF ptm # NIL THEN + mod.loadTime[0] := SHORT(tm.tm_year + 1900); + mod.loadTime[1] := SHORT(tm.tm_mon + 1); + mod.loadTime[2] := SHORT(tm.tm_mday); + mod.loadTime[3] := SHORT(tm.tm_hour); + mod.loadTime[4] := SHORT(tm.tm_min); + mod.loadTime[5] := SHORT(tm.tm_sec) + ELSE + mod.loadTime[0] := 0; + mod.loadTime[1] := 0; + mod.loadTime[2] := 0; + mod.loadTime[3] := 0; + mod.loadTime[4] := 0; + mod.loadTime[5] := 0 + END; + IF ~(init IN mod.opts) THEN InitModule(mod) END + END RegisterMod; + + PROCEDURE^ Collect*; + + PROCEDURE UnloadMod* (mod: Module); + VAR i: INTEGER; t: Command; + BEGIN + IF mod.refcnt = 0 THEN + t := mod.term; mod.term := NIL; + IF t # NIL THEN t() END; (* terminate module *) + i := 0; + WHILE i < mod.nofptrs DO (* release global pointers *) + S.PUT(mod.varBase + mod.ptrs[i], 0); INC(i) + END; + Collect; (* call finalizers *) + i := 0; + WHILE i < mod.nofimps DO (* release imported modules *) + IF mod.imports[i] # NIL THEN DEC(mod.imports[i].refcnt) END; + INC(i) + END; + mod.refcnt := -1; + IF dyn IN mod.opts THEN (* release memory *) + InvalModMem(mod.data + mod.dsize - mod.refs, mod.refs) + END + END + END UnloadMod; + + (* -------------------- dynamic procedure call --------------------- *) + + PROCEDURE Call* (adr: INTEGER; sig: Signature; IN par: ARRAY OF INTEGER; n: INTEGER): LONGINT; + BEGIN + HALT(126); (* !!! *) + RETURN 0 + END Call; + + (* -------------------- reference information (portable) --------------------- *) + + PROCEDURE RefCh (VAR ref: INTEGER; OUT ch: SHORTCHAR); + BEGIN + S.GET(ref, ch); INC(ref) + END RefCh; + + PROCEDURE RefNum (VAR ref: INTEGER; OUT x: INTEGER); + VAR s, n: INTEGER; ch: SHORTCHAR; + BEGIN + s := 0; n := 0; RefCh(ref, ch); + WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); RefCh(ref, ch) END; + x := n + ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s) + END RefNum; + + PROCEDURE RefName (VAR ref: INTEGER; OUT n: Utf8Name); + VAR i: INTEGER; ch: SHORTCHAR; + BEGIN + i := 0; RefCh(ref, ch); + WHILE ch # 0X DO n[i] := ch; INC(i); RefCh(ref, ch) END; + n[i] := 0X + END RefName; + + PROCEDURE GetRefProc* (VAR ref: INTEGER; OUT adr: INTEGER; OUT name: Utf8Name); + VAR ch: SHORTCHAR; + BEGIN + S.GET(ref, ch); + WHILE ch >= 0FDX DO (* skip variables *) + INC(ref); RefCh(ref, ch); + IF ch = 10X THEN INC(ref, 4) END; + RefNum(ref, adr); RefName(ref, name); S.GET(ref, ch) + END; + WHILE (ch > 0X) & (ch < 0FCX) DO (* skip source refs *) + INC(ref); RefNum(ref, adr); S.GET(ref, ch) + END; + IF ch = 0FCX THEN INC(ref); RefNum(ref, adr); RefName(ref, name) + ELSE adr := 0 + END + END GetRefProc; + + PROCEDURE GetRefVar* (VAR ref: INTEGER; OUT mode, form: SHORTCHAR; OUT desc: Type; OUT adr: INTEGER; OUT name: Utf8Name); + BEGIN + S.GET(ref, mode); desc := NIL; + IF mode >= 0FDX THEN + mode := SHORT(CHR(ORD(mode) - 0FCH)); + INC(ref); RefCh(ref, form); + IF form = 10X THEN + S.GET(ref, desc); INC(ref, 4); form := SHORT(CHR(16 + desc.id MOD 4)) + END; + RefNum(ref, adr); RefName(ref, name) + ELSE + mode := 0X; form := 0X; adr := 0 + END + END GetRefVar; + + PROCEDURE SourcePos* (mod: Module; codePos: INTEGER): INTEGER; + VAR ref, pos, ad, d: INTEGER; ch: SHORTCHAR; name: Utf8Name; + BEGIN + IF mod # NIL THEN (* mf, 12.02.04 *) + ref := mod.refs; pos := 0; ad := 0; S.GET(ref, ch); + WHILE ch # 0X DO + WHILE (ch > 0X) & (ch < 0FCX) DO (* srcref: {dAdr,dPos} *) + INC(ad, ORD(ch)); INC(ref); RefNum(ref, d); + IF ad > codePos THEN RETURN pos END; + INC(pos, d); S.GET(ref, ch) + END; + IF ch = 0FCX THEN (* proc: 0FCX,Adr,Name *) + INC(ref); RefNum(ref, d); RefName(ref, name); S.GET(ref, ch); + IF (d > codePos) & (pos > 0) THEN RETURN pos END + END; + WHILE ch >= 0FDX DO (* skip variables: Mode, Form, adr, Name *) + INC(ref); RefCh(ref, ch); + IF ch = 10X THEN INC(ref, 4) END; + RefNum(ref, d); RefName(ref, name); S.GET(ref, ch) + END + END; + END; + RETURN -1 + END SourcePos; + + PROCEDURE LoadDll* (IN name: ARRAY OF CHAR; VAR ok: BOOLEAN); + VAR h: ADDRESS; file: Utf8Name; res: INTEGER; + BEGIN + StringToUtf8(name, file, res); + IF res = 0 THEN + h := dlfcn.dlopen(file, dlfcn.RTLD_LAZY + dlfcn.RTLD_GLOBAL); + ok := h # 0 + ELSE + ok := FALSE + END + END LoadDll; + + PROCEDURE ThisDllObj* (mode, fprint: INTEGER; IN dll, name: ARRAY OF CHAR): INTEGER; + VAR h, p: ADDRESS; file, sym: Utf8Name; res: INTEGER; err: dlfcn.int; + BEGIN + StringToUtf8(dll, file, res); + IF res = 0 THEN + h := dlfcn.dlopen(file, dlfcn.RTLD_LAZY + dlfcn.RTLD_GLOBAL); + IF h # 0 THEN + StringToUtf8(name, sym, res); + IF res = 0 THEN + p := dlfcn.dlsym(h, sym) + ELSE + p := 0 + END; + err := dlfcn.dlclose(h); + ASSERT(err = 0, 100) + ELSE + p := 0 + END + ELSE + p := 0 + END; + RETURN p + END ThisDllObj; + + (* -------------------- garbage collector (portable) --------------------- *) + + PROCEDURE Mark (this: Block); + VAR father, son: Block; tag: Type; flag, offset, actual: INTEGER; + BEGIN + IF ~ODD(S.VAL(INTEGER, this.tag)) THEN + father := NIL; + LOOP + INC(S.VAL(INTEGER, this.tag)); + flag := S.VAL(INTEGER, this.tag) MOD 4; + tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag); + IF flag >= 2 THEN actual := this.first; this.actual := actual + ELSE actual := S.ADR(this.last) + END; + LOOP + offset := tag.ptroffs[0]; + IF offset < 0 THEN + INC(S.VAL(INTEGER, tag), offset + 4); (* restore tag *) + IF (flag >= 2) & (actual < this.last) & (offset < -4) THEN (* next array element *) + INC(actual, tag.size); this.actual := actual + ELSE (* up *) + this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag); + IF father = NIL THEN RETURN END; + son := this; this := father; + flag := S.VAL(INTEGER, this.tag) MOD 4; + tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag); + offset := tag.ptroffs[0]; + IF flag >= 2 THEN actual := this.actual ELSE actual := S.ADR(this.last) END; + S.GET(actual + offset, father); S.PUT(actual + offset, S.ADR(son.last)); + INC(S.VAL(INTEGER, tag), 4) + END + ELSE + S.GET(actual + offset, son); + IF son # NIL THEN + DEC(S.VAL(INTEGER, son), 4); + IF ~ODD(S.VAL(INTEGER, son.tag)) THEN (* down *) + this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag); + S.PUT(actual + offset, father); father := this; this := son; + EXIT + END + END; + INC(S.VAL(INTEGER, tag), 4) + END + END + END + END + END Mark; + + PROCEDURE MarkGlobals; + VAR m: Module; i, p: INTEGER; + BEGIN + m := modList; + WHILE m # NIL DO + IF m.refcnt >= 0 THEN + i := 0; + WHILE i < m.nofptrs DO + S.GET(m.varBase + m.ptrs[i], p); INC(i); + IF p # 0 THEN Mark(S.VAL(Block, p - 4)) END + END + END; + m := m.next + END + END MarkGlobals; + + PROCEDURE Next (b: Block): Block; (* next block in same cluster *) + VAR size: INTEGER; + BEGIN + S.GET(S.VAL(INTEGER, b.tag) DIV 4 * 4, size); + IF ODD(S.VAL(INTEGER, b.tag) DIV 2) THEN INC(size, b.last - S.ADR(b.last)) END; + RETURN S.VAL(Block, S.VAL(INTEGER, b) + (size + 19) DIV 16 * 16) + END Next; + + PROCEDURE CheckCandidates; + (* pre: nofcand > 0 *) + VAR i, j, h, p, end: INTEGER; c: Cluster; blk, next: Block; + BEGIN + (* sort candidates (shellsort) *) + h := 1; REPEAT h := h*3 + 1 UNTIL h > nofcand; + REPEAT h := h DIV 3; i := h; + WHILE i < nofcand DO p := candidates[i]; j := i; + WHILE (j >= h) & (candidates[j-h] > p) DO + candidates[j] := candidates[j-h]; j := j-h + END; + candidates[j] := p; INC(i) + END + UNTIL h = 1; + (* sweep *) + c := root; i := 0; + WHILE c # NIL DO + blk := S.VAL(Block, S.VAL(INTEGER, c) + 12); + end := S.VAL(INTEGER, blk) + (c.size - 12) DIV 16 * 16; + WHILE candidates[i] < S.VAL(INTEGER, blk) DO + INC(i); + IF i = nofcand THEN RETURN END + END; + WHILE S.VAL(INTEGER, blk) < end DO + next := Next(blk); + IF candidates[i] < S.VAL(INTEGER, next) THEN + IF (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last)) (* not a free block *) + & (~strictStackSweep OR (candidates[i] = S.ADR(blk.last))) THEN + Mark(blk) + END; + REPEAT + INC(i); + IF i = nofcand THEN RETURN END + UNTIL candidates[i] >= S.VAL(INTEGER, next) + END; + IF (S.VAL(INTEGER, blk.tag) MOD 4 = 0) & (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last)) + & (blk.tag.base[0] = NIL) & (blk.actual > 0) THEN (* referenced interface record *) + Mark(blk) + END; + blk := next + END; + c := c.next + END + END CheckCandidates; + + PROCEDURE MarkLocals; + VAR sp, p, min, max: INTEGER; c: Cluster; + BEGIN + sp := S.ADR(sp); nofcand := 0; c := root; + WHILE c.next # NIL DO c := c.next END; + min := S.VAL(INTEGER, root); max := S.VAL(INTEGER, c) + c.size; + WHILE sp < baseStack DO + S.GET(sp, p); + IF (p > min) & (p < max) & (~strictStackSweep OR (p MOD 16 = 0)) THEN + candidates[nofcand] := p; INC(nofcand); + IF nofcand = LEN(candidates) - 1 THEN CheckCandidates; nofcand := 0 END + END; + INC(sp, 4) + END; + candidates[nofcand] := max; INC(nofcand); (* ensure complete scan for interface mark*) + IF nofcand > 0 THEN CheckCandidates END + END MarkLocals; + + PROCEDURE MarkFinObj; + VAR f: FList; + BEGIN + wouldFinalize := FALSE; + f := finalizers; + WHILE f # NIL DO + IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END; + Mark(f.blk); + f := f.next + END; + f := hotFinalizers; + WHILE f # NIL DO IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END; + Mark(f.blk); + f := f.next + END + END MarkFinObj; + + PROCEDURE CheckFinalizers; + VAR f, g, h, k: FList; + BEGIN + f := finalizers; g := NIL; + IF hotFinalizers = NIL THEN k := NIL + ELSE + k := hotFinalizers; + WHILE k.next # NIL DO k := k.next END + END; + WHILE f # NIL DO + h := f; f := f.next; + IF ~ODD(S.VAL(INTEGER, h.blk.tag)) THEN + IF g = NIL THEN finalizers := f ELSE g.next := f END; + IF k = NIL THEN hotFinalizers := h ELSE k.next := h END; + k := h; h.next := NIL + ELSE g := h + END + END; + h := hotFinalizers; + WHILE h # NIL DO Mark(h.blk); h := h.next END + END CheckFinalizers; + + PROCEDURE ExecFinalizer (a, b, c: INTEGER); + VAR f: FList; fin: PROCEDURE(this: ANYPTR); + BEGIN + f := S.VAL(FList, a); + S.GET(S.VAL(INTEGER, f.blk.tag) - 4, fin); (* method 0 *) + IF (fin # NIL) & (f.blk.tag.mod.refcnt >= 0) THEN fin(S.VAL(ANYPTR, S.ADR(f.blk.last))) END; + END ExecFinalizer; + + PROCEDURE^ Try* (h: TryHandler; a, b, c: INTEGER); (* COMPILER DEPENDENT *) + + PROCEDURE CallFinalizers; + VAR f: FList; + BEGIN + WHILE hotFinalizers # NIL DO + f := hotFinalizers; hotFinalizers := hotFinalizers.next; + Try(ExecFinalizer, S.VAL(INTEGER, f), 0, 0) + END; + wouldFinalize := FALSE + END CallFinalizers; + + PROCEDURE Insert (blk: FreeBlock; size: INTEGER); (* insert block in free list *) + VAR i: INTEGER; + BEGIN + blk.size := size - 4; blk.tag := S.VAL(Type, S.ADR(blk.size)); + i := MIN(N - 1, (blk.size DIV 16)); + blk.next := free[i]; free[i] := blk + END Insert; + + PROCEDURE Sweep (dealloc: BOOLEAN); + VAR cluster, last, c: Cluster; blk, next: Block; fblk, b, t: FreeBlock; end, i: INTEGER; + BEGIN + cluster := root; last := NIL; allocated := 0; + i := N; + REPEAT DEC(i); free[i] := sentinel UNTIL i = 0; + WHILE cluster # NIL DO + blk := S.VAL(Block, S.VAL(INTEGER, cluster) + 12); + end := S.VAL(INTEGER, blk) + (cluster.size - 12) DIV 16 * 16; + fblk := NIL; + WHILE S.VAL(INTEGER, blk) < end DO + next := Next(blk); + IF ODD(S.VAL(INTEGER, blk.tag)) THEN + IF fblk # NIL THEN + Insert(fblk, S.VAL(INTEGER, blk) - S.VAL(INTEGER, fblk)); + fblk := NIL + END; + DEC(S.VAL(INTEGER, blk.tag)); (* unmark *) + INC(allocated, S.VAL(INTEGER, next) - S.VAL(INTEGER, blk)) + ELSIF fblk = NIL THEN + fblk := S.VAL(FreeBlock, blk) + END; + blk := next + END; + IF dealloc & (S.VAL(INTEGER, fblk) = S.VAL(INTEGER, cluster) + 12) THEN (* deallocate cluster *) + c := cluster; cluster := cluster.next; + IF last = NIL THEN root := cluster ELSE last.next := cluster END; + FreeHeapMem(c) + ELSE + IF fblk # NIL THEN Insert(fblk, end - S.VAL(INTEGER, fblk)) END; + last := cluster; cluster := cluster.next + END + END; + (* reverse free list *) + i := N; + REPEAT + DEC(i); + b := free[i]; fblk := sentinel; + WHILE b # sentinel DO t := b; b := t.next; t.next := fblk; fblk := t END; + free[i] := fblk + UNTIL i = 0 + END Sweep; + + PROCEDURE Collect*; + BEGIN + IF root # NIL THEN + CallFinalizers; (* trap cleanup *) + MarkGlobals; + MarkLocals; + CheckFinalizers; + Sweep(TRUE); + CallFinalizers + END + END Collect; + + PROCEDURE FastCollect*; + BEGIN + IF root # NIL THEN + MarkGlobals; + MarkLocals; + MarkFinObj; + Sweep(FALSE) + END + END FastCollect; + + PROCEDURE WouldFinalize* (): BOOLEAN; + BEGIN + RETURN wouldFinalize + END WouldFinalize; + + (* --------------------- memory allocation (portable) -------------------- *) + + PROCEDURE OldBlock (size: INTEGER): FreeBlock; (* size MOD 16 = 0 *) + VAR b, l: FreeBlock; s, i: INTEGER; + BEGIN + s := size - 4; + i := MIN(N - 1, s DIV 16); + WHILE (i # N - 1) & (free[i] = sentinel) DO INC(i) END; + b := free[i]; l := NIL; + WHILE b.size < s DO l := b; b := b.next END; + IF b # sentinel THEN + IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END + ELSE b := NIL + END; + RETURN b + END OldBlock; + + PROCEDURE LastBlock (limit: INTEGER): FreeBlock; (* size MOD 16 = 0 *) + VAR b, l: FreeBlock; s, i: INTEGER; + BEGIN + s := limit - 4; + i := 0; + REPEAT + b := free[i]; l := NIL; + WHILE (b # sentinel) & (S.VAL(INTEGER, b) + b.size # s) DO l := b; b := b.next END; + IF b # sentinel THEN + IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END + ELSE b := NIL + END; + INC(i) + UNTIL (b # NIL) OR (i = N); + RETURN b + END LastBlock; + + PROCEDURE NewBlock (size: INTEGER): Block; + VAR tsize, a, s: INTEGER; b: FreeBlock; new, c: Cluster; r: Reducer; + BEGIN + ASSERT(size >= 0, 20); + IF size > MAX(INTEGER) - 19 THEN RETURN NIL END; + tsize := (size + 19) DIV 16 * 16; + b := OldBlock(tsize); (* 1) search for free block *) + IF b = NIL THEN + FastCollect; b := OldBlock(tsize); (* 2) collect *) + IF b = NIL THEN + Collect; b := OldBlock(tsize); (* 2a) fully collect *) + END; + IF b = NIL THEN + AllocHeapMem(tsize + 12, new); (* 3) allocate new cluster *) + IF new # NIL THEN + IF (root = NIL) OR (S.VAL(INTEGER, new) < S.VAL(INTEGER, root)) THEN + new.next := root; root := new + ELSE + c := root; + WHILE (c.next # NIL) & (S.VAL(INTEGER, new) > S.VAL(INTEGER, c.next)) DO c := c.next END; + new.next := c.next; c.next := new + END; + b := S.VAL(FreeBlock, S.VAL(INTEGER, new) + 12); + b.size := (new.size - 12) DIV 16 * 16 - 4 + ELSE + RETURN NIL (* 4) give up *) + END + END + END; + (* b # NIL *) + a := b.size + 4 - tsize; + IF a > 0 THEN Insert(S.VAL(FreeBlock, S.VAL(INTEGER, b) + tsize), a) END; + IF size > 0 THEN Erase(S.ADR(b.size), (size + 3) DIV 4) END; + INC(allocated, tsize); + RETURN S.VAL(Block, b) + END NewBlock; + + PROCEDURE Allocated* (): INTEGER; + BEGIN + RETURN allocated + END Allocated; + + PROCEDURE Used* (): INTEGER; + BEGIN + RETURN used + END Used; + + PROCEDURE Root* (): INTEGER; + BEGIN + RETURN S.VAL(INTEGER, root) + END Root; + + (* -------------------- Trap Handling --------------------- *) + + PROCEDURE Start* (code: Command); + VAR res: setjmp.int; + BEGIN + restart := code; + S.GETREG(SP, baseStack); + res := setjmp.sigsetjmp(startEnv, 1); + restart + END Start; + + PROCEDURE Quit* (exitCode: INTEGER); + VAR m: Module; term: Command; t: BOOLEAN; + BEGIN + trapViewer := NIL; trapChecker := NIL; restart := NIL; + t := terminating; terminating := TRUE; m := modList; + WHILE m # NIL DO (* call terminators *) + IF ~static OR ~t THEN + term := m.term; m.term := NIL; + IF term # NIL THEN term() END + END; + m := m.next + END; + CallFinalizers; + hotFinalizers := finalizers; finalizers := NIL; + CallFinalizers; + stdlib.exit(exitCode) + END Quit; + + PROCEDURE FatalError* (id: INTEGER; str: ARRAY OF CHAR); + VAR res: stdio.int; title: ARRAY 16 OF CHAR; text: ARRAY 256 OF SHORTCHAR; + BEGIN + title := "Error xy"; + title[6] := CHR(id DIV 10 + ORD("0")); + title[7] := CHR(id MOD 10 + ORD("0")); + res := unistd.write(2, S.ADR(title), 8); + stdlib.abort + END FatalError; + + PROCEDURE DefaultTrapViewer; + VAR out: ARRAY 2048 OF SHORTCHAR; a, b, c, len, ref, end: INTEGER; mod: Module; + modName, name: Name; n: Utf8Name; res: unistd.int; + + PROCEDURE WriteString (IN s: ARRAY OF SHORTCHAR); + VAR i: INTEGER; + BEGIN + i := 0; + WHILE (len < LEN(out) - 1) & (s[i] # 0X) DO out[len] := s[i]; INC(i); INC(len) END + END WriteString; + + PROCEDURE WriteHex (x, n: INTEGER); + VAR i, y: INTEGER; + BEGIN + IF len + n < LEN(out) THEN + i := len + n - 1; + WHILE i >= len DO + y := x MOD 16; x := x DIV 16; + IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END; + out[i] := SHORT(CHR(y + ORD("0"))); DEC(i) + END; + INC(len, n) + END + END WriteHex; + + PROCEDURE WriteLn; + BEGIN + IF len < LEN(out) - 1 THEN out[len] := 0AX; INC(len) END + END WriteLn; + + BEGIN + len := 0; + WriteString("====== "); + IF err = 129 THEN WriteString("invalid with") + ELSIF err = 130 THEN WriteString("invalid case") + ELSIF err = 131 THEN WriteString("function without return") + ELSIF err = 132 THEN WriteString("type guard") + ELSIF err = 133 THEN WriteString("implied type guard") + ELSIF err = 134 THEN WriteString("value out of range") + ELSIF err = 135 THEN WriteString("index out of range") + ELSIF err = 136 THEN WriteString("string too long") + ELSIF err = 137 THEN WriteString("stack overflow") + ELSIF err = 138 THEN WriteString("integer overflow") + ELSIF err = 139 THEN WriteString("division by zero") + ELSIF err = 140 THEN WriteString("infinite real result") + ELSIF err = 141 THEN WriteString("real underflow") + ELSIF err = 142 THEN WriteString("real overflow") + ELSIF err = 143 THEN WriteString("undefined real result") + ELSIF err = 144 THEN WriteString("not a number") + ELSIF err = 200 THEN WriteString("keyboard interrupt") + ELSIF err = 201 THEN WriteString("NIL dereference") + ELSIF err = 202 THEN WriteString("illegal instruction: "); + WriteHex(val, 4) + ELSIF err = 203 THEN WriteString("illegal memory read [ad = "); + WriteHex(val, 8); WriteString("]") + ELSIF err = 204 THEN WriteString("illegal memory write [ad = "); + WriteHex(val, 8); WriteString("]") + ELSIF err = 205 THEN WriteString("illegal execution [ad = "); + WriteHex(val, 8); WriteString("]") + ELSIF err = 257 THEN WriteString("out of memory") + ELSIF err = 10001H THEN WriteString("bus error") + ELSIF err = 10002H THEN WriteString("address error") + ELSIF err = 10007H THEN WriteString("fpu error") + ELSIF err < 0 THEN WriteString("exception #"); WriteHex(-err, 2) + ELSE err := err DIV 100 * 256 + err DIV 10 MOD 10 * 16 + err MOD 10; + WriteString("trap #"); WriteHex(err, 3) + END; + WriteString(" ======"); + a := pc; b := fp; c := 12; + REPEAT + WriteLn; WriteString("- "); + mod := modList; + WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO mod := mod.next END; + IF mod # NIL THEN + DEC(a, mod.code); + IF mod.refcnt >= 0 THEN + GetModName(mod, modName); WriteString(SHORT(modName)); ref := mod.refs; + REPEAT GetRefProc(ref, end, n) UNTIL (end = 0) OR (a < end); + IF a < end THEN + Utf8ToString(n, name, res); WriteString("."); WriteString(SHORT(name)) + END + ELSE + GetModName(mod, modName); WriteString("("); WriteString(SHORT(modName)); WriteString(")") + END; + WriteString(" ") + END; + WriteString("(pc="); WriteHex(a, 8); + WriteString(", fp="); WriteHex(b, 8); WriteString(")"); + IF (b >= sp) & (b < stack) THEN + S.GET(b+4, a); (* stacked pc *) + S.GET(b, b); (* dynamic link *) + DEC(c) + ELSE c := 0 + END + UNTIL c = 0; + out[len] := 0X; + res := unistd.write(2, S.ADR(out), len) + END DefaultTrapViewer; + + PROCEDURE TrapCleanup; + VAR t: TrapCleaner; + BEGIN + WHILE trapStack # NIL DO + t := trapStack; trapStack := trapStack.next; t.Cleanup + END; + IF (trapChecker # NIL) & (err # 128) THEN trapChecker END + END TrapCleanup; + + PROCEDURE SetTrapGuard* (on: BOOLEAN); + BEGIN + guarded := on + END SetTrapGuard; + + PROCEDURE Try* (h: TryHandler; a, b, c: INTEGER); + VAR oldIsTry: BOOLEAN; oldTryEnv: setjmp.jmp_buf; res: setjmp.int; + BEGIN + oldIsTry := isTry; oldTryEnv := tryEnv; + isTry := TRUE; + res := setjmp._setjmp(tryEnv); + IF res = 0 THEN h(a, b, c) END; + isTry := oldIsTry; tryEnv := oldTryEnv + END Try; + + PROCEDURE Trap* (n: INTEGER); + BEGIN + IF trapped THEN + DefaultTrapViewer; + IF ~secondTrap THEN trapped := FALSE; secondTrap := TRUE END + END; + IF n >= 0 THEN err := n + ELSE err := -n + 128 + END; + pc := 0; sp := 0; fp := 0; stack := 0; val := 0; + S.GETREG(SP, sp); S.GETREG(FP, fp); + INC(trapCount); + (* !!! InitFPU *) + TrapCleanup; + IF isTry THEN + setjmp._longjmp(tryEnv, 1) + END; + IF err = 128 THEN (* do nothing *) + ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN + trapped := TRUE; trapViewer() + ELSE DefaultTrapViewer + END; + trapped := FALSE; secondTrap := FALSE; + IF restart # NIL THEN + setjmp.siglongjmp(startEnv, 1) + END; + stdlib.abort + END Trap; + + PROCEDURE [ccall] TrapHandler (signo: signal.int; IN info: signal.siginfo_t; context: ADDRESS); + VAR res: signal.int; uc: signal.Pucontext_t; + BEGIN + IF testRead THEN + setjmp.longjmp(readEnv, 1) + END; + IF trapped THEN + DefaultTrapViewer; + IF ~secondTrap THEN trapped := FALSE; secondTrap := TRUE END + END; + err := -signo; + uc := S.VAL(signal.Pucontext_t, context); + pc := uc.uc_mcontext.gregs[14]; (* %eip *) + sp := uc.uc_mcontext.gregs[7]; (* %esp *) + fp := uc.uc_mcontext.gregs[6]; (* %ebp *) + stack := baseStack; + val := info.info.sigsegv.si_addr; + CASE signo OF + | signal.SIGFPE: + val := info.si_code; + pc := info.info.sigfpe.si_addr; + CASE info.si_code OF + | signal.FPE_INTDIV: err := 139 (* division by zero *) + | signal.FPE_INTOVF: err := 138 (* integer overflow *) + | signal.FPE_FLTDIV: err := 140 (* fpu: division by zero *) + | signal.FPE_FLTOVF: err := 142 (* fpu: overflow *) + | signal.FPE_FLTUND: err := 141 (* fpu: underflow *) + (* !!! | signal.FPE_FLTRES: err := ??? (* fpu: *) *) + | signal.FPE_FLTINV: err := 143 (* val := opcode *) (* fpu: invalid op *) + (* !!! | signal.FPE_FLTSUB: err := ??? (* fpu: *) *) + ELSE (* unknown *) + END + | signal.SIGINT: + val := info.si_code; + err := 200 (* keyboard interrupt *) + | signal.SIGSEGV: + val := info.info.sigsegv.si_addr; + err := 203 (* illigal read *) + | signal.SIGBUS: + val := info.info.sigbus.si_addr; + err := 10001H (* bus error *) + | signal.SIGILL: + pc := info.info.sigill.si_addr; + err := 202; (* illigal instruction *) + IF IsReadable(pc, pc + 4) THEN + S.GET(pc, val); + IF val MOD 100H = 8DH THEN (* lea reg,reg *) + IF val DIV 100H MOD 100H = 0F0H THEN + err := val DIV 10000H MOD 100H (* trap *) + ELSIF val DIV 1000H MOD 10H = 0EH THEN + err := 128 + val DIV 100H MOD 10H (* run time error *) + END + END + END + ELSE (* unknown *) + END; + INC(trapCount); + (* !!! InitFPU *) + TrapCleanup; + IF isTry THEN + setjmp._longjmp(tryEnv, 1) + END; + IF err = 128 THEN (* do nothing *) + ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN + trapped := TRUE; trapViewer() + ELSE DefaultTrapViewer + END; + trapped := FALSE; secondTrap := FALSE; + IF restart # NIL THEN + setjmp.siglongjmp(startEnv, 1) + END; + stdlib.abort + END TrapHandler; + + (* -------------------- Initialization --------------------- *) + + PROCEDURE InstallTrap (signo: signal.int); + VAR act: signal.struct_sigaction; res: signal.int; + BEGIN + act.handler.sa_handler := NIL; + res := signal.sigemptyset(act.sa_mask); + act.sa_flags := signal.SA_NODEFER + signal.SA_SIGINFO; + act.handler.sa_sigaction := TrapHandler; + res := signal.sigaction(signo, act, NIL); + END InstallTrap; + + PROCEDURE InstallTrapVectors; + BEGIN + InstallTrap(signal.SIGFPE); + InstallTrap(signal.SIGINT); + InstallTrap(signal.SIGSEGV); + InstallTrap(signal.SIGBUS); + InstallTrap(signal.SIGILL) + END InstallTrapVectors; + + PROCEDURE RemoveTrapVectors; + END RemoveTrapVectors; + + PROCEDURE Init; + VAR i: INTEGER; + BEGIN + pagesize := unistd.sysconf(unistd._SC_PAGESIZE); + + (* init heap *) + allocated := 0; total := 0; used := 0; + sentinelBlock.size := MAX(INTEGER); + sentinel := S.ADR(sentinelBlock); + i := N; + REPEAT DEC(i); free[i] := sentinel UNTIL i = 0; + + IF ~inDll THEN + InstallTrapVectors + END; + + (* !!! InitFPU *) + IF ~static THEN + InitModule(modList); + IF ~inDll THEN Quit(1) END + END + END Init; + +BEGIN + IF modList = NIL THEN (* only once *) + S.GETREG(SP, baseStack); + S.GET(baseStack + 16, argc); + argv := S.VAL(ArrStrPtr, baseStack + 20); + S.GETREG(ML, modList); (* linker loads module list to BX *) + static := init IN modList.opts; + inDll := dll IN modList.opts; + Init + END +CLOSE + IF ~terminating THEN + terminating := TRUE; + Quit(0) + END +END Kernel. diff --git a/src/i486/posix/System/Mod/Kernel.cp b/src/i486/posix/System/Mod/Kernel.cp new file mode 100644 index 0000000..083c997 --- /dev/null +++ b/src/i486/posix/System/Mod/Kernel.cp @@ -0,0 +1,1696 @@ +MODULE Kernel; + + IMPORT S := SYSTEM, stdlib := C99stdlib, stdio := C99stdio, + time := C99time, wctype := C99wctype, sysmman := C99sys_mman, + dlfcn := C99dlfcn, types := C99types, fcntl := C99fcntl, + unistd := C99unistd, signal := C99signal, setjmp := C99setjmp; + + (* init fpu? *) + (* add signal blocking to avoid race conditions in Try/Trap/TrapHandler *) + (* add BeepHook for Beep *) + (* implement Call using libffi *) + + CONST + nameLen* = 256; + + littleEndian* = TRUE; + timeResolution* = 1000; (* ticks per second *) + + processor* = 1; (* generic c *) + + objType* = "ocf"; (* file types *) + symType* = "osf"; + docType* = "odc"; + + (* loader constants *) + done* = 0; + fileNotFound* = 1; + syntaxError* = 2; + objNotFound* = 3; + illegalFPrint* = 4; + cyclicImport* = 5; + noMem* = 6; + commNotFound* = 7; + commSyntaxError* = 8; + moduleNotFound* = 9; + + any = 1000000; + + CX = 1; + SP = 4; (* register number of stack pointer *) + FP = 5; (* register number of frame pointer *) + ML = 3; (* register which holds the module list at program start *) + + strictStackSweep = FALSE; + N = 128 DIV 16; (* free lists *) + + (* kernel flags in module desc *) + init = 16; dyn = 17; dll = 24; iptrs = 30; + + (* meta interface consts *) + mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5; + + TYPE + Name* = ARRAY nameLen OF CHAR; + Utf8Name* = ARRAY nameLen OF SHORTCHAR; + Command* = PROCEDURE; + + Module* = POINTER TO RECORD [untagged] + next-: Module; + opts-: SET; (* 0..15: compiler opts, 16..31: kernel flags *) + refcnt-: INTEGER; (* <0: module invalidated *) + compTime-, loadTime-: ARRAY 6 OF SHORTINT; + ext-: INTEGER; (* currently not used *) + term-: Command; (* terminator *) + nofimps-, nofptrs-: INTEGER; + csize-, dsize-, rsize-: INTEGER; + code-, data-, refs-: INTEGER; + procBase-, varBase-: INTEGER; (* meta base addresses *) + names-: POINTER TO ARRAY [untagged] OF SHORTCHAR; (* names[0] = 0X *) + ptrs-: POINTER TO ARRAY [untagged] OF INTEGER; + imports-: POINTER TO ARRAY [untagged] OF Module; + export-: Directory; (* exported objects (name sorted) *) + name-: Utf8Name + END; + + Type* = POINTER TO RECORD [untagged] + (* record: ptr to method n at offset - 4 * (n+1) *) + size-: INTEGER; (* record: size, array: #elem, dyn array: 0, proc: sigfp *) + mod-: Module; + id-: INTEGER; (* name idx * 256 + lev * 16 + attr * 4 + form *) + base-: ARRAY 16 OF Type; (* signature if form = ProcTyp *) + fields-: Directory; (* new fields (declaration order) *) + ptroffs-: ARRAY any OF INTEGER (* array of any length *) + END; + + Object* = POINTER TO ObjDesc; + + ObjDesc* = RECORD [untagged] + fprint-: INTEGER; + offs-: INTEGER; (* pvfprint for record types *) + id-: INTEGER; (* name idx * 256 + vis * 16 + mode *) + struct-: Type (* id of basic type or pointer to typedesc/signature *) + END; + + Directory* = POINTER TO RECORD [untagged] + num-: INTEGER; (* number of entries *) + obj-: ARRAY any OF ObjDesc (* array of any length *) + END; + + Signature* = POINTER TO RECORD [untagged] + retStruct-: Type; (* id of basic type or pointer to typedesc or 0 *) + num-: INTEGER; (* number of parameters *) + par-: ARRAY any OF RECORD [untagged] (* parameters *) + id-: INTEGER; (* name idx * 256 + kind *) + struct-: Type (* id of basic type or pointer to typedesc *) + END + END; + + Handler* = PROCEDURE; + + Reducer* = POINTER TO ABSTRACT RECORD + next: Reducer + END; + + Identifier* = ABSTRACT RECORD + typ*: INTEGER; + obj-: ANYPTR + END; + + TrapCleaner* = POINTER TO ABSTRACT RECORD + next: TrapCleaner + END; + + TryHandler* = PROCEDURE (a, b, c: INTEGER); + + (* meta extension suport *) + + ItemExt* = POINTER TO ABSTRACT RECORD END; + + ItemAttr* = RECORD + obj*, vis*, typ*, adr*: INTEGER; + mod*: Module; + desc*: Type; + ptr*: S.PTR; + ext*: ItemExt + END; + + Hook* = POINTER TO ABSTRACT RECORD END; + + LoaderHook* = POINTER TO ABSTRACT RECORD (Hook) + res*: INTEGER; + importing*, imported*, object*: ARRAY 256 OF CHAR + END; + + Block = POINTER TO RECORD [untagged] + tag: Type; + last: INTEGER; (* arrays: last element *) + actual: INTEGER; (* arrays: used during mark phase *) + first: INTEGER (* arrays: first element *) + END; + + FreeBlock = POINTER TO FreeDesc; + + FreeDesc = RECORD [untagged] + tag: Type; (* f.tag = ADR(f.size) *) + size: INTEGER; + next: FreeBlock + END; + + Cluster = POINTER TO RECORD [untagged] + size: INTEGER; (* total size *) + next: Cluster; + max: INTEGER (* exe: reserved size, dll: original address *) + (* start of first block *) + END; + + FList = POINTER TO RECORD + next: FList; + blk: Block; + iptr, aiptr: BOOLEAN + END; + + CList = POINTER TO RECORD + next: CList; + do: Command; + trapped: BOOLEAN + END; + + + PtrType = RECORD v: S.PTR END; (* used for array of pointer *) + Char8Type = RECORD v: SHORTCHAR END; + Char16Type = RECORD v: CHAR END; + Int8Type = RECORD v: BYTE END; + Int16Type = RECORD v: SHORTINT END; + Int32Type = RECORD v: INTEGER END; + Int64Type = RECORD v: LONGINT END; + BoolType = RECORD v: BOOLEAN END; + SetType = RECORD v: SET END; + Real32Type = RECORD v: SHORTREAL END; + Real64Type = RECORD v: REAL END; + ProcType = RECORD v: PROCEDURE END; + UPtrType = RECORD v: INTEGER END; + StrPtr = POINTER TO ARRAY [untagged] OF SHORTCHAR; + + ArrStrPtr = POINTER TO ARRAY [untagged] OF StrPtr; + + ADDRESS* = types.Pvoid; + + VAR + baseStack: INTEGER; + root: Cluster; + modList-: Module; + trapCount-: INTEGER; + err-, pc-, sp-, fp-, stack-, val-: INTEGER; + + isTry: BOOLEAN; + startEnv: setjmp.sigjmp_buf; + tryEnv: setjmp.jmp_buf; + + argc-: INTEGER; + argv-: ArrStrPtr; + pagesize: unistd.long; + + free: ARRAY N OF FreeBlock; (* free list *) + sentinelBlock: FreeDesc; + sentinel: FreeBlock; + candidates: ARRAY 1024 OF INTEGER; + nofcand: INTEGER; + allocated: INTEGER; (* bytes allocated on BlackBox heap *) + total: INTEGER; (* current total size of BlackBox heap *) + used: INTEGER; (* bytes allocated on system heap *) + finalizers: FList; + hotFinalizers: FList; + cleaners: CList; + reducers: Reducer; + trapStack: TrapCleaner; + actual: Module; (* valid during module initialization *) + + trapViewer, trapChecker: Handler; + trapped, guarded, secondTrap: BOOLEAN; + interrupted: BOOLEAN; + static, inDll, terminating: BOOLEAN; + restart: Command; + + loader: LoaderHook; + loadres: INTEGER; + + wouldFinalize: BOOLEAN; + + watcher*: PROCEDURE (event: INTEGER); (* for debugging *) + + PROCEDURE Erase (adr, words: INTEGER); + BEGIN + ASSERT(words >= 0, 20); + WHILE words > 0 DO + S.PUT(adr, 0); + INC(adr, 4); + DEC(words) + END + END Erase; + + + PROCEDURE (VAR id: Identifier) Identified* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (r: Reducer) Reduce* (full: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (c: TrapCleaner) Cleanup*, NEW, EMPTY; + + (* meta extension suport *) + + PROCEDURE (e: ItemExt) Lookup* (name: ARRAY OF CHAR; VAR i: ANYREC), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Index* (index: INTEGER; VAR elem: ANYREC), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Deref* (VAR ref: ANYREC), NEW, ABSTRACT; + + PROCEDURE (e: ItemExt) Valid* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Size* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) BaseTyp* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) Len* (): INTEGER, NEW, ABSTRACT; + + PROCEDURE (e: ItemExt) Call* (OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) BoolVal* (): BOOLEAN, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutBoolVal* (x: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) CharVal* (): CHAR, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutCharVal* (x: CHAR), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) IntVal* (): INTEGER, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutIntVal* (x: INTEGER), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) LongVal* (): LONGINT, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutLongVal* (x: LONGINT), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) RealVal* (): REAL, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutRealVal* (x: REAL), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) SetVal* (): SET, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutSetVal* (x: SET), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PtrVal* (): ANYPTR, NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutPtrVal* (x: ANYPTR), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) GetSStringVal* (OUT x: ARRAY OF SHORTCHAR; + OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutSStringVal* (IN x: ARRAY OF SHORTCHAR; + OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) GetStringVal* (OUT x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT; + PROCEDURE (e: ItemExt) PutStringVal* (IN x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT; + + (* -------------------- miscellaneous tools -------------------- *) + + PROCEDURE IsUpper* (ch: CHAR): BOOLEAN; + BEGIN + RETURN wctype.iswupper(ORD(ch)) # 0 + END IsUpper; + + PROCEDURE Upper* (ch: CHAR): CHAR; + BEGIN + RETURN CHR(wctype.towupper(ORD(ch))) + END Upper; + + PROCEDURE IsLower* (ch: CHAR): BOOLEAN; + BEGIN + RETURN wctype.iswlower(ORD(ch)) # 0 + END IsLower; + + PROCEDURE Lower* (ch: CHAR): CHAR; + BEGIN + RETURN CHR(wctype.towlower(ORD(ch))) + END Lower; + + PROCEDURE IsAlpha* (ch: CHAR): BOOLEAN; + BEGIN + RETURN wctype.iswalpha(ORD(ch)) # 0 + END IsAlpha; + + PROCEDURE Utf8ToString* (IN in: ARRAY OF SHORTCHAR; OUT out: ARRAY OF CHAR; OUT res: INTEGER); + VAR i, j, val, max: INTEGER; ch: SHORTCHAR; + + PROCEDURE FormatError(); + BEGIN out := in$; res := 2 (*format error*) + END FormatError; + + BEGIN + ch := in[0]; i := 1; j := 0; max := LEN(out) - 1; + WHILE (ch # 0X) & (j < max) DO + IF ch < 80X THEN + out[j] := ch; INC(j) + ELSIF ch < 0E0X THEN + val := ORD(ch) - 192; + IF val < 0 THEN FormatError; RETURN END ; + ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128; + IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ; + out[j] := CHR(val); INC(j) + ELSIF ch < 0F0X THEN + val := ORD(ch) - 224; + ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128; + IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ; + ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128; + IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ; + out[j] := CHR(val); INC(j) + ELSE + FormatError; RETURN + END ; + ch := in[i]; INC(i) + END; + out[j] := 0X; + IF ch = 0X THEN res := 0 (*ok*) ELSE res := 1 (*truncated*) END + END Utf8ToString; + + PROCEDURE StringToUtf8* (IN in: ARRAY OF CHAR; OUT out: ARRAY OF SHORTCHAR; OUT res: INTEGER); + VAR i, j, val, max: INTEGER; + BEGIN + i := 0; j := 0; max := LEN(out) - 3; + WHILE (in[i] # 0X) & (j < max) DO + val := ORD(in[i]); INC(i); + IF val < 128 THEN + out[j] := SHORT(CHR(val)); INC(j) + ELSIF val < 2048 THEN + out[j] := SHORT(CHR(val DIV 64 + 192)); INC(j); + out[j] := SHORT(CHR(val MOD 64 + 128)); INC(j) + ELSE + out[j] := SHORT(CHR(val DIV 4096 + 224)); INC(j); + out[j] := SHORT(CHR(val DIV 64 MOD 64 + 128)); INC(j); + out[j] := SHORT(CHR(val MOD 64 + 128)); INC(j) + END; + END; + out[j] := 0X; + IF in[i] = 0X THEN res := 0 (*ok*) ELSE res := 1 (*truncated*) END + END StringToUtf8; + + PROCEDURE SplitName* (name: ARRAY OF CHAR; VAR head, tail: ARRAY OF CHAR); + (* portable *) + VAR i, j: INTEGER; ch, lch: CHAR; + BEGIN + i := 0; ch := name[0]; + IF ch # 0X THEN + REPEAT + head[i] := ch; lch := ch; INC(i); ch := name[i] + UNTIL (ch = 0X) OR (ch = ".") OR IsUpper(ch) & ~IsUpper(lch); + IF ch = "." THEN i := 0; ch := name[0] END; + head[i] := 0X; j := 0; + WHILE ch # 0X DO tail[j] := ch; INC(i); INC(j); ch := name[i] END; + tail[j] := 0X; + IF tail = "" THEN tail := head$; head := "" END + ELSE head := ""; tail := "" + END + END SplitName; + + PROCEDURE MakeFileName* (VAR name: ARRAY OF CHAR; type: ARRAY OF CHAR); + VAR i, j: INTEGER; ext: ARRAY 8 OF CHAR; ch: CHAR; + BEGIN + i := 0; + WHILE (name[i] # 0X) & (name[i] # ".") DO INC(i) END; + IF name[i] = "." THEN + IF name[i + 1] = 0X THEN name[i] := 0X END + ELSE + IF type = "" THEN ext := docType ELSE ext := type$ END; + IF i < LEN(name) - LEN(ext$) - 1 THEN + name[i] := "."; INC(i); j := 0; ch := ext[0]; + WHILE ch # 0X DO + name[i] := Lower(ch); INC(i); INC(j); ch := ext[j] + END; + name[i] := 0X + END + END + END MakeFileName; + + PROCEDURE Time* (): LONGINT; + VAR res: time.int; tp: time.struct_timespec; + BEGIN + ASSERT(timeResolution >= 1); + ASSERT(timeResolution <= 1000000000); + res := time.clock_gettime(time.CLOCK_MONOTONIC, tp); + ASSERT(res = 0, 100); + RETURN tp.tv_sec * LONG(timeResolution) + tp.tv_nsec DIV LONG(1000000000 DIV timeResolution) + END Time; + + PROCEDURE Beep*; + (* !!! *) + END Beep; + + PROCEDURE SearchProcVar* (var: INTEGER; VAR m: Module; VAR adr: INTEGER); + BEGIN + adr := var; m := NIL; + IF var # 0 THEN + m := modList; + WHILE (m # NIL) & ((var < m.code) OR (var >= m.code + m.csize)) DO m := m.next END; + IF m # NIL THEN DEC(adr, m.code) END + END + END SearchProcVar; + + (* -------------------- system memory management --------------------- *) + + PROCEDURE AllocMem (size: sysmman.size_t; VAR max: sysmman.size_t): ADDRESS; + VAR fd, flags, res: fcntl.int; ptr: ADDRESS; + BEGIN + max := (size + pagesize - 1) DIV pagesize * pagesize; + fd := fcntl.open("/dev/zero", fcntl.O_RDWR, 0); + IF fd # -1 THEN + flags := sysmman.PROT_READ + sysmman.PROT_WRITE; + ptr := sysmman.mmap(0, max, flags, sysmman.MAP_PRIVATE, fd, 0); + IF ptr = sysmman.MAP_FAILED THEN ptr := 0 END; + res := unistd.close(fd); + ASSERT(res = 0, 100) + ELSE + ptr := 0 + END; + RETURN ptr + END AllocMem; + + PROCEDURE FreeMem (adr: ADDRESS; size: sysmman.size_t); + VAR res: types.int; + BEGIN + size := (size + pagesize - 1) DIV pagesize * pagesize; + res := sysmman.munmap(adr, size); + ASSERT(res = 0, 100) + END FreeMem; + + PROCEDURE AllocHeapMem (size: INTEGER; VAR c: Cluster); + CONST N = 65536; (* cluster size for dll *) + VAR adr, allocated: INTEGER; + BEGIN + INC(size, 16); + ASSERT(size > 0, 100); adr := 0; + IF size < N THEN adr := stdlib.malloc(N) END; + IF adr = 0 THEN adr := stdlib.malloc(size); allocated := size ELSE allocated := N END; + IF adr = 0 THEN c := NIL + ELSE + c := S.VAL(Cluster, (adr + 15) DIV 16 * 16); c.max := adr; + c.size := allocated - (S.VAL(INTEGER, c) - adr); + INC(used, c.size); INC(total, c.size) + END; + ASSERT((adr = 0) OR (adr MOD 16 = 0) & (c.size >= size), 101); + (* post: (c = NIL) OR (c MOD 16 = 0) & (c.size >= size) *) + END AllocHeapMem; + + PROCEDURE FreeHeapMem (c: Cluster); + BEGIN + DEC(used, c.size); DEC(total, c.size); + stdlib.free(S.VAL(ADDRESS, c.max)) + END FreeHeapMem; + + PROCEDURE HeapFull (size: INTEGER): BOOLEAN; + BEGIN + RETURN TRUE + END HeapFull; + + PROCEDURE AllocModMem* (descSize, modSize: INTEGER; VAR descAdr, modAdr: INTEGER); + BEGIN + descAdr := 0; modAdr := 0; + descAdr := AllocMem(descSize, descSize); + IF descAdr # 0 THEN + modAdr := AllocMem(modSize, modSize); + IF modAdr = 0 THEN + FreeMem(descAdr, descSize) + ELSE + INC(used, descSize + modSize) + END + END + END AllocModMem; + + PROCEDURE DeallocModMem* (descSize, modSize, descAdr, modAdr: INTEGER); + BEGIN + FreeMem(descAdr, descSize); + FreeMem(modAdr, modSize); + DEC(used, descSize + modSize) + END DeallocModMem; + + PROCEDURE InvalModMem (modSize, modAdr: INTEGER); + BEGIN + FreeMem(modAdr, modSize) + END InvalModMem; + + PROCEDURE TryRead (from, to, c: INTEGER); + VAR i: INTEGER; x: BYTE; + BEGIN + IF from <= to THEN + FOR i := from TO to DO + S.GET(i, x) + END + ELSE + FOR i := to TO from BY -1 DO + S.GET(i, x) + END + END; + END TryRead; + + PROCEDURE^ Try* (h: TryHandler; a, b, c: INTEGER); + + PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN; + VAR i: INTEGER; + BEGIN + i := trapCount; + Try(TryRead, from, to, 0); + RETURN trapCount = i + END IsReadable; + + (* --------------------- NEW implementation (portable) -------------------- *) + + PROCEDURE^ NewBlock (size: INTEGER): Block; + + PROCEDURE NewRec* (typ: INTEGER): INTEGER; (* implementation of NEW(ptr) *) + VAR size, adr: INTEGER; b: Block; tag: Type; l: FList; + BEGIN + IF ~ODD(typ) THEN + tag := S.VAL(Type, typ); + b := NewBlock(tag.size); + IF b # NIL THEN + b.tag := tag; + S.GET(typ - 4, size); + IF size # 0 THEN (* record uses a finalizer *) + l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *) + l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *) + l.blk := b; l.next := finalizers; finalizers := l + END; + adr := S.ADR(b.last) + ELSE + adr := 0 + END + ELSE + HALT(100) (* COM interface pointers not supported *) + END; + RETURN adr + END NewRec; + + PROCEDURE NewArr* (eltyp, nofelem, nofdim: INTEGER): INTEGER; (* impl. of NEW(ptr, dim0, dim1, ...) *) + VAR b: Block; size, headSize: INTEGER; t: Type; + BEGIN + CASE eltyp OF + | -1: HALT(100) (* COM interface pointers not supported *) + | 0: eltyp := S.ADR(PtrType) + | 1: eltyp := S.ADR(Char8Type) + | 2: eltyp := S.ADR(Int16Type) + | 3: eltyp := S.ADR(Int8Type) + | 4: eltyp := S.ADR(Int32Type) + | 5: eltyp := S.ADR(BoolType) + | 6: eltyp := S.ADR(SetType) + | 7: eltyp := S.ADR(Real32Type) + | 8: eltyp := S.ADR(Real64Type) + | 9: eltyp := S.ADR(Char16Type) + | 10: eltyp := S.ADR(Int64Type) + | 11: eltyp := S.ADR(ProcType) + | 12: HALT(101) (* COM interface pointers not supported *) + ELSE + ASSERT(~ODD(eltyp), 102) (* COM interface pointers not supported *) + END; + t := S.VAL(Type, eltyp); + headSize := 4 * nofdim + 12; + size := headSize + nofelem * t.size; + b := NewBlock(size); + IF b # NIL THEN + b.tag := S.VAL(Type, eltyp + 2); (* tag + array mark *) + b.last := S.ADR(b.last) + size - t.size; (* pointer to last elem *) + b.first := S.ADR(b.last) + headSize; (* pointer to first elem *) + RETURN S.ADR(b.last) + ELSE + RETURN 0 + END; + END NewArr; + + (* -------------------- handler installation (portable) --------------------- *) + + PROCEDURE ThisFinObj* (VAR id: Identifier): ANYPTR; + VAR l: FList; + BEGIN + ASSERT(id.typ # 0, 100); + l := finalizers; + WHILE l # NIL DO + IF S.VAL(INTEGER, l.blk.tag) = id.typ THEN + id.obj := S.VAL(ANYPTR, S.ADR(l.blk.last)); + IF id.Identified() THEN RETURN id.obj END + END; + l := l.next + END; + RETURN NIL + END ThisFinObj; + + PROCEDURE InstallReducer* (r: Reducer); + BEGIN + r.next := reducers; reducers := r + END InstallReducer; + + PROCEDURE InstallTrapViewer* (h: Handler); + BEGIN + trapViewer := h + END InstallTrapViewer; + + PROCEDURE InstallTrapChecker* (h: Handler); + BEGIN + trapChecker := h + END InstallTrapChecker; + + PROCEDURE PushTrapCleaner* (c: TrapCleaner); + VAR t: TrapCleaner; + BEGIN + t := trapStack; WHILE (t # NIL) & (t # c) DO t := t.next END; + ASSERT(t = NIL, 20); + c.next := trapStack; trapStack := c + END PushTrapCleaner; + + PROCEDURE PopTrapCleaner* (c: TrapCleaner); + VAR t: TrapCleaner; + BEGIN + t := NIL; + WHILE (trapStack # NIL) & (t # c) DO + t := trapStack; trapStack := trapStack.next + END + END PopTrapCleaner; + + PROCEDURE InstallCleaner* (p: Command); + VAR c: CList; + BEGIN + c := S.VAL(CList, NewRec(S.TYP(CList))); (* NEW(c) *) + c.do := p; c.trapped := FALSE; c.next := cleaners; cleaners := c + END InstallCleaner; + + PROCEDURE RemoveCleaner* (p: Command); + VAR c0, c: CList; + BEGIN + c := cleaners; c0 := NIL; + WHILE (c # NIL) & (c.do # p) DO c0 := c; c := c.next END; + IF c # NIL THEN + IF c0 = NIL THEN cleaners := cleaners.next ELSE c0.next := c.next END + END + END RemoveCleaner; + + PROCEDURE Cleanup*; + VAR c, c0: CList; + BEGIN + c := cleaners; c0 := NIL; + WHILE c # NIL DO + IF ~c.trapped THEN + c.trapped := TRUE; c.do; c.trapped := FALSE; c0 := c + ELSE + IF c0 = NIL THEN cleaners := cleaners.next + ELSE c0.next := c.next + END + END; + c := c.next + END + END Cleanup; + + (* -------------------- meta information (portable) --------------------- *) + + PROCEDURE (h: LoaderHook) ThisMod* (IN name: ARRAY OF CHAR): Module, NEW, ABSTRACT; + + PROCEDURE SetLoaderHook*(h: LoaderHook); + BEGIN + loader := h + END SetLoaderHook; + + PROCEDURE InitModule (mod: Module); (* initialize linked modules *) + VAR body: Command; + BEGIN + IF ~(dyn IN mod.opts) & (mod.next # NIL) & ~(init IN mod.next.opts) THEN InitModule(mod.next) END; + IF ~(init IN mod.opts) THEN + body := S.VAL(Command, mod.code); + INCL(mod.opts, init); + actual := mod; + body(); actual := NIL + END + END InitModule; + + PROCEDURE ThisLoadedMod* (IN name: ARRAY OF CHAR): Module; (* loaded modules only *) + VAR m: Module; res: INTEGER; n: Utf8Name; + BEGIN + StringToUtf8(name, n, res); ASSERT(res = 0); + loadres := done; + m := modList; + WHILE (m # NIL) & ((m.name # n) OR (m.refcnt < 0)) DO m := m.next END; + IF (m # NIL) & ~(init IN m.opts) THEN InitModule(m) END; + IF m = NIL THEN loadres := moduleNotFound END; + RETURN m + END ThisLoadedMod; + + PROCEDURE ThisMod* (IN name: ARRAY OF CHAR): Module; + BEGIN + IF loader # NIL THEN + loader.res := done; + RETURN loader.ThisMod(name) + ELSE + RETURN ThisLoadedMod(name) + END + END ThisMod; + + PROCEDURE LoadMod* (IN name: ARRAY OF CHAR); + VAR m: Module; + BEGIN + m := ThisMod(name) + END LoadMod; + + PROCEDURE GetLoaderResult* (OUT res: INTEGER; OUT importing, imported, object: ARRAY OF CHAR); + BEGIN + IF loader # NIL THEN + res := loader.res; + importing := loader.importing$; + imported := loader.imported$; + object := loader.object$ + ELSE + res := loadres; + importing := ""; + imported := ""; + object := "" + END + END GetLoaderResult; + + PROCEDURE ThisObject* (mod: Module; IN name: ARRAY OF CHAR): Object; + VAR l, r, m, res: INTEGER; p: StrPtr; n: Utf8Name; + BEGIN + StringToUtf8(name, n, res); ASSERT(res = 0); + l := 0; r := mod.export.num; + WHILE l < r DO (* binary search *) + m := (l + r) DIV 2; + p := S.VAL(StrPtr, S.ADR(mod.names[mod.export.obj[m].id DIV 256])); + IF p^ = n THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[m])) END; + IF p^ < n THEN l := m + 1 ELSE r := m END + END; + RETURN NIL + END ThisObject; + + PROCEDURE ThisDesc* (mod: Module; fprint: INTEGER): Object; + VAR i, n: INTEGER; + BEGIN + i := 0; n := mod.export.num; + WHILE (i < n) & (mod.export.obj[i].id DIV 256 = 0) DO + IF mod.export.obj[i].offs = fprint THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[i])) END; + INC(i) + END; + RETURN NIL + END ThisDesc; + + PROCEDURE ThisField* (rec: Type; IN name: ARRAY OF CHAR): Object; + VAR n, res: INTEGER; p: StrPtr; obj: Object; m: Module; nn: Utf8Name; + BEGIN + StringToUtf8(name, nn, res); ASSERT(res = 0); + m := rec.mod; + obj := S.VAL(Object, S.ADR(rec.fields.obj[0])); n := rec.fields.num; + WHILE n > 0 DO + p := S.VAL(StrPtr, S.ADR(m.names[obj.id DIV 256])); + IF p^ = nn THEN RETURN obj END; + DEC(n); INC(S.VAL(INTEGER, obj), 16) + END; + RETURN NIL + END ThisField; + + PROCEDURE ThisCommand* (mod: Module; IN name: ARRAY OF CHAR): Command; + VAR x: Object; sig: Signature; + BEGIN + x := ThisObject(mod, name); + IF (x # NIL) & (x.id MOD 16 = mProc) THEN + sig := S.VAL(Signature, x.struct); + IF (sig.retStruct = NIL) & (sig.num = 0) THEN RETURN S.VAL(Command, mod.procBase + x.offs) END + END; + RETURN NIL + END ThisCommand; + + PROCEDURE ThisType* (mod: Module; IN name: ARRAY OF CHAR): Type; + VAR x: Object; + BEGIN + x := ThisObject(mod, name); + IF (x # NIL) & (x.id MOD 16 = mTyp) & (S.VAL(INTEGER, x.struct) DIV 256 # 0) THEN + RETURN x.struct + ELSE + RETURN NIL + END + END ThisType; + + PROCEDURE TypeOf* (IN rec: ANYREC): Type; + BEGIN + RETURN S.VAL(Type, S.TYP(rec)) + END TypeOf; + + PROCEDURE LevelOf* (t: Type): SHORTINT; + BEGIN + RETURN SHORT(t.id DIV 16 MOD 16) + END LevelOf; + + PROCEDURE NewObj* (VAR o: S.PTR; t: Type); + VAR i: INTEGER; + BEGIN + IF t.size = -1 THEN o := NIL + ELSE + i := 0; WHILE t.ptroffs[i] >= 0 DO INC(i) END; + IF t.ptroffs[i+1] >= 0 THEN INC(S.VAL(INTEGER, t)) END; (* with interface pointers *) + o := S.VAL(S.PTR, NewRec(S.VAL(INTEGER, t))) (* generic NEW *) + END + END NewObj; + + PROCEDURE GetModName* (mod: Module; OUT name: Name); + VAR res: INTEGER; + BEGIN + Utf8ToString(mod.name, name, res); ASSERT(res = 0) + END GetModName; + + PROCEDURE GetObjName* (mod: Module; obj: Object; OUT name: Name); + VAR p: StrPtr; res: INTEGER; + BEGIN + p := S.VAL(StrPtr, S.ADR(mod.names[obj.id DIV 256])); + Utf8ToString(p^$, name, res); ASSERT(res = 0) + END GetObjName; + + PROCEDURE GetTypeName* (t: Type; OUT name: Name); + VAR p: StrPtr; res: INTEGER; + BEGIN + p := S.VAL(StrPtr, S.ADR(t.mod.names[t.id DIV 256])); + Utf8ToString(p^$, name, res); ASSERT(res = 0) + END GetTypeName; + + PROCEDURE RegisterMod* (mod: Module); + VAR i: INTEGER; epoch: time.time_t; tm: time.struct_tm; ptm: time.Pstruct_tm; + BEGIN + mod.next := modList; modList := mod; mod.refcnt := 0; INCL(mod.opts, dyn); i := 0; + WHILE i < mod.nofimps DO + IF mod.imports[i] # NIL THEN INC(mod.imports[i].refcnt) END; + INC(i) + END; + epoch := time.time(NIL); + ptm := time.localtime_r(epoch, tm); + IF ptm # NIL THEN + mod.loadTime[0] := SHORT(tm.tm_year + 1900); + mod.loadTime[1] := SHORT(tm.tm_mon + 1); + mod.loadTime[2] := SHORT(tm.tm_mday); + mod.loadTime[3] := SHORT(tm.tm_hour); + mod.loadTime[4] := SHORT(tm.tm_min); + mod.loadTime[5] := SHORT(tm.tm_sec) + ELSE + mod.loadTime[0] := 0; + mod.loadTime[1] := 0; + mod.loadTime[2] := 0; + mod.loadTime[3] := 0; + mod.loadTime[4] := 0; + mod.loadTime[5] := 0 + END; + IF ~(init IN mod.opts) THEN InitModule(mod) END + END RegisterMod; + + PROCEDURE^ Collect*; + + PROCEDURE UnloadMod* (mod: Module); + VAR i: INTEGER; t: Command; + BEGIN + IF mod.refcnt = 0 THEN + t := mod.term; mod.term := NIL; + IF t # NIL THEN t() END; (* terminate module *) + i := 0; + WHILE i < mod.nofptrs DO (* release global pointers *) + S.PUT(mod.varBase + mod.ptrs[i], 0); INC(i) + END; + Collect; (* call finalizers *) + i := 0; + WHILE i < mod.nofimps DO (* release imported modules *) + IF mod.imports[i] # NIL THEN DEC(mod.imports[i].refcnt) END; + INC(i) + END; + mod.refcnt := -1; + IF dyn IN mod.opts THEN (* release memory *) + InvalModMem(mod.data + mod.dsize - mod.refs, mod.refs) + END + END + END UnloadMod; + + (* -------------------- dynamic procedure call --------------------- *) + + PROCEDURE Call* (adr: INTEGER; sig: Signature; IN par: ARRAY OF INTEGER; n: INTEGER): LONGINT; + BEGIN + HALT(126); (* !!! *) + RETURN 0 + END Call; + + (* -------------------- reference information (portable) --------------------- *) + + PROCEDURE RefCh (VAR ref: INTEGER; OUT ch: SHORTCHAR); + BEGIN + S.GET(ref, ch); INC(ref) + END RefCh; + + PROCEDURE RefNum (VAR ref: INTEGER; OUT x: INTEGER); + VAR s, n: INTEGER; ch: SHORTCHAR; + BEGIN + s := 0; n := 0; RefCh(ref, ch); + WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); RefCh(ref, ch) END; + x := n + ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s) + END RefNum; + + PROCEDURE RefName (VAR ref: INTEGER; OUT n: Utf8Name); + VAR i: INTEGER; ch: SHORTCHAR; + BEGIN + i := 0; RefCh(ref, ch); + WHILE ch # 0X DO n[i] := ch; INC(i); RefCh(ref, ch) END; + n[i] := 0X + END RefName; + + PROCEDURE GetRefProc* (VAR ref: INTEGER; OUT adr: INTEGER; OUT name: Utf8Name); + VAR ch: SHORTCHAR; + BEGIN + S.GET(ref, ch); + WHILE ch >= 0FDX DO (* skip variables *) + INC(ref); RefCh(ref, ch); + IF ch = 10X THEN INC(ref, 4) END; + RefNum(ref, adr); RefName(ref, name); S.GET(ref, ch) + END; + WHILE (ch > 0X) & (ch < 0FCX) DO (* skip source refs *) + INC(ref); RefNum(ref, adr); S.GET(ref, ch) + END; + IF ch = 0FCX THEN INC(ref); RefNum(ref, adr); RefName(ref, name) + ELSE adr := 0 + END + END GetRefProc; + + PROCEDURE GetRefVar* (VAR ref: INTEGER; OUT mode, form: SHORTCHAR; OUT desc: Type; OUT adr: INTEGER; OUT name: Utf8Name); + BEGIN + S.GET(ref, mode); desc := NIL; + IF mode >= 0FDX THEN + mode := SHORT(CHR(ORD(mode) - 0FCH)); + INC(ref); RefCh(ref, form); + IF form = 10X THEN + S.GET(ref, desc); INC(ref, 4); form := SHORT(CHR(16 + desc.id MOD 4)) + END; + RefNum(ref, adr); RefName(ref, name) + ELSE + mode := 0X; form := 0X; adr := 0 + END + END GetRefVar; + + PROCEDURE SourcePos* (mod: Module; codePos: INTEGER): INTEGER; + VAR ref, pos, ad, d: INTEGER; ch: SHORTCHAR; name: Utf8Name; + BEGIN + IF mod # NIL THEN (* mf, 12.02.04 *) + ref := mod.refs; pos := 0; ad := 0; S.GET(ref, ch); + WHILE ch # 0X DO + WHILE (ch > 0X) & (ch < 0FCX) DO (* srcref: {dAdr,dPos} *) + INC(ad, ORD(ch)); INC(ref); RefNum(ref, d); + IF ad > codePos THEN RETURN pos END; + INC(pos, d); S.GET(ref, ch) + END; + IF ch = 0FCX THEN (* proc: 0FCX,Adr,Name *) + INC(ref); RefNum(ref, d); RefName(ref, name); S.GET(ref, ch); + IF (d > codePos) & (pos > 0) THEN RETURN pos END + END; + WHILE ch >= 0FDX DO (* skip variables: Mode, Form, adr, Name *) + INC(ref); RefCh(ref, ch); + IF ch = 10X THEN INC(ref, 4) END; + RefNum(ref, d); RefName(ref, name); S.GET(ref, ch) + END + END; + END; + RETURN -1 + END SourcePos; + + PROCEDURE LoadDll* (IN name: ARRAY OF CHAR; VAR ok: BOOLEAN); + VAR h: ADDRESS; file: Utf8Name; res: INTEGER; + BEGIN + StringToUtf8(name, file, res); + IF res = 0 THEN + h := dlfcn.dlopen(file, dlfcn.RTLD_LAZY + dlfcn.RTLD_GLOBAL); + ok := h # 0 + ELSE + ok := FALSE + END + END LoadDll; + + PROCEDURE ThisDllObj* (mode, fprint: INTEGER; IN dll, name: ARRAY OF CHAR): INTEGER; + VAR h, p: ADDRESS; file, sym: Utf8Name; res: INTEGER; err: dlfcn.int; + BEGIN + StringToUtf8(dll, file, res); + IF res = 0 THEN + h := dlfcn.dlopen(file, dlfcn.RTLD_LAZY + dlfcn.RTLD_GLOBAL); + IF h # 0 THEN + StringToUtf8(name, sym, res); + IF res = 0 THEN + p := dlfcn.dlsym(h, sym) + ELSE + p := 0 + END; + err := dlfcn.dlclose(h); + ASSERT(err = 0, 100) + ELSE + p := 0 + END + ELSE + p := 0 + END; + RETURN p + END ThisDllObj; + + (* -------------------- garbage collector (portable) --------------------- *) + + PROCEDURE Mark (this: Block); + VAR father, son: Block; tag: Type; flag, offset, actual: INTEGER; + BEGIN + IF ~ODD(S.VAL(INTEGER, this.tag)) THEN + father := NIL; + LOOP + INC(S.VAL(INTEGER, this.tag)); + flag := S.VAL(INTEGER, this.tag) MOD 4; + tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag); + IF flag >= 2 THEN actual := this.first; this.actual := actual + ELSE actual := S.ADR(this.last) + END; + LOOP + offset := tag.ptroffs[0]; + IF offset < 0 THEN + INC(S.VAL(INTEGER, tag), offset + 4); (* restore tag *) + IF (flag >= 2) & (actual < this.last) & (offset < -4) THEN (* next array element *) + INC(actual, tag.size); this.actual := actual + ELSE (* up *) + this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag); + IF father = NIL THEN RETURN END; + son := this; this := father; + flag := S.VAL(INTEGER, this.tag) MOD 4; + tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag); + offset := tag.ptroffs[0]; + IF flag >= 2 THEN actual := this.actual ELSE actual := S.ADR(this.last) END; + S.GET(actual + offset, father); S.PUT(actual + offset, S.ADR(son.last)); + INC(S.VAL(INTEGER, tag), 4) + END + ELSE + S.GET(actual + offset, son); + IF son # NIL THEN + DEC(S.VAL(INTEGER, son), 4); + IF ~ODD(S.VAL(INTEGER, son.tag)) THEN (* down *) + this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag); + S.PUT(actual + offset, father); father := this; this := son; + EXIT + END + END; + INC(S.VAL(INTEGER, tag), 4) + END + END + END + END + END Mark; + + PROCEDURE MarkGlobals; + VAR m: Module; i, p: INTEGER; + BEGIN + m := modList; + WHILE m # NIL DO + IF m.refcnt >= 0 THEN + i := 0; + WHILE i < m.nofptrs DO + S.GET(m.varBase + m.ptrs[i], p); INC(i); + IF p # 0 THEN Mark(S.VAL(Block, p - 4)) END + END + END; + m := m.next + END + END MarkGlobals; + + PROCEDURE Next (b: Block): Block; (* next block in same cluster *) + VAR size: INTEGER; + BEGIN + S.GET(S.VAL(INTEGER, b.tag) DIV 4 * 4, size); + IF ODD(S.VAL(INTEGER, b.tag) DIV 2) THEN INC(size, b.last - S.ADR(b.last)) END; + RETURN S.VAL(Block, S.VAL(INTEGER, b) + (size + 19) DIV 16 * 16) + END Next; + + PROCEDURE CheckCandidates; + (* pre: nofcand > 0 *) + VAR i, j, h, p, end: INTEGER; c: Cluster; blk, next: Block; + BEGIN + (* sort candidates (shellsort) *) + h := 1; REPEAT h := h*3 + 1 UNTIL h > nofcand; + REPEAT h := h DIV 3; i := h; + WHILE i < nofcand DO p := candidates[i]; j := i; + WHILE (j >= h) & (candidates[j-h] > p) DO + candidates[j] := candidates[j-h]; j := j-h + END; + candidates[j] := p; INC(i) + END + UNTIL h = 1; + (* sweep *) + c := root; i := 0; + WHILE c # NIL DO + blk := S.VAL(Block, S.VAL(INTEGER, c) + 12); + end := S.VAL(INTEGER, blk) + (c.size - 12) DIV 16 * 16; + WHILE candidates[i] < S.VAL(INTEGER, blk) DO + INC(i); + IF i = nofcand THEN RETURN END + END; + WHILE S.VAL(INTEGER, blk) < end DO + next := Next(blk); + IF candidates[i] < S.VAL(INTEGER, next) THEN + IF (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last)) (* not a free block *) + & (~strictStackSweep OR (candidates[i] = S.ADR(blk.last))) THEN + Mark(blk) + END; + REPEAT + INC(i); + IF i = nofcand THEN RETURN END + UNTIL candidates[i] >= S.VAL(INTEGER, next) + END; + IF (S.VAL(INTEGER, blk.tag) MOD 4 = 0) & (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last)) + & (blk.tag.base[0] = NIL) & (blk.actual > 0) THEN (* referenced interface record *) + Mark(blk) + END; + blk := next + END; + c := c.next + END + END CheckCandidates; + + PROCEDURE MarkLocals; + VAR sp, p, min, max: INTEGER; c: Cluster; + BEGIN + sp := S.ADR(sp); nofcand := 0; c := root; + WHILE c.next # NIL DO c := c.next END; + min := S.VAL(INTEGER, root); max := S.VAL(INTEGER, c) + c.size; + WHILE sp < baseStack DO + S.GET(sp, p); + IF (p > min) & (p < max) & (~strictStackSweep OR (p MOD 16 = 0)) THEN + candidates[nofcand] := p; INC(nofcand); + IF nofcand = LEN(candidates) - 1 THEN CheckCandidates; nofcand := 0 END + END; + INC(sp, 4) + END; + candidates[nofcand] := max; INC(nofcand); (* ensure complete scan for interface mark*) + IF nofcand > 0 THEN CheckCandidates END + END MarkLocals; + + PROCEDURE MarkFinObj; + VAR f: FList; + BEGIN + wouldFinalize := FALSE; + f := finalizers; + WHILE f # NIL DO + IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END; + Mark(f.blk); + f := f.next + END; + f := hotFinalizers; + WHILE f # NIL DO IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END; + Mark(f.blk); + f := f.next + END + END MarkFinObj; + + PROCEDURE CheckFinalizers; + VAR f, g, h, k: FList; + BEGIN + f := finalizers; g := NIL; + IF hotFinalizers = NIL THEN k := NIL + ELSE + k := hotFinalizers; + WHILE k.next # NIL DO k := k.next END + END; + WHILE f # NIL DO + h := f; f := f.next; + IF ~ODD(S.VAL(INTEGER, h.blk.tag)) THEN + IF g = NIL THEN finalizers := f ELSE g.next := f END; + IF k = NIL THEN hotFinalizers := h ELSE k.next := h END; + k := h; h.next := NIL + ELSE g := h + END + END; + h := hotFinalizers; + WHILE h # NIL DO Mark(h.blk); h := h.next END + END CheckFinalizers; + + PROCEDURE ExecFinalizer (a, b, c: INTEGER); + VAR f: FList; fin: PROCEDURE(this: ANYPTR); + BEGIN + f := S.VAL(FList, a); + S.GET(S.VAL(INTEGER, f.blk.tag) - 4, fin); (* method 0 *) + IF (fin # NIL) & (f.blk.tag.mod.refcnt >= 0) THEN fin(S.VAL(ANYPTR, S.ADR(f.blk.last))) END; + END ExecFinalizer; + + PROCEDURE^ Try* (h: TryHandler; a, b, c: INTEGER); (* COMPILER DEPENDENT *) + + PROCEDURE CallFinalizers; + VAR f: FList; + BEGIN + WHILE hotFinalizers # NIL DO + f := hotFinalizers; hotFinalizers := hotFinalizers.next; + Try(ExecFinalizer, S.VAL(INTEGER, f), 0, 0) + END; + wouldFinalize := FALSE + END CallFinalizers; + + PROCEDURE Insert (blk: FreeBlock; size: INTEGER); (* insert block in free list *) + VAR i: INTEGER; + BEGIN + blk.size := size - 4; blk.tag := S.VAL(Type, S.ADR(blk.size)); + i := MIN(N - 1, (blk.size DIV 16)); + blk.next := free[i]; free[i] := blk + END Insert; + + PROCEDURE Sweep (dealloc: BOOLEAN); + VAR cluster, last, c: Cluster; blk, next: Block; fblk, b, t: FreeBlock; end, i: INTEGER; + BEGIN + cluster := root; last := NIL; allocated := 0; + i := N; + REPEAT DEC(i); free[i] := sentinel UNTIL i = 0; + WHILE cluster # NIL DO + blk := S.VAL(Block, S.VAL(INTEGER, cluster) + 12); + end := S.VAL(INTEGER, blk) + (cluster.size - 12) DIV 16 * 16; + fblk := NIL; + WHILE S.VAL(INTEGER, blk) < end DO + next := Next(blk); + IF ODD(S.VAL(INTEGER, blk.tag)) THEN + IF fblk # NIL THEN + Insert(fblk, S.VAL(INTEGER, blk) - S.VAL(INTEGER, fblk)); + fblk := NIL + END; + DEC(S.VAL(INTEGER, blk.tag)); (* unmark *) + INC(allocated, S.VAL(INTEGER, next) - S.VAL(INTEGER, blk)) + ELSIF fblk = NIL THEN + fblk := S.VAL(FreeBlock, blk) + END; + blk := next + END; + IF dealloc & (S.VAL(INTEGER, fblk) = S.VAL(INTEGER, cluster) + 12) THEN (* deallocate cluster *) + c := cluster; cluster := cluster.next; + IF last = NIL THEN root := cluster ELSE last.next := cluster END; + FreeHeapMem(c) + ELSE + IF fblk # NIL THEN Insert(fblk, end - S.VAL(INTEGER, fblk)) END; + last := cluster; cluster := cluster.next + END + END; + (* reverse free list *) + i := N; + REPEAT + DEC(i); + b := free[i]; fblk := sentinel; + WHILE b # sentinel DO t := b; b := t.next; t.next := fblk; fblk := t END; + free[i] := fblk + UNTIL i = 0 + END Sweep; + + PROCEDURE Collect*; + BEGIN + IF root # NIL THEN + CallFinalizers; (* trap cleanup *) + MarkGlobals; + MarkLocals; + CheckFinalizers; + Sweep(TRUE); + CallFinalizers + END + END Collect; + + PROCEDURE FastCollect*; + BEGIN + IF root # NIL THEN + MarkGlobals; + MarkLocals; + MarkFinObj; + Sweep(FALSE) + END + END FastCollect; + + PROCEDURE WouldFinalize* (): BOOLEAN; + BEGIN + RETURN wouldFinalize + END WouldFinalize; + + (* --------------------- memory allocation (portable) -------------------- *) + + PROCEDURE OldBlock (size: INTEGER): FreeBlock; (* size MOD 16 = 0 *) + VAR b, l: FreeBlock; s, i: INTEGER; + BEGIN + s := size - 4; + i := MIN(N - 1, s DIV 16); + WHILE (i # N - 1) & (free[i] = sentinel) DO INC(i) END; + b := free[i]; l := NIL; + WHILE b.size < s DO l := b; b := b.next END; + IF b # sentinel THEN + IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END + ELSE b := NIL + END; + RETURN b + END OldBlock; + + PROCEDURE LastBlock (limit: INTEGER): FreeBlock; (* size MOD 16 = 0 *) + VAR b, l: FreeBlock; s, i: INTEGER; + BEGIN + s := limit - 4; + i := 0; + REPEAT + b := free[i]; l := NIL; + WHILE (b # sentinel) & (S.VAL(INTEGER, b) + b.size # s) DO l := b; b := b.next END; + IF b # sentinel THEN + IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END + ELSE b := NIL + END; + INC(i) + UNTIL (b # NIL) OR (i = N); + RETURN b + END LastBlock; + + PROCEDURE NewBlock (size: INTEGER): Block; + VAR tsize, a, s: INTEGER; b: FreeBlock; new, c: Cluster; r: Reducer; + BEGIN + ASSERT(size >= 0, 20); + IF size > MAX(INTEGER) - 19 THEN RETURN NIL END; + tsize := (size + 19) DIV 16 * 16; + b := OldBlock(tsize); (* 1) search for free block *) + IF b = NIL THEN + FastCollect; b := OldBlock(tsize); (* 2) collect *) + IF b = NIL THEN + Collect; b := OldBlock(tsize); (* 2a) fully collect *) + END; + IF b = NIL THEN + AllocHeapMem(tsize + 12, new); (* 3) allocate new cluster *) + IF new # NIL THEN + IF (root = NIL) OR (S.VAL(INTEGER, new) < S.VAL(INTEGER, root)) THEN + new.next := root; root := new + ELSE + c := root; + WHILE (c.next # NIL) & (S.VAL(INTEGER, new) > S.VAL(INTEGER, c.next)) DO c := c.next END; + new.next := c.next; c.next := new + END; + b := S.VAL(FreeBlock, S.VAL(INTEGER, new) + 12); + b.size := (new.size - 12) DIV 16 * 16 - 4 + ELSE + RETURN NIL (* 4) give up *) + END + END + END; + (* b # NIL *) + a := b.size + 4 - tsize; + IF a > 0 THEN Insert(S.VAL(FreeBlock, S.VAL(INTEGER, b) + tsize), a) END; + IF size > 0 THEN Erase(S.ADR(b.size), (size + 3) DIV 4) END; + INC(allocated, tsize); + RETURN S.VAL(Block, b) + END NewBlock; + + PROCEDURE Allocated* (): INTEGER; + BEGIN + RETURN allocated + END Allocated; + + PROCEDURE Used* (): INTEGER; + BEGIN + RETURN used + END Used; + + PROCEDURE Root* (): INTEGER; + BEGIN + RETURN S.VAL(INTEGER, root) + END Root; + + (* -------------------- Trap Handling --------------------- *) + + PROCEDURE Start* (code: Command); + VAR res: setjmp.int; + BEGIN + restart := code; + S.GETREG(SP, baseStack); + res := setjmp.sigsetjmp(startEnv, 1); + restart + END Start; + + PROCEDURE Quit* (exitCode: INTEGER); + VAR m: Module; term: Command; t: BOOLEAN; + BEGIN + trapViewer := NIL; trapChecker := NIL; restart := NIL; + t := terminating; terminating := TRUE; m := modList; + WHILE m # NIL DO (* call terminators *) + IF ~static OR ~t THEN + term := m.term; m.term := NIL; + IF term # NIL THEN term() END + END; + m := m.next + END; + CallFinalizers; + hotFinalizers := finalizers; finalizers := NIL; + CallFinalizers; + stdlib.exit(exitCode) + END Quit; + + PROCEDURE FatalError* (id: INTEGER; str: ARRAY OF CHAR); + VAR res: stdio.int; title: ARRAY 16 OF CHAR; text: ARRAY 256 OF SHORTCHAR; + BEGIN + title := "Error xy"; + title[6] := CHR(id DIV 10 + ORD("0")); + title[7] := CHR(id MOD 10 + ORD("0")); + res := unistd.write(2, S.ADR(title), 8); + stdlib.abort + END FatalError; + + PROCEDURE DefaultTrapViewer; + VAR out: ARRAY 2048 OF SHORTCHAR; a, b, c, len, ref, end: INTEGER; mod: Module; + modName, name: Name; n: Utf8Name; res: unistd.int; + + PROCEDURE WriteString (IN s: ARRAY OF SHORTCHAR); + VAR i: INTEGER; + BEGIN + i := 0; + WHILE (len < LEN(out) - 1) & (s[i] # 0X) DO out[len] := s[i]; INC(i); INC(len) END + END WriteString; + + PROCEDURE WriteHex (x, n: INTEGER); + VAR i, y: INTEGER; + BEGIN + IF len + n < LEN(out) THEN + i := len + n - 1; + WHILE i >= len DO + y := x MOD 16; x := x DIV 16; + IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END; + out[i] := SHORT(CHR(y + ORD("0"))); DEC(i) + END; + INC(len, n) + END + END WriteHex; + + PROCEDURE WriteLn; + BEGIN + IF len < LEN(out) - 1 THEN out[len] := 0AX; INC(len) END + END WriteLn; + + BEGIN + len := 0; + WriteString("====== "); + IF err = 129 THEN WriteString("invalid with") + ELSIF err = 130 THEN WriteString("invalid case") + ELSIF err = 131 THEN WriteString("function without return") + ELSIF err = 132 THEN WriteString("type guard") + ELSIF err = 133 THEN WriteString("implied type guard") + ELSIF err = 134 THEN WriteString("value out of range") + ELSIF err = 135 THEN WriteString("index out of range") + ELSIF err = 136 THEN WriteString("string too long") + ELSIF err = 137 THEN WriteString("stack overflow") + ELSIF err = 138 THEN WriteString("integer overflow") + ELSIF err = 139 THEN WriteString("division by zero") + ELSIF err = 140 THEN WriteString("infinite real result") + ELSIF err = 141 THEN WriteString("real underflow") + ELSIF err = 142 THEN WriteString("real overflow") + ELSIF err = 143 THEN WriteString("undefined real result") + ELSIF err = 144 THEN WriteString("not a number") + ELSIF err = 200 THEN WriteString("keyboard interrupt") + ELSIF err = 201 THEN WriteString("NIL dereference") + ELSIF err = 202 THEN WriteString("illegal instruction: "); + WriteHex(val, 4) + ELSIF err = 203 THEN WriteString("illegal memory read [ad = "); + WriteHex(val, 8); WriteString("]") + ELSIF err = 204 THEN WriteString("illegal memory write [ad = "); + WriteHex(val, 8); WriteString("]") + ELSIF err = 205 THEN WriteString("illegal execution [ad = "); + WriteHex(val, 8); WriteString("]") + ELSIF err = 257 THEN WriteString("out of memory") + ELSIF err = 10001H THEN WriteString("bus error") + ELSIF err = 10002H THEN WriteString("address error") + ELSIF err = 10007H THEN WriteString("fpu error") + ELSIF err < 0 THEN WriteString("exception #"); WriteHex(-err, 2) + ELSE err := err DIV 100 * 256 + err DIV 10 MOD 10 * 16 + err MOD 10; + WriteString("trap #"); WriteHex(err, 3) + END; + WriteString(" ======"); + a := pc; b := fp; c := 12; + REPEAT + WriteLn; WriteString("- "); + mod := modList; + WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO mod := mod.next END; + IF mod # NIL THEN + DEC(a, mod.code); + IF mod.refcnt >= 0 THEN + GetModName(mod, modName); WriteString(SHORT(modName)); ref := mod.refs; + REPEAT GetRefProc(ref, end, n) UNTIL (end = 0) OR (a < end); + IF a < end THEN + Utf8ToString(n, name, res); WriteString("."); WriteString(SHORT(name)) + END + ELSE + GetModName(mod, modName); WriteString("("); WriteString(SHORT(modName)); WriteString(")") + END; + WriteString(" ") + END; + WriteString("(pc="); WriteHex(a, 8); + WriteString(", fp="); WriteHex(b, 8); WriteString(")"); + IF (b >= sp) & (b < stack) THEN + S.GET(b+4, a); (* stacked pc *) + S.GET(b, b); (* dynamic link *) + DEC(c) + ELSE c := 0 + END + UNTIL c = 0; + out[len] := 0X; + res := unistd.write(2, S.ADR(out), len) + END DefaultTrapViewer; + + PROCEDURE TrapCleanup; + VAR t: TrapCleaner; + BEGIN + WHILE trapStack # NIL DO + t := trapStack; trapStack := trapStack.next; t.Cleanup + END; + IF (trapChecker # NIL) & (err # 128) THEN trapChecker END + END TrapCleanup; + + PROCEDURE SetTrapGuard* (on: BOOLEAN); + BEGIN + guarded := on + END SetTrapGuard; + + PROCEDURE Try* (h: TryHandler; a, b, c: INTEGER); + VAR oldIsTry: BOOLEAN; oldTryEnv: setjmp.jmp_buf; res: setjmp.int; + BEGIN + oldIsTry := isTry; oldTryEnv := tryEnv; + isTry := TRUE; + res := setjmp._setjmp(tryEnv); + IF res = 0 THEN h(a, b, c) END; + isTry := oldIsTry; tryEnv := oldTryEnv + END Try; + + PROCEDURE Trap* (n: INTEGER); + BEGIN + IF trapped THEN + DefaultTrapViewer; + IF ~secondTrap THEN trapped := FALSE; secondTrap := TRUE END + END; + IF n >= 0 THEN err := n + ELSE err := -n + 128 + END; + pc := 0; sp := 0; fp := 0; stack := 0; val := 0; + INC(trapCount); + (* !!! InitFPU *) + TrapCleanup; + IF isTry THEN + setjmp._longjmp(tryEnv, 1) + END; + IF err = 128 THEN (* do nothing *) + ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN + trapped := TRUE; trapViewer() + ELSE DefaultTrapViewer + END; + trapped := FALSE; secondTrap := FALSE; + IF restart # NIL THEN + setjmp.siglongjmp(startEnv, 1) + END; + stdlib.abort + END Trap; + + PROCEDURE [ccall] TrapHandler (signo: signal.int; IN info: signal.siginfo_t; context: ADDRESS); + VAR res: signal.int; + BEGIN + IF trapped THEN + DefaultTrapViewer; + IF ~secondTrap THEN trapped := FALSE; secondTrap := TRUE END + END; + err := -signo; pc := 0; sp := 0; fp := 0; stack := baseStack; val := 0; + CASE signo OF + | signal.SIGFPE: + val := info.si_code; + pc := info.info.sigfpe.si_addr; + CASE info.si_code OF + | signal.FPE_INTDIV: err := 139 (* division by zero *) + | signal.FPE_INTOVF: err := 138 (* integer overflow *) + | signal.FPE_FLTDIV: err := 140 (* fpu: division by zero *) + | signal.FPE_FLTOVF: err := 142 (* fpu: overflow *) + | signal.FPE_FLTUND: err := 141 (* fpu: underflow *) + (* !!! | signal.FPE_FLTRES: err := ??? (* fpu: *) *) + | signal.FPE_FLTINV: err := 143 (* val := opcode *) (* fpu: invalid op *) + (* !!! | signal.FPE_FLTSUB: err := ??? (* fpu: *) *) + ELSE (* unknown *) + END + | signal.SIGINT: + val := info.si_code; + err := 200 (* keyboard interrupt *) + | signal.SIGSEGV: + val := info.info.sigsegv.si_addr; + err := 203 (* illigal read *) + | signal.SIGBUS: + val := info.info.sigbus.si_addr; + err := 10001H (* bus error *) + | signal.SIGILL: + pc := info.info.sigill.si_addr; + err := 202; (* illigal instruction *) + IF IsReadable(pc, pc + 4) THEN + S.GET(pc, val) + (* !!! err := halt code *) + END; + ELSE (* unknown *) + END; + INC(trapCount); + (* !!! InitFPU *) + TrapCleanup; + IF isTry THEN + setjmp._longjmp(tryEnv, 1) + END; + IF err = 128 THEN (* do nothing *) + ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN + trapped := TRUE; trapViewer() + ELSE DefaultTrapViewer + END; + trapped := FALSE; secondTrap := FALSE; + IF restart # NIL THEN + setjmp.siglongjmp(startEnv, 1) + END; + stdlib.abort + END TrapHandler; + + (* -------------------- Initialization --------------------- *) + + PROCEDURE InstallTrap (signo: signal.int); + VAR act: signal.struct_sigaction; res: signal.int; + BEGIN + act.handler.sa_handler := NIL; + res := signal.sigemptyset(act.sa_mask); + act.sa_flags := signal.SA_NODEFER + signal.SA_SIGINFO; + act.handler.sa_sigaction := TrapHandler; + res := signal.sigaction(signo, act, NIL); + END InstallTrap; + + PROCEDURE InstallTrapVectors; + BEGIN + InstallTrap(signal.SIGFPE); + InstallTrap(signal.SIGINT); + InstallTrap(signal.SIGSEGV); + InstallTrap(signal.SIGBUS); + InstallTrap(signal.SIGILL) + END InstallTrapVectors; + + PROCEDURE RemoveTrapVectors; + END RemoveTrapVectors; + + PROCEDURE Init; + VAR i: INTEGER; + BEGIN + pagesize := unistd.sysconf(unistd._SC_PAGESIZE); + + (* init heap *) + allocated := 0; total := 0; used := 0; + sentinelBlock.size := MAX(INTEGER); + sentinel := S.ADR(sentinelBlock); + i := N; + REPEAT DEC(i); free[i] := sentinel UNTIL i = 0; + + IF ~inDll THEN + InstallTrapVectors + END; + + (* !!! InitFPU *) + IF ~static THEN + InitModule(modList); + IF ~inDll THEN Quit(1) END + END + END Init; + +BEGIN + IF modList = NIL THEN (* only once *) + S.GETREG(SP, baseStack); + S.GET(baseStack + 16, argc); + argv := S.VAL(ArrStrPtr, baseStack + 20); + S.GETREG(ML, modList); (* linker loads module list to BX *) + static := init IN modList.opts; + inDll := dll IN modList.opts; + Init + END +CLOSE + IF ~terminating THEN + terminating := TRUE; + Quit(0) + END +END Kernel. diff --git a/src/posix/Host/Mod/Console.cp b/src/posix/Host/Mod/Console.cp new file mode 100644 index 0000000..d29048e --- /dev/null +++ b/src/posix/Host/Mod/Console.cp @@ -0,0 +1,41 @@ +MODULE HostConsole; + + IMPORT S := SYSTEM, Console, HostLang, unistd := C99unistd; + + TYPE + Directory = POINTER TO RECORD (Console.Directory) END; + + PROCEDURE (d: Directory) WriteChar (ch: CHAR); + VAR res: INTEGER; s: ARRAY 2 OF CHAR; ss: ARRAY 12 OF SHORTCHAR; + BEGIN + s[0] := ch; s[1] := 0X; + HostLang.StringToHost(s, ss, TRUE, res); + ASSERT(res = 0, 100); + res := unistd.write(1, S.ADR(ss[0]), LEN(ss$)); + res := unistd.fsync(1) + END WriteChar; + + PROCEDURE (d: Directory) WriteString (IN s: ARRAY OF CHAR); + VAR ss: POINTER TO ARRAY OF SHORTCHAR; res: INTEGER; + BEGIN + NEW(ss, LEN(s$) * 4 + 1); + HostLang.StringToHost(s, ss, TRUE, res); + ASSERT(res = 0, 100); + res := unistd.write(1, S.ADR(ss[0]), LEN(ss$)); + res := unistd.fsync(1) + END WriteString; + + PROCEDURE (d: Directory) WriteLn; + BEGIN + d.WriteChar(0AX) + END WriteLn; + + PROCEDURE Init; + VAR d: Directory; + BEGIN + NEW(d); Console.SetDir(d) + END Init; + +BEGIN + Init +END HostConsole. diff --git a/src/posix/Host/Mod/Dates.cp b/src/posix/Host/Mod/Dates.cp new file mode 100644 index 0000000..3d7acab --- /dev/null +++ b/src/posix/Host/Mod/Dates.cp @@ -0,0 +1,142 @@ +MODULE HostDates; + + IMPORT Dates, Strings, time := C99time; + + (* add localization? *) + + TYPE + Hook = POINTER TO RECORD (Dates.Hook) END; + + VAR + day: ARRAY 7, 10 OF CHAR; + month: ARRAY 12, 10 OF CHAR; + + PROCEDURE (h: Hook) GetTime (OUT d: Dates.Date; OUT t: Dates.Time); + VAR epoch: time.time_t; tm: time.struct_tm; ptm: time.Pstruct_tm; + BEGIN + epoch := time.time(NIL); + ptm := time.localtime_r(epoch, tm); + IF ptm # NIL THEN + d.year := tm.tm_year + 1900; + d.month := tm.tm_mon + 1; + d.day := tm.tm_mday; + t.hour := tm.tm_hour; + t.minute := tm.tm_min; + t.second := tm.tm_sec + ELSE + d.year := 0; + d.month := 0; + d.day := 0; + t.hour := 0; + t.minute := 0; + t.second := 0 + END + END GetTime; + + PROCEDURE (h: Hook) GetUTCTime (OUT d: Dates.Date; OUT t: Dates.Time); + VAR epoch: time.time_t; tm: time.struct_tm; ptm: time.Pstruct_tm; + BEGIN + epoch := time.time(NIL); + ptm := time.gmtime_r(epoch, tm); + IF ptm # NIL THEN + d.year := tm.tm_year + 1900; + d.month := tm.tm_mon + 1; + d.day := tm.tm_mday; + t.hour := tm.tm_hour; + t.minute := tm.tm_min; + t.second := tm.tm_sec + ELSE + d.year := 0; + d.month := 0; + d.day := 0; + t.hour := 0; + t.minute := 0; + t.second := 0 + END + END GetUTCTime; + + PROCEDURE (h: Hook) GetUTCBias (OUT bias: INTEGER); + BEGIN + time.tzset; + (* !!! fix Dev2 *) + (* bias := time.timezone DIV 60 *) + bias := 0; + END GetUTCBias; + + PROCEDURE (h: Hook) DateToString (d: Dates.Date; format: INTEGER; OUT str: ARRAY OF CHAR); + VAR s: ARRAY 20 OF CHAR; + + PROCEDURE Copy (IN s: ARRAY OF CHAR; n: INTEGER; OUT str: ARRAY OF CHAR); + VAR i: INTEGER; + BEGIN + FOR i := 0 TO n - 1 DO + str[i] := s[i] + END; + str[i] := 0X + END Copy; + + BEGIN + CASE format OF + | Dates.short: + str[0] := CHR(d.day DIV 10 MOD 10 + ORD("0")); + str[1] := CHR(d.day MOD 10 + ORD("0")); + str[2] := "/"; + str[3] := CHR(d.month DIV 10 MOD 10 + ORD("0")); + str[4] := CHR(d.month MOD 10 + ORD("0")); + str[5] := "/"; + str[6] := CHR(d.year DIV 10 MOD 10 + ORD("0")); + str[7] := CHR(d.year MOD 10 + ORD("0")); + str[8] := 0X + | Dates.abbreviated: + Copy(day[d.day - 1], 3, str); + Copy(month[d.month - 1], 3, s); str := str + ", " + s; + Strings.IntToString(d.year, s); str := str + ", " + s + | Dates.long: + str := day[d.day - 1] + ", " + month[d.month - 1]; + Strings.IntToString(d.year, s); str := str + ", " + s + | Dates.plainAbbreviated: + Copy(month[d.month - 1], 3, str); + Strings.IntToString(d.day, s); str := str + " " + s; + Strings.IntToString(d.year, s); str := str + ", " + s + | Dates.plainLong: + Strings.IntToString(d.day, s); str := month[d.month - 1] + " " + s; + Strings.IntToString(d.year, s); str := str + ", " + s + END + END DateToString; + + PROCEDURE (h: Hook) TimeToString (t: Dates.Time; OUT str: ARRAY OF CHAR); + VAR s: ARRAY 12 OF CHAR; + BEGIN + Strings.IntToString(t.hour, str); + Strings.IntToString(t.minute, s); str := str + ":" + s; + Strings.IntToString(t.second, s); str := str + ":" + s; + END TimeToString; + + PROCEDURE Init; + VAR h: Hook; + BEGIN + day[0] := "Monday"; + day[1] := "Tuesday"; + day[2] := "Wednesday"; + day[3] := "Thursday"; + day[4] := "Friday"; + day[5] := "Saturday"; + day[6] := "Sunday"; + month[0] := "January"; + month[1] := "February"; + month[2] := "March"; + month[3] := "April"; + month[4] := "May"; + month[5] := "June"; + month[6] := "July"; + month[7] := "August"; + month[8] := "September"; + month[9] := "October"; + month[10] := "November"; + month[11] := "December"; + NEW(h); Dates.SetHook(h) + END Init; + +BEGIN + Init +END HostDates. diff --git a/src/posix/Host/Mod/Files.cp b/src/posix/Host/Mod/Files.cp new file mode 100644 index 0000000..19517f2 --- /dev/null +++ b/src/posix/Host/Mod/Files.cp @@ -0,0 +1,757 @@ +MODULE HostFiles; + + IMPORT S := SYSTEM, Kernel, HostLang, Files, Log, stdlib := C99stdlib, + unistd := C99unistd, dirent := C99dirent, fcntl := C99fcntl, + sysstat := C99sys_stat, stdio := C99stdio, errno := C99errno, + macro := C99macro, libgen := C99libgen, time := C99time; + + (* !!! add buffer cache *) + + CONST + closed = 0; new = 1; temp = 2; shared = 3; exclusive = 4; + + TYPE + FullName* = Files.Name; + NativeName* = ARRAY 1024 OF SHORTCHAR; + + Locator = POINTER TO RECORD (Files.Locator) + path-: FullName (* pathname # "" *) + END; + + Directory = POINTER TO RECORD (Files.Directory) END; + + File = POINTER TO RECORD (Files.File) + state: INTEGER; + len: INTEGER; + fd: unistd.int; + ino: sysstat.ino_t; + pathname: FullName + END; + + Reader = POINTER TO RECORD (Files.Reader) + f: File; + pos: INTEGER + END; + + Writer = POINTER TO RECORD (Files.Writer) + f: File; + pos: INTEGER + END; + + InodeIdentifier = RECORD (Kernel.Identifier) + ino: sysstat.ino_t + END; + + VAR + ignoreAsk-: BOOLEAN; + root: Locator; + + PROCEDURE (VAR id: InodeIdentifier) Identified (): BOOLEAN; + VAR f: File; + BEGIN + f := id.obj(File); + RETURN (f.state # closed) & (f.ino = id.ino) + END Identified; + + PROCEDURE GetFileByInode (ino: sysstat.ino_t): File; + VAR id: InodeIdentifier; obj: ANYPTR; f: File; + BEGIN + ASSERT(ino # 0, 20); + id.typ := S.TYP(File); + id.ino := ino; + obj := Kernel.ThisFinObj(id); + IF obj # NIL THEN f := obj(File) + ELSE f := NIL + END; + RETURN f + END GetFileByInode; + + PROCEDURE GetError (OUT res: INTEGER); + VAR err: INTEGER; + BEGIN + err := macro.errno(); + CASE err OF + | errno.ENAMETOOLONG, errno.ENOTDIR: res := 1 (* invalid name/location *) + | errno.ENOENT: res := 2 (* file/dir not found *) + | errno.EEXIST: res := 3 (* file/dir already exists *) + | errno.EROFS: res := 4 (* write-protection *) + | errno.EIO: res := 5 (* io error *) + | errno.EACCES, errno.EPERM: res := 6 (* access denied *) + | errno.ENOMEM: res := 80 (* not enough memory *) + | errno.ENFILE, errno.ENOBUFS, errno.ENOSPC: res := 81 (* not enough system resources *) + ELSE res := -err + END + END GetError; + + (* Locator *) + + PROCEDURE NewLocator* (IN path: ARRAY OF CHAR): Locator; + VAR l: Locator; ch: SHORTCHAR; + BEGIN + NEW(l); + IF path = "" THEN l.path := "." + ELSE l.path := path$ + END; + RETURN l + END NewLocator; + + PROCEDURE (l: Locator) This (IN path: ARRAY OF CHAR): Locator; + VAR loc: Locator; + BEGIN + IF path = "" THEN NEW(loc); loc^ := l^ + ELSIF path[0] = "/" THEN loc := NewLocator(path) + ELSE loc := NewLocator(l.path + "/" + path) + END; + RETURN loc + END This; + + (* File *) + + PROCEDURE (f: File) Length (): INTEGER; + BEGIN + RETURN f.len + END Length; + + PROCEDURE (f: File) NewReader (old: Files.Reader): Reader; + VAR r: Reader; + BEGIN + ASSERT(f.state # closed, 20); + IF (old # NIL) & (old.Base() = f) THEN + r := old(Reader); + IF r.pos > f.len THEN r.pos := 0 END; + r.eof := FALSE + ELSE NEW(r); r.f := f; r.pos := 0 + END; + RETURN r + END NewReader; + + PROCEDURE (f: File) NewWriter (old: Files.Writer): Writer; + VAR w: Writer; + BEGIN + ASSERT(f.state # closed, 20); + ASSERT(f.state # shared, 21); + IF (old # NIL) & (old.Base() = f) THEN + w := old(Writer); + IF w.pos > f.len THEN w.pos := 0 END + ELSE NEW(w); w.f := f; w.pos := 0 + END; + RETURN w + END NewWriter; + + PROCEDURE (f: File) Flush; + VAR res: unistd.int; + BEGIN + IF f.state # closed THEN + res := unistd.fsync(f.fd); + ASSERT(res = 0, 100) + END + END Flush; + + PROCEDURE IsName (IN name: Files.Name): BOOLEAN; + VAR i: INTEGER; + BEGIN + i := 0; + WHILE (name[i] # "/") & (name[i] # 0X) DO INC(i) END; + RETURN name[i] = 0X + END IsName; + + PROCEDURE DirName (VAR path: ARRAY OF CHAR); + VAR i, j, k: INTEGER; + BEGIN + IF path[0] = "/" THEN i := 1; j := 1; k := 1 + ELSE i := 0; j := 0; k := 0 + END; + WHILE path[i] # 0X DO + IF path[i] = "/" THEN + k := j; j := i; INC(i); + WHILE (path[i] # 0X) & (path[i] = "/") DO INC(i) END; + IF path[i] = 0X THEN j := k END + ELSE + INC(i) + END + END; + path[j] := 0X + END DirName; + + PROCEDURE (f: File) Register (name: Files.Name; type: Files.Type; ask: BOOLEAN; OUT res: INTEGER); + VAR i, err: INTEGER; dir: FullName; p0, p1: NativeName; s: sysstat.struct_stat; x: unistd.int; + BEGIN + ASSERT(f.state = new, 20); + ASSERT(name # "", 21); + ASSERT(IsName(name), 22); + HostLang.StringToHost(f.pathname, p0, FALSE, err); + IF err = 0 THEN + dir := f.pathname$; + DirName(dir); + HostLang.StringToHost(dir + "/" + name, p1, FALSE, err); + IF err = 0 THEN + x := stdio.rename(p0, p1); + IF x = 0 THEN res := 0 (* no error *) + ELSE GetError(res) + END; + f.state := exclusive; + f.Close + ELSE + res := 1 (* invalid name (too long?) *) + END + ELSE + res := 1 (* invalid name (too long?) *) + END + END Register; + + PROCEDURE (f: File) Close; + VAR res: unistd.int; path: NativeName; err: INTEGER; + BEGIN + IF f.state # closed THEN + f.Flush; + IF f.state = new THEN + HostLang.StringToHost(f.pathname, path, FALSE, err); + ASSERT(err = 0, 100); + res := unistd.unlink(path); + ASSERT(res = 0, 101); + f.state := temp + END; + res := unistd.close(f.fd); + ASSERT(res = 0, 102); + f.state := closed + END + END Close; + + PROCEDURE (f: File) Closed (): BOOLEAN; + BEGIN + RETURN f.state = closed + END Closed; + + PROCEDURE (f: File) Shared (): BOOLEAN; + BEGIN + RETURN f.state = shared + END Shared; + + PROCEDURE (f: File) FINALIZE; + BEGIN + f.Close + END FINALIZE; + + (* Reader *) + + PROCEDURE (r: Reader) Base (): File; + BEGIN + RETURN r.f + END Base; + + PROCEDURE (r: Reader) Pos (): INTEGER; + BEGIN + RETURN r.pos + END Pos; + + PROCEDURE (r: Reader) SetPos (pos: INTEGER); + BEGIN + ASSERT(pos >= 0, 20); + ASSERT(pos <= r.f.len, 21); + r.pos := pos; + r.eof := FALSE + END SetPos; + + PROCEDURE (r: Reader) ReadByte (OUT x: BYTE); + VAR res: unistd.int; offset: unistd.off_t; + BEGIN + ASSERT(r.f.state # closed, 20); + offset := unistd.lseek(r.f.fd, r.pos, unistd.SEEK_SET); + ASSERT(offset = r.pos, 100); + res := unistd.read(r.f.fd, S.ADR(x), 1); + ASSERT(res # -1, 101); + IF res = 0 THEN x := 0 END; + r.pos := r.pos + res; + r.eof := res = 0 + END ReadByte; + + PROCEDURE (r: Reader) ReadBytes (VAR x: ARRAY OF BYTE; beg, len: INTEGER); + VAR res: unistd.int; offset: unistd.off_t; + BEGIN + ASSERT(beg >= 0, 20); + ASSERT(len >= 0, 2); + ASSERT(beg + len <= LEN(x), 22); + ASSERT(r.f.state # closed, 23); + offset := unistd.lseek(r.f.fd, r.pos, unistd.SEEK_SET); + ASSERT(offset = r.pos, 100); + res := unistd.read(r.f.fd, S.ADR(x[beg]), len); + ASSERT(res # -1, 101); + r.pos := r.pos + res; + r.eof := res = 0 + END ReadBytes; + + (* Writer *) + + PROCEDURE (w: Writer) Base (): File; + BEGIN + RETURN w.f + END Base; + + PROCEDURE (w: Writer) Pos (): INTEGER; + BEGIN + RETURN w.pos + END Pos; + + PROCEDURE (w: Writer) SetPos (pos: INTEGER); + BEGIN + ASSERT(pos >= 0, 20); + ASSERT(pos <= w.f.len, 21); + w.pos := pos + END SetPos; + + PROCEDURE (w: Writer) WriteByte (x: BYTE); + VAR res: unistd.int; offset: unistd.off_t; + BEGIN + ASSERT(w.f.state # closed, 20); + offset := unistd.lseek(w.f.fd, w.pos, unistd.SEEK_SET); + ASSERT(offset = w.pos, 100); + res := unistd.write(w.f.fd, S.ADR(x), 1); + ASSERT(res # -1, 101); + w.pos := w.pos + res; + w.f.len := MAX(w.f.len, w.pos); + ASSERT(res = 1, 60) + END WriteByte; + + PROCEDURE (w: Writer) WriteBytes (IN x: ARRAY OF BYTE; beg, len: INTEGER); + VAR res: unistd.int; offset: unistd.off_t; + BEGIN + ASSERT(beg >= 0, 20); + ASSERT(len >= 0, 21); + ASSERT(beg + len <= LEN(x), 22); + ASSERT(w.f.state # closed, 23); + offset := unistd.lseek(w.f.fd, w.pos, unistd.SEEK_SET); + ASSERT(offset = w.pos, 100); + res := unistd.write(w.f.fd, S.ADR(x[beg]), len); + ASSERT(res # -1, 101); + w.pos := w.pos + res; + w.f.len := MAX(w.f.len, w.pos); + ASSERT(res = len, 60) + END WriteBytes; + + (* Directory *) + + PROCEDURE (d: Directory) This (IN path: ARRAY OF CHAR): Locator; + BEGIN + RETURN root.This(path) + END This; + + PROCEDURE MakeDir (path: ARRAY OF SHORTCHAR; OUT res: unistd.int); + VAR i: INTEGER; sep: BOOLEAN; err: unistd.int; s: sysstat.struct_stat; mode: sysstat.mode_t; + BEGIN + i := 0; err := 0; + mode := ORD(BITS(511(*a=rwx*)) - BITS(sysstat.umask(0))); + WHILE (err = 0) & (path[i] # 0X) DO + WHILE (path[i] # "/") & (path[i] # 0X) DO INC(i) END; + sep := path[i] = "/"; + IF sep THEN path[i] := 0X END; + err := sysstat.mkdir(path, mode); + IF err = -1 THEN + GetError(err); + IF err = 3 THEN + (* already exists, continue make dirs *) + err := 0 + END + END; + IF sep THEN path[i] := "/" END; + INC(i) + END; + res := err + END MakeDir; + + PROCEDURE (d: Directory) New (loc: Files.Locator; ask: BOOLEAN): File; + VAR err: INTEGER; f: File; s: sysstat.struct_stat; fd, res: unistd.int; pathname: NativeName; + BEGIN + ASSERT(loc # NIL, 20); + WITH loc: Locator DO + HostLang.StringToHost(loc.path, pathname, FALSE, err); + IF err = 0 THEN + MakeDir(pathname, res); + IF res = 0 THEN + (* use fcntl.open() with O_TMPFILE for Linux 3.11+? *) + pathname := pathname + "/" + ".newXXXXXX"; + fd := stdlib.mkstemp(pathname); + IF fd # -1 THEN + NEW(f); HostLang.HostToString(pathname, f.pathname, FALSE, err); + IF err = 0 THEN + (* !!! get valid inode? *) + f.fd := fd; f.len := 0; f.state := new; f.ino := 0; + loc.res := 0 (* no errors *) + ELSE + f := NIL; + res := unistd.close(fd); + ASSERT(res = 0, 100); + res := unistd.unlink(pathname); + ASSERT(res = 0, 101); + loc.res := 1 (* invalid name *) + END + ELSE + GetError(loc.res) + END + ELSE + loc.res := res + END + ELSE + loc.res := 1 (* invalid name *) + END + ELSE + loc.res := 1 (* invalid locator *) + END; + RETURN f + END New; + + PROCEDURE IsRegFile (IN s: sysstat.struct_stat): BOOLEAN; + BEGIN + RETURN BITS(s.st_mode) * BITS(sysstat.S_IFMT) = BITS(sysstat.S_IFREG) + END IsRegFile; + + PROCEDURE (d: Directory) Old (loc: Files.Locator; name: Files.Name; isShared: BOOLEAN): File; + CONST rwrwrw = 438; + VAR err: INTEGER; f, if: File; s: sysstat.struct_stat; fd, flags, res: unistd.int; + pathname: NativeName; mode: sysstat.mode_t; lock: fcntl.struct_flock; + + PROCEDURE Cleanup; + BEGIN + f := NIL; + res := unistd.close(fd); + ASSERT(res = 0, 100) + END Cleanup; + + BEGIN + ASSERT(loc # NIL, 20); + ASSERT(name # "", 21); + WITH loc: Locator DO + IF IsName(name) THEN + HostLang.StringToHost(loc.path + "/" + name, pathname, FALSE, err); + IF err = 0 THEN + res := macro.stat(pathname, s); + IF res = 0 THEN + IF IsRegFile(s) THEN + if := GetFileByInode(s.st_ino); + IF (if = NIL) OR isShared & (if.state = shared) THEN + mode := ORD(BITS(rwrwrw) - BITS(sysstat.umask(0))); + IF isShared THEN flags := fcntl.O_RDONLY + ELSE flags := fcntl.O_RDWR + END; + fd := fcntl.open(pathname, flags, mode); + IF fd # -1 THEN + IF isShared THEN lock.l_type := fcntl.F_RDLCK + ELSE lock.l_type := fcntl.F_WRLCK + END; + lock.l_whence := unistd.SEEK_SET; + lock.l_start := 0; + lock.l_len := 0; + lock.l_pid := 0; + res := fcntl.fcntl(fd, fcntl.F_SETLK, S.ADR(lock)); + IF res # -1 THEN + NEW(f); HostLang.HostToString(pathname, f.pathname, FALSE, err); + IF err = 0 THEN + f.fd := fd; f.len := s.st_size; f.ino := s.st_ino; + IF isShared THEN f.state := shared + ELSE f.state := exclusive + END; + loc.res := 0 (* no errors *) + ELSE + loc.res := 1; (* invalid name *) + Cleanup + END + ELSE + GetError(loc.res); (* already locked *) + Cleanup + END + ELSE + GetError(loc.res) (* failed to open *) + END + ELSE + loc.res := 6 (* already opened / locked *) + END + ELSE + loc.res := 6 (* access denied (not a regular file) *) + END + ELSE + loc.res := 2 (* file not found *) + END + ELSE + loc.res := 1 (* invalid name *) + END + ELSE + loc.res := 1 (* invalid name *) + END + ELSE + loc.res := 1 (* invalid locator *) + END; + RETURN f + END Old; + + PROCEDURE (d: Directory) Temp (): File; + VAR f: File; fd: unistd.int; name: ARRAY 12 OF SHORTCHAR; + BEGIN + (* use fcntl.open() with O_TMPFILE for Linux 3.11+? *) + name := ".tmpXXXXXX"; + fd := stdlib.mkstemp(name); + ASSERT(fd # -1, 100); + (* !!! get pathname and unlink it here *) + NEW(f); f.fd := fd; f.pathname := ""; f.len := 0; f.ino := 0; f.state := temp; + RETURN f + END Temp; + + PROCEDURE (d: Directory) Delete (loc: Files.Locator; name: Files.Name); + VAR pathname: NativeName; err: INTEGER; res: unistd.int; + BEGIN + ASSERT(loc # NIL, 20); + ASSERT(IsName(name), 21); + WITH loc: Locator DO + IF IsName(name) THEN + HostLang.StringToHost(loc.path + "/" + name, pathname, FALSE, err); + IF err = 0 THEN + res := unistd.unlink(pathname); + IF res = 0 THEN loc.res := 0 (* no error *) + ELSE GetError(loc.res) + END + ELSE + loc.res := 1 (* invalid name *) + END + ELSE + loc.res := 1 (* invalid name *) + END + ELSE + loc.res := 1 (* invalid locator *) + END + END Delete; + + PROCEDURE (d: Directory) Rename (loc: Files.Locator; old, new: Files.Name; ask: BOOLEAN); + VAR p0, p1: NativeName; res: stdio.int; err: INTEGER; + BEGIN + ASSERT(loc # NIL, 20); + ASSERT(old # "", 21); + ASSERT(new # "", 22); + WITH loc: Locator DO + IF IsName(old) & IsName(new) THEN + HostLang.StringToHost(loc.path + "/" + old, p0, FALSE, err); + IF err = 0 THEN + HostLang.StringToHost(loc.path + "/" + new, p1, FALSE, err); + IF err = 0 THEN + res := stdio.rename(p0, p1); + IF res = 0 THEN loc.res := 0 (* no error *) + ELSE GetError(loc.res) + END + ELSE + loc.res := 1 (* invalid name *) + END + ELSE + loc.res := 1 (* invalid name *) + END + ELSE + loc.res := 1 (* invalid name *) + END + ELSE + loc.res := 1 (* invalid locator *) + END + END Rename; + + PROCEDURE (d: Directory) SameFile (loc0: Files.Locator; name0: Files.Name; loc1: Files.Locator; name1: Files.Name): BOOLEAN; + VAR ok: BOOLEAN; a0, a1: NativeName; s0, s1: sysstat.struct_stat; err: INTEGER; + BEGIN + ASSERT(loc0 # NIL, 20); + ASSERT(name0 # "", 21); + ASSERT(loc1 # NIL, 22); + ASSERT(name1 # "", 23); + ok := FALSE; + WITH loc0: Locator DO + WITH loc1: Locator DO + IF IsName(name0) & IsName(name1) THEN + HostLang.StringToHost(loc0.path + "/" + name0, a0, FALSE, err); + IF err = 0 THEN + err := macro.stat(a0, s0); + IF err = 0 THEN + HostLang.StringToHost(loc1.path + "/" + name1, a1, FALSE, err); + IF err = 0 THEN + err := macro.stat(a1, s1); + IF err = 0 THEN + ok := s0.st_ino = s1.st_ino + END + END + END + END + END + ELSE (* don't trap *) + END + ELSE (* don't trap *) + END; + RETURN ok + END SameFile; + + PROCEDURE IsDir (IN s: sysstat.struct_stat): BOOLEAN; + BEGIN + RETURN BITS(s.st_mode) * BITS(sysstat.S_IFMT) = BITS(sysstat.S_IFDIR) + END IsDir; + + PROCEDURE GetAttr (IN path: NativeName; IN name: FullName; s: sysstat.struct_stat): SET; + VAR attr: SET; + BEGIN + attr := {}; + IF name[0] = "." THEN INCL(attr, Files.hidden) END; + IF BITS(s.st_mode) * BITS(sysstat.S_IXOTH) # {} THEN INCL(attr, 16) END; + IF BITS(s.st_mode) * BITS(sysstat.S_IWOTH) # {} THEN INCL(attr, 17) END; + IF BITS(s.st_mode) * BITS(sysstat.S_IROTH) # {} THEN INCL(attr, 18) END; + IF BITS(s.st_mode) * BITS(sysstat.S_IXGRP) # {} THEN INCL(attr, 19) END; + IF BITS(s.st_mode) * BITS(sysstat.S_IWGRP) # {} THEN INCL(attr, 20) END; + IF BITS(s.st_mode) * BITS(sysstat.S_IRGRP) # {} THEN INCL(attr, 21) END; + IF BITS(s.st_mode) * BITS(sysstat.S_IXUSR) # {} THEN INCL(attr, 22) END; + IF BITS(s.st_mode) * BITS(sysstat.S_IWUSR) # {} THEN INCL(attr, 23) END; + IF BITS(s.st_mode) * BITS(sysstat.S_IRUSR) # {} THEN INCL(attr, 24) END; + IF BITS(s.st_mode) * BITS(sysstat.S_ISVTX) # {} THEN INCL(attr, 25) END; + IF BITS(s.st_mode) * BITS(sysstat.S_ISGID) # {} THEN INCL(attr, 26) END; + IF BITS(s.st_mode) * BITS(sysstat.S_ISUID) # {} THEN INCL(attr, 27) END; + (* !!! better to check real access? *) + IF BITS(s.st_mode) * BITS(sysstat.S_IRUSR) # {} THEN INCL(attr, Files.readOnly) END; + RETURN attr + END GetAttr; + + PROCEDURE (d: Directory) FileList (loc: Files.Locator): Files.FileInfo; + VAR + pathname: NativeName; + name: FullName; + err: INTEGER; + p: dirent.PDIR; + ent: dirent.Pstruct_dirent; + s: sysstat.struct_stat; + res: sysstat.int; + tm: time.Pstruct_tm; + h, t: Files.FileInfo; + BEGIN + ASSERT(loc # NIL, 20); + WITH loc: Locator DO + HostLang.StringToHost(loc.path, pathname, FALSE, err); + IF err = 0 THEN + p := dirent.opendir(pathname); + IF p # NIL THEN + ent := dirent.readdir(p); + WHILE ent # NIL DO + HostLang.HostToString(ent.d_name, name, FALSE, err); + IF err = 0 THEN + HostLang.StringToHost(loc.path + "/" + name, pathname, FALSE, err); + IF err = 0 THEN + res := macro.stat(pathname, s); + IF (res = 0) & ~IsDir(s) THEN + IF h = NIL THEN NEW(h); t := h + ELSE NEW(t.next); t := t.next + END; + t.name := name$; + t.type := ""; (* ??? *) + t.length := s.st_size; + tm := time.localtime(s.st_mtim.tv_sec); + IF tm # NIL THEN + t.modified.year := tm.tm_year + 1900; + t.modified.month := tm.tm_mon + 1; + t.modified.day := tm.tm_mday; + t.modified.hour := tm.tm_hour; + t.modified.minute := tm.tm_min; + t.modified.second := tm.tm_sec + END; + t.attr := GetAttr(pathname, name, s) + END + END + END; + ent := dirent.readdir(p) + END; + res := dirent.closedir(p); + ASSERT(res = 0, 100); + loc.res := 0 (* no error *) + ELSE + GetError(loc.res) + END + ELSE + loc.res := 1 (* invalid name *) + END + ELSE + loc.res := 1 (* invalid locator *) + END; + RETURN h + END FileList; + + PROCEDURE (d: Directory) LocList (loc: Files.Locator): Files.LocInfo; + VAR + pathname: NativeName; + name: FullName; + err: INTEGER; + p: dirent.PDIR; + ent: dirent.Pstruct_dirent; + s: sysstat.struct_stat; + res: sysstat.int; + tm: time.Pstruct_tm; + h, t: Files.LocInfo; + BEGIN + ASSERT(loc # NIL, 20); + WITH loc: Locator DO + HostLang.StringToHost(loc.path, pathname, FALSE, err); + IF err = 0 THEN + p := dirent.opendir(pathname); + IF p # NIL THEN + ent := dirent.readdir(p); + WHILE ent # NIL DO + HostLang.HostToString(ent.d_name, name, FALSE, err); + IF err = 0 THEN + HostLang.StringToHost(loc.path + "/" + name, pathname, FALSE, err); + IF err = 0 THEN + res := macro.stat(pathname, s); + IF (res = 0) & IsDir(s) & (name # ".") & (name # "..") THEN + IF h = NIL THEN NEW(h); t := h + ELSE NEW(t.next); t := t.next + END; + t.name := name$; + t.attr := GetAttr(pathname, name, s) + END + END + END; + ent := dirent.readdir(p) + END; + res := dirent.closedir(p); + ASSERT(res = 0, 100); + loc.res := 0 (* no error *) + ELSE + GetError(loc.res) + END + ELSE + loc.res := 1 (* invlid name *) + END + ELSE + loc.res := 1 (* invalid locator *) + END; + RETURN h + END LocList; + + PROCEDURE (d: Directory) GetFileName (name: Files.Name; type: Files.Type; OUT filename: Files.Name); + BEGIN + filename := name + "." + type + END GetFileName; + + (* Misc *) + + (* !!! implement NofFiles *) + (* !!! implement GetModDate & GetName *) + + PROCEDURE SetRootDir* (x: ARRAY OF CHAR); + BEGIN + root := NewLocator(x) + END SetRootDir; + + PROCEDURE UseAsk*; + BEGIN + ignoreAsk := FALSE + END UseAsk; + + PROCEDURE IgnoreAsk*; + BEGIN + ignoreAsk := TRUE + END IgnoreAsk; + + PROCEDURE Init; + VAR d: Directory; + BEGIN + SetRootDir("."); + NEW(d); Files.SetDir(d) + END Init; + +BEGIN + Init +END HostFiles. diff --git a/src/posix/Host/Mod/Lang.cp b/src/posix/Host/Mod/Lang.cp new file mode 100644 index 0000000..836888e --- /dev/null +++ b/src/posix/Host/Mod/Lang.cp @@ -0,0 +1,167 @@ +MODULE HostLang; + + IMPORT S := SYSTEM, Kernel, stdlib := C99stdlib, locale := C99locale, + iconv := C99iconv, errno := C99errno, macro := C99macro; + + CONST + maxLen = 32; + + VAR + lang-, country-, encoding-: ARRAY maxLen OF CHAR; + c2sc, sc2c, invalid: iconv.iconv_t; + + (* PEP 383 *) + + PROCEDURE StringToHost* (IN in: ARRAY OF CHAR; OUT out: ARRAY OF SHORTCHAR; low: BOOLEAN; OUT res: INTEGER); + VAR i, j, err: INTEGER; maxlen, len, count: iconv.size_t; inadr, outadr: Kernel.ADDRESS; ch: SHORTCHAR; + BEGIN + ASSERT(c2sc # invalid, 100); + i := 0; err := 0; + outadr := S.ADR(out[0]); + maxlen := LEN(out) - 1; + WHILE (err = 0) & (in[i] # 0X) DO + j := i; + WHILE (in[i] # 0X) & ((in[i] < 0D800X) OR (in[i] > 0D8FFX)) DO INC(i) END; + len := (i - j) * 2; + WHILE (err = 0) & (len > 0) & (maxlen > 0) DO + inadr := S.ADR(in[j]); + count := iconv.iconv(c2sc, inadr, len, outadr, maxlen); + IF count # 0 THEN + CASE macro.errno() OF + | errno.EILSEQ: + (* !!! HALT(101)*) (* invalid input char *) + IF maxlen < 1 THEN + err := 1 + ELSE + ch := "?"; + S.PUT(outadr, ch); INC(outadr); DEC(maxlen); + INC(j); DEC(len, 2) + END + | errno.E2BIG: err := 1 (* unexpected end of out *) + | errno.EINVAL: HALT(102) (* unexpected end of input *) + | errno.EBADF: HALT(103) (* invalid iconv descriptor *) + ELSE HALT(104) (* unknown error *) + END + END + END; + WHILE (err = 0) & (in[i] >= 0D800X) & (in[i] <= 0D8FFX) DO + IF maxlen < 1 THEN + err := 1 + ELSE + ch := SHORT(CHR(ORD(in[i]) MOD 256)); + IF low OR (ch > 7FX) THEN + S.PUT(outadr, ch); INC(outadr); DEC(maxlen); + INC(i) + ELSE + err := 3 (* invalid char *) + END + END + END + END; + ch := 0X; + S.PUT(outadr, ch); + res := err + END StringToHost; + + PROCEDURE HostToString* (IN in: ARRAY OF SHORTCHAR; OUT out: ARRAY OF CHAR; low: BOOLEAN; OUT res: INTEGER); + VAR err: INTEGER; maxin, maxout, count: iconv.size_t; inadr, outadr: Kernel.ADDRESS; sch: SHORTCHAR; ch: CHAR; + BEGIN + ASSERT(sc2c # invalid, 100); + err := 0; + inadr := S.ADR(in[0]); + outadr := S.ADR(out[0]); + maxin := LEN(in$); maxout := LEN(out) * 2 - 2; + WHILE (err = 0) & (maxout > 1) & (maxin > 0) DO + count := iconv.iconv(sc2c, inadr, maxin, outadr, maxout); + IF count # 0 THEN + CASE macro.errno() OF + | errno.EILSEQ, errno.EINVAL, errno.E2BIG: + IF maxout < 2 THEN + err := 1 (* unexpected end of output buffer *) + ELSIF maxin < 1 THEN + err := 2 (* unexpected end of input buffer *) + ELSE + S.GET(inadr, sch); INC(inadr); DEC(maxin); + ch := CHR(0D800H + ORD(sch)); + IF low OR (ch > 7FX) THEN + S.PUT(outadr, ch); INC(outadr, 2); DEC(maxout, 2) + ELSE + err := 3 (* invalid char *) + END + END + | errno.EBADF: HALT(101) + ELSE HALT(102) + END + END + END; + ch := 0X; + S.PUT(outadr, ch); + res := err + END HostToString; + + PROCEDURE Init; + VAR p: POINTER TO ARRAY [untagged] OF SHORTCHAR; i, j: INTEGER; enc: ARRAY 32 OF SHORTCHAR; + BEGIN + invalid := S.VAL(iconv.iconv_t, -1); + p := locale.setlocale(locale.LC_ALL, ""); + IF p = NIL THEN + p := stdlib.getenv("LANG"); + IF p = NIL THEN + p := "" + END + END; + i := 0; j := 0; + WHILE (p[i] # 0X) & (p[i] # "_") & (p[i] # ".") DO + lang[j] := p[i]; + INC(i); INC(j) + END; + lang[j] := 0X; + IF p[i] = "_" THEN + INC(i); j := 0; + WHILE (p[i] # 0X) & (p[i] # ".") DO + country[j] := p[i]; + INC(i); INC(j) + END; + country[j] := 0X + END; + enc := "ASCII"; + IF p[i] = "." THEN + INC(i); j := 0; + WHILE p[i] # 0X DO + enc[j] := p[i]; + INC(i); INC(j) + END; + enc[j] := 0X + END; + IF (lang = "C") OR (lang = "POSIX") THEN + lang := "" + END; + sc2c := invalid; c2sc := invalid; + IF Kernel.littleEndian THEN sc2c := iconv.iconv_open("UCS-2LE", enc) + ELSE sc2c := iconv.iconv_open("UCS-2BE", enc) + END; + IF sc2c = invalid THEN enc := "ASCII"; + IF Kernel.littleEndian THEN sc2c := iconv.iconv_open("UCS-2LE", enc) + ELSE sc2c := iconv.iconv_open("UCS-2BE", enc) + END; + ASSERT(c2sc # invalid, 100) (* ascii to ucs2 not supported? *) + END; + IF Kernel.littleEndian THEN c2sc := iconv.iconv_open(enc, "UCS-2LE") + ELSE c2sc := iconv.iconv_open(enc, "UCS-2BE"); + END; + ASSERT(c2sc # invalid, 101); (* ucs2 to ascii not supported? *) + encoding := enc$ + END Init; + + PROCEDURE Fin; + VAR res: iconv.int; + BEGIN + res := iconv.iconv_close(sc2c); sc2c := invalid; + res := iconv.iconv_close(c2sc); c2sc := invalid + END Fin; + +BEGIN + Init +CLOSE + Fin +END HostLang.