vishapoberon/compiler
1
0
Fork 0
mirror of https://github.com/vishapoberon/compiler.git synced 2026-04-06 09:52:24 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding powerpc target

Browse source
This commit is contained in:
Norayr Chilingarian 2014-01-06 20:30:21 +04:00
parent b18729c519
commit 931dae4763
37 changed files with 2846 additions and 4948 deletions
Download patch file Download diff file Expand all files Collapse all files

64
src/lib/system/gnuc/powerpc/Args.Mod Normal file
View file

@ -0,0 +1,64 @@
MODULE Args; (* jt, 8.12.94 *)
(* command line argument handling for ofront *)
IMPORT SYSTEM;
TYPE
ArgPtr = POINTER TO ARRAY 1024 OF CHAR;
ArgVec = POINTER TO ARRAY 1024 OF ArgPtr;
VAR argc-, argv-: LONGINT;
PROCEDURE -Argc(): INTEGER "SYSTEM_argc";
PROCEDURE -Argv(): LONGINT "(long)SYSTEM_argv";
PROCEDURE -getenv(var: ARRAY OF CHAR): ArgPtr
"(Args_ArgPtr)getenv(var)";
PROCEDURE Get*(n: INTEGER; VAR val: ARRAY OF CHAR);
VAR av: ArgVec;
BEGIN
IF n < argc THEN av := SYSTEM.VAL(ArgVec, argv); COPY(av[n]^, val) END
END Get;
PROCEDURE GetInt*(n: INTEGER; VAR val: LONGINT);
VAR s: ARRAY 64 OF CHAR; k, d, i: LONGINT;
BEGIN
s := ""; Get(n, s); i := 0;
IF s[0] = "-" THEN i := 1 END ;
k := 0; d := ORD(s[i]) - ORD("0");
WHILE (d >= 0 ) & (d <= 9) DO k := k*10 + d; INC(i); d := ORD(s[i]) - ORD("0") END ;
IF s[0] = "-" THEN d := -d; DEC(i) END ;
IF i > 0 THEN val := k END
END GetInt;
PROCEDURE Pos*(s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER; arg: ARRAY 256 OF CHAR;
BEGIN
i := 0; Get(i, arg);
WHILE (i < argc) & (s # arg) DO INC(i); Get(i, arg) END ;
RETURN i
END Pos;
PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR);
VAR p: ArgPtr;
BEGIN
p := getenv(var);
IF p # NIL THEN COPY(p^, val) END
END GetEnv;
PROCEDURE getEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR): BOOLEAN;
VAR p: ArgPtr;
BEGIN
p := getenv(var);
IF p # NIL THEN
COPY(p^, val);
RETURN TRUE
ELSE
RETURN FALSE
END
END getEnv;
BEGIN argc := Argc(); argv := Argv()
END Args.

205
src/lib/system/gnuc/powerpc/SYSTEM.c0 Normal file
View file

@ -0,0 +1,205 @@
/*
* The body prefix file of the Ofront runtime system, Version 1.0
*
* Copyright (c) Software Templ, 1994, 1995
*
* Module SYSTEM is subject to change any time without prior notification.
* Software Templ disclaims all warranties with regard to module SYSTEM,
* in particular shall Software Templ not be liable for any damage resulting
* from inappropriate use or modification of module SYSTEM.
*
* Version 1.1 jt, 24.11.95 fixes for correct pointer arithmetic on Cray computers
* jt 31.1.2007 ANSI prototypes for malloc and exit in order to avoid cc warnings
*
*/
#include "SYSTEM.h"
#ifdef __STDC__
#include "stdarg.h"
#else
#include "varargs.h"
#endif
extern void *malloc(long size);
extern void exit(int status);
void (*SYSTEM_Halt)();
LONGINT SYSTEM_halt; /* x in HALT(x) */
LONGINT SYSTEM_assert; /* x in ASSERT(cond, x) */
LONGINT SYSTEM_argc;
LONGINT SYSTEM_argv;
LONGINT SYSTEM_lock;
BOOLEAN SYSTEM_interrupted;
static LONGINT SYSTEM_mainfrm; /* adr of main proc stack frame, used for stack collection */
#define Lock SYSTEM_lock++
#define Unlock SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9)
static void SYSTEM_InitHeap();
void *SYSTEM__init();
void SYSTEM_INIT(argc, argvadr)
int argc; long argvadr;
{
SYSTEM_mainfrm = argvadr;
SYSTEM_argc = argc;
SYSTEM_argv = *(long*)argvadr;
SYSTEM_InitHeap();
SYSTEM_halt = -128;
SYSTEM__init();
}
void SYSTEM_FINI()
{
SYSTEM_FINALL();
}
long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);}
long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);}
long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);}
long SYSTEM_ABS(i) long i; {return __ABS(i);}
double SYSTEM_ABSD(i) double i; {return __ABS(i);}
void SYSTEM_INHERIT(t, t0)
long *t, *t0;
{
t -= __TPROC0OFF;
t0 -= __TPROC0OFF;
while (*t0 != __EOM) {*t = *t0; t--; t0--;}
}
void SYSTEM_ENUMP(adr, n, P)
long *adr;
long n;
void (*P)();
{
while (n > 0) {P(*adr); adr++; n--;}
}
void SYSTEM_ENUMR(adr, typ, size, n, P)
char *adr;
long *typ, size, n;
void (*P)();
{
long *t, off;
typ++;
while (n > 0) {
t = typ;
off = *t;
while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;}
adr += size; n--;
}
}
long SYSTEM_DIV(x, y)
unsigned long x, y;
{ if ((long) x >= 0) return (x / y);
else return -((y - 1 - x) / y);
}
long SYSTEM_MOD(x, y)
unsigned long x, y;
{ unsigned long m;
if ((long) x >= 0) return (x % y);
else { m = (-x) % y;
if (m != 0) return (y - m); else return 0;
}
}
long SYSTEM_ENTIER(x)
double x;
{
long y;
if (x >= 0)
return (long)x;
else {
y = (long)x;
if (y <= x) return y; else return y - 1;
}
}
void SYSTEM_HALT(n)
int n;
{
SYSTEM_halt = n;
if (SYSTEM_Halt!=0) SYSTEM_Halt(n);
exit(n);
}
#ifdef __STDC__
SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...)
#else
SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist)
long *typ, elemsz;
int elemalgn, nofdim, nofdyn;
va_dcl
#endif
{
long nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off;
va_list ap;
#ifdef __STDC__
va_start(ap, nofdyn);
#else
va_start(ap);
#endif
nofelems = 1;
while (nofdim > 0) {
nofelems = nofelems * va_arg(ap, long); nofdim--;
if (nofelems <= 0) __HALT(-20);
}
va_end(ap);
dataoff = nofdyn * sizeof(long);
if (elemalgn > sizeof(long)) {
n = dataoff % elemalgn;
if (n != 0) dataoff += elemalgn - n;
}
size = dataoff + nofelems * elemsz;
Lock;
if (typ == NIL) {
/* element typ does not contain pointers */
x = SYSTEM_NEWBLK(size);
}
else if (typ == POINTER__typ) {
/* element type is a pointer */
x = SYSTEM_NEWBLK(size + nofelems * sizeof(long));
p = (long*)x[-1];
p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */
while (n <= nofelems) {*p = n*sizeof(long); p++; n++;}
*p = - (nofelems + 1) * sizeof(long); /* sentinel */
x[-1] -= nofelems * sizeof(long);
}
else {
/* element type is a record that contains pointers */
ptab = typ + 1; nofptrs = 0;
while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */
nptr = nofelems * nofptrs; /* total number of pointers */
x = SYSTEM_NEWBLK(size + nptr * sizeof(long));
p = (long*)x[- 1];
p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
p -= nptr - 1; n = 0; off = dataoff;
while (n < nofelems) {i = 0;
while (i < nofptrs) {*p = off + ptab[i]; p++; i++;}
off += elemsz; n++;
}
*p = - (nptr + 1) * sizeof(long); /* sentinel */
x[-1] -= nptr * sizeof(long);
}
if (nofdyn != 0) {
/* setup len vector for index checks */
#ifdef __STDC__
va_start(ap, nofdyn);
#else
va_start(ap);
#endif
p = x;
while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;}
va_end(ap);
}
Unlock;
return x;
}
/* ----------- end of SYSTEM.co ------------- */

215
src/lib/system/gnuc/powerpc/SYSTEM.h Normal file
View file

@ -0,0 +1,215 @@
#ifndef SYSTEM__h
#define SYSTEM__h
/*
the Ofront runtime system interface and macros library
copyright (c) Josef Templ, 1995, 1996
gcc for Linux version (same as SPARC/Solaris2)
uses double # as concatenation operator
*/
#include <alloca.h>
//extern void *memcpy(void *dest, const void *src, long n);
extern void *memcpy(void *dest, const void *src, size_t n);
extern void *malloc(long size);
extern void exit(int status);
#define export
#define import extern
/* constants */
#define __MAXEXT 16
#define NIL 0L
#define POINTER__typ (long*)1L /* not NIL and not a valid type */
/* basic types */
typedef char BOOLEAN;
typedef unsigned char CHAR;
typedef signed char SHORTINT;
typedef short int INTEGER;
typedef long LONGINT;
typedef float REAL;
typedef double LONGREAL;
typedef unsigned long SET;
typedef void *SYSTEM_PTR;
typedef unsigned char SYSTEM_BYTE;
/* runtime system routines */
extern long SYSTEM_DIV();
extern long SYSTEM_MOD();
extern long SYSTEM_ENTIER();
extern long SYSTEM_ASH();
extern long SYSTEM_ABS();
extern long SYSTEM_XCHK();
extern long SYSTEM_RCHK();
extern double SYSTEM_ABSD();
extern SYSTEM_PTR SYSTEM_NEWREC();
extern SYSTEM_PTR SYSTEM_NEWBLK();
#ifdef __STDC__
extern SYSTEM_PTR SYSTEM_NEWARR(long*, long, int, int, int, ...);
#else
extern SYSTEM_PTR SYSTEM_NEWARR();
#endif
extern SYSTEM_PTR SYSTEM_REGMOD();
extern void SYSTEM_INCREF();
extern void SYSTEM_REGCMD();
extern void SYSTEM_REGTYP();
extern void SYSTEM_REGFIN();
extern void SYSTEM_FINALL();
extern void SYSTEM_INIT();
extern void SYSTEM_FINI();
extern void SYSTEM_HALT();
extern void SYSTEM_INHERIT();
extern void SYSTEM_ENUMP();
extern void SYSTEM_ENUMR();
/* module registry */
#define __DEFMOD static void *m; if(m!=0)return m
#define __REGMOD(name, enum) if(m==0)m=SYSTEM_REGMOD((CHAR*)name,enum); else return m
#define __ENDMOD return m
#define __INIT(argc, argv) static void *m; SYSTEM_INIT(argc, (long)&argv);
#define __REGMAIN(name, enum) m=SYSTEM_REGMOD(name,enum)
#define __FINI SYSTEM_FINI(); return 0
#define __IMPORT(name) SYSTEM_INCREF(name##__init())
#define __REGCMD(name, cmd) SYSTEM_REGCMD(m, name, cmd)
/* SYSTEM ops */
#define __SYSNEW(p, len) p=SYSTEM_NEWBLK((long)(len))
#define __VAL(t, x) (*(t*)&(x))
#define __GET(a, x, t) x= *(t*)(a)
#define __PUT(a, x, t) *(t*)(a)=x
#define __LSHL(x, n, t) ((t)((unsigned)(x)<<(n)))
#define __LSHR(x, n, t) ((t)((unsigned)(x)>>(n)))
#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t))
#define __ROTL(x, n, t) ((t)((unsigned)(x)<<(n)|(unsigned)(x)>>(8*sizeof(t)-(n))))
#define __ROTR(x, n, t) ((t)((unsigned)(x)>>(n)|(unsigned)(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 long*)(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 long)(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):-(((y)-1-(x))/(y)))
#define __DIVF(x, y) SYSTEM_DIV((long)(x),(long)(y))
#define __MOD(x, y) ((x)>=0?(x)%(y):__MODF(x,y))
#define __MODF(x, y) SYSTEM_MOD((long)(x),(long)(y))
#define __NEW(p, t) p=SYSTEM_NEWREC((long)t##__typ)
#define __NEWARR SYSTEM_NEWARR
#define __HALT(x) SYSTEM_HALT(x)
#define __ASSERT(cond, x) if (!(cond)) {SYSTEM_assert = x; SYSTEM_HALT(-1);}
#define __ENTIER(x) SYSTEM_ENTIER(x)
#define __ABS(x) (((x)<0)?-(x):(x))
#define __ABSF(x) SYSTEM_ABS((long)(x))
#define __ABSFD(x) SYSTEM_ABSD((double)(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 __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d;long _i=0,_t=n-1;while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;}
static int __STRCMP(x, y)
CHAR *x, *y;
{long i = 0; CHAR ch1, ch2;
do {ch1 = x[i]; ch2 = y[i]; i++;
if (!ch1) return -(int)ch2;
} while (ch1==ch2);
return (int)ch1 - (int)ch2;
}
#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n)))
#define __ASHL(x, n) ((long)(x)<<(n))
#define __ASHR(x, n) ((long)(x)>>(n))
#define __ASHF(x, n) SYSTEM_ASH((long)(x), (long)(n))
#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t))
#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t))
#define __DEL(x) /* DUP with alloca frees storage automatically */
#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ)
#define __TYPEOF(p) (*(((long**)(p))-1))
#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level)
/* runtime checks */
#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0))
#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub))
#define __RETCHK __retchk: __HALT(-3)
#define __CASECHK __HALT(-4)
#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p)))
#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r))))
#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p)))
#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p)
#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p)
#define __WITHCHK __HALT(-7)
#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0))
#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub))
/* record type descriptors */
#define __TDESC(t, m, n) \
static struct t##__desc {\
long tproc[m]; \
long tag, next, level, module; \
char name[24]; \
long *base[__MAXEXT]; \
char *rsrvd; \
long blksz, ptr[n+1]; \
} t##__desc
#define __BASEOFF (__MAXEXT+1)
#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5)
#define __EOM 1
#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size
#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P)
#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P)
#define __INITYP(t, t0, level) \
t##__typ= &t##__desc.blksz; \
memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \
t##__desc.base[level]=t##__typ; \
t##__desc.module=(long)m; \
if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \
t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \
SYSTEM_REGTYP(m, (long)&t##__desc.next); \
SYSTEM_INHERIT(t##__typ, t0##__typ)
/* Oberon-2 type bound procedures support */
#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc
#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist
/* runtime system variables */
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;
/* ANSI prototypes; not used so far
static int __STRCMP(CHAR *x, CHAR *y);
void SYSTEM_INIT(int argc, long argvadr);
void SYSTEM_FINI(void);
long SYSTEM_XCHK(long i, long ub);
long SYSTEM_RCHK(long i, long ub);
long SYSTEM_ASH(long i, long n);
long SYSTEM_ABS(long i);
double SYSTEM_ABSD(double i);
void SYSTEM_INHERIT(long *t, long *t0);
void SYSTEM_ENUMP(long *adr, long n, void (*P)(void*));
void SYSTEM_ENUMR(char *adr, long *typ, long size, long n, void (*P)(void*));
long SYSTEM_DIV(unsigned long x, unsigned long y);
long SYSTEM_MOD(unsigned long x, unsigned long y);
long SYSTEM_ENTIER(double x);
void SYSTEM_HALT(int n);
*/
#endif

419
src/lib/system/gnuc/powerpc/Unix.Mod Normal file
View file

@ -0,0 +1,419 @@
MODULE Unix; (* Josef Templ, 5.3.90 Linux system calls *)
(* system procedure added by noch *)
(* Module Unix provides a system call interface to Linux.
Naming conventions:
Procedure and Type-names always start with a capital letter.
error numbers as defined in Unix
other constants start with lower case letters *)
IMPORT SYSTEM;
CONST
(* various important constants *)
stdin* = 0; stdout* =1; stderr* = 2;
LOCKEX* = 2; LOCKUN* = 8; (* /usr/include/file.h *)
AFINET* = 2; (* /usr/include/sys/socket.h *)
PFINET* = AFINET; (* /usr/include/linux/socket.h *)
SOCKSTREAM* = 1; (* /usr/include/linux/socket.h *)
FIONREAD* = 541BH; (* in /usr/include/asm/termios.h *)
SETFL* = 4; (* set file descriptor flags; in asm/fcntl.h *)
TCP* = 0;
(* flag sets, cf. /usr/include/asm/fcntl.h *)
rdonly* = {}; wronly* = {0}; rdwr* = {1}; creat* = {6}; excl* = {7}; trunc* = {9}; append* = {10}; ndelay = {11};
(* error numbers *)
EPERM* = 1; (* Not owner *)
ENOENT* = 2; (* No such file or directory *)
ESRCH* = 3; (* No such process *)
EINTR* = 4; (* Interrupted system call *)
EIO* = 5; (* I/O error *)
ENXIO* = 6; (* No such device or address *)
E2BIG* = 7; (* Arg list too long *)
ENOEXEC* = 8; (* Exec format error *)
EBADF* = 9; (* Bad file number *)
ECHILD* = 10; (* No children *)
EAGAIN* = 11; (* No more processes *)
ENOMEM* = 12; (* Not enough core *)
EACCES* = 13; (* Permission denied *)
EFAULT* = 14; (* Bad address *)
ENOTBLK* = 15; (* Block device required *)
EBUSY* = 16; (* Mount device busy *)
EEXIST* = 17; (* File exists *)
EXDEV* = 18; (* Cross-device link *)
ENODEV* = 19; (* No such device *)
ENOTDIR* = 20; (* Not a directory*)
EISDIR* = 21; (* Is a directory *)
EINVAL* = 22; (* Invalid argument *)
ENFILE* = 23; (* File table overflow *)
EMFILE* = 24; (* Too many open files *)
ENOTTY* = 25; (* Not a typewriter *)
ETXTBSY* = 26; (* Text file busy *)
EFBIG* = 27; (* File too large *)
ENOSPC* = 28; (* No space left on device *)
ESPIPE* = 29; (* Illegal seek *)
EROFS* = 30; (* Read-only file system *)
EMLINK* = 31; (* Too many links *)
EPIPE* = 32; (* Broken pipe *)
EDOM* = 33; (* Argument too large *)
ERANGE* = 34; (* Result too large *)
EDEADLK* = 35; (* Resource deadlock would occur *)
ENAMETOOLONG* = 36; (* File name too long *)
ENOLCK* = 37; (* No record locks available *)
ENOSYS* = 38; (* Function not implemented *)
ENOTEMPTY* = 39; (* Directory not empty *)
ELOOP* = 40; (* Too many symbolic links encountered *)
EWOULDBLOCK* = EAGAIN; (* Operation would block *)
ENOMSG* = 42; (* No message of desired type *)
EIDRM* = 43; (* Identifier removed *)
ECHRNG* = 44; (* Channel number out of range *)
EL2NSYNC* = 45; (* Level 2 not synchronized *)
EL3HLT* = 46; (* Level 3 halted *)
EL3RST* = 47; (* Level 3 reset *)
ELNRNG* = 48; (* Link number out of range *)
EUNATCH* = 49; (* Protocol driver not attached *)
ENOCSI* = 50; (* No CSI structure available *)
EL2HLT* = 51; (* Level 2 halted *)
EBADE* = 52; (* Invalid exchange *)
EBADR* = 53; (* Invalid request descriptor *)
EXFULL* = 54; (* Exchange full *)
ENOANO* = 55; (* No anode *)
EBADRQC* = 56; (* Invalid request code *)
EBADSLT* = 57; (* Invalid slot *)
EDEADLOCK* = 58; (* File locking deadlock error *)
EBFONT* = 59; (* Bad font file format *)
ENOSTR* = 60; (* Device not a stream *)
ENODATA* = 61; (* No data available *)
ETIME* = 62; (* Timer expired *)
ENOSR* = 63; (* Out of streams resources *)
ENONET* = 64; (* Machine is not on the network *)
ENOPKG* = 65; (* Package not installed *)
EREMOTE* = 66; (* Object is remote *)
ENOLINK* = 67; (* Link has been severed *)
EADV* = 68; (* Advertise error *)
ESRMNT* = 69; (* Srmount error *)
ECOMM* = 70; (* Communication error on send *)
EPROTO* = 71; (* Protocol error *)
EMULTIHOP* = 72; (* Multihop attempted *)
EDOTDOT* = 73; (* RFS specific error *)
EBADMSG* = 74; (* Not a data message *)
EOVERFLOW* = 75; (* Value too large for defined data type *)
ENOTUNIQ* = 76; (* Name not unique on network *)
EBADFD* = 77; (* File descriptor in bad state *)
EREMCHG* = 78; (* Remote address changed *)
ELIBACC* = 79; (* Can not access a needed shared library *)
ELIBBAD* = 80; (* Accessing a corrupted shared library *)
ELIBSCN* = 81; (* .lib section in a.out corrupted *)
ELIBMAX* = 82; (* Attempting to link in too many shared libraries *)
ELIBEXEC* = 83; (* Cannot exec a shared library directly *)
EILSEQ* = 84; (* Illegal byte sequence *)
ERESTART* = 85; (* Interrupted system call should be restarted *)
ESTRPIPE* = 86; (* Streams pipe error *)
EUSERS* = 87; (* Too many users *)
ENOTSOCK* = 88; (* Socket operation on non-socket *)
EDESTADDRREQ* = 89; (* Destination address required *)
EMSGSIZE* = 90; (* Message too long *)
EPROTOTYPE* = 91; (* Protocol wrong type for socket *)
ENOPROTOOPT* = 92; (* Protocol not available *)
EPROTONOSUPPORT* = 93; (* Protocol not supported *)
ESOCKTNOSUPPORT* = 94; (* Socket type not supported *)
EOPNOTSUPP* = 95; (* Operation not supported on transport endpoint *)
EPFNOSUPPORT* = 96; (* Protocol family not supported *)
EAFNOSUPPORT* = 97; (* Address family not supported by protocol *)
EADDRINUSE* = 98; (* Address already in use *)
EADDRNOTAVAIL* = 99; (* Cannot assign requested address *)
ENETDOWN* = 100; (* Network is down *)
ENETUNREACH* = 101; (* Network is unreachable *)
ENETRESET* = 102; (* Network dropped connection because of reset *)
ECONNABORTED* = 103; (* Software caused connection abort *)
ECONNRESET* = 104; (* Connection reset by peer *)
ENOBUFS* = 105; (* No buffer space available *)
EISCONN* = 106; (* Transport endpoint is already connected *)
ENOTCONN* = 107; (* Transport endpoint is not connected *)
ESHUTDOWN* = 108; (* Cannot send after transport endpoint shutdown *)
ETOOMANYREFS* = 109; (* Too many references: cannot splice *)
ETIMEDOUT* = 110; (* Connection timed out *)
ECONNREFUSED* = 111; (* Connection refused *)
EHOSTDOWN* = 112; (* Host is down *)
EHOSTUNREACH* = 113; (* No route to host *)
EALREADY* = 114; (* Operation already in progress *)
EINPROGRESS* = 115; (* Operation now in progress *)
ESTALE* = 116; (* Stale NFS file handle *)
EUCLEAN* = 117; (* Structure needs cleaning *)
ENOTNAM* = 118; (* Not a XENIX named type file *)
ENAVAIL* = 119; (* No XENIX semaphores available *)
EISNAM* = 120; (* Is a named type file *)
EREMOTEIO* = 121; (* Remote I/O error *)
EDQUOT* = 122; (* Quota exceeded *)
TYPE
JmpBuf* = RECORD
bx*, si*, di*, bp*, sp*, pc*: LONGINT;
maskWasSaved*, savedMask*: LONGINT;
END ;
Status* = RECORD (* struct stat *)
dev*, devX*: LONGINT; (* 64 bit in Linux 2.2 *)
pad1: INTEGER;
ino*, mode*, nlink*, uid*, gid*: LONGINT;
rdev*, rdevX*: LONGINT; (* 64 bit in Linux 2.2 *)
pad2: INTEGER;
size*, blksize*, blocks*, atime*, unused1*, mtime*, unused2*, ctime*,
unused3*, unused4*, unused5*: LONGINT;
END ;
Timeval* = RECORD
sec*, usec*: LONGINT
END ;
Timezone* = RECORD
minuteswest*, dsttime*: LONGINT
END ;
Itimerval* = RECORD
interval*, value*: Timeval
END ;
FdSet* = ARRAY 8 OF SET;
SigCtxPtr* = POINTER TO SigContext;
SigContext* = RECORD
END ;
SignalHandler* = PROCEDURE (sig, code: LONGINT; scp: SigCtxPtr);
Dirent* = RECORD
ino, off: LONGINT;
reclen: INTEGER;
name: ARRAY 256 OF CHAR;
END ;
Rusage* = RECORD
utime*, stime*: Timeval;
maxrss*, ixrss*, idrss*, isrss*,
minflt*, majflt*, nswap*, inblock*,
oublock*, msgsnd*, msgrcv*, nsignals*,
nvcsw*, nivcsw*: LONGINT
END ;
Iovec* = RECORD
base*, len*: LONGINT
END ;
SocketPair* = ARRAY 2 OF LONGINT;
Pollfd* = RECORD
fd*: LONGINT;
events*, revents*: INTEGER
END ;
Sockaddr* = RECORD
family*: INTEGER;
port*: INTEGER;
internetAddr*: LONGINT;
pad*: ARRAY 8 OF CHAR;
END ;
HostEntry* = POINTER [1] TO Hostent;
Hostent* = RECORD
name*, aliases*: LONGINT;
addrtype*, length*: LONGINT;
addrlist*: LONGINT; (*POINTER TO POINTER TO LONGINT, network byte order*)
END;
Name* = ARRAY OF CHAR;
PROCEDURE -includeStat()
"#include <sys/stat.h>";
PROCEDURE -includeErrno()
"#include <errno.h>";
PROCEDURE -err(): LONGINT
"errno";
PROCEDURE errno*(): LONGINT;
BEGIN
RETURN err()
END errno;
PROCEDURE -Exit*(n: LONGINT)
"exit(n)";
PROCEDURE -Fork*(): LONGINT
"fork()";
PROCEDURE -Wait*(VAR status: LONGINT): LONGINT
"wait(status)";
PROCEDURE -Select*(width: LONGINT; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): LONGINT
"select(width, readfds, writefds, exceptfds, timeout)";
PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone) : LONGINT
"gettimeofday(tv, tz)";
PROCEDURE -Read* (fd, buf, nbyte: LONGINT): LONGINT
"read(fd, buf, nbyte)";
PROCEDURE -ReadBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT
"read(fd, buf, buf__len)";
PROCEDURE -Write* (fd, buf, nbyte: LONGINT): LONGINT
"write(fd, buf, nbyte)";
PROCEDURE -WriteBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT
"write(fd, buf, buf__len)";
PROCEDURE -Dup*(fd: LONGINT): LONGINT
"dup(fd)";
PROCEDURE -Dup2*(fd1, fd2: LONGINT): LONGINT
"dup(fd1, fd2)";
PROCEDURE -Pipe*(fds : LONGINT): LONGINT
"pipe(fds)";
PROCEDURE -Getpid*(): LONGINT
"getpid()";
PROCEDURE -Getuid*(): LONGINT
"getuid()";
PROCEDURE -Geteuid*(): LONGINT
"geteuid()";
PROCEDURE -Getgid*(): LONGINT
"getgid()";
PROCEDURE -Getegid*(): LONGINT
"getegid()";
PROCEDURE -Unlink*(name: Name): LONGINT
"unlink(name)";
PROCEDURE -Open*(name: Name; flag, mode: SET): LONGINT
"open(name, flag, mode)";
PROCEDURE -Close*(fd: LONGINT): LONGINT
"close(fd)";
PROCEDURE -stat(name: Name; VAR statbuf: Status): LONGINT
"stat((const char*)name, (struct stat*)statbuf)";
PROCEDURE Stat*(name: Name; VAR statbuf: Status): LONGINT;
VAR res: LONGINT;
BEGIN
res := stat(name, statbuf);
(* make the first 4 bytes as unique as possible (used in module Files for caching!) *)
INC(statbuf.dev, statbuf.devX);
INC(statbuf.rdev, statbuf.rdevX);
RETURN res;
END Stat;
PROCEDURE -fstat(fd: LONGINT; VAR statbuf: Status): LONGINT
"fstat(fd, (struct stat*)statbuf)";
PROCEDURE Fstat*(fd: LONGINT; VAR statbuf: Status): LONGINT;
VAR res: LONGINT;
BEGIN
res := fstat(fd, statbuf);
(* make the first 4 bytes as unique as possible (used in module Files for caching!) *)
INC(statbuf.dev, statbuf.devX);
INC(statbuf.rdev, statbuf.rdevX);
RETURN res;
END Fstat;
PROCEDURE -Fchmod*(fd, mode: LONGINT): LONGINT
"fchmod(fd, mode)";
PROCEDURE -Chmod*(path: Name; mode: LONGINT): LONGINT
"chmod(path, mode)";
PROCEDURE -Lseek*(fd, offset, origin: LONGINT): LONGINT
"lseek(fd, offset, origin)";
PROCEDURE -Fsync*(fd: LONGINT): LONGINT
"fsync(fd)";
PROCEDURE -Fcntl*(fd, cmd, arg: LONGINT ): LONGINT
"fcntl(fd, cmd, arg)";
PROCEDURE -Flock*(fd, operation: LONGINT): LONGINT
"flock(fd, operation)";
PROCEDURE -Ftruncate*(fd, length: LONGINT): LONGINT
"ftruncate(fd, length)";
PROCEDURE -Readblk*(fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT
"read(fd, buf, len)";
PROCEDURE -Rename*(old, new: Name): LONGINT
"rename(old, new)";
PROCEDURE -Chdir*(path: Name): LONGINT
"chdir(path)";
PROCEDURE -Ioctl*(fd, request, arg: LONGINT): LONGINT
"ioctl(fd, request, arg)";
PROCEDURE -Kill*(pid, sig: LONGINT): LONGINT
"kill(pid, sig)";
PROCEDURE -Sigsetmask*(mask: LONGINT): LONGINT
"sigsetmask(mask)";
(* TCP/IP networking *)
PROCEDURE -Gethostbyname*(name: Name): HostEntry
"(Unix_HostEntry)gethostbyname(name)";
PROCEDURE -Gethostname*(VAR name: Name): LONGINT
"gethostname(name, name__len)";
PROCEDURE -Socket*(af, type, protocol: LONGINT): LONGINT
"socket(af, type, protocol)";
PROCEDURE -Connect*(socket: LONGINT; name: Sockaddr; namelen: LONGINT): LONGINT
"connect(socket, &(name), namelen)";
PROCEDURE -Getsockname*(socket: LONGINT; VAR name: Sockaddr; VAR namelen: LONGINT): LONGINT
"getsockname(socket, name, namelen)";
PROCEDURE -Bind*(socket: LONGINT; name: Sockaddr; namelen: LONGINT): LONGINT
"bind(socket, &(name), namelen)";
PROCEDURE -Listen*(socket, backlog: LONGINT): LONGINT
"listen(socket, backlog)";
PROCEDURE -Accept*(socket: LONGINT; VAR addr: Sockaddr; VAR addrlen: LONGINT): LONGINT
"accept(socket, addr, addrlen)";
PROCEDURE -Recv*(socket, bufadr, buflen, flags: LONGINT): LONGINT
"recv(socket, bufadr, buflen, flags)";
PROCEDURE -Send*(socket, bufadr, buflen, flags: LONGINT): LONGINT
"send(socket, bufadr, buflen, flags)";
PROCEDURE -sys(str: ARRAY OF CHAR): INTEGER (* need this to call external tools like gcc or gas; noch *)
"system(str)";
PROCEDURE system*(cmd : ARRAY OF CHAR);
VAR r : INTEGER;
BEGIN
r := sys(cmd);
END system;
PROCEDURE System*(cmd : ARRAY OF CHAR): INTEGER;
VAR r : INTEGER;
BEGIN
r := sys(cmd);
RETURN r
END System;
END Unix.

574
src/lib/ulm/powerpc/ulmSysConversions.Mod Normal file
View file

@ -0,0 +1,574 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: SysConversi.om,v 1.2 1997/07/30 09:38:16 borchert Exp $
----------------------------------------------------------------------------
$Log: SysConversi.om,v $
Revision 1.2 1997/07/30 09:38:16 borchert
bug in ReadConv fixed: cv.flags was used but not set for
counts > 1
Revision 1.1 1994/02/23 07:58:28 borchert
Initial revision
----------------------------------------------------------------------------
AFB 8/90
adapted to linux cae 02/01
----------------------------------------------------------------------------
*)
MODULE ulmSysConversions;
(* convert Oberon records to/from C structures *)
IMPORT Events := ulmEvents, Objects := ulmObjects, Priorities := ulmPriorities, Streams := ulmStreams, Strings := ulmStrings,
SYS := SYSTEM, SysTypes := ulmSysTypes, Texts := ulmTexts;
TYPE
Address* = SysTypes.Address;
Size* = Address;
(* format:
Format = Conversion { "/" Conversion } .
Conversion = [ Factors ] ConvChars [ Comment ] .
Factors = Array | Factor | Array Factor | Factor Array .
Array = Integer ":" .
Factor = Integer "*" .
ConvChars = OberonType CType | Skip CType | OberonType Skip .
OberonType = "a" | "b" | "c" | "s" | "i" | "l" | "S" .
CType = "a" | "c" | "s" | "i" | "l" .
Integer = Digit { Digit } .
Digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9" .
Skip = "-" .
Comment = "=" { AnyChar } .
AnyChar = (* all characters except "/" *) .
Oberon data types:
a: Address
b: SYS.BYTE
B: BOOLEAN
c: CHAR
s: SHORTINT
i: INTEGER
l: LONGINT
S: SET
C data types:
a: char *
c: /* signed */ char
C: unsigned char
s: short int
S: unsigned short int
i: int
I: unsigned int
u: unsigned int
l: long int
L: unsigned long int
example:
conversion from
Rec =
RECORD
a, b: INTEGER;
c: CHAR;
s: SET;
f: ARRAY 3 OF INTEGER;
END;
to
struct rec {
short a, b;
char c;
int xx; /* to be skipped on conversion */
int s;
int f[3];
};
or vice versa:
"2*is=a,b/cc=c/-i=xx/Si=s/3:ii=f"
The comments allow to give the field names.
*)
CONST
(* conversion flags *)
unsigned = 0; (* suppress sign extension *)
boolean = 1; (* convert anything # 0 to 1 *)
TYPE
Flags = SET;
Event* = POINTER TO EventRec;
EventRec* =
RECORD
(Events.EventRec)
format*: Events.Message;
END;
ConvStream = POINTER TO ConvStreamRec;
ConvStreamRec =
RECORD
fmt: Texts.Text;
char: CHAR;
eof: BOOLEAN;
(* 1: Oberon type
2: C type
*)
type1, type2: CHAR; length: INTEGER; left: INTEGER;
offset1, offset2: Address;
size1, size2: Address; elementsleft: INTEGER; flags: Flags;
END;
Format* = POINTER TO FormatRec;
FormatRec* =
RECORD
(Objects.ObjectRec)
offset1, offset2: Address;
size1, size2: Address;
flags: Flags;
next: Format;
END;
VAR
badformat*: Events.EventType;
PROCEDURE Error(cv: ConvStream; msg: ARRAY OF CHAR);
VAR
event: Event;
BEGIN
NEW(event);
event.type := badformat;
event.message := "SysConversions: ";
Strings.Concatenate(event.message, msg);
Strings.Read(event.format, cv.fmt);
Events.Raise(event);
cv.eof := TRUE;
cv.char := 0X;
cv.left := 0;
cv.elementsleft := 0;
END Error;
PROCEDURE SizeError(msg, format: ARRAY OF CHAR);
VAR
event: Event;
BEGIN
NEW(event);
event.type := badformat;
event.message := "SysConversions: ";
Strings.Concatenate(event.message, msg);
COPY(format, event.format);
Events.Raise(event);
END SizeError;
PROCEDURE NextCh(cv: ConvStream);
BEGIN
cv.eof := cv.eof OR ~Streams.ReadByte(cv.fmt, cv.char) OR (cv.char = 0X);
IF cv.eof THEN
cv.char := 0X;
END;
END NextCh;
PROCEDURE IsDigit(ch: CHAR) : BOOLEAN;
BEGIN
RETURN (ch >= "0") & (ch <= "9")
END IsDigit;
PROCEDURE ReadInt(cv: ConvStream; VAR i: INTEGER);
BEGIN
i := 0;
REPEAT
i := 10 * i + ORD(cv.char) - ORD("0");
NextCh(cv);
UNTIL ~IsDigit(cv.char);
END ReadInt;
PROCEDURE Open(VAR cv: ConvStream; format: ARRAY OF CHAR);
BEGIN
NEW(cv);
Texts.Open(SYS.VAL(Streams.Stream, cv.fmt));
Strings.Write(cv.fmt, format);
cv.left := 0; cv.elementsleft := 0;
cv.offset1 := 0; cv.offset2 := 0;
cv.eof := FALSE;
NextCh(cv);
END Open;
PROCEDURE Close(VAR cv: ConvStream);
BEGIN
IF ~Streams.Close(cv.fmt) THEN END;
END Close;
PROCEDURE ScanConv(cv: ConvStream;
VAR type1, type2: CHAR;
VAR length: INTEGER) : BOOLEAN;
VAR
i: INTEGER;
factor: INTEGER;
BEGIN
IF cv.left > 0 THEN
type1 := cv.type1;
type2 := cv.type2;
length := cv.length;
DEC(cv.left);
RETURN TRUE
END;
IF cv.char = "/" THEN
NextCh(cv);
END;
IF cv.eof THEN
RETURN FALSE
END;
factor := 0; length := 0;
WHILE IsDigit(cv.char) DO
ReadInt(cv, i);
IF i <= 0 THEN
Error(cv, "integer must be positive"); RETURN FALSE
END;
IF cv.char = ":" THEN
IF length # 0 THEN
Error(cv, "multiple length specification"); RETURN FALSE
END;
length := i;
NextCh(cv);
ELSIF cv.char = "*" THEN
IF factor # 0 THEN
Error(cv, "multiple factor specification"); RETURN FALSE
END;
factor := i; cv.left := factor - 1;
NextCh(cv);
ELSE
Error(cv, "factor or length expected"); RETURN FALSE
END;
END;
type1 := cv.char; NextCh(cv);
type2 := cv.char; NextCh(cv);
IF cv.left > 0 THEN
cv.type1 := type1; cv.type2 := type2; cv.length := length;
END;
IF cv.char = "=" THEN (* comment *)
REPEAT
NextCh(cv);
UNTIL cv.eof OR (cv.char = "/");
END;
RETURN TRUE
END ScanConv;
PROCEDURE Align(VAR offset: Address; boundary: Address);
BEGIN
IF SYS.VAL (INTEGER, offset) MOD SYS.VAL (INTEGER, boundary) # 0 THEN
offset := SYS.VAL (INTEGER, offset) + (SYS.VAL (INTEGER, boundary) - SYS.VAL (INTEGER, offset) MOD SYS.VAL (INTEGER, boundary));
END;
END Align;
PROCEDURE ReadConv(cv: ConvStream;
VAR offset1, offset2: Address;
VAR size1, size2: Address;
VAR flags: Flags) : BOOLEAN;
VAR
type1, type2: CHAR;
length: INTEGER;
align: BOOLEAN;
boundary: INTEGER;
BEGIN
IF cv.elementsleft > 0 THEN
DEC(cv.elementsleft);
(* Oberon type *)
IF size1 > SIZE(SYS.BYTE) THEN
Align(cv.offset1, SIZE(INTEGER));
END;
offset1 := cv.offset1; cv.offset1 := SYS.VAL (INTEGER, cv.offset1) + size1;
size1 := cv.size1; size2 := cv.size2; flags := cv.flags;
IF (size1 > 0) & (cv.elementsleft = 0) THEN
Align(cv.offset1, SIZE(INTEGER));
END;
(* C type *)
IF size2 > 1 THEN
Align(cv.offset2, 2);
END;
offset2 := cv.offset2; cv.offset2 := SYS.VAL (INTEGER, cv.offset2) + SYS.VAL (INTEGER, size2);
RETURN TRUE
END;
IF ScanConv(cv, type1, type2, length) THEN
flags := {};
(* Oberon type *)
CASE type1 OF
| "a": size1 := SIZE(Address); INCL(flags, unsigned);
| "b": size1 := SIZE(SYS.BYTE); INCL(flags, unsigned);
| "B": size1 := SIZE(BOOLEAN); INCL(flags, boolean);
| "c": size1 := SIZE(CHAR); INCL(flags, unsigned);
| "s": size1 := SIZE(SHORTINT);
| "i": size1 := SIZE(INTEGER);
| "l": size1 := SIZE(LONGINT);
| "S": size1 := SIZE(SET); INCL(flags, unsigned);
| "-": size1 := 0;
ELSE Error(cv, "bad Oberon type specifier"); RETURN FALSE
END;
IF size1 > 0 THEN
IF length > 0 THEN
Align(cv.offset1, SIZE(INTEGER));
ELSIF size1 > SIZE(SYS.BYTE) THEN
Align(cv.offset1, SIZE(INTEGER));
END;
END;
offset1 := cv.offset1; cv.offset1 := SYS.VAL (INTEGER, cv.offset1) + size1;
(* C type *)
CASE type2 OF
| "a": size2 := 4; INCL(flags, unsigned); (* char* *)
| "c": size2 := 1; (* /* signed */ char *)
| "C": size2 := 1; INCL(flags, unsigned); (* unsigned char *)
| "s": size2 := 2; (* short int *)
| "S": size2 := 2; INCL(flags, unsigned); (* unsigned short int *)
| "i": size2 := 4; (* int *)
| "I": size2 := 4; INCL(flags, unsigned); (* unsigned int *)
| "u": size2 := 4; INCL(flags, unsigned); (* unsigned int *)
| "l": size2 := 4; (* long int *)
| "L": size2 := 4; INCL(flags, unsigned); (* long int *)
| "-": size2 := 0;
ELSE Error(cv, "bad C type specifier"); RETURN FALSE
END;
IF size2 > 1 THEN
Align(cv.offset2, size2);
END;
offset2 := cv.offset2; cv.offset2 := SYS.VAL (INTEGER, cv.offset2) + SYS.VAL (INTEGER, size2);
cv.size1 := size1; cv.size2 := size2;
IF length > 0 THEN
cv.elementsleft := length - 1;
cv.flags := flags;
END;
RETURN TRUE
ELSE
RETURN FALSE
END;
END ReadConv;
PROCEDURE Convert(from, to: Address; ssize, dsize: Address; flags: Flags);
TYPE
Bytes = ARRAY 8 OF CHAR;
Pointer = POINTER TO Bytes;
VAR
dest, source: Pointer;
dindex, sindex: INTEGER;
nonzero: BOOLEAN;
fill : CHAR;
BEGIN
IF ssize > 0 THEN
dest := SYS.VAL(Pointer, to);
source := SYS.VAL(Pointer, from);
dindex := 0; sindex := 0;
IF boolean IN flags THEN
nonzero := FALSE;
WHILE ssize > 0 DO
nonzero := nonzero OR (source[sindex] # 0X);
INC(sindex); ssize := SYS.VAL (INTEGER, ssize) - 1;
END;
IF dsize > 0 THEN
IF nonzero THEN
dest[dindex] := 1X;
ELSE
dest[dindex] := 0X;
END;
dsize := dsize - 1; INC (dindex);
END;
WHILE dsize > 0 DO
dest[dindex] := 0X;
dsize := SYS.VAL (INTEGER, dsize) - 1; INC(dindex);
END;
ELSE
WHILE (dsize > 0) & (ssize > 0) DO
dest[dindex] := source[sindex];
ssize := SYS.VAL (INTEGER, ssize) - 1;
dsize := dsize - 1;
INC(dindex); INC(sindex);
END;
IF dsize > 0 THEN
(* sindex has been incremented at least once because
* ssize and dsize were greater than 0, i.e. sindex-1
* is a valid inex. *)
fill := 0X;
IF ~(unsigned IN flags) & (source[sindex-1] >= 080X) THEN
fill := 0FFX;
END;
END;
WHILE dsize > 0 DO
dest[dindex] := fill;
dsize := SYS.VAL (INTEGER, dsize) - 1; INC(dindex);
END;
END;
END;
END Convert;
PROCEDURE ByAddrToC*(from, to: Address; format: ARRAY OF CHAR);
VAR
cv: ConvStream;
offset1, offset2, size1, size2: Address;
flags: Flags;
BEGIN
Open(cv, format);
WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO
Convert(from + offset1, to + offset2, size1, size2, flags);
END;
Close(cv);
END ByAddrToC;
PROCEDURE ByAddrFromC*(from, to: Address; format: ARRAY OF CHAR);
VAR
cv: ConvStream;
offset1, offset2, size1, size2: Address;
flags: Flags;
BEGIN
Open(cv, format);
WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO
Convert(from + offset2, to + offset1, size2, size1, flags);
END;
Close(cv);
END ByAddrFromC;
PROCEDURE CSize*(format: ARRAY OF CHAR) : Size;
(* returns the size of the C-structure described by `format' *)
VAR
cv: ConvStream;
offset1, offset2, size1, size2: Address;
size: Address;
flags: Flags;
BEGIN
Open(cv, format);
WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO END;
Close(cv);
size := offset2 + size2;
Align(size, 2);
RETURN size
END CSize;
PROCEDURE OberonSize*(format: ARRAY OF CHAR) : Size;
(* returns the size of the Oberon-structure described by `format' *)
VAR
cv: ConvStream;
offset1, offset2, size1, size2: Address;
size: Address;
flags: Flags;
BEGIN
Open(cv, format);
WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO END;
Close(cv);
size := offset1 + size1;
Align(size, SIZE(INTEGER));
RETURN size
END OberonSize;
PROCEDURE ToC*(VAR from, to: ARRAY OF SYS.BYTE; format: ARRAY OF CHAR);
BEGIN
IF OberonSize(format) > LEN(from) THEN
SizeError("Oberon record is too small", format); RETURN
END;
IF CSize(format) > LEN(to) THEN
SizeError("C structure is too small", format); RETURN
END;
ByAddrToC(SYS.ADR(from), SYS.ADR(to), format);
END ToC;
PROCEDURE FromC*(VAR from, to: ARRAY OF SYS.BYTE; format: ARRAY OF CHAR);
BEGIN
IF OberonSize(format) > LEN(to) THEN
SizeError("Oberon record is too small", format); RETURN
END;
IF CSize(format) > LEN(from) THEN
SizeError("C structure is too small", format); RETURN
END;
ByAddrFromC(SYS.ADR(from), SYS.ADR(to), format);
END FromC;
PROCEDURE Compile*(VAR fmt: Format; format: ARRAY OF CHAR);
(* translate format into an internal representation
which is later referenced by fmt;
ByFmtToC and ByFmtFromC are faster than ToC and FromC
*)
VAR
cv: ConvStream;
offset1, offset2, size1, size2: Address;
flags: Flags;
element: Format;
head, tail: Format;
BEGIN
Open(cv, format);
head := NIL; tail := NIL;
WHILE ReadConv(cv, offset1, offset2, size1, size2, flags) DO
NEW(element);
element.offset1 := offset1;
element.offset2 := offset2;
element.size1 := size1;
element.size2 := size2;
element.flags := flags;
element.next := NIL;
IF tail # NIL THEN
tail.next := element;
ELSE
head := element;
END;
tail := element;
END;
fmt := head;
Close(cv);
END Compile;
PROCEDURE ByFmtAndAddrToC*(from, to: Address; format: Format);
VAR
offset1, offset2, size1, size2: Address;
flags: Flags;
BEGIN
WHILE format # NIL DO
Convert(from + format.offset1, to + format.offset2,
format.size1, format.size2, format.flags);
format := format.next;
END;
END ByFmtAndAddrToC;
PROCEDURE ByFmtAndAddrFromC*(from, to: Address; format: Format);
VAR
offset1, offset2, size1, size2: Address;
flags: Flags;
BEGIN
WHILE format # NIL DO
Convert(from + format.offset2, to + format.offset1,
format.size2, format.size1, format.flags);
format := format.next;
END;
END ByFmtAndAddrFromC;
PROCEDURE ByFmtToC*(VAR from, to: ARRAY OF SYS.BYTE; format: Format);
BEGIN
ByFmtAndAddrToC(SYS.ADR(from), SYS.ADR(to), format);
END ByFmtToC;
PROCEDURE ByFmtFromC*(VAR from, to: ARRAY OF SYS.BYTE; format: Format);
BEGIN
ByFmtAndAddrFromC(SYS.ADR(from), SYS.ADR(to), format);
END ByFmtFromC;
BEGIN
Events.Define(badformat);
Events.SetPriority(badformat, Priorities.liberrors);
END ulmSysConversions.

201
src/lib/ulm/powerpc/ulmSysStat.Mod Normal file
View file

@ -0,0 +1,201 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: SysStat.om,v 1.3 2000/11/12 13:02:09 borchert Exp $
----------------------------------------------------------------------------
$Log: SysStat.om,v $
Revision 1.3 2000/11/12 13:02:09 borchert
door file type added
Revision 1.2 2000/11/12 12:48:07 borchert
- conversion adapted to Solaris 2.x
- Lstat added
Revision 1.1 1994/02/23 08:00:48 borchert
Initial revision
----------------------------------------------------------------------------
AFB 9/89
----------------------------------------------------------------------------
*)
MODULE ulmSysStat;
(* examine inode: stat(2) and fstat(2) *)
IMPORT RelatedEvents := ulmRelatedEvents, Sys := ulmSys, SYS := SYSTEM, uSYS := ulmSYSTEM, SysConversions := ulmSysConversions, SysErrors := ulmSysErrors,
SysTypes := ulmSysTypes;
CONST
(* file mode:
bit 0 = 1<<0 bit 31 = 1<<31
user group other
3 1 1111 11
1 ... 6 5432 109 876 543 210
+--------+------+-----+-----+-----+-----+
| unused | type | sst | rwx | rwx | rwx |
+--------+------+-----+-----+-----+-----+
*)
type* = {12..15};
prot* = {0..8};
(* file types; example: (stat.mode * type = dir) *)
reg* = {15}; (* regular *)
dir* = {14}; (* directory *)
chr* = {13}; (* character special *)
fifo* = {12}; (* fifo *)
blk* = {13..14}; (* block special *)
symlink* = {13, 15}; (* symbolic link *)
socket* = {14, 15}; (* socket *)
(* special *)
setuid* = 11; (* set user id on execution *)
setgid* = 10; (* set group id on execution *)
savetext* = 9; (* save swapped text even after use *)
(* protection *)
uread* = 8; (* read permission owner *)
uwrite* = 7; (* write permission owner *)
uexec* = 6; (* execute/search permission owner *)
gread* = 5; (* read permission group *)
gwrite* = 4; (* write permission group *)
gexec* = 3; (* execute/search permission group *)
oread* = 2; (* read permission other *)
owrite* = 1; (* write permission other *)
oexec* = 0; (* execute/search permission other *)
(* example for "r-xr-x---": (read + exec) * (owner + group) *)
owner* = {uread, uwrite, uexec};
group* = {gread, gwrite, gexec};
other* = {oread, owrite, oexec};
read* = {uread, gread, oread};
write* = {uwrite, gwrite, owrite};
exec* = {uexec, gexec, oexec};
rwx* = prot;
TYPE
StatRec* = (* result of stat(2) and fstat(2) *)
RECORD
device*: SysTypes.Device; (* ID of device containing
a directory entry for this file *)
inode*: SysTypes.Inode; (* inode number *)
mode*: SET; (* file mode; see mknod(2) *)
nlinks*: LONGINT; (* number of links *)
uid*: LONGINT; (* user id of the file's owner *)
gid*: LONGINT; (* group id of the file's group *)
rdev*: SysTypes.Device; (* ID of device
this entry is defined only for
character special or block
special files
*)
size*: SysTypes.Offset; (* file size in bytes *)
blksize*: LONGINT; (* preferred blocksize *)
blocks*: LONGINT; (* # of blocks allocated *)
atime*: SysTypes.Time; (* time of last access *)
mtime*: SysTypes.Time; (* time of last data modification *)
ctime*: SysTypes.Time; (* time of last file status change *)
END;
(* Linux kernel struct stat (2.2.17)
struct stat {
unsigned short st_dev;
unsigned short __pad1;
unsigned long st_ino;
unsigned short st_mode;
unsigned short st_nlink;
unsigned short st_uid;
unsigned short st_gid;
unsigned short st_rdev;
unsigned short __pad2;
unsigned long st_size;
unsigned long st_blksize;
unsigned long st_blocks;
unsigned long st_atime;
unsigned long __unused1;
unsigned long st_mtime;
unsigned long __unused2;
unsigned long st_ctime;
unsigned long __unused3;
unsigned long __unused4;
unsigned long __unused5;
};
*)
CONST
statbufsize = 88(*64*); (* see <sys/stat.h> *) (* sizeof struct stat gives us 144 on x86_64 and 88 on x86 *)
TYPE
UnixStatRec = ARRAY statbufsize OF SYS.BYTE;
CONST
statbufconv =
(*"is=dev/-s=pad1/ll=ino/Ss=mode/4*is=nlink+uid+gid+rdev/-s=pad2/ll=size/2*ll=blksize,blocks/il=atime/-l/il=mtime/-l/il=ctime/3*-l";*)
(*"ls=dev/-s=pad1/lL=ino/Ss=mode/4*is=nlink+uid+gid+rdev/-s=pad2/lL=size/2*lL=blksize,blocks/lL=atime/-l/lL=mtime/-l/lL=ctime/3*-l";*)
"ll=dev/-l=devx/-s=pad1/ll=ino/Sl=mode/ll=nlink/ll=uid/ll=gid/ll=rdev/-l=rdevx/-s=pad2/ll=size/2*ll=blksize,blocks/lL=atime/-l/lL=mtime/-l/lL=ctime/3*-l";
VAR
statbuffmt: SysConversions.Format;
PROCEDURE Stat*(path: ARRAY OF CHAR; VAR buf: StatRec;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
d0, d1, d2: LONGINT;
origbuf: UnixStatRec;
BEGIN
IF uSYS.UNIXCALL(Sys.newstat, d0, d1, SYS.ADR(path), SYS.ADR(origbuf), d2) THEN
SysConversions.ByFmtFromC(origbuf, buf, statbuffmt);
RETURN TRUE
ELSE
SysErrors.Raise(errors, d0, Sys.newstat, path);
RETURN FALSE
END;
END Stat;
(*
PROCEDURE Lstat*(path: ARRAY OF CHAR; VAR buf: StatRec;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
d0, d1: INTEGER;
origbuf: UnixStatRec;
BEGIN
IF SYS.UNIXCALL(Sys.newlstat, d0, d1, SYS.ADR(path), SYS.ADR(origbuf)) THEN
SysConversions.ByFmtFromC(origbuf, buf, statbuffmt);
RETURN TRUE
ELSE
SysErrors.Raise(errors, d0, Sys.newlstat, path);
RETURN FALSE
END;
END Lstat;
*)
PROCEDURE Fstat*(fd: SysTypes.File; VAR buf: StatRec;
errors: RelatedEvents.Object) : BOOLEAN;
VAR
d0, d1, d2: LONGINT;
origbuf: UnixStatRec;
BEGIN
IF uSYS.UNIXCALL(Sys.newfstat, d0, d1, fd, SYS.ADR(origbuf), d2) THEN
SysConversions.ByFmtFromC(origbuf, buf, statbuffmt);
RETURN TRUE
ELSE
SysErrors.Raise(errors, d0, Sys.newfstat, "");
RETURN FALSE
END;
END Fstat;
BEGIN
SysConversions.Compile(statbuffmt, statbufconv);
END ulmSysStat.

70
src/lib/ulm/powerpc/ulmSysTypes.Mod Normal file
View file

@ -0,0 +1,70 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: SysTypes.om,v 1.1 1994/02/23 08:01:38 borchert Exp $
----------------------------------------------------------------------------
$Log: SysTypes.om,v $
Revision 1.1 1994/02/23 08:01:38 borchert
Initial revision
----------------------------------------------------------------------------
AFB 9/89
----------------------------------------------------------------------------
*)
MODULE ulmSysTypes;
IMPORT Types := ulmTypes;
TYPE
Address* = Types.Address;
UntracedAddress* = Types.UntracedAddress;
Count* = Types.Count;
Size* = Types.Size;
Byte* = Types.Byte;
File* = (*INTEGER*)LONGINT; (* in ulm's system both INTEGER and LONGINT are 4 bytes long *)
Offset* = LONGINT;
Device* = LONGINT;
Inode* = LONGINT;
Time* = LONGINT;
Word* = INTEGER; (* must have the size of C's int-type *)
(* Note: linux supports wait4 but not waitid, i.e. these
* constants aren't needed. *)
(*
CONST
(* possible values of the idtype parameter (4 bytes),
see <sys/procset.h>
*)
idPid = 0; (* a process identifier *)
idPpid = 1; (* a parent process identifier *)
idPgid = 2; (* a process group (job control group) identifier *)
idSid = 3; (* a session identifier *)
idCid = 4; (* a scheduling class identifier *)
idUid = 5; (* a user identifier *)
idGid = 6; (* a group identifier *)
idAll = 7; (* all processes *)
idLwpid = 8; (* an LWP identifier *)
TYPE
IdType = INTEGER; (* idPid .. idLwpid *)
*)
END ulmSysTypes.

125
src/lib/ulm/powerpc/ulmTypes.Mod Normal file
View file

@ -0,0 +1,125 @@
(* Ulm's Oberon Library
Copyright (C) 1989-2000 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Types.om,v 1.5 2000/12/13 10:03:00 borchert Exp $
----------------------------------------------------------------------------
$Log: Types.om,v $
Revision 1.5 2000/12/13 10:03:00 borchert
SetInt type used in msb constant
Revision 1.4 2000/12/13 09:51:57 borchert
constants and types for the relationship of INTEGER and SET added
Revision 1.3 1998/09/25 15:23:09 borchert
Real32..Real128 added
Revision 1.2 1994/07/01 11:08:04 borchert
IntAddress, Int8/16/32, ToInt8/16/32 and bit/little endian stuff added
Revision 1.1 1994/02/22 20:12:14 borchert
Initial revision
----------------------------------------------------------------------------
AFB 9/93
----------------------------------------------------------------------------
*)
MODULE ulmTypes;
(* compiler-dependent type definitions;
this version works for Ulm's Oberon Compilers on
following architectures: m68k and sparc
*)
IMPORT SYS := SYSTEM;
TYPE
Address* = LONGINT (*SYS.ADDRESS*);
UntracedAddress* = LONGINT; (*SYS.UNTRACEDADDRESS;*)
Count* = LONGINT;
Size* = Count;
Byte* = SYS.BYTE;
IntAddress* = LONGINT;
Int8* = SHORTINT;
Int16* = INTEGER;
Int32* = LONGINT;
Real32* = REAL;
Real64* = LONGREAL;
CONST
bigEndian* = 0; (* SPARC, M68K etc *)
littleEndian* = 1; (* Intel 80x86, VAX etc *)
byteorder* = littleEndian; (* machine-dependent constant *)
TYPE
ByteOrder* = SHORTINT; (* bigEndian or littleEndian *)
(* following constants and type definitions try to make
conversions from INTEGER to SET and vice versa more portable
to allow for bit operations on INTEGER values
*)
TYPE
SetInt* = LONGINT; (* INTEGER type that corresponds to SET *)
VAR msb* : SET;
msbIsMax*, msbIs0*: SHORTINT;
msbindex*, lsbindex*, nofbits*: LONGINT;
PROCEDURE ToInt8*(int: LONGINT) : Int8;
BEGIN
RETURN SHORT(SHORT(int))
END ToInt8;
PROCEDURE ToInt16*(int: LONGINT) : Int16;
BEGIN
RETURN SYS.VAL(Int16, int)
END ToInt16;
PROCEDURE ToInt32*(int: LONGINT) : Int32;
BEGIN
RETURN int
END ToInt32;
PROCEDURE ToReal32*(real: LONGREAL) : Real32;
BEGIN
RETURN SHORT(real)
END ToReal32;
PROCEDURE ToReal64*(real: LONGREAL) : Real64;
BEGIN
RETURN real
END ToReal64;
BEGIN
msb := SYS.VAL(SET, MIN(SetInt));
(* most significant bit, converted to a SET *)
(* we expect msbIsMax XOR msbIs0 to be 1;
this is checked for by an assertion
*)
msbIsMax := SYS.VAL(SHORTINT, (msb = {MAX(SET)}));
(* is 1, if msb equals {MAX(SET)} *)
msbIs0 := SYS.VAL(SHORTINT, (msb = {0}));
(* is 0, if msb equals {0} *)
msbindex := msbIsMax * MAX(SET);
(* set element that corresponds to the most-significant-bit *)
lsbindex := MAX(SET) - msbindex;
(* set element that corresponds to the lowest-significant-bit *)
nofbits := MAX(SET) + 1;
(* number of elements in SETs *)
ASSERT((msbIs0 = 1) & (msbIsMax = 0) OR (msbIs0 = 0) & (msbIsMax = 1));
END ulmTypes.

109
src/lib/v4/powerpc/Reals.Mod Normal file
View file

@ -0,0 +1,109 @@
MODULE Reals;
(* JT, 5.2.90 / RC 9.12.91 conversion between reals and strings for HP-700, MB 9.12.91, JT for Ofront, 16.3. 95*)
IMPORT S := SYSTEM;
PROCEDURE -ecvt (x: LONGREAL; ndigit, decpt, sign: LONGINT): LONGINT
"ecvt (x, ndigit, decpt, sign)";
PROCEDURE Ten*(e: INTEGER): REAL;
VAR r, power: LONGREAL;
BEGIN r := 1.0;
power := 10.0;
WHILE e > 0 DO
IF ODD(e) THEN r := r * power END ;
power := power * power; e := e DIV 2
END ;
RETURN SHORT(r)
END Ten;
PROCEDURE TenL*(e: INTEGER): LONGREAL;
VAR r, power: LONGREAL;
BEGIN r := 1.0;
power := 10.0;
LOOP
IF ODD(e) THEN r := r * power END ;
e := e DIV 2;
IF e <= 0 THEN RETURN r END ;
power := power * power
END
END TenL;
PROCEDURE Expo*(x: REAL): INTEGER;
BEGIN
RETURN SHORT(ASH(S.VAL(LONGINT, x), -23) MOD 256)
END Expo;
PROCEDURE ExpoL*(x: LONGREAL): INTEGER;
VAR h: LONGINT;
BEGIN
S.GET(S.ADR(x)+4, h);
RETURN SHORT(ASH(h, -20) MOD 2048)
END ExpoL;
PROCEDURE SetExpo*(e: INTEGER; VAR x: REAL);
CONST expo = {1..8};
BEGIN
x := S.VAL(REAL, S.VAL(SET, x) - expo + S.VAL(SET, ASH(LONG(e), 23)))
END SetExpo;
PROCEDURE SetExpoL*(e: INTEGER; VAR x: LONGREAL);
CONST expo = {1..11};
VAR h: SET;
BEGIN
S.GET(S.ADR(x)+4, h);
h := h - expo + S.VAL(SET, ASH(LONG(e), 20));
S.PUT(S.ADR(x)+4, h)
END SetExpoL;
PROCEDURE Convert*(x: REAL; n: INTEGER; VAR d: ARRAY OF CHAR);
VAR i, k: LONGINT;
BEGIN
i := ENTIER(x); k := 0;
WHILE k < n DO
d[k] := CHR(i MOD 10 + 48); i := i DIV 10; INC(k)
END
END Convert;
(*
PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR);
VAR i, k: LONGINT;
BEGIN
i := ENTIER(x); k := 0;
WHILE k < n DO
d[k] := CHR(i MOD 10 + 48); i := i DIV 10; INC(k)
END
END ConvertL;
*)
PROCEDURE ConvertL*(x: LONGREAL; n: INTEGER; VAR d: ARRAY OF CHAR);
VAR decpt, sign, i: LONGINT; buf: LONGINT;
BEGIN
(*x := x - 0.5; already rounded in ecvt*)
buf := ecvt(x, n+2, S.ADR(decpt), S.ADR(sign));
i := 0;
WHILE i < decpt DO S.GET(buf + i, d[n - i -1]); INC(i) END ; (* showdef was crashing here on oocLowLReal.sym because of ecvt *)
i := n - i - 1;
WHILE i >= 0 DO d[i] := "0"; DEC(i) END ;
END ConvertL;
PROCEDURE Unpack(VAR b, d: ARRAY OF S.BYTE);
VAR i, k: SHORTINT; len: LONGINT;
BEGIN i := 0; len := LEN(b);
WHILE i < len DO
k := SHORT(ORD(S.VAL(CHAR, b[i])) DIV 16);
IF k > 9 THEN d[i*2] := k + 55 ELSE d[i*2] := k + 48 END ;
k := SHORT(ORD(S.VAL(CHAR, b[i])) MOD 16);
IF k > 9 THEN d[i*2+1] := k + 55 ELSE d[i*2+1] := k + 48 END ;
INC(i)
END
END Unpack;
PROCEDURE ConvertH* (y: REAL; VAR d: ARRAY OF CHAR);
BEGIN Unpack(y, d)
END ConvertH;
PROCEDURE ConvertHL* (x: LONGREAL; VAR d: ARRAY OF CHAR);
BEGIN Unpack(x, d)
END ConvertHL;
END Reals.