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

initial of OpenBSD changes for voc on X86_64

Browse source 
Former-commit-id: 0170d2b442
This commit is contained in:
Antranig Vartanian 2015-12-03 22:50:57 +04:00
parent 5305dbaa89
commit 7d3258c2f2
12 changed files with 3413 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

86
src/lib/system/openbsd/gcc/Console.Mod Normal file
View file

@ -0,0 +1,86 @@
MODULE Console; (* J. Templ, 29-June-96 *)
(* output to Unix standard output device based Write system call *)
IMPORT SYSTEM;
VAR line: ARRAY 128 OF CHAR;
pos: INTEGER;
PROCEDURE -Write(adr, n: LONGINT)
"write(1/*stdout*/, adr, n)";
PROCEDURE -read(VAR ch: CHAR): LONGINT
"read(0/*stdin*/, ch, 1)";
PROCEDURE Flush*();
BEGIN
Write(SYSTEM.ADR(line), pos); pos := 0;
END Flush;
PROCEDURE Char*(ch: CHAR);
BEGIN
IF pos = LEN(line) THEN Flush() END ;
line[pos] := ch; INC(pos);
IF ch = 0AX THEN Flush() END
END Char;
PROCEDURE String*(s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE s[i] # 0X DO Char(s[i]); INC(i) END
END String;
PROCEDURE Int*(i, n: LONGINT);
VAR s: ARRAY 32 OF CHAR; i1, k: LONGINT;
BEGIN
IF i = SYSTEM.LSH(LONG(LONG(1)), SIZE(LONGINT)*8 - 1) THEN
IF SIZE(LONGINT) = 8 THEN s := "8085774586302733229"; k := 19
ELSE s := "8463847412"; k := 10
END
ELSE
i1 := ABS(i);
s[0] := CHR(i1 MOD 10 + ORD("0")); i1 := i1 DIV 10; k := 1;
WHILE i1 > 0 DO s[k] := CHR(i1 MOD 10 + ORD("0")); i1 := i1 DIV 10; INC(k) END
END ;
IF i < 0 THEN s[k] := "-"; INC(k) END ;
WHILE n > k DO Char(" "); DEC(n) END ;
WHILE k > 0 DO DEC(k); Char(s[k]) END
END Int;
PROCEDURE Ln*;
BEGIN Char(0AX); (* Unix end-of-line *)
END Ln;
PROCEDURE Bool*(b: BOOLEAN);
BEGIN IF b THEN String("TRUE") ELSE String("FALSE") END
END Bool;
PROCEDURE Hex*(i: LONGINT);
VAR k, n: LONGINT;
BEGIN
k := -28;
WHILE k <= 0 DO
n := ASH(i, k) MOD 16;
IF n <= 9 THEN Char(CHR(ORD("0") + n)) ELSE Char(CHR(ORD("A") - 10 + n)) END ;
INC(k, 4)
END
END Hex;
PROCEDURE Read*(VAR ch: CHAR);
VAR n: LONGINT;
BEGIN Flush();
n := read(ch);
IF n # 1 THEN ch := 0X END
END Read;
PROCEDURE ReadLine*(VAR line: ARRAY OF CHAR);
VAR i: LONGINT; ch: CHAR;
BEGIN Flush();
i := 0; Read(ch);
WHILE (i < LEN(line) - 1) & (ch # 0AX) & (ch # 0X) DO line[i] := ch; INC(i); Read(ch) END ;
line[i] := 0X
END ReadLine;
BEGIN pos := 0;
END Console.

188
src/lib/system/openbsd/gcc/Kernel.Mod Normal file
View file

@ -0,0 +1,188 @@
MODULE Kernel;
(*
J. Templ, 16.4.95
communication with C-runtime and storage management
*)
IMPORT SYSTEM, Unix, Args;
TYPE
RealTime = POINTER TO TimeDesc;
TimeDesc = RECORD
sec, min, hour, mday, mon, year, wday, isdst, zone, gmtoff: LONGINT
END ;
KeyCmd* = PROCEDURE;
ObjFinalizer* = PROCEDURE(obj: SYSTEM.PTR);
VAR
(* trap handling *)
trapEnv*: Unix.JmpBuf; (* saved stack environment for trap handling *)
(* oberon heap management *)
nofiles*: LONGINT;
(* input event handling *)
readSet*, readySet*: Unix.FdSet;
FKey*: ARRAY 16 OF KeyCmd;
littleEndian*: BOOLEAN;
TimeUnit*: LONGINT; (* 1 sec *)
LIB*, CWD*: ARRAY 256 OF CHAR;
OBERON*: ARRAY 1024 OF CHAR;
timeStart: LONGINT; (* milliseconds *)
PROCEDURE -includesetjmp()
'#include "setjmp.h"';
(* for localtime *)
PROCEDURE -includetime()
'#include "time.h"';
PROCEDURE -Lock*()
"SYSTEM_lock++";
PROCEDURE -Unlock*()
"SYSTEM_lock--; if (SYSTEM_interrupted && SYSTEM_lock == 0) __HALT(-9)";
PROCEDURE -Exit*(n: LONGINT)
"exit(n)";
PROCEDURE -sigsetjmp*(VAR env: Unix.JmpBuf; savemask: LONGINT): LONGINT
"__sigsetjmp(env, savemask)";
PROCEDURE -siglongjmp*(VAR env:Unix. JmpBuf; val: LONGINT)
"siglongjmp(env, val)";
PROCEDURE -heapsize*(): LONGINT
"SYSTEM_heapsize";
PROCEDURE -allocated*(): LONGINT
"SYSTEM_allocated";
PROCEDURE -localtime(VAR clock: LONGINT): RealTime
"(Kernel_RealTime)localtime(clock)";
PROCEDURE -malloc*(size: LONGINT): LONGINT
"(LONGINT)malloc(size)";
PROCEDURE -free*(adr: LONGINT)
"(void)free(adr)";
PROCEDURE -getcwd(VAR cwd: Unix.Name)
"getcwd(cwd, cwd__len)";
PROCEDURE GetClock* (VAR t, d: LONGINT);
VAR tv: Unix.Timeval; tz: Unix.Timezone; time: RealTime;
l : LONGINT;
BEGIN
l := Unix.Gettimeofday(tv, tz);
time := localtime(tv.sec);
t := time.sec + ASH(time.min, 6) + ASH(time.hour, 12);
d := time.mday + ASH(time.mon+1, 5) + ASH(time.year MOD 100, 9);
END GetClock;
PROCEDURE SetClock* (t, d: LONGINT);
VAR err: ARRAY 25 OF CHAR;
BEGIN err := "not yet implemented"; HALT(99)
END SetClock;
PROCEDURE Time*(): LONGINT;
VAR timeval: Unix.Timeval; timezone: Unix.Timezone;
l : LONGINT;
BEGIN
l := Unix.Gettimeofday(timeval, timezone);
RETURN (timeval.usec DIV 1000 + timeval.sec * 1000 - timeStart) MOD 7FFFFFFFH
END Time;
(*
PROCEDURE UserTime*(): LONGINT;
VAR rusage: Unix.Rusage;
BEGIN
Unix.Getrusage(0, S.ADR(rusage));
RETURN rusage.utime.sec*1000 + rusage.utime.usec DIV 1000
(* + rusage.stime.sec*1000 + rusage.stime.usec DIV 1000*)
END UserTime;
*)
PROCEDURE Select*(delay: LONGINT);
VAR rs, ws, xs: Unix.FdSet; n: LONGINT; tv: Unix.Timeval;
BEGIN
rs := readSet;
FOR n := 0 TO 7 DO ws[n] := {}; xs[n] := {}; readySet[n] := {} END;
IF delay < 0 THEN delay := 0 END ;
tv.sec := delay DIV 1000; tv.usec := delay MOD 1000 * 1000;
n := Unix.Select(256, rs, ws, xs, tv);
IF n >= 0 THEN readySet := rs END
END Select;
PROCEDURE -GC*(markStack: BOOLEAN)
"SYSTEM_GC(markStack)";
PROCEDURE -RegisterObject*(obj: SYSTEM.PTR; finalize: ObjFinalizer)
"SYSTEM_REGFIN(obj, finalize)";
PROCEDURE -SetHalt*(p: PROCEDURE(n: LONGINT))
"SYSTEM_Halt = p";
PROCEDURE InstallTermHandler*(p: PROCEDURE);
(* not yet supported; no Modules.Free *)
END InstallTermHandler;
PROCEDURE LargestAvailable*(): LONGINT;
BEGIN
(* dummy proc for System 3 compatibility
no meaningful value except may be the remaining swap space can be returned
in the context of an extensible heap *)
RETURN MAX(LONGINT)
END LargestAvailable;
PROCEDURE Halt(n: LONGINT);
VAR res: LONGINT;
BEGIN res := Unix.Kill(Unix.Getpid(), 4);
END Halt;
PROCEDURE EndianTest;
VAR i: LONGINT; dmy: INTEGER;
BEGIN
dmy := 1; i := SYSTEM.ADR(dmy);
SYSTEM.GET(i, littleEndian); (* indirection via i avoids warning on SUN cc -O *)
END EndianTest;
PROCEDURE -SizeofUnixJmpBuf(): INTEGER
"sizeof(Unix_JmpBuf)";
PROCEDURE -SizeofSigJmpBuf(): INTEGER
"sizeof(sigjmp_buf)";
PROCEDURE -Error(msg: ARRAY OF CHAR; len: INTEGER)
"write(1/*stdout*/, msg, len); char ch = 0xa; write(1, &ch, 1)";
PROCEDURE JmpBufCheck; (* check for inconsistent usage of sigjmp_buf *)
VAR x, y: LONGINT;
BEGIN
x := SizeofUnixJmpBuf();
y := SizeofSigJmpBuf();
IF x < y THEN
Error("Kernel.JmpBufCheck: inconsistent usage of sigjmp_buf", 52);
Exit(1);
END
END JmpBufCheck;
BEGIN
EndianTest();
SetHalt(Halt);
CWD := ""; OBERON := "."; LIB := "";
getcwd(CWD);
Args.GetEnv("OBERON", OBERON);
Args.GetEnv("OBERON_LIB", LIB);
TimeUnit := 1000; timeStart := 0; timeStart := Time();
JmpBufCheck()
END Kernel.

200
src/lib/system/openbsd/gcc/Kernel0.Mod Normal file
View file

@ -0,0 +1,200 @@
MODULE Kernel0;
(*
J. Templ, 16.4.95
communication with C-runtime and storage management
*)
(* version for bootstrapping voc *)
IMPORT SYSTEM, Unix, Args, Strings, version;
TYPE
RealTime = POINTER TO TimeDesc;
TimeDesc = RECORD
sec, min, hour, mday, mon, year, wday, isdst, zone, gmtoff: LONGINT
(* sec, min, hour, mday, mon, year, wday, isdst, zone, gmtoff: INTEGER*)
END ;
KeyCmd* = PROCEDURE;
ObjFinalizer* = PROCEDURE(obj: SYSTEM.PTR);
VAR
(* trap handling *)
trapEnv*: Unix.JmpBuf; (* saved stack environment for trap handling *)
(* oberon heap management *)
nofiles*: LONGINT;
(* input event handling *)
readSet*, readySet*: Unix.FdSet;
FKey*: ARRAY 16 OF KeyCmd;
littleEndian*: BOOLEAN;
TimeUnit*: LONGINT; (* 1 sec *)
LIB*, CWD*: ARRAY 256 OF CHAR;
OBERON*: ARRAY 1024 OF CHAR;
MODULES-: ARRAY 1024 OF CHAR;
prefix*, fullprefix* : ARRAY 256 OF CHAR;
timeStart: LONGINT; (* milliseconds *)
PROCEDURE -includesetjmp()
'#include "setjmp.h"';
(* for localtime *)
PROCEDURE -includetime()
'#include "time.h"';
PROCEDURE -Lock*()
"SYSTEM_lock++";
PROCEDURE -Unlock*()
"SYSTEM_lock--; if (SYSTEM_interrupted && SYSTEM_lock == 0) __HALT(-9)";
PROCEDURE -Exit*(n: LONGINT)
"exit(n)";
PROCEDURE -sigsetjmp*(VAR env: Unix.JmpBuf; savemask: LONGINT): LONGINT
"__sigsetjmp(env, savemask)";
PROCEDURE -siglongjmp*(VAR env:Unix.JmpBuf; val: LONGINT)
"siglongjmp(env, val)";
PROCEDURE -heapsize*(): LONGINT
"SYSTEM_heapsize";
PROCEDURE -allocated*(): LONGINT
"SYSTEM_allocated";
PROCEDURE -localtime(VAR clock: LONGINT): RealTime
"(Kernel0_RealTime)localtime(clock)";
PROCEDURE -malloc*(size: LONGINT): LONGINT
"(LONGINT)malloc(size)";
PROCEDURE -free*(adr: LONGINT)
"(void)free(adr)";
PROCEDURE -getcwd(VAR cwd: Unix.Name)
"getcwd(cwd, cwd__len)";
PROCEDURE GetClock* (VAR t, d: LONGINT);
VAR tv: Unix.Timeval; tz: Unix.Timezone; time: RealTime;
l : LONGINT;
BEGIN
l := Unix.Gettimeofday(tv, tz);
time := localtime(tv.sec);
t := time.sec + ASH(time.min, 6) + ASH(time.hour, 12);
d := time.mday + ASH(time.mon+1, 5) + ASH(time.year MOD 100, 9);
END GetClock;
PROCEDURE SetClock* (t, d: LONGINT);
VAR err: ARRAY 25 OF CHAR;
BEGIN err := "not yet implemented"; HALT(99)
END SetClock;
PROCEDURE Time*(): LONGINT;
VAR timeval: Unix.Timeval; timezone: Unix.Timezone;
l : LONGINT;
BEGIN
l := Unix.Gettimeofday(timeval, timezone);
RETURN (timeval.usec DIV 1000 + timeval.sec * 1000 - timeStart) MOD 7FFFFFFFH
END Time;
(*
PROCEDURE UserTime*(): LONGINT;
VAR rusage: Unix.Rusage;
BEGIN
Unix.Getrusage(0, S.ADR(rusage));
RETURN rusage.utime.sec*1000 + rusage.utime.usec DIV 1000
(* + rusage.stime.sec*1000 + rusage.stime.usec DIV 1000*)
END UserTime;
*)
PROCEDURE Select*(delay: LONGINT);
VAR rs, ws, xs: Unix.FdSet; n: LONGINT; tv: Unix.Timeval;
BEGIN
rs := readSet;
FOR n := 0 TO 7 DO ws[n] := {}; xs[n] := {}; readySet[n] := {} END;
IF delay < 0 THEN delay := 0 END ;
tv.sec := delay DIV 1000; tv.usec := delay MOD 1000 * 1000;
n := Unix.Select(256, rs, ws, xs, tv);
IF n >= 0 THEN readySet := rs END
END Select;
PROCEDURE -GC*(markStack: BOOLEAN)
"SYSTEM_GC(markStack)";
PROCEDURE -RegisterObject*(obj: SYSTEM.PTR; finalize: ObjFinalizer)
"SYSTEM_REGFIN(obj, finalize)";
PROCEDURE -SetHalt*(p: PROCEDURE(n: LONGINT))
"SYSTEM_Halt = p";
PROCEDURE InstallTermHandler*(p: PROCEDURE);
(* not yet supported; no Modules.Free *)
END InstallTermHandler;
PROCEDURE LargestAvailable*(): LONGINT;
BEGIN
(* dummy proc for System 3 compatibility
no meaningful value except may be the remaining swap space can be returned
in the context of an extensible heap *)
RETURN MAX(LONGINT)
END LargestAvailable;
PROCEDURE Halt(n: LONGINT);
VAR res: LONGINT;
BEGIN res := Unix.Kill(Unix.Getpid(), 4);
END Halt;
PROCEDURE EndianTest;
VAR i: LONGINT; dmy: INTEGER;
BEGIN
dmy := 1; i := SYSTEM.ADR(dmy);
SYSTEM.GET(i, littleEndian); (* indirection via i avoids warning on SUN cc -O *)
END EndianTest;
PROCEDURE -SizeofUnixJmpBuf(): INTEGER
"sizeof(Unix_JmpBuf)";
PROCEDURE -SizeofSigJmpBuf(): INTEGER
"sizeof(sigjmp_buf)";
PROCEDURE -Error(msg: ARRAY OF CHAR; len: INTEGER)
"write(1/*stdout*/, msg, len); char ch = 0xa; write(1, &ch, 1)";
PROCEDURE JmpBufCheck; (* check for inconsistent usage of sigjmp_buf *)
VAR x, y: LONGINT;
BEGIN
x := SizeofUnixJmpBuf();
y := SizeofSigJmpBuf();
IF x < y THEN
Error("Kernel.JmpBufCheck: inconsistent usage of sigjmp_buf", 52);
Exit(1);
END
END JmpBufCheck;
BEGIN
EndianTest();
SetHalt(Halt);
CWD := ""; OBERON := "."; LIB := "";
MODULES := ""; (* additional modules path which can be specified on commandline and will be added to the OBERON variable; noch *)
getcwd(CWD);
Args.GetEnv ("MODULES", MODULES);
Args.GetEnv("OBERON", OBERON);
(* always have current directory in module search path, noch *)
Strings.Append(":.:", OBERON);
Strings.Append(MODULES, OBERON);
Strings.Append(":", OBERON);
Strings.Append(version.prefix, OBERON);
Strings.Append("/lib/voc/sym:", OBERON);
Args.GetEnv("OBERON_LIB", LIB);
TimeUnit := 1000; timeStart := 0; timeStart := Time();
JmpBufCheck()
END Kernel0.

520
src/lib/system/openbsd/gcc/SYSTEM.Mod Normal file
View file

@ -0,0 +1,520 @@
(*
* voc (jet backend) runtime system, Version 1.1
*
* Copyright (c) Software Templ, 1994, 1995, 1996
*
* 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.
*)
MODULE SYSTEM; (* J. Templ, 31.5.95 *)
IMPORT SYSTEM; (*must not import other modules*)
CONST
ModNameLen = 20;
CmdNameLen = 24;
SZL = SIZE(LONGINT);
Unit = 4*SZL; (* smallest possible heap block *)
nofLists = 9; (* number of free_lists *)
heapSize0 = 8000*Unit; (* startup heap size *)
(* all blocks look the same:
free blocks describe themselves: size = Unit
tag = &tag++
->blksize
sentinel = -SZL
next
*)
(* heap chunks *)
nextChnkOff = 0; (* next heap chunk, sorted ascendingly! *)
endOff = SZL; (* end of heap chunk *)
blkOff = 3*SZL; (* first block in a chunk *)
(* heap blocks *)
tagOff = 0; (* block starts with tag *)
sizeOff = SZL; (* block size in free block relative to block start *)
sntlOff = 2*SZL; (* pointer offset table sentinel in free block relative to block start *)
nextOff = 3*SZL; (* next pointer in free block relative to block start *)
NoPtrSntl = LONG(LONG(-SZL));
TYPE
ModuleName = ARRAY ModNameLen OF CHAR;
CmdName = ARRAY CmdNameLen OF CHAR;
Module = POINTER TO ModuleDesc;
Cmd = POINTER TO CmdDesc;
EnumProc = PROCEDURE(P: PROCEDURE(p: SYSTEM.PTR));
ModuleDesc = RECORD
next: Module;
name: ModuleName;
refcnt: LONGINT;
cmds: Cmd;
types: LONGINT;
enumPtrs: EnumProc;
reserved1, reserved2: LONGINT
END ;
Command = PROCEDURE;
CmdDesc = RECORD
next: Cmd;
name: CmdName;
cmd: Command
END ;
Finalizer = PROCEDURE(obj: SYSTEM.PTR);
FinNode = POINTER TO FinDesc;
FinDesc = RECORD
next: FinNode;
obj: LONGINT; (* weak pointer *)
marked: BOOLEAN;
finalize: Finalizer;
END ;
VAR
(* the list of loaded (=initialization started) modules *)
modules*: SYSTEM.PTR;
freeList: ARRAY nofLists + 1 OF LONGINT; (* dummy, 16, 32, 48, 64, 80, 96, 112, 128, sentinel *)
bigBlocks, allocated*: LONGINT;
firstTry: BOOLEAN;
(* extensible heap *)
heap, (* the sorted list of heap chunks *)
heapend, (* max possible pointer value (used for stack collection) *)
heapsize*: LONGINT; (* the sum of all heap chunk sizes *)
(* finalization candidates *)
fin: FinNode;
(* garbage collector locking *)
gclock*: SHORTINT;
PROCEDURE -malloc(size: LONGINT): LONGINT "(LONGINT)malloc(size)";
PROCEDURE -Lock() "Lock";
PROCEDURE -Unlock() "Unlock";
PROCEDURE -Mainfrm(): LONGINT "SYSTEM_mainfrm";
(*
PROCEDURE TAS*(VAR flag:BOOLEAN): BOOLEAN; (* added for compatibility with ulmSYSTEM module; noch *)
VAR oldflag : BOOLEAN;
BEGIN
oldflag := flag;
flag := TRUE;
RETURN oldflag;
END TAS;
*)
PROCEDURE REGMOD*(VAR name: ModuleName; enumPtrs: EnumProc): SYSTEM.PTR;
VAR m: Module;
BEGIN
IF name = "SYSTEM" THEN (* cannot use NEW *)
SYSTEM.NEW(m, SIZE(ModuleDesc)); m.cmds := NIL
ELSE NEW(m)
END ;
COPY(name, m.name); m.refcnt := 0; m.enumPtrs := enumPtrs; m.next := SYSTEM.VAL(Module, modules);
modules := m;
RETURN m
END REGMOD;
PROCEDURE REGCMD*(m: Module; VAR name: CmdName; cmd: Command);
VAR c: Cmd;
BEGIN NEW(c);
COPY(name, c.name); c.cmd := cmd; c.next := m.cmds; m.cmds := c
END REGCMD;
PROCEDURE REGTYP*(m: Module; typ: LONGINT);
BEGIN SYSTEM.PUT(typ, m.types); m.types := typ
END REGTYP;
PROCEDURE INCREF*(m: Module);
BEGIN INC(m.refcnt)
END INCREF;
PROCEDURE NewChunk(blksz: LONGINT): LONGINT;
VAR chnk: LONGINT;
BEGIN
chnk := malloc(blksz + blkOff);
IF chnk # 0 THEN
SYSTEM.PUT(chnk + endOff, chnk + (blkOff + blksz));
SYSTEM.PUT(chnk + blkOff, chnk + (blkOff + sizeOff));
SYSTEM.PUT(chnk + (blkOff + sizeOff), blksz);
SYSTEM.PUT(chnk + (blkOff + sntlOff), NoPtrSntl);
SYSTEM.PUT(chnk + (blkOff + nextOff), bigBlocks);
bigBlocks := chnk + blkOff;
INC(heapsize, blksz)
END ;
RETURN chnk
END NewChunk;
PROCEDURE ExtendHeap(blksz: LONGINT);
VAR size, chnk, j, next: LONGINT;
BEGIN
IF blksz > 10000*Unit THEN size := blksz
ELSE size := 10000*Unit (* additional heuristics *)
END ;
chnk := NewChunk(size);
IF chnk # 0 THEN
(*sorted insertion*)
IF chnk < heap THEN
SYSTEM.PUT(chnk, heap); heap := chnk
ELSE
j := heap; SYSTEM.GET(j, next);
WHILE (next # 0) & (chnk > next) DO j := next; SYSTEM.GET(j, next) END ;
SYSTEM.PUT(chnk, next); SYSTEM.PUT(j, chnk)
END ;
IF next = 0 THEN SYSTEM.GET(chnk + endOff, heapend) END
END
END ExtendHeap;
PROCEDURE ^GC*(markStack: BOOLEAN);
PROCEDURE NEWREC*(tag: LONGINT): SYSTEM.PTR;
VAR i, i0, di, blksz, restsize, t, adr, end, next, prev: LONGINT; new: SYSTEM.PTR;
BEGIN
Lock();
SYSTEM.GET(tag, blksz);
ASSERT(blksz MOD Unit = 0);
i0 := blksz DIV Unit; i := i0;
IF i < nofLists THEN adr := freeList[i];
WHILE adr = 0 DO INC(i); adr := freeList[i] END
END ;
IF i < nofLists THEN (* unlink *)
SYSTEM.GET(adr + nextOff, next);
freeList[i] := next;
IF i # i0 THEN (* split *)
di := i - i0; restsize := di * Unit; end := adr + restsize;
SYSTEM.PUT(end + sizeOff, blksz);
SYSTEM.PUT(end + sntlOff, NoPtrSntl);
SYSTEM.PUT(end, end + sizeOff);
SYSTEM.PUT(adr + sizeOff, restsize);
SYSTEM.PUT(adr + nextOff, freeList[di]);
freeList[di] := adr;
INC(adr, restsize)
END
ELSE
adr := bigBlocks; prev := 0;
LOOP
IF adr = 0 THEN
IF firstTry THEN
GC(TRUE); INC(blksz, Unit);
IF (heapsize - allocated - blksz) * 4 < heapsize THEN
(* heap is still almost full; expand to avoid thrashing *)
ExtendHeap((allocated + blksz) DIV (3*Unit) * (4*Unit) - heapsize)
END ;
firstTry := FALSE; new := NEWREC(tag); firstTry := TRUE;
IF new = NIL THEN
(* depending on the fragmentation, the heap may not have been extended by
the anti-thrashing heuristics above *)
ExtendHeap((allocated + blksz) DIV (3*Unit) * (4*Unit) - heapsize);
new := NEWREC(tag); (* will find a free block if heap has been expanded properly *)
END ;
Unlock(); RETURN new
ELSE
Unlock(); RETURN NIL
END
END ;
SYSTEM.GET(adr+sizeOff, t);
IF t >= blksz THEN EXIT END ;
prev := adr; SYSTEM.GET(adr + nextOff, adr)
END ;
restsize := t - blksz; end := adr + restsize;
SYSTEM.PUT(end + sizeOff, blksz);
SYSTEM.PUT(end + sntlOff, NoPtrSntl);
SYSTEM.PUT(end, end + sizeOff);
IF restsize > nofLists * Unit THEN (*resize*)
SYSTEM.PUT(adr + sizeOff, restsize)
ELSE (*unlink*)
SYSTEM.GET(adr + nextOff, next);
IF prev = 0 THEN bigBlocks := next
ELSE SYSTEM.PUT(prev + nextOff, next);
END ;
IF restsize > 0 THEN (*move*)
di := restsize DIV Unit;
SYSTEM.PUT(adr + sizeOff, restsize);
SYSTEM.PUT(adr + nextOff, freeList[di]);
freeList[di] := adr
END
END ;
INC(adr, restsize)
END ;
i := adr + 4*SZL; end := adr + blksz;
WHILE i < end DO (*deliberately unrolled*)
SYSTEM.PUT(i, LONG(LONG(0)));
SYSTEM.PUT(i + SZL, LONG(LONG(0)));
SYSTEM.PUT(i + 2*SZL, LONG(LONG(0)));
SYSTEM.PUT(i + 3*SZL, LONG(LONG(0)));
INC(i, 4*SZL)
END ;
SYSTEM.PUT(adr + nextOff, LONG(LONG(0)));
SYSTEM.PUT(adr, tag);
SYSTEM.PUT(adr + sizeOff, LONG(LONG(0)));
SYSTEM.PUT(adr + sntlOff, LONG(LONG(0)));
INC(allocated, blksz);
Unlock();
RETURN SYSTEM.VAL(SYSTEM.PTR, adr + SZL)
END NEWREC;
PROCEDURE NEWBLK*(size: LONGINT): SYSTEM.PTR;
VAR blksz, tag: LONGINT; new: SYSTEM.PTR;
BEGIN
Lock();
blksz := (size + (4*SZL + Unit - 1)) DIV Unit * Unit; (*size + tag + meta + blksz + sntnl + UnitAlignment*)
new := NEWREC(SYSTEM.ADR(blksz));
tag := SYSTEM.VAL(LONGINT, new) + blksz - 3*SZL;
SYSTEM.PUT(tag - SZL, LONG(LONG(0))); (*reserved for meta info*)
SYSTEM.PUT(tag, blksz);
SYSTEM.PUT(tag + SZL, NoPtrSntl);
SYSTEM.PUT(SYSTEM.VAL(LONGINT, new) - SZL, tag);
Unlock();
RETURN new
END NEWBLK;
PROCEDURE Mark(q: LONGINT);
VAR p, tag, fld, n, offset, tagbits: LONGINT;
BEGIN
IF q # 0 THEN SYSTEM.GET(q - SZL, tagbits);
IF ~ODD(tagbits) THEN
SYSTEM.PUT(q - SZL, tagbits + 1);
p := 0; tag := tagbits + SZL;
LOOP
SYSTEM.GET(tag, offset);
IF offset < 0 THEN
SYSTEM.PUT(q - SZL, tag + offset + 1);
IF p = 0 THEN EXIT END ;
n := q; q := p;
SYSTEM.GET(q - SZL, tag); DEC(tag, 1);
SYSTEM.GET(tag, offset); fld := q + offset;
SYSTEM.GET(fld, p); SYSTEM.PUT(fld, n)
ELSE
fld := q + offset;
SYSTEM.GET(fld, n);
IF n # 0 THEN
SYSTEM.GET(n - SZL, tagbits);
IF ~ODD(tagbits) THEN
SYSTEM.PUT(n - SZL, tagbits + 1);
SYSTEM.PUT(q - SZL, tag + 1);
SYSTEM.PUT(fld, p); p := q; q := n;
tag := tagbits
END
END
END ;
INC(tag, SZL)
END
END
END
END Mark;
PROCEDURE MarkP(p: SYSTEM.PTR); (* for compatibility with EnumPtrs in ANSI mode *)
BEGIN
Mark(SYSTEM.VAL(LONGINT, p))
END MarkP;
PROCEDURE Scan;
VAR chnk, adr, end, start, tag, i, size, freesize: LONGINT;
BEGIN bigBlocks := 0; i := 1;
WHILE i < nofLists DO freeList[i] := 0; INC(i) END ;
freesize := 0; allocated := 0; chnk := heap;
WHILE chnk # 0 DO
adr := chnk + blkOff; SYSTEM.GET(chnk + endOff, end);
WHILE adr < end DO
SYSTEM.GET(adr, tag);
IF ODD(tag) THEN (*marked*)
IF freesize > 0 THEN
start := adr - freesize;
SYSTEM.PUT(start, start+SZL);
SYSTEM.PUT(start+sizeOff, freesize);
SYSTEM.PUT(start+sntlOff, NoPtrSntl);
i := freesize DIV Unit; freesize := 0;
IF i < nofLists THEN SYSTEM.PUT(start + nextOff, freeList[i]); freeList[i] := start
ELSE SYSTEM.PUT(start + nextOff, bigBlocks); bigBlocks := start
END
END ;
DEC(tag, 1);
SYSTEM.PUT(adr, tag);
SYSTEM.GET(tag, size);
INC(allocated, size);
INC(adr, size)
ELSE (*unmarked*)
SYSTEM.GET(tag, size);
INC(freesize, size);
INC(adr, size)
END
END ;
IF freesize > 0 THEN (*collect last block*)
start := adr - freesize;
SYSTEM.PUT(start, start+SZL);
SYSTEM.PUT(start+sizeOff, freesize);
SYSTEM.PUT(start+sntlOff, NoPtrSntl);
i := freesize DIV Unit; freesize := 0;
IF i < nofLists THEN SYSTEM.PUT(start + nextOff, freeList[i]); freeList[i] := start
ELSE SYSTEM.PUT(start + nextOff, bigBlocks); bigBlocks := start
END
END ;
SYSTEM.GET(chnk, chnk)
END
END Scan;
PROCEDURE Sift (l, r: LONGINT; VAR a: ARRAY OF LONGINT);
VAR i, j, x: LONGINT;
BEGIN j := l; x := a[j];
LOOP i := j; j := 2*j + 1;
IF (j < r) & (a[j] < a[j+1]) THEN INC(j) END;
IF (j > r) OR (a[j] <= x) THEN EXIT END;
a[i] := a[j]
END;
a[i] := x
END Sift;
PROCEDURE HeapSort (n: LONGINT; VAR a: ARRAY OF LONGINT);
VAR l, r, x: LONGINT;
BEGIN l := n DIV 2; r := n - 1;
WHILE l > 0 DO DEC(l); Sift(l, r, a) END;
WHILE r > 0 DO x := a[0]; a[0] := a[r]; a[r] := x; DEC(r); Sift(l, r, a) END
END HeapSort;
PROCEDURE MarkCandidates(n: LONGINT; VAR cand: ARRAY OF LONGINT);
VAR chnk, adr, tag, next, lim, lim1, i, ptr, size: LONGINT;
BEGIN
chnk := heap; i := 0; lim := cand[n-1];
WHILE (chnk # 0 ) & (chnk < lim) DO
adr := chnk + blkOff;
SYSTEM.GET(chnk + endOff, lim1);
IF lim < lim1 THEN lim1 := lim END ;
WHILE adr < lim1 DO
SYSTEM.GET(adr, tag);
IF ODD(tag) THEN (*already marked*)
SYSTEM.GET(tag-1, size); INC(adr, size)
ELSE
SYSTEM.GET(tag, size);
ptr := adr + SZL;
WHILE cand[i] < ptr DO INC(i) END ;
IF i = n THEN RETURN END ;
next := adr + size;
IF cand[i] < next THEN Mark(ptr) END ;
adr := next
END
END ;
SYSTEM.GET(chnk, chnk)
END
END MarkCandidates;
PROCEDURE CheckFin;
VAR n: FinNode; tag: LONGINT;
BEGIN n := fin;
WHILE n # NIL DO
SYSTEM.GET(n.obj - SZL, tag);
IF ~ODD(tag) THEN n.marked := FALSE; Mark(n.obj)
ELSE n.marked := TRUE
END ;
n := n.next
END
END CheckFin;
PROCEDURE Finalize;
VAR n, prev: FinNode;
BEGIN n := fin; prev := NIL;
WHILE n # NIL DO
IF ~n.marked THEN
IF n = fin THEN fin := fin.next ELSE prev.next := n.next END ;
n.finalize(SYSTEM.VAL(SYSTEM.PTR, n.obj));
(* new nodes may have been pushed in n.finalize, therefore: *)
IF prev = NIL THEN n := fin ELSE n := n.next END
ELSE prev := n; n := n.next
END
END
END Finalize;
PROCEDURE FINALL*;
VAR n: FinNode;
BEGIN
WHILE fin # NIL DO
n := fin; fin := fin.next;
n.finalize(SYSTEM.VAL(SYSTEM.PTR, n.obj))
END
END FINALL;
PROCEDURE MarkStack(n: LONGINT; VAR cand: ARRAY OF LONGINT);
VAR
frame: SYSTEM.PTR;
inc, nofcand: LONGINT;
sp, p, stack0, ptr: LONGINT;
align: RECORD ch: CHAR; p: SYSTEM.PTR END ;
BEGIN
IF n > 0 THEN MarkStack(n-1, cand); (* flush register windows by means of recursive calls *)
IF n > 100 THEN RETURN END (* prevent tail recursion optimization *)
END ;
IF n = 0 THEN
nofcand := 0; sp := SYSTEM.ADR(frame);
stack0 := Mainfrm();
(* check for minimum alignment of pointers *)
inc := SYSTEM.ADR(align.p) - SYSTEM.ADR(align);
IF sp > stack0 THEN inc := -inc END ;
WHILE sp # stack0 DO
SYSTEM.GET(sp, p);
IF (p > heap) & (p < heapend) THEN
IF nofcand = LEN(cand) THEN HeapSort(nofcand, cand); MarkCandidates(nofcand, cand); nofcand := 0 END ;
cand[nofcand] := p; INC(nofcand)
END ;
INC(sp, inc)
END ;
IF nofcand > 0 THEN HeapSort(nofcand, cand); MarkCandidates(nofcand, cand) END
END
END MarkStack;
PROCEDURE GC*(markStack: BOOLEAN);
VAR
m: Module;
i0, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, i21, i22, i23: LONGINT;
cand: ARRAY 10000 OF LONGINT;
BEGIN
IF (gclock = 0) OR (gclock = 1) & ~markStack THEN
Lock();
m := SYSTEM.VAL(Module, modules);
WHILE m # NIL DO
IF m.enumPtrs # NIL THEN m.enumPtrs(MarkP) END ;
m := m^.next
END ;
IF markStack THEN
(* generate register pressure to force callee saved registers to memory;
may be simplified by inlining OS calls or processor specific instructions
*)
i0 := -100; i1 := -101; i2 := -102; i3 := -103; i4 := -104; i5 := -105; i6 := -106; i7 := -107;
i8 := 1; i9 := 2; i10 := 3; i11 := 4; i12 := 5; i13 := 6; i14 := 7; i15 := 8;
i16 := 9; i17 := 10; i18 := 11; i19 := 12; i20 := 13; i21 := 14; i22 := 15; i23 := 16;
LOOP INC(i0, 1); INC(i1, 2); INC(i2, 3); INC(i3, 4); INC(i4, 5); INC(i5, 6); INC(i6, 7); INC(i7, 8);
INC(i8, 9); INC(i9, 10); INC(i10, 11); INC(i11, 12); INC(i12, 13); INC(i13, 14); INC(i14, 15); INC(i15, 16);
INC(i16, 17); INC(i17, 18); INC(i18, 19); INC(i19, 20); INC(i20, 21); INC(i21, 22); INC(i22, 23); INC(i23, 24);
IF (i0 = -99) & (i15 = 24) THEN MarkStack(32, cand); EXIT END
END ;
IF i0 + i1 + i2 + i3 + i4 + i5 + i6 + i7 + i8 + i9 + i10 + i11 + i12 + i13 + i14 + i15
+ i16 + i17 + i18 + i19 + i20 + i21 + i22 + i23 > 10000 THEN RETURN (* use all variables *)
END ;
END;
CheckFin;
Scan;
Finalize;
Unlock()
END
END GC;
PROCEDURE REGFIN*(obj: SYSTEM.PTR; finalize: Finalizer);
VAR f: FinNode;
BEGIN NEW(f);
f.obj := SYSTEM.VAL(LONGINT, obj); f.finalize := finalize; f.marked := TRUE; f.next := fin; fin := f
END REGFIN;
PROCEDURE InitHeap; (* initialized before body to enable NEW, SYSTEM.NEW *)
BEGIN
heap := NewChunk(heapSize0);
SYSTEM.GET(heap + endOff, heapend);
SYSTEM.PUT(heap, LONG(LONG(0)));
allocated := 0; firstTry := TRUE; freeList[nofLists] := 1; gclock := 0
END InitHeap;
END SYSTEM.

65
src/lib/system/openbsd/gcc/x86_64/Args.Mod Normal file
View file

@ -0,0 +1,65 @@
MODULE Args; (* jt, 8.12.94 *)
(* command line argument handling for voc (jet backend) *)
IMPORT SYSTEM;
TYPE
ArgPtr = POINTER TO ARRAY 1024 OF CHAR;
ArgVec = POINTER TO ARRAY 1024 OF ArgPtr;
VAR argc-: INTEGER; argv-: LONGINT;
(*PROCEDURE -includestdlib() "#include <stdlib.h>";*)
PROCEDURE -externgetenv() "extern char *getenv(const char *name);"; (* took this from stdlib.h*)
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.

664
src/lib/system/openbsd/gcc/x86_64/Files.Mod Normal file
View file

@ -0,0 +1,664 @@
MODULE Files; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files *)
(* modified version of Files, which opens only the file provided and does not scan any path in any environment variable, also ReadLine procedure added; -- noch *)
IMPORT SYSTEM, Unix, Kernel, Args, Console;
(* standard data type I/O
little endian,
Sint:1, Int:2, Lint:4
ORD({0}) = 1,
false = 0, true =1
IEEE real format,
null terminated strings,
compact numbers according to M.Odersky *)
CONST
nofbufs = 4;
bufsize = 4096;
fileTabSize = 64;
noDesc = -1;
notDone = -1;
(* file states *)
open = 0; create = 1; close = 2;
TYPE
FileName = ARRAY 101 OF CHAR;
File* = POINTER TO Handle;
Buffer = POINTER TO BufDesc;
Handle = RECORD
workName, registerName: FileName;
tempFile: BOOLEAN;
dev, ino, mtime: LONGINT;
fd-: INTEGER;
len, pos: LONGINT;
bufs: ARRAY nofbufs OF Buffer;
swapper, state: INTEGER
END ;
BufDesc = RECORD
f: File;
chg: BOOLEAN;
org, size: LONGINT;
data: ARRAY bufsize OF SYSTEM.BYTE
END ;
Rider* = RECORD
res*: LONGINT;
eof*: BOOLEAN;
buf: Buffer;
org, offset: LONGINT
END ;
Time = POINTER TO TimeDesc;
TimeDesc = RECORD
sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: LONGINT;
(* sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: INTEGER;*)
END ;
VAR
fileTab: ARRAY fileTabSize OF LONGINT (*=File*);
tempno: INTEGER;
(* for localtime *)
PROCEDURE -includetime()
'#include "time.h"';
PROCEDURE -localtime(VAR clock: LONGINT): Time
"(Files_Time) localtime(clock)";
PROCEDURE -getcwd(VAR cwd: Unix.Name)
"getcwd(cwd, cwd__len)";
PROCEDURE -IdxTrap "__HALT(-1)";
PROCEDURE^ Finalize(o: SYSTEM.PTR);
PROCEDURE Err(s: ARRAY OF CHAR; f: File; errno: LONGINT);
BEGIN
Console.Ln; Console.String("-- "); Console.String(s); Console.String(": ");
IF f # NIL THEN
IF f.registerName # "" THEN Console.String(f.registerName) ELSE Console.String(f.workName) END
END ;
IF errno # 0 THEN Console.String(" errno = "); Console.Int(errno, 1) END ;
Console.Ln;
HALT(99)
END Err;
PROCEDURE MakeFileName(dir, name: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR);
VAR i, j: INTEGER;
BEGIN i := 0; j := 0;
WHILE dir[i] # 0X DO dest[i] := dir[i]; INC(i) END ;
IF dest[i-1] # "/" THEN dest[i] := "/"; INC(i) END ;
WHILE name[j] # 0X DO dest[i] := name[j]; INC(i); INC(j) END ;
dest[i] := 0X
END MakeFileName;
PROCEDURE GetTempName(finalName: ARRAY OF CHAR; VAR name: ARRAY OF CHAR);
VAR n, i, j: LONGINT;
BEGIN
INC(tempno); n := tempno; i := 0;
IF finalName[0] # "/" THEN (* relative pathname *)
WHILE Kernel.CWD[i] # 0X DO name[i] := Kernel.CWD[i]; INC(i) END;
IF Kernel.CWD[i-1] # "/" THEN name[i] := "/"; INC(i) END
END;
j := 0;
WHILE finalName[j] # 0X DO name[i] := finalName[j]; INC(i); INC(j) END;
DEC(i);
WHILE name[i] # "/" DO DEC(i) END;
name[i+1] := "."; name[i+2] := "t"; name[i+3] := "m"; name[i+4] := "p"; name[i+5] := "."; INC(i, 6);
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
name[i] := "."; INC(i); n := SHORT(Unix.Getpid());
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
name[i] := 0X
END GetTempName;
PROCEDURE Create(f: File);
VAR stat: Unix.Status; done: BOOLEAN;
errno: LONGINT; err: ARRAY 32 OF CHAR;
BEGIN
IF f.fd = noDesc THEN
IF f.state = create THEN GetTempName(f.registerName, f.workName); f.tempFile := TRUE
ELSIF f.state = close THEN
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END ;
errno := Unix.Unlink(f.workName); (*unlink first to avoid stale NFS handles and to avoid reuse of inodes*)
f.fd := Unix.Open(f.workName, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {2, 4,5, 7,8})));
done := f.fd >= 0; errno := Unix.errno();
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (f.fd >= fileTabSize)) THEN
IF done & (f.fd >= fileTabSize) THEN errno := Unix.Close(f.fd) END ;
Kernel.GC(TRUE);
f.fd := Unix.Open(f.workName, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {2, 4,5, 7,8})));
done := f.fd >= 0
END ;
IF done THEN
IF f.fd >= fileTabSize THEN errno := Unix.Close(f.fd); Err("too many files open", f, 0)
ELSE fileTab[f.fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize);
f.state := open; f.pos := 0; errno := Unix.Fstat(f.fd, stat);
f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime
END
ELSE errno := Unix.errno();
IF errno = Unix.ENOENT THEN err := "no such directory"
ELSIF (errno = Unix.ENFILE) OR (errno = Unix.EMFILE) THEN err := "too many files open"
ELSE err := "file not created"
END ;
Err(err, f, errno)
END
END
END Create;
PROCEDURE Flush(buf: Buffer);
VAR res: LONGINT; f: File; stat: Unix.Status;
BEGIN
IF buf.chg THEN f := buf.f; Create(f);
IF buf.org # f.pos THEN res := Unix.Lseek(f.fd, buf.org, 0) END ;
res := Unix.Write(f.fd, SYSTEM.ADR(buf.data), buf.size);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END ;
f.pos := buf.org + buf.size;
buf.chg := FALSE;
res := Unix.Fstat(f.fd, stat);
f.mtime := stat.mtime
END
END Flush;
PROCEDURE Close* (f: File);
VAR i, res: LONGINT;
BEGIN
IF (f.state # create) OR (f.registerName # "") THEN
Create(f); i := 0;
WHILE (i < nofbufs) & (f.bufs[i] # NIL) DO Flush(f.bufs[i]); INC(i) END ;
res := Unix.Fsync(f.fd);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END
END
END Close;
PROCEDURE Length* (f: File): LONGINT;
BEGIN RETURN f.len
END Length;
PROCEDURE New* (name: ARRAY OF CHAR): File;
VAR f: File;
BEGIN
NEW(f); f.workName := ""; COPY(name, f.registerName);
f.fd := noDesc; f.state := create; f.len := 0; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
RETURN f
END New;
(*
PROCEDURE ScanPath(VAR pos: INTEGER; VAR dir: ARRAY OF CHAR); (* supports ~, ~user and blanks inside path *)
VAR i: INTEGER; ch: CHAR; home: ARRAY 256 OF CHAR;
BEGIN
i := 0; ch := Kernel.OBERON[pos];
WHILE (ch = " ") OR (ch = ":") DO INC(pos); ch := Kernel.OBERON[pos] END ;
IF ch = "~" THEN
INC(pos); ch := Kernel.OBERON[pos];
home := ""; Args.GetEnv("HOME", home);
WHILE home[i] # 0X DO dir[i] := home[i]; INC(i) END ;
IF (ch # "/") & (ch # 0X) & (ch # ":") & (ch # " ") THEN
WHILE (i > 0) & (dir[i-1] # "/") DO DEC(i) END
END
END ;
WHILE (ch # 0X) & (ch # ":") DO dir[i] := ch; INC(i); INC(pos); ch := Kernel.OBERON[pos] END ;
WHILE (i > 0) & (dir[i-1] = " ") DO DEC(i) END ;
dir[i] := 0X
END ScanPath;
*)
PROCEDURE HasDir(VAR name: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; ch: CHAR;
BEGIN i := 0; ch := name[0];
WHILE (ch # 0X) & (ch # "/") DO INC(i); ch := name[i] END ;
RETURN ch = "/"
END HasDir;
PROCEDURE CacheEntry(dev, ino: LONGINT; mtime: LONGINT): File;
VAR f: File; i: INTEGER; stat: Unix.Status; res: LONGINT;
BEGIN i := 0;
WHILE i < fileTabSize DO
f := SYSTEM.VAL(File, fileTab[i]);
IF (f # NIL) & (ino = f.ino) & (dev = f.dev) THEN
IF mtime # f.mtime THEN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END ;
INC(i)
END ;
f.swapper := -1; f.mtime := mtime;
res := Unix.Fstat(f.fd, stat); f.len := stat.size
END ;
RETURN f
END ;
INC(i)
END ;
RETURN NIL
END CacheEntry;
PROCEDURE Old* (name: ARRAY OF CHAR): File;
VAR f: File; fd: INTEGER; res, errno: LONGINT; pos: INTEGER; done: BOOLEAN;
dir, path: ARRAY 256 OF CHAR;
stat: Unix.Status;
BEGIN
IF name # "" THEN
IF HasDir(name) THEN dir := ""; COPY(name, path)
ELSE
pos := 0;
COPY(name, path); (* -- noch *)
(*ScanPath(pos, dir);*) (*MakeFileName(dir, name, path);*) (*ScanPath(pos, dir)*)
END ;
LOOP
fd := Unix.Open(path, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); done := fd >= 0; errno := Unix.errno();
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (fd >= fileTabSize)) THEN
IF done & (fd >= fileTabSize) THEN res := Unix.Close(fd) END ;
Kernel.GC(TRUE);
fd := Unix.Open(path, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {})));
done := fd >= 0; errno := Unix.errno();
IF ~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE)) THEN Err("too many files open", f, errno) END
END ;
IF ~done & ((errno = Unix.EACCES) OR (errno = Unix.EROFS) OR (errno = Unix.EAGAIN)) THEN
(* errno EAGAIN observed on Solaris 2.4 *)
fd := Unix.Open(path, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); done := fd >= 0; errno := Unix.errno()
END ;
IF (~done) & (errno # Unix.ENOENT) THEN
Console.String("warning Files.Old "); Console.String(name);
Console.String(" errno = "); Console.Int(errno, 0); Console.Ln;
END ;
IF done THEN
res := Unix.Fstat(fd, stat);
f := CacheEntry(stat.dev, stat.ino, stat.mtime);
IF f # NIL THEN res := Unix.Close(fd); RETURN f
ELSIF fd >= fileTabSize THEN res := Unix.Close(fd); Err("too many files open", f, 0)
ELSE NEW(f); fileTab[fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize);
f.fd := fd; f.state := open; f.len := stat.size; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
COPY(name, f.workName); f.registerName := ""; f.tempFile := FALSE;
f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime;
RETURN f
END
ELSIF dir = "" THEN RETURN NIL
ELSE (*MakeFileName(dir, name, path);*) (*ScanPath(pos, dir)*)
RETURN NIL
END
END
ELSE RETURN NIL
END
END Old;
PROCEDURE Purge* (f: File);
VAR i: INTEGER; stat: Unix.Status; res: LONGINT;
BEGIN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END ;
INC(i)
END ;
IF f.fd # noDesc THEN res := Unix.Ftruncate(f.fd, 0); res := Unix.Lseek(f.fd, 0, 0) END ;
f.pos := 0; f.len := 0; f.swapper := -1;
res := Unix.Fstat(f.fd, stat); f.mtime := stat.mtime
END Purge;
PROCEDURE GetDate* (f: File; VAR t, d: LONGINT);
VAR stat: Unix.Status; clock, res: LONGINT; time: Time;
BEGIN
Create(f); res := Unix.Fstat(f.fd, stat);
time := localtime(stat.mtime);
t := time.sec + ASH(time.min, 6) + ASH(time.hour, 12);
d := time.mday + ASH(time.mon+1, 5) + ASH(time.year MOD 100, 9)
END GetDate;
PROCEDURE Pos* (VAR r: Rider): LONGINT;
BEGIN RETURN r.org + r.offset
END Pos;
PROCEDURE Set* (VAR r: Rider; f: File; pos: LONGINT);
VAR org, offset, i, n, res: LONGINT; buf: Buffer;
BEGIN
IF f # NIL THEN
IF pos > f.len THEN pos := f.len ELSIF pos < 0 THEN pos := 0 END ;
offset := pos MOD bufsize; org := pos - offset; i := 0;
WHILE (i < nofbufs) & (f.bufs[i] # NIL) & (org # f.bufs[i].org) DO INC(i) END ;
IF i < nofbufs THEN
IF f.bufs[i] = NIL THEN NEW(buf); buf.chg := FALSE; buf.org := -1; buf.f := f; f.bufs[i] := buf
ELSE buf := f.bufs[i]
END
ELSE
f.swapper := (f.swapper + 1) MOD nofbufs;
buf := f.bufs[f.swapper];
Flush(buf)
END ;
IF buf.org # org THEN
IF org = f.len THEN buf.size := 0
ELSE Create(f);
IF f.pos # org THEN res := Unix.Lseek(f.fd, org, 0) END ;
n := Unix.ReadBlk(f.fd, buf.data);
IF n < 0 THEN Err("read from file not done", f, Unix.errno()) END ;
f.pos := org + n;
buf.size := n
END ;
buf.org := org; buf.chg := FALSE
END
ELSE buf := NIL; org := 0; offset := 0
END ;
r.buf := buf; r.org := org; r.offset := offset; r.eof := FALSE; r.res := 0
END Set;
PROCEDURE Read* (VAR r: Rider; VAR x: SYSTEM.BYTE);
VAR offset: LONGINT; buf: Buffer;
BEGIN
buf := r.buf; offset := r.offset;
IF r.org # buf.org THEN Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset END ;
IF (offset < buf.size) THEN
x := buf.data[offset]; r.offset := offset + 1
ELSIF r.org + offset < buf.f.len THEN
Set(r, r.buf.f, r.org + offset);
x := r.buf.data[0]; r.offset := 1
ELSE
x := 0X; r.eof := TRUE
END
END Read;
PROCEDURE ReadBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer;
BEGIN
IF n > LEN(x) THEN IdxTrap END ;
xpos := 0; buf := r.buf; offset := r.offset;
WHILE n > 0 DO
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END ;
restInBuf := buf.size - offset;
IF restInBuf = 0 THEN r.res := n; r.eof := TRUE; RETURN
ELSIF n > restInBuf THEN min := restInBuf ELSE min := n END ;
SYSTEM.MOVE(SYSTEM.ADR(buf.data) + offset, SYSTEM.ADR(x) + xpos, min);
INC(offset, min); r.offset := offset; INC(xpos, min); DEC(n, min)
END ;
r.res := 0; r.eof := FALSE
END ReadBytes;
PROCEDURE ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE);
BEGIN
ReadBytes(r, x, 1);
END ReadByte;
PROCEDURE Base* (VAR r: Rider): File;
BEGIN RETURN r.buf.f
END Base;
PROCEDURE Write* (VAR r: Rider; x: SYSTEM.BYTE);
VAR buf: Buffer; offset: LONGINT;
BEGIN
buf := r.buf; offset := r.offset;
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END ;
buf.data[offset] := x;
buf.chg := TRUE;
IF offset = buf.size THEN
INC(buf.size); INC(buf.f.len)
END ;
r.offset := offset + 1; r.res := 0
END Write;
PROCEDURE WriteByte* (VAR r : Rider; x : SYSTEM.BYTE); (* added for compatibility with PO 2013, -- noch *)
BEGIN
Write(r, x);
END WriteByte;
PROCEDURE WriteBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer;
BEGIN
IF n > LEN(x) THEN IdxTrap END ;
xpos := 0; buf := r.buf; offset := r.offset;
WHILE n > 0 DO
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END ;
restInBuf := bufsize - offset;
IF n > restInBuf THEN min := restInBuf ELSE min := n END ;
SYSTEM.MOVE(SYSTEM.ADR(x) + xpos, SYSTEM.ADR(buf.data) + offset, min);
INC(offset, min); r.offset := offset;
IF offset > buf.size THEN INC(buf.f.len, offset - buf.size); buf.size := offset END ;
INC(xpos, min); DEC(n, min); buf.chg := TRUE
END ;
r.res := 0
END WriteBytes;
(* another solution would be one that is similar to ReadBytes, WriteBytes.
No code duplication, more symmetric, only two ifs for
Read and Write in buffer, buf.size replaced by bufsize in Write ops, buf.size and len
must be made consistent with offset (if offset > buf.size) in a lazy way.
PROCEDURE Write* (VAR r: Rider; x: SYSTEM.BYTE);
VAR buf: Buffer; offset: LONGINT;
BEGIN
buf := r.buf; offset := r.offset;
IF (offset >= bufsize) OR (r.org # buf.org) THEN
Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset;
END ;
buf.data[offset] := x; r.offset := offset + 1; buf.chg := TRUE
END Write;
PROCEDURE WriteBytes ...
PROCEDURE Read* (VAR r: Rider; VAR x: SYSTEM.BYTE);
VAR offset: LONGINT; buf: Buffer;
BEGIN
buf := r.buf; offset := r.offset;
IF (offset >= buf.size) OR (r.org # buf.org) THEN
IF r.org + offset >= buf.f.len THEN x := 0X; r.eof := TRUE; RETURN
ELSE Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset
END
END ;
x := buf.data[offset]; r.offset := offset + 1
END Read;
but this would also affect Set, Length, and Flush.
Especially Length would become fairly complex.
*)
PROCEDURE Delete* (name: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN
res := SHORT(Unix.Unlink(name));
res := SHORT(Unix.errno())
END Delete;
PROCEDURE Rename* (old, new: ARRAY OF CHAR; VAR res: INTEGER);
VAR fdold, fdnew: INTEGER; n, errno, r: LONGINT;
ostat, nstat: Unix.Status;
buf: ARRAY 4096 OF CHAR;
BEGIN
r := Unix.Stat(old, ostat);
IF r >= 0 THEN
r := Unix.Stat(new, nstat);
IF (r >= 0) & ((ostat.dev # nstat.dev) OR (ostat.ino # nstat.ino)) THEN
Delete(new, res); (* work around stale nfs handles *)
END ;
r := Unix.Rename(old, new);
IF r < 0 THEN res := SHORT(Unix.errno());
IF res = Unix.EXDEV THEN (* cross device link, move the file *)
fdold := Unix.Open(old, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {})));
IF fdold < 0 THEN res := 2; RETURN END ;
fdnew := Unix.Open(new, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {2, 4,5, 7,8})));
IF fdnew < 0 THEN r := Unix.Close(fdold); res := 3; RETURN END ;
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize);
WHILE n > 0 DO
r := Unix.Write(fdnew, SYSTEM.ADR(buf), n);
IF r < 0 THEN errno := Unix.errno(); r := Unix.Close(fdold); r := Unix.Close(fdnew);
Err("cannot move file", NIL, errno)
END ;
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize)
END ;
errno := Unix.errno();
r := Unix.Close(fdold); r := Unix.Close(fdnew);
IF n = 0 THEN r := Unix.Unlink(old); res := 0
ELSE Err("cannot move file", NIL, errno)
END ;
ELSE RETURN (* res is Unix.Rename return code *)
END
END ;
res := 0
ELSE res := 2 (* old file not found *)
END
END Rename;
PROCEDURE Register* (f: File);
VAR idx, errno: INTEGER; f1: File; file: ARRAY 104 OF CHAR;
BEGIN
IF (f.state = create) & (f.registerName # "") THEN f.state := close (* shortcut renaming *) END ;
Close(f);
IF f.registerName # "" THEN
Rename(f.workName, f.registerName, errno);
IF errno # 0 THEN COPY(f.registerName, file); HALT(99) END ;
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END
END Register;
PROCEDURE ChangeDirectory*(path: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN
res := SHORT(Unix.Chdir(path));
getcwd(Kernel.CWD)
END ChangeDirectory;
PROCEDURE FlipBytes(VAR src, dest: ARRAY OF SYSTEM.BYTE);
VAR i, j: LONGINT;
BEGIN
IF ~Kernel.littleEndian THEN i := LEN(src); j := 0;
WHILE i > 0 DO DEC(i); dest[j] := src[i]; INC(j) END
ELSE SYSTEM.MOVE(SYSTEM.ADR(src), SYSTEM.ADR(dest), LEN(src))
END
END FlipBytes;
PROCEDURE ReadBool* (VAR R: Rider; VAR x: BOOLEAN);
BEGIN Read(R, SYSTEM.VAL(CHAR, x))
END ReadBool;
PROCEDURE ReadInt* (VAR R: Rider; VAR x: INTEGER);
VAR b: ARRAY 2 OF CHAR;
BEGIN ReadBytes(R, b, 2);
x := ORD(b[0]) + ORD(b[1])*256
END ReadInt;
PROCEDURE ReadLInt* (VAR R: Rider; VAR x: LONGINT);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4);
x := ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H
END ReadLInt;
PROCEDURE ReadSet* (VAR R: Rider; VAR x: SET);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4);
x := SYSTEM.VAL(SET, ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H)
END ReadSet;
PROCEDURE ReadReal* (VAR R: Rider; VAR x: REAL);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4); FlipBytes(b, x)
END ReadReal;
PROCEDURE ReadLReal* (VAR R: Rider; VAR x: LONGREAL);
VAR b: ARRAY 8 OF CHAR;
BEGIN ReadBytes(R, b, 8); FlipBytes(b, x)
END ReadLReal;
PROCEDURE ReadString* (VAR R: Rider; VAR x: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR;
BEGIN i := 0;
REPEAT Read(R, ch); x[i] := ch; INC(i) UNTIL ch = 0X
END ReadString;
(* need to read line; -- noch *)
PROCEDURE ReadLine* (VAR R: Rider; VAR x: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR; b : BOOLEAN;
BEGIN i := 0;
b := FALSE;
REPEAT
Read(R, ch);
IF ((ch = 0X) OR (ch = 0AX) OR (ch = 0DX)) THEN
b := TRUE
ELSE
x[i] := ch;
INC(i);
END;
UNTIL b
END ReadLine;
PROCEDURE ReadNum* (VAR R: Rider; VAR x: LONGINT);
VAR s: SHORTINT; ch: CHAR; n: LONGINT;
BEGIN s := 0; n := 0; Read(R, ch);
WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); Read(R, ch) END;
INC(n, ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s) );
x := n
END ReadNum;
PROCEDURE WriteBool* (VAR R: Rider; x: BOOLEAN);
BEGIN Write(R, SYSTEM.VAL(CHAR, x))
END WriteBool;
PROCEDURE WriteInt* (VAR R: Rider; x: INTEGER);
VAR b: ARRAY 2 OF CHAR;
BEGIN b[0] := CHR(x); b[1] := CHR(x DIV 256);
WriteBytes(R, b, 2);
END WriteInt;
PROCEDURE WriteLInt* (VAR R: Rider; x: LONGINT);
VAR b: ARRAY 4 OF CHAR;
BEGIN
b[0] := CHR(x); b[1] := CHR(x DIV 100H); b[2] := CHR(x DIV 10000H); b[3] := CHR(x DIV 1000000H);
WriteBytes(R, b, 4);
END WriteLInt;
PROCEDURE WriteSet* (VAR R: Rider; x: SET);
VAR b: ARRAY 4 OF CHAR; i: LONGINT;
BEGIN i := SYSTEM.VAL(LONGINT, x);
b[0] := CHR(i); b[1] := CHR(i DIV 100H); b[2] := CHR(i DIV 10000H); b[3] := CHR(i DIV 1000000H);
WriteBytes(R, b, 4);
END WriteSet;
PROCEDURE WriteReal* (VAR R: Rider; x: REAL);
VAR b: ARRAY 4 OF CHAR;
BEGIN FlipBytes(x, b); WriteBytes(R, b, 4)
END WriteReal;
PROCEDURE WriteLReal* (VAR R: Rider; x: LONGREAL);
VAR b: ARRAY 8 OF CHAR;
BEGIN FlipBytes(x, b); WriteBytes(R, b, 8)
END WriteLReal;
PROCEDURE WriteString* (VAR R: Rider; x: ARRAY [1] OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE x[i] # 0X DO INC(i) END ;
WriteBytes(R, x, i+1)
END WriteString;
PROCEDURE WriteNum* (VAR R: Rider; x: LONGINT);
BEGIN
WHILE (x < - 64) OR (x > 63) DO Write(R, CHR(x MOD 128 + 128)); x := x DIV 128 END;
Write(R, CHR(x MOD 128))
END WriteNum;
PROCEDURE GetName*(f: File; VAR name: ARRAY OF CHAR);
BEGIN
COPY (f.workName, name);
END GetName;
PROCEDURE Finalize(o: SYSTEM.PTR);
VAR f: File; res: LONGINT;
BEGIN
f := SYSTEM.VAL(File, o);
IF f.fd >= 0 THEN
fileTab[f.fd] := 0; res := Unix.Close(f.fd); f.fd := -1; DEC(Kernel.nofiles);
IF f.tempFile THEN res := Unix.Unlink(f.workName) END
END
END Finalize;
PROCEDURE Init;
VAR i: LONGINT;
BEGIN
i := 0; WHILE i < fileTabSize DO fileTab[i] := 0; INC(i) END ;
tempno := -1; Kernel.nofiles := 0
END Init;
BEGIN Init
END Files.

636
src/lib/system/openbsd/gcc/x86_64/Files0.Mod Normal file
View file

@ -0,0 +1,636 @@
MODULE Files0; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files *)
(* this module is not for use by developers and inteded to bootstrap voc *)
(* for general use import Files module *)
IMPORT SYSTEM, Unix, Kernel := Kernel0, Args, Console;
(* standard data type I/O
little endian,
Sint:1, Int:2, Lint:4
ORD({0}) = 1,
false = 0, true =1
IEEE real format,
null terminated strings,
compact numbers according to M.Odersky *)
CONST
nofbufs = 4;
bufsize = 4096;
fileTabSize = 64;
noDesc = -1;
notDone = -1;
(* file states *)
open = 0; create = 1; close = 2;
TYPE
FileName = ARRAY 101 OF CHAR;
File* = POINTER TO Handle;
Buffer = POINTER TO BufDesc;
Handle = RECORD
workName, registerName: FileName;
tempFile: BOOLEAN;
dev, ino, mtime: LONGINT;
fd-: INTEGER;
len, pos: LONGINT;
bufs: ARRAY nofbufs OF Buffer;
swapper, state: INTEGER
END ;
BufDesc = RECORD
f: File;
chg: BOOLEAN;
org, size: LONGINT;
data: ARRAY bufsize OF SYSTEM.BYTE
END ;
Rider* = RECORD
res*: LONGINT;
eof*: BOOLEAN;
buf: Buffer;
org, offset: LONGINT
END ;
Time = POINTER TO TimeDesc;
TimeDesc = RECORD
sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: LONGINT;
(* sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: INTEGER;*)
END ;
VAR
fileTab: ARRAY fileTabSize OF LONGINT (*=File*);
tempno: INTEGER;
(* for localtime *)
PROCEDURE -includetime()
'#include "time.h"';
PROCEDURE -localtime(VAR clock: LONGINT): Time
"(Files0_Time) localtime(clock)";
PROCEDURE -getcwd(VAR cwd: Unix.Name)
"getcwd(cwd, cwd__len)";
PROCEDURE -IdxTrap "__HALT(-1)";
PROCEDURE^ Finalize(o: SYSTEM.PTR);
PROCEDURE Err(s: ARRAY OF CHAR; f: File; errno: LONGINT);
BEGIN
Console.Ln; Console.String("-- "); Console.String(s); Console.String(": ");
IF f # NIL THEN
IF f.registerName # "" THEN Console.String(f.registerName) ELSE Console.String(f.workName) END
END ;
IF errno # 0 THEN Console.String(" errno = "); Console.Int(errno, 1) END ;
Console.Ln;
HALT(99)
END Err;
PROCEDURE MakeFileName(dir, name: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR);
VAR i, j: INTEGER;
BEGIN i := 0; j := 0;
WHILE dir[i] # 0X DO dest[i] := dir[i]; INC(i) END ;
IF dest[i-1] # "/" THEN dest[i] := "/"; INC(i) END ;
WHILE name[j] # 0X DO dest[i] := name[j]; INC(i); INC(j) END ;
dest[i] := 0X
END MakeFileName;
PROCEDURE GetTempName(finalName: ARRAY OF CHAR; VAR name: ARRAY OF CHAR);
VAR n, i, j: LONGINT;
BEGIN
INC(tempno); n := tempno; i := 0;
IF finalName[0] # "/" THEN (* relative pathname *)
WHILE Kernel.CWD[i] # 0X DO name[i] := Kernel.CWD[i]; INC(i) END;
IF Kernel.CWD[i-1] # "/" THEN name[i] := "/"; INC(i) END
END;
j := 0;
WHILE finalName[j] # 0X DO name[i] := finalName[j]; INC(i); INC(j) END;
DEC(i);
WHILE name[i] # "/" DO DEC(i) END;
name[i+1] := "."; name[i+2] := "t"; name[i+3] := "m"; name[i+4] := "p"; name[i+5] := "."; INC(i, 6);
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
name[i] := "."; INC(i); n := SHORT(Unix.Getpid());
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
name[i] := 0X
END GetTempName;
PROCEDURE Create(f: File);
VAR stat: Unix.Status; done: BOOLEAN;
errno: LONGINT; err: ARRAY 32 OF CHAR;
BEGIN
IF f.fd = noDesc THEN
IF f.state = create THEN GetTempName(f.registerName, f.workName); f.tempFile := TRUE
ELSIF f.state = close THEN
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END ;
errno := Unix.Unlink(f.workName); (*unlink first to avoid stale NFS handles and to avoid reuse of inodes*)
f.fd := Unix.Open(f.workName, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat + Unix.trunc))), SHORT(SYSTEM.VAL(LONGINT, ({2, 4,5, 7,8}))));
done := f.fd >= 0; errno := Unix.errno();
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (f.fd >= fileTabSize)) THEN
IF done & (f.fd >= fileTabSize) THEN errno := Unix.Close(f.fd) END ;
Kernel.GC(TRUE);
f.fd := Unix.Open(f.workName, SHORT(SYSTEM.VAL(LONGINT, (Unix.rdwr + Unix.creat + Unix.trunc))), SHORT(SYSTEM.VAL(LONGINT, {2, 4,5, 7,8})));
done := f.fd >= 0
END ;
IF done THEN
IF f.fd >= fileTabSize THEN errno := Unix.Close(f.fd); Err("too many files open", f, 0)
ELSE fileTab[f.fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize);
f.state := open; f.pos := 0; errno := Unix.Fstat(f.fd, stat);
f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime
END
ELSE errno := Unix.errno();
IF errno = Unix.ENOENT THEN err := "no such directory"
ELSIF (errno = Unix.ENFILE) OR (errno = Unix.EMFILE) THEN err := "too many files open"
ELSE err := "file not created"
END ;
Err(err, f, errno)
END
END
END Create;
PROCEDURE Flush(buf: Buffer);
VAR res: LONGINT; f: File; stat: Unix.Status;
BEGIN
IF buf.chg THEN f := buf.f; Create(f);
IF buf.org # f.pos THEN res := Unix.Lseek(f.fd, buf.org, 0) END ;
res := Unix.Write(f.fd, SYSTEM.ADR(buf.data), buf.size);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END ;
f.pos := buf.org + buf.size;
buf.chg := FALSE;
res := Unix.Fstat(f.fd, stat);
f.mtime := stat.mtime
END
END Flush;
PROCEDURE Close* (f: File);
VAR i, res: LONGINT;
BEGIN
IF (f.state # create) OR (f.registerName # "") THEN
Create(f); i := 0;
WHILE (i < nofbufs) & (f.bufs[i] # NIL) DO Flush(f.bufs[i]); INC(i) END ;
res := Unix.Fsync(f.fd);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END
END
END Close;
PROCEDURE Length* (f: File): LONGINT;
BEGIN RETURN f.len
END Length;
PROCEDURE New* (name: ARRAY OF CHAR): File;
VAR f: File;
BEGIN
NEW(f); f.workName := ""; COPY(name, f.registerName);
f.fd := noDesc; f.state := create; f.len := 0; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
RETURN f
END New;
PROCEDURE ScanPath(VAR pos: INTEGER; VAR dir: ARRAY OF CHAR); (* supports ~, ~user and blanks inside path *)
VAR i: INTEGER; ch: CHAR; home: ARRAY 256 OF CHAR;
BEGIN
i := 0; ch := Kernel.OBERON[pos];
WHILE (ch = " ") OR (ch = ":") DO INC(pos); ch := Kernel.OBERON[pos] END ;
IF ch = "~" THEN
INC(pos); ch := Kernel.OBERON[pos];
home := ""; Args.GetEnv("HOME", home);
WHILE home[i] # 0X DO dir[i] := home[i]; INC(i) END ;
IF (ch # "/") & (ch # 0X) & (ch # ":") & (ch # " ") THEN
WHILE (i > 0) & (dir[i-1] # "/") DO DEC(i) END
END
END ;
WHILE (ch # 0X) & (ch # ":") DO dir[i] := ch; INC(i); INC(pos); ch := Kernel.OBERON[pos] END ;
WHILE (i > 0) & (dir[i-1] = " ") DO DEC(i) END ;
dir[i] := 0X
END ScanPath;
PROCEDURE HasDir(VAR name: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; ch: CHAR;
BEGIN i := 0; ch := name[0];
WHILE (ch # 0X) & (ch # "/") DO INC(i); ch := name[i] END ;
RETURN ch = "/"
END HasDir;
PROCEDURE CacheEntry(dev, ino: LONGINT; mtime: LONGINT): File;
VAR f: File; i: INTEGER; stat: Unix.Status; res: LONGINT;
BEGIN i := 0;
WHILE i < fileTabSize DO
f := SYSTEM.VAL(File, fileTab[i]);
IF (f # NIL) & (ino = f.ino) & (dev = f.dev) THEN
IF mtime # f.mtime THEN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END ;
INC(i)
END ;
f.swapper := -1; f.mtime := mtime;
res := Unix.Fstat(f.fd, stat); f.len := stat.size
END ;
RETURN f
END ;
INC(i)
END ;
RETURN NIL
END CacheEntry;
PROCEDURE Old* (name: ARRAY OF CHAR): File;
VAR f: File; fd: INTEGER; res, errno: LONGINT; pos: INTEGER; done: BOOLEAN;
dir, path: ARRAY 256 OF CHAR;
stat: Unix.Status;
BEGIN
IF name # "" THEN
IF HasDir(name) THEN dir := ""; COPY(name, path)
ELSE pos := 0; ScanPath(pos, dir); MakeFileName(dir, name, path); ScanPath(pos, dir)
END ;
LOOP
fd := Unix.Open(path, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {}))); done := fd >= 0; errno := Unix.errno();
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (fd >= fileTabSize)) THEN
IF done & (fd >= fileTabSize) THEN res := Unix.Close(fd) END ;
Kernel.GC(TRUE);
fd := Unix.Open(path, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr)), SHORT(SYSTEM.VAL(LONGINT, {})));
done := fd >= 0; errno := Unix.errno();
IF ~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE)) THEN Err("too many files open", f, errno) END
END ;
IF ~done & ((errno = Unix.EACCES) OR (errno = Unix.EROFS) OR (errno = Unix.EAGAIN)) THEN
(* errno EAGAIN observed on Solaris 2.4 *)
fd := Unix.Open(path, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {}))); done := fd >= 0; errno := Unix.errno()
END ;
IF (~done) & (errno # Unix.ENOENT) THEN
Console.String("warning Files0.Old "); Console.String(name);
Console.String(" errno = "); Console.Int(errno, 0); Console.Ln;
END ;
IF done THEN
res := Unix.Fstat(fd, stat);
f := CacheEntry(stat.dev, stat.ino, stat.mtime);
IF f # NIL THEN res := Unix.Close(fd); RETURN f
ELSIF fd >= fileTabSize THEN res := Unix.Close(fd); Err("too many files open", f, 0)
ELSE NEW(f); fileTab[fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize);
f.fd := fd; f.state := open; f.len := stat.size; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
COPY(name, f.workName); f.registerName := ""; f.tempFile := FALSE;
f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime;
RETURN f
END
ELSIF dir = "" THEN RETURN NIL
ELSE MakeFileName(dir, name, path); ScanPath(pos, dir)
END
END
ELSE RETURN NIL
END
END Old;
PROCEDURE Purge* (f: File);
VAR i: INTEGER; stat: Unix.Status; res: LONGINT;
BEGIN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END ;
INC(i)
END ;
IF f.fd # noDesc THEN res := Unix.Ftruncate(f.fd, 0); res := Unix.Lseek(f.fd, 0, 0) END ;
f.pos := 0; f.len := 0; f.swapper := -1;
res := Unix.Fstat(f.fd, stat); f.mtime := stat.mtime
END Purge;
PROCEDURE GetDate* (f: File; VAR t, d: LONGINT);
VAR stat: Unix.Status; clock, res: LONGINT; time: Time;
BEGIN
Create(f); res := Unix.Fstat(f.fd, stat);
time := localtime(stat.mtime);
t := time.sec + ASH(time.min, 6) + ASH(time.hour, 12);
d := time.mday + ASH(time.mon+1, 5) + ASH(time.year MOD 100, 9)
END GetDate;
PROCEDURE Pos* (VAR r: Rider): LONGINT;
BEGIN RETURN r.org + r.offset
END Pos;
PROCEDURE Set* (VAR r: Rider; f: File; pos: LONGINT);
VAR org, offset, i, n, res: LONGINT; buf: Buffer;
BEGIN
IF f # NIL THEN
IF pos > f.len THEN pos := f.len ELSIF pos < 0 THEN pos := 0 END ;
offset := pos MOD bufsize; org := pos - offset; i := 0;
WHILE (i < nofbufs) & (f.bufs[i] # NIL) & (org # f.bufs[i].org) DO INC(i) END ;
IF i < nofbufs THEN
IF f.bufs[i] = NIL THEN NEW(buf); buf.chg := FALSE; buf.org := -1; buf.f := f; f.bufs[i] := buf
ELSE buf := f.bufs[i]
END
ELSE
f.swapper := (f.swapper + 1) MOD nofbufs;
buf := f.bufs[f.swapper];
Flush(buf)
END ;
IF buf.org # org THEN
IF org = f.len THEN buf.size := 0
ELSE Create(f);
IF f.pos # org THEN res := Unix.Lseek(f.fd, org, 0) END ;
n := Unix.ReadBlk(f.fd, buf.data);
IF n < 0 THEN Err("read from file not done", f, Unix.errno()) END ;
f.pos := org + n;
buf.size := n
END ;
buf.org := org; buf.chg := FALSE
END
ELSE buf := NIL; org := 0; offset := 0
END ;
r.buf := buf; r.org := org; r.offset := offset; r.eof := FALSE; r.res := 0
END Set;
PROCEDURE Read* (VAR r: Rider; VAR x: SYSTEM.BYTE);
VAR offset: LONGINT; buf: Buffer;
BEGIN
buf := r.buf; offset := r.offset;
IF r.org # buf.org THEN Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset END ;
IF (offset < buf.size) THEN
x := buf.data[offset]; r.offset := offset + 1
ELSIF r.org + offset < buf.f.len THEN
Set(r, r.buf.f, r.org + offset);
x := r.buf.data[0]; r.offset := 1
ELSE
x := 0X; r.eof := TRUE
END
END Read;
PROCEDURE ReadBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer;
BEGIN
IF n > LEN(x) THEN IdxTrap END ;
xpos := 0; buf := r.buf; offset := r.offset;
WHILE n > 0 DO
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END ;
restInBuf := buf.size - offset;
IF restInBuf = 0 THEN r.res := n; r.eof := TRUE; RETURN
ELSIF n > restInBuf THEN min := restInBuf ELSE min := n END ;
SYSTEM.MOVE(SYSTEM.ADR(buf.data) + offset, SYSTEM.ADR(x) + xpos, min);
INC(offset, min); r.offset := offset; INC(xpos, min); DEC(n, min)
END ;
r.res := 0; r.eof := FALSE
END ReadBytes;
PROCEDURE ReadByte* (VAR r : Rider; VAR x : ARRAY OF SYSTEM.BYTE);
BEGIN
ReadBytes(r, x, 1);
END ReadByte;
PROCEDURE Base* (VAR r: Rider): File;
BEGIN RETURN r.buf.f
END Base;
PROCEDURE Write* (VAR r: Rider; x: SYSTEM.BYTE);
VAR buf: Buffer; offset: LONGINT;
BEGIN
buf := r.buf; offset := r.offset;
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END ;
buf.data[offset] := x;
buf.chg := TRUE;
IF offset = buf.size THEN
INC(buf.size); INC(buf.f.len)
END ;
r.offset := offset + 1; r.res := 0
END Write;
PROCEDURE WriteBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer;
BEGIN
IF n > LEN(x) THEN IdxTrap END ;
xpos := 0; buf := r.buf; offset := r.offset;
WHILE n > 0 DO
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END ;
restInBuf := bufsize - offset;
IF n > restInBuf THEN min := restInBuf ELSE min := n END ;
SYSTEM.MOVE(SYSTEM.ADR(x) + xpos, SYSTEM.ADR(buf.data) + offset, min);
INC(offset, min); r.offset := offset;
IF offset > buf.size THEN INC(buf.f.len, offset - buf.size); buf.size := offset END ;
INC(xpos, min); DEC(n, min); buf.chg := TRUE
END ;
r.res := 0
END WriteBytes;
(* another solution would be one that is similar to ReadBytes, WriteBytes.
No code duplication, more symmetric, only two ifs for
Read and Write in buffer, buf.size replaced by bufsize in Write ops, buf.size and len
must be made consistent with offset (if offset > buf.size) in a lazy way.
PROCEDURE Write* (VAR r: Rider; x: SYSTEM.BYTE);
VAR buf: Buffer; offset: LONGINT;
BEGIN
buf := r.buf; offset := r.offset;
IF (offset >= bufsize) OR (r.org # buf.org) THEN
Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset;
END ;
buf.data[offset] := x; r.offset := offset + 1; buf.chg := TRUE
END Write;
PROCEDURE WriteBytes ...
PROCEDURE Read* (VAR r: Rider; VAR x: SYSTEM.BYTE);
VAR offset: LONGINT; buf: Buffer;
BEGIN
buf := r.buf; offset := r.offset;
IF (offset >= buf.size) OR (r.org # buf.org) THEN
IF r.org + offset >= buf.f.len THEN x := 0X; r.eof := TRUE; RETURN
ELSE Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset
END
END ;
x := buf.data[offset]; r.offset := offset + 1
END Read;
but this would also affect Set, Length, and Flush.
Especially Length would become fairly complex.
*)
PROCEDURE Delete* (name: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN
res := SHORT(Unix.Unlink(name));
res := SHORT(Unix.errno())
END Delete;
PROCEDURE Rename* (old, new: ARRAY OF CHAR; VAR res: INTEGER);
VAR fdold, fdnew: INTEGER; n, errno, r: LONGINT;
ostat, nstat: Unix.Status;
buf: ARRAY 4096 OF CHAR;
BEGIN
r := Unix.Stat(old, ostat);
IF r >= 0 THEN
r := Unix.Stat(new, nstat);
IF (r >= 0) & ((ostat.dev # nstat.dev) OR (ostat.ino # nstat.ino)) THEN
Delete(new, res); (* work around stale nfs handles *)
END ;
r := Unix.Rename(old, new);
IF r < 0 THEN res := SHORT(Unix.errno());
IF res = Unix.EXDEV THEN (* cross device link, move the file *)
fdold := Unix.Open(old, SHORT(SYSTEM.VAL(LONGINT, Unix.rdonly)), SHORT(SYSTEM.VAL(LONGINT, {})));
IF fdold < 0 THEN res := 2; RETURN END ;
fdnew := Unix.Open(new, SHORT(SYSTEM.VAL(LONGINT, Unix.rdwr + Unix.creat + Unix.trunc)), SHORT(SYSTEM.VAL(LONGINT, {2, 4,5, 7,8})));
IF fdnew < 0 THEN r := Unix.Close(fdold); res := 3; RETURN END ;
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize);
WHILE n > 0 DO
r := Unix.Write(fdnew, SYSTEM.ADR(buf), n);
IF r < 0 THEN errno := Unix.errno(); r := Unix.Close(fdold); r := Unix.Close(fdnew);
Err("cannot move file", NIL, errno)
END ;
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize)
END ;
errno := Unix.errno();
r := Unix.Close(fdold); r := Unix.Close(fdnew);
IF n = 0 THEN r := Unix.Unlink(old); res := 0
ELSE Err("cannot move file", NIL, errno)
END ;
ELSE RETURN (* res is Unix.Rename return code *)
END
END ;
res := 0
ELSE res := 2 (* old file not found *)
END
END Rename;
PROCEDURE Register* (f: File);
VAR idx, errno: INTEGER; f1: File; file: ARRAY 104 OF CHAR;
BEGIN
IF (f.state = create) & (f.registerName # "") THEN f.state := close (* shortcut renaming *) END ;
Close(f);
IF f.registerName # "" THEN
Rename(f.workName, f.registerName, errno);
IF errno # 0 THEN COPY(f.registerName, file); HALT(99) END ;
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END
END Register;
PROCEDURE ChangeDirectory*(path: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN
res := SHORT(Unix.Chdir(path));
getcwd(Kernel.CWD)
END ChangeDirectory;
PROCEDURE FlipBytes(VAR src, dest: ARRAY OF SYSTEM.BYTE);
VAR i, j: LONGINT;
BEGIN
IF ~Kernel.littleEndian THEN i := LEN(src); j := 0;
WHILE i > 0 DO DEC(i); dest[j] := src[i]; INC(j) END
ELSE SYSTEM.MOVE(SYSTEM.ADR(src), SYSTEM.ADR(dest), LEN(src))
END
END FlipBytes;
PROCEDURE ReadBool* (VAR R: Rider; VAR x: BOOLEAN);
BEGIN Read(R, SYSTEM.VAL(CHAR, x))
END ReadBool;
PROCEDURE ReadInt* (VAR R: Rider; VAR x: INTEGER);
VAR b: ARRAY 2 OF CHAR;
BEGIN ReadBytes(R, b, 2);
x := ORD(b[0]) + ORD(b[1])*256
END ReadInt;
PROCEDURE ReadLInt* (VAR R: Rider; VAR x: LONGINT);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4);
x := ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H
END ReadLInt;
PROCEDURE ReadSet* (VAR R: Rider; VAR x: SET);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4);
x := SYSTEM.VAL(SET, ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H)
END ReadSet;
PROCEDURE ReadReal* (VAR R: Rider; VAR x: REAL);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4); FlipBytes(b, x)
END ReadReal;
PROCEDURE ReadLReal* (VAR R: Rider; VAR x: LONGREAL);
VAR b: ARRAY 8 OF CHAR;
BEGIN ReadBytes(R, b, 8); FlipBytes(b, x)
END ReadLReal;
PROCEDURE ReadString* (VAR R: Rider; VAR x: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR;
BEGIN i := 0;
REPEAT Read(R, ch); x[i] := ch; INC(i) UNTIL ch = 0X
END ReadString;
PROCEDURE ReadNum* (VAR R: Rider; VAR x: LONGINT);
VAR s: SHORTINT; ch: CHAR; n: LONGINT;
BEGIN s := 0; n := 0; Read(R, ch);
WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); Read(R, ch) END;
INC(n, ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s) );
x := n
END ReadNum;
PROCEDURE WriteBool* (VAR R: Rider; x: BOOLEAN);
BEGIN Write(R, SYSTEM.VAL(CHAR, x))
END WriteBool;
PROCEDURE WriteInt* (VAR R: Rider; x: INTEGER);
VAR b: ARRAY 2 OF CHAR;
BEGIN b[0] := CHR(x); b[1] := CHR(x DIV 256);
WriteBytes(R, b, 2);
END WriteInt;
PROCEDURE WriteLInt* (VAR R: Rider; x: LONGINT);
VAR b: ARRAY 4 OF CHAR;
BEGIN
b[0] := CHR(x); b[1] := CHR(x DIV 100H); b[2] := CHR(x DIV 10000H); b[3] := CHR(x DIV 1000000H);
WriteBytes(R, b, 4);
END WriteLInt;
PROCEDURE WriteSet* (VAR R: Rider; x: SET);
VAR b: ARRAY 4 OF CHAR; i: LONGINT;
BEGIN i := SYSTEM.VAL(LONGINT, x);
b[0] := CHR(i); b[1] := CHR(i DIV 100H); b[2] := CHR(i DIV 10000H); b[3] := CHR(i DIV 1000000H);
WriteBytes(R, b, 4);
END WriteSet;
PROCEDURE WriteReal* (VAR R: Rider; x: REAL);
VAR b: ARRAY 4 OF CHAR;
BEGIN FlipBytes(x, b); WriteBytes(R, b, 4)
END WriteReal;
PROCEDURE WriteLReal* (VAR R: Rider; x: LONGREAL);
VAR b: ARRAY 8 OF CHAR;
BEGIN FlipBytes(x, b); WriteBytes(R, b, 8)
END WriteLReal;
PROCEDURE WriteString* (VAR R: Rider; x: ARRAY [1] OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE x[i] # 0X DO INC(i) END ;
WriteBytes(R, x, i+1)
END WriteString;
PROCEDURE WriteNum* (VAR R: Rider; x: LONGINT);
BEGIN
WHILE (x < - 64) OR (x > 63) DO Write(R, CHR(x MOD 128 + 128)); x := x DIV 128 END;
Write(R, CHR(x MOD 128))
END WriteNum;
PROCEDURE Finalize(o: SYSTEM.PTR);
VAR f: File; res: LONGINT;
BEGIN
f := SYSTEM.VAL(File, o);
IF f.fd >= 0 THEN
fileTab[f.fd] := 0; res := Unix.Close(f.fd); f.fd := -1; DEC(Kernel.nofiles);
IF f.tempFile THEN res := Unix.Unlink(f.workName) END
END
END Finalize;
PROCEDURE Init;
VAR i: LONGINT;
BEGIN
i := 0; WHILE i < fileTabSize DO fileTab[i] := 0; INC(i) END ;
tempno := -1; Kernel.nofiles := 0
END Init;
BEGIN Init
END Files0.

205
src/lib/system/openbsd/gcc/x86_64/SYSTEM.c0 Normal file
View file

@ -0,0 +1,205 @@
/*
* The body prefix file of the voc(jet backend) 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(unsigned 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 ------------- */

238
src/lib/system/openbsd/gcc/x86_64/SYSTEM.h Normal file
View file

@ -0,0 +1,238 @@
#ifndef SYSTEM__h
#define SYSTEM__h
/*
voc (jet backend) 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>
#include <stdint.h> /* for type sizes -- noch */
extern void *memcpy(void *dest, const void *src, unsigned long n);
extern void *malloc(unsigned 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;
#define BOOLEAN char
//typedef unsigned char CHAR;
#define CHAR unsigned char
//exactly two bytes
#define LONGCHAR unsigned short int
//typedef signed char SHORTINT;
#define SHORTINT signed char
//for x86 GNU/Linux
//typedef short int INTEGER;
//for x86_64 GNU/Linux
//typedef int INTEGER;
#define INTEGER int
//typedef long LONGINT;
#define LONGINT long
//typedef float REAL;
#define REAL float
//typedef double LONGREAL;
#define LONGREAL double
//typedef unsigned long SET;
#define SET unsigned long
typedef void *SYSTEM_PTR;
//#define *SYSTEM_PTR void
//typedef unsigned char SYSTEM_BYTE;
#define SYSTEM_BYTE unsigned char
typedef int8_t SYSTEM_INT8;
typedef int16_t SYSTEM_INT16;
typedef int32_t SYSTEM_INT32;
typedef int64_t SYSTEM_INT64;
/* 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 t)(x)<<(n)))
#define __LSHR(x, n, t) ((t)((unsigned t)(x)>>(n)))
#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t))
#define __ROTL(x, n, t) ((t)((unsigned t)(x)<<(n)|(unsigned t)(x)>>(8*sizeof(t)-(n))))
#define __ROTR(x, n, t) ((t)((unsigned t)(x)>>(n)|(unsigned t)(x)<<(8*sizeof(t)-(n))))
#define __LSHR(x, n, t) ((t)((unsigned t)(x)>>(n)))
#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t))
#define __ROTL(x, n, t) ((t)((unsigned t)(x)<<(n)|(unsigned t)(x)>>(8*sizeof(t)-(n))))
#define __ROTR(x, n, t) ((t)((unsigned t)(x)>>(n)|(unsigned 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 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

519
src/lib/system/openbsd/gcc/x86_64/Unix.Mod Normal file
View file

@ -0,0 +1,519 @@
MODULE Unix; (* Josef Templ, 5.3.90 Linux system calls *)
(* ported to gnu x86_64 and added system(), sleep() functions, 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 *)
CONST sigsetarrlength = 1024 / 8 * SIZE(LONGINT);
TYPE
(* cpp /usr/include/setjmp.h
struct __jmp_buf_tag
{
__jmp_buf __jmpbuf;
int __mask_was_saved;
__sigset_t __saved_mask;
};
typedef struct __jmp_buf_tag jmp_buf[1];
__sigset_t is 128 byte long in glibc on arm, x86, x86_64
__jmp_buf is 24 bytes long in glibc on x86
256 bytes long in glibc on armv6
64 bytes long in glibc on x86_64
*)
JmpBuf* = RECORD
jmpbuf: ARRAY 8 OF LONGINT; (* 8 * 8 = 64 *)
maskWasSaved*: INTEGER;
savedMask*: ARRAY 16 OF LONGINT; (* 16 * 8 = 128 *)
END ;
Status* = RECORD (* struct stat *)
mode* : INTEGER;
dev* : INTEGER; (* dev_t 4 *)
ino* : LONGINT; (* ino 8 *)
nlink* : INTEGER;
uid*, gid*: INTEGER;
rdev* : INTEGER;
atime* : LONGINT;
atimences* : LONGINT;
mtime* : LONGINT;
mtimensec* : LONGINT;
ctime* : LONGINT;
ctimensec* : LONGINT;
size* : LONGINT;
blocks* : LONGINT;
blksize* : INTEGER;
unused0*, unused1*: INTEGER;
unused2*, unused3*: LONGINT;
END ;
(* from /usr/include/bits/time.h
struct timeval
{
__time_t tv_sec; /* Seconds. */ //__time_t 8
__suseconds_t tv_usec; /* Microseconds. */ __suseconds_t 8
};
*)
Timeval* = RECORD
sec*, usec*: LONGINT
END ;
(*
from man gettimeofday
struct timezone {
int tz_minuteswest; /* minutes west of Greenwich */ int 4
int tz_dsttime; /* type of DST correction */ int 4
};
*)
Timezone* = RECORD
(*minuteswest*, dsttime*: LONGINT*)
minuteswest*, dsttime*: INTEGER
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
family0*, family1*: SHORTINT;
pad0, pad1: SHORTINT;
pad2 : INTEGER;
(*port*: INTEGER;
internetAddr*: LONGINT;*)
pad*: ARRAY 14 OF CHAR;
END ;
HostEntry* = POINTER [1] TO Hostent;
Hostent* = RECORD
name*, aliases*: LONGINT;
addrtype*, length*: INTEGER;
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>";
(* for read(), write() and sleep() *)
PROCEDURE -includeUnistd()
"#include <unistd.h>";
(* for system() *)
PROCEDURE -includeStdlib()
"#include <stdlib.h>";
(* for nanosleep() *)
PROCEDURE -includeTime()
"#include <time.h>";
(* for select() *)
PROCEDURE -includeSelect()
"#include <sys/select.h>";
PROCEDURE -err(): INTEGER
"errno";
PROCEDURE errno*(): INTEGER;
BEGIN
RETURN err()
END errno;
PROCEDURE -Exit*(n: INTEGER)
"exit(n)";
PROCEDURE -Fork*(): INTEGER
"fork()";
PROCEDURE -Wait*(VAR status: INTEGER): INTEGER
"wait(status)";
PROCEDURE -Select*(width: INTEGER; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): INTEGER
"select(width, readfds, writefds, exceptfds, timeout)";
PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone) : INTEGER
"gettimeofday(tv, tz)";
PROCEDURE -Read* (fd: INTEGER; buf, nbyte: LONGINT): LONGINT
"read(fd, buf, nbyte)";
PROCEDURE -ReadBlk* (fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT
"read(fd, buf, buf__len)";
PROCEDURE -Write* (fd: INTEGER; buf, nbyte: LONGINT): LONGINT
"write(fd, buf, nbyte)";
PROCEDURE -WriteBlk* (fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT
"write(fd, buf, buf__len)";
PROCEDURE -Dup*(fd: INTEGER): INTEGER
"dup(fd)";
PROCEDURE -Dup2*(fd1, fd2: INTEGER): INTEGER
"dup(fd1, fd2)";
PROCEDURE -Pipe*(fds : LONGINT): INTEGER
"pipe(fds)";
PROCEDURE -Getpid*(): INTEGER
"getpid()";
PROCEDURE -Getuid*(): INTEGER
"getuid()";
PROCEDURE -Geteuid*(): INTEGER
"geteuid()";
PROCEDURE -Getgid*(): INTEGER
"getgid()";
PROCEDURE -Getegid*(): INTEGER
"getegid()";
PROCEDURE -Unlink*(name: Name): INTEGER
"unlink(name)";
PROCEDURE -Open*(name: Name; flag: INTEGER; mode: LONGINT): INTEGER
"open(name, flag, mode)";
PROCEDURE -Close*(fd: INTEGER): INTEGER
"close(fd)";
PROCEDURE -stat(name: Name; VAR statbuf: Status): INTEGER
"stat((const char*)name, (struct stat*)statbuf)";
PROCEDURE Stat*(name: Name; VAR statbuf: Status): INTEGER;
VAR res: INTEGER;
BEGIN
res := stat(name, statbuf);
(* make the first 4 bytes as unique as possible (used in module Files for caching!) *)
(* don't understand this
INC(statbuf.dev, statbuf.devX);
INC(statbuf.rdev, statbuf.rdevX); *)
RETURN res;
END Stat;
PROCEDURE -fstat(fd: INTEGER; VAR statbuf: Status): INTEGER
"fstat(fd, (struct stat*)statbuf)";
PROCEDURE Fstat*(fd: INTEGER; VAR statbuf: Status): INTEGER;
VAR res: INTEGER;
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: INTEGER): INTEGER
"fchmod(fd, mode)";
PROCEDURE -Chmod*(path: Name; mode: INTEGER): INTEGER
"chmod(path, mode)";
PROCEDURE -Lseek*(fd: INTEGER; offset: LONGINT; origin: INTEGER): LONGINT
"lseek(fd, offset, origin)";
PROCEDURE -Fsync*(fd: INTEGER): INTEGER
"fsync(fd)";
PROCEDURE -Fcntl*(fd: INTEGER; cmd: INTEGER; arg: LONGINT ): INTEGER
"fcntl(fd, cmd, arg)";
PROCEDURE -Flock*(fd, operation: INTEGER): INTEGER
"flock(fd, operation)";
PROCEDURE -Ftruncate*(fd: INTEGER; length: LONGINT): INTEGER
"ftruncate(fd, length)";
PROCEDURE -Readblk*(fd: INTEGER; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT
"read(fd, buf, len)";
PROCEDURE -Rename*(old, new: Name): INTEGER
"rename(old, new)";
PROCEDURE -Chdir*(path: Name): INTEGER
"chdir(path)";
PROCEDURE -Ioctl*(fd: INTEGER; request, arg: LONGINT): INTEGER
"ioctl(fd, request, arg)";
PROCEDURE -Kill*(pid, sig: INTEGER): INTEGER
"kill(pid, sig)";
PROCEDURE -Sigsetmask*(mask: INTEGER): INTEGER
"sigsetmask(mask)";
PROCEDURE -Sleep*(ms : INTEGER): INTEGER
"(INTEGER)sleep(ms)";
PROCEDURE -Nanosleep*(VAR req : Timeval; VAR rem : Timeval): INTEGER
"(INTEGER)nanosleep(req, rem)";
(* TCP/IP networking *)
PROCEDURE -Gethostbyname*(name: Name): HostEntry
"(Unix_HostEntry)gethostbyname(name)";
PROCEDURE -Gethostname*(VAR name: Name): INTEGER
"gethostname(name, name__len)";
PROCEDURE -Socket*(af, type, protocol: INTEGER): INTEGER
"socket(af, type, protocol)";
PROCEDURE -Connect*(socket: INTEGER; name: Sockaddr; namelen: INTEGER): INTEGER
"connect(socket, &(name), namelen)";
PROCEDURE -Getsockname*(socket: INTEGER; VAR name: Sockaddr; VAR namelen: INTEGER): INTEGER
"getsockname(socket, name, namelen)";
PROCEDURE -Bind*(socket: INTEGER; name: Sockaddr; namelen: INTEGER): INTEGER
"bind(socket, &(name), namelen)";
PROCEDURE -Listen*(socket, backlog: INTEGER): INTEGER
"listen(socket, backlog)";
PROCEDURE -Accept*(socket: INTEGER; VAR addr: Sockaddr; VAR addrlen: INTEGER): LONGINT
"accept(socket, addr, addrlen)";
PROCEDURE -Recv*(socket: INTEGER; bufadr, buflen: LONGINT; flags: INTEGER): LONGINT
"recv(socket, bufadr, buflen, flags)";
PROCEDURE -Send*(socket: INTEGER; bufadr, buflen: LONGINT; flags: INTEGER): 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;
PROCEDURE -SizeofUnixStat(): INTEGER
"sizeof(Unix_Status)";
PROCEDURE -SizeofStat(): INTEGER
"sizeof(struct stat)";
PROCEDURE -Error(msg: ARRAY OF CHAR; len: INTEGER)
"write(1/*stdout*/, msg, len); char ch = 0xa; write(1, &ch, 1)";
PROCEDURE StatCheck;
VAR x, y: LONGINT;
BEGIN
x := SizeofUnixStat();
y := SizeofStat();
IF x # y THEN
Error("Unix.StatCheck: inconsistent usage of struct stat", 49);
Exit(1);
END
END StatCheck;
BEGIN
StatCheck();
END Unix.