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

re re revised oberon compiler for RISC works -- noch

Browse source
This commit is contained in:
Norayr Chilingarian 2014-09-14 06:09:09 +04:00
parent c8cc104507
commit c900218965
11 changed files with 1771 additions and 572 deletions
Download patch file Download diff file Expand all files Collapse all files

677
src/voc07R/CompatFiles.Mod Normal file
View file

@ -0,0 +1,677 @@
MODULE CompatFiles; (* 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-, 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
"(CompatFiles_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, Unix.rdwr + Unix.creat + Unix.trunc, {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, Unix.rdwr + Unix.creat + Unix.trunc, {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, 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, Unix.rdwr, {}); 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, Unix.rdwr, {});
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, Unix.rdonly, {}); 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, 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, Unix.rdonly, {});
IF fdold < 0 THEN res := 2; RETURN END ;
fdnew := Unix.Open(new, Unix.rdwr + Unix.creat + Unix.trunc, {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 ReadInt* (VAR R: Rider; VAR x: LONGINT); (* to compile OR compiler; -- noch *)
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 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 WriteInt* (VAR R: Rider; x: LONGINT); (* to compile OR compiler; -- noch *)
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 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 CompatFiles.

581
src/voc07R/CompatTexts.Mod Normal file
View file

@ -0,0 +1,581 @@
MODULE CompatTexts; (*JG 21.11.90 / NW 11.7.90 / 24.12.95 / 22.11.10 / 26.3.2014*)
IMPORT Files := CompatFiles, Fonts;
TYPE INTEGER = LONGINT; (* voc adaptation by noch *)
BYTE = CHAR;
CONST (*scanner symbol classes*)
Inval* = 0; (*invalid symbol*)
Name* = 1; (*name s (length len)*)
String* = 2; (*literal string s (length len)*)
Int* = 3; (*integer i (decimal or hexadecimal)*)
Real* = 4; (*real number x*)
Char* = 6; (*special character c*)
(* TextBlock = TextTag "1" offset run {run} "0" len {AsciiCode}.
run = fnt [name] col voff len. *)
TAB = 9X; CR = 0DX; maxD = 9;
TextTag = 0F1X;
replace* = 0; insert* = 1; delete* = 2; unmark* = 3; (*op-codes*)
TYPE Piece = POINTER TO PieceDesc;
PieceDesc = RECORD
f: Files.File;
off, len: LONGINT;
fnt: Fonts.Font;
col, voff: INTEGER;
prev, next: Piece
END;
Text* = POINTER TO TextDesc;
Notifier* = PROCEDURE (T: Text; op: INTEGER; beg, end: LONGINT);
TextDesc* = RECORD
len*: LONGINT;
changed*: BOOLEAN;
notify*: Notifier;
trailer: Piece;
pce: Piece; (*cache*)
org: LONGINT; (*cache*)
END;
Reader* = RECORD
eot*: BOOLEAN;
fnt*: Fonts.Font;
col*, voff*: INTEGER;
ref: Piece;
org: LONGINT;
off: LONGINT;
rider: Files.Rider
END;
Scanner* = RECORD (Reader)
nextCh*: CHAR;
line*, class*: INTEGER;
i*: LONGINT;
x*: REAL;
y*: LONGREAL;
c*: CHAR;
len*: INTEGER;
s*: ARRAY 32 OF CHAR
END;
Buffer* = POINTER TO BufDesc;
BufDesc* = RECORD
len*: LONGINT;
header, last: Piece
END;
Writer* = RECORD
buf*: Buffer;
fnt*: Fonts.Font;
col*, voff*: INTEGER;
rider: Files.Rider
END;
VAR TrailerFile: Files.File;
(* voc adaptation by noch *)
PROCEDURE FLOOR(x : REAL): INTEGER;
BEGIN
RETURN ENTIER(x)
END FLOOR;
PROCEDURE LSL (x, n : INTEGER): INTEGER;
BEGIN
RETURN ASH(x, n);
END LSL;
PROCEDURE ASR (x, n : INTEGER): INTEGER;
BEGIN
RETURN ASH(x, n);
END ASR;
(* -------------------- Filing ------------------------*)
PROCEDURE Trailer(): Piece;
VAR Q: Piece;
BEGIN NEW(Q);
Q.f := TrailerFile; Q.off := -1; Q.len := 1; Q.fnt := NIL; Q.col := 0; Q.voff := 0; RETURN Q
END Trailer;
PROCEDURE Load* (VAR R: Files.Rider; T: Text);
VAR Q, q, p: Piece;
off: LONGINT;
N, fno: INTEGER; bt: BYTE;
f: Files.File;
FName: ARRAY 32 OF CHAR;
Dict: ARRAY 32 OF Fonts.Font;
BEGIN f := Files.Base(R); N := 1; Q := Trailer(); p := Q;
Files.ReadInt(R, off); Files.ReadByte(R, bt);
(*fno := bt;*)
fno := ORD(bt); (* voc adaptation by noch *)
WHILE fno # 0 DO
IF fno = N THEN
Files.ReadString(R, FName);
Dict[N] := Fonts.This(FName); INC(N)
END;
NEW(q); q.fnt := Dict[fno];
Files.ReadByte(R, bt);
(*q.col := bt;*)
q.col := ORD(bt); (* voc adaptation by noch *)
Files.ReadByte(R, bt);
(*q.voff := ASR(LSL(bt, -24), 24);*)
q.voff := ASR(LSL(ORD(bt), -24), 24); (* voc adaptation by noch *)
Files.ReadInt(R, q.len);
Files.ReadByte(R, bt);
(*fno := bt;*)
fno := ORD(bt); (* voc adaptation by noch *)
q.f := f; q.off := off; off := off + q.len;
p.next := q; q.prev := p; p := q
END;
p.next := Q; Q.prev := p;
T.trailer := Q; Files.ReadInt(R, T.len); (*Files.Set(R, f, Files.Pos(R) + T.len)*)
END Load;
PROCEDURE Open* (T: Text; name: ARRAY OF CHAR);
VAR f: Files.File; R: Files.Rider; Q, q: Piece;
tag: CHAR; len: LONGINT;
BEGIN f := Files.Old(name);
IF f # NIL THEN
Files.Set(R, f, 0); Files.Read(R, tag);
IF tag = TextTag THEN Load(R, T)
ELSE (*Ascii file*)
len := Files.Length(f); Q := Trailer();
NEW(q); q.fnt := Fonts.Default; q.col := 1; q.voff := 0; q.f := f; q.off := 0; q.len := len;
Q.next := q; q.prev := Q; q.next := Q; Q.prev := q; T.trailer := Q; T.len := len
END
ELSE (*create new text*)
Q := Trailer(); Q.next := Q; Q.prev := Q; T.trailer := Q; T.len := 0
END ;
T.changed := FALSE; T.org := -1; T.pce := T.trailer (*init cache*)
END Open;
PROCEDURE Store* (VAR W: Files.Rider; T: Text);
VAR p, q: Piece;
R: Files.Rider;
off, rlen, pos: LONGINT;
N, n: INTEGER;
ch: CHAR;
Dict: ARRAY 32, 32 OF CHAR;
BEGIN pos := Files.Pos(W); Files.WriteInt(W, 0); (*place holder*)
N := 1; p := T.trailer.next;
WHILE p # T.trailer DO
rlen := p.len; q := p.next;
WHILE (q # T.trailer) & (q.fnt = p.fnt) & (q.col = p.col) & (q.voff = p.voff) DO
rlen := rlen + q.len; q := q.next
END;
(*Dict[N] := p.fnt.name;*)
COPY(p.fnt.name, Dict[N]); (* voc adaptation by noch *)
n := 1;
WHILE Dict[n] # p.fnt.name DO INC(n) END;
(*Files.WriteByte(W, n);*)
Files.WriteByte(W, SHORT(SHORT(n))); (* voc adaptation by noch *)
IF n = N THEN Files.WriteString(W, p.fnt.name); INC(N) END;
(*Files.WriteByte(W, p.col);*)
Files.WriteByte(W, SHORT(SHORT(p.col))); (* voc adaptation by noch *)
(*Files.WriteByte(W, p.voff);*)
Files.WriteByte(W, SHORT(SHORT(p.voff))); (* voc adaptation by noch *)
Files.WriteInt(W, rlen);
p := q
END;
Files.WriteByte(W, 0); Files.WriteInt(W, T.len);
off := Files.Pos(W); p := T.trailer.next;
WHILE p # T.trailer DO
rlen := p.len; Files.Set(R, p.f, p.off);
WHILE rlen > 0 DO Files.Read(R, ch); Files.Write(W, ch); DEC(rlen) END ;
p := p.next
END ;
Files.Set(W, Files.Base(W), pos); Files.WriteInt(W, off); (*fixup*)
T.changed := FALSE;
IF T.notify # NIL THEN T.notify(T, unmark, 0, 0) END
END Store;
PROCEDURE Close*(T: Text; name: ARRAY OF CHAR);
VAR f: Files.File; w: Files.Rider;
BEGIN f := Files.New(name); Files.Set(w, f, 0);
Files.Write(w, TextTag); Store(w, T); Files.Register(f)
END Close;
(* -------------------- Editing ----------------------- *)
PROCEDURE OpenBuf* (B: Buffer);
BEGIN NEW(B.header); (*null piece*)
B.last := B.header; B.len := 0
END OpenBuf;
PROCEDURE FindPiece (T: Text; pos: LONGINT; VAR org: LONGINT; VAR pce: Piece);
VAR p: Piece; porg: LONGINT;
BEGIN p := T.pce; porg := T.org;
IF pos >= porg THEN
WHILE pos >= porg + p.len DO INC(porg, p.len); p := p.next END
ELSE p := p.prev; DEC(porg, p.len);
WHILE pos < porg DO p := p.prev; DEC(porg, p.len) END
END ;
T.pce := p; T.org := porg; (*update cache*)
pce := p; org := porg
END FindPiece;
PROCEDURE SplitPiece (p: Piece; off: LONGINT; VAR pr: Piece);
VAR q: Piece;
BEGIN
IF off > 0 THEN NEW(q);
q.fnt := p.fnt; q.col := p.col; q.voff := p.voff;
q.len := p.len - off;
q.f := p.f; q.off := p.off + off;
p.len := off;
q.next := p.next; p.next := q;
q.prev := p; q.next.prev := q;
pr := q
ELSE pr := p
END
END SplitPiece;
PROCEDURE Save* (T: Text; beg, end: LONGINT; B: Buffer);
VAR p, q, qb, qe: Piece; org: LONGINT;
BEGIN
IF end > T.len THEN end := T.len END;
FindPiece(T, beg, org, p);
NEW(qb); qb^ := p^;
qb.len := qb.len - (beg - org);
qb.off := qb.off + (beg - org);
qe := qb;
WHILE end > org + p.len DO
org := org + p.len; p := p.next;
NEW(q); q^ := p^; qe.next := q; q.prev := qe; qe := q
END;
qe.next := NIL; qe.len := qe.len - (org + p.len - end);
B.last.next := qb; qb.prev := B.last; B.last := qe;
B.len := B.len + (end - beg)
END Save;
PROCEDURE Copy* (SB, DB: Buffer);
VAR Q, q, p: Piece;
BEGIN p := SB.header; Q := DB.last;
WHILE p # SB.last DO p := p.next;
NEW(q); q^ := p^; Q.next := q; q.prev := Q; Q := q
END;
DB.last := Q; DB.len := DB.len + SB.len
END Copy;
PROCEDURE Insert* (T: Text; pos: LONGINT; B: Buffer);
VAR pl, pr, p, qb, qe: Piece; org, end: LONGINT;
BEGIN
FindPiece(T, pos, org, p); SplitPiece(p, pos - org, pr);
IF T.org >= org THEN T.org := org - p.prev.len; T.pce := p.prev END ;
pl := pr.prev; qb := B.header.next;
IF (qb # NIL) & (qb.f = pl.f) & (qb.off = pl.off + pl.len)
& (qb.fnt = pl.fnt) & (qb.col = pl.col) & (qb.voff = pl.voff) THEN
pl.len := pl.len + qb.len; qb := qb.next
END;
IF qb # NIL THEN qe := B.last;
qb.prev := pl; pl.next := qb; qe.next := pr; pr.prev := qe
END;
T.len := T.len + B.len; end := pos + B.len;
B.last := B.header; B.last.next := NIL; B.len := 0;
T.changed := TRUE;
(*T.notify(T, insert, pos, end)*)
IF T.notify # NIL THEN
T.notify(T, insert, pos, end)
END(* voc adaptation by noch *)
END Insert;
PROCEDURE Append* (T: Text; B: Buffer);
BEGIN Insert(T, T.len, B)
END Append;
PROCEDURE Delete* (T: Text; beg, end: LONGINT; B: Buffer);
VAR pb, pe, pbr, per: Piece; orgb, orge: LONGINT;
BEGIN
IF end > T.len THEN end := T.len END;
FindPiece(T, beg, orgb, pb); SplitPiece(pb, beg - orgb, pbr);
FindPiece(T, end, orge, pe);
SplitPiece(pe, end - orge, per);
IF T.org >= orgb THEN (*adjust cache*)
T.org := orgb - pb.prev.len; T.pce := pb.prev
END;
B.header.next := pbr; B.last := per.prev;
B.last.next := NIL; B.len := end - beg;
per.prev := pbr.prev; pbr.prev.next := per;
T.len := T.len - B.len;
T.changed := TRUE;
IF T.notify # NIL THEN (* noch *)
T.notify(T, delete, beg, end)
END
END Delete;
PROCEDURE ChangeLooks* (T: Text; beg, end: LONGINT; sel: SET; fnt: Fonts.Font; col, voff: INTEGER);
VAR pb, pe, p: Piece; org: LONGINT;
BEGIN
IF end > T.len THEN end := T.len END;
FindPiece(T, beg, org, p); SplitPiece(p, beg - org, pb);
FindPiece(T, end, org, p); SplitPiece(p, end - org, pe);
p := pb;
REPEAT
IF 0 IN sel THEN p.fnt := fnt END;
IF 1 IN sel THEN p.col := col END;
IF 2 IN sel THEN p.voff := voff END;
p := p.next
UNTIL p = pe;
T.changed := TRUE;
IF T.notify # NIL THEN (* noch *)
T.notify(T, replace, beg, end)
END
END ChangeLooks;
PROCEDURE Attributes*(T: Text; pos: LONGINT; VAR fnt: Fonts.Font; VAR col, voff: INTEGER);
VAR p: Piece; org: LONGINT;
BEGIN FindPiece(T, pos, org, p); fnt := p.fnt; col := p.col; voff := p.voff
END Attributes;
(* ------------------ Access: Readers ------------------------- *)
PROCEDURE OpenReader* (VAR R: Reader; T: Text; pos: LONGINT);
VAR p: Piece; org: LONGINT;
BEGIN FindPiece(T, pos, org, p);
R.ref := p; R.org := org; R.off := pos - org;
Files.Set(R.rider, p.f, p.off + R.off); R.eot := FALSE
END OpenReader;
PROCEDURE Read* (VAR R: Reader; VAR ch: CHAR);
BEGIN Files.Read(R.rider, ch);
R.fnt := R.ref.fnt; R.col := R.ref.col; R.voff := R.ref.voff;
INC(R.off);
IF R.off = R.ref.len THEN
IF R.ref.f = TrailerFile THEN R.eot := TRUE END;
R.org := R.org + R.off; R.off := 0;
R.ref := R.ref.next; R.org := R.org + R.off; R.off := 0;
Files.Set(R.rider, R.ref.f, R.ref.off)
END
END Read;
PROCEDURE Pos* (VAR R: Reader): LONGINT;
BEGIN RETURN R.org + R.off
END Pos;
(* ------------------ Access: Scanners (NW) ------------------------- *)
PROCEDURE OpenScanner* (VAR S: Scanner; T: Text; pos: LONGINT);
BEGIN OpenReader(S, T, pos); S.line := 0; S.nextCh := " "
END OpenScanner;
(*floating point formats:
x = 1.m * 2^(e-127) bit 0: sign, bits 1- 8: e, bits 9-31: m
x = 1.m * 2^(e-1023) bit 0: sign, bits 1-11: e, bits 12-63: m *)
PROCEDURE Ten(n: INTEGER): REAL;
VAR t, p: REAL;
BEGIN t := 1.0; p := 10.0; (*compute 10^n *)
WHILE n > 0 DO
IF ODD(n) THEN t := p * t END ;
p := p*p; n := n DIV 2
END ;
RETURN t
END Ten;
PROCEDURE Scan* (VAR S: Scanner);
CONST maxExp = 38; maxM = 16777216; (*2^24*)
VAR ch, term: CHAR;
neg, negE, hex: BOOLEAN;
i, j, h, d, e, n, s: INTEGER;
k: LONGINT;
x: REAL;
BEGIN ch := S.nextCh; i := 0;
WHILE (ch = " ") OR (ch = TAB) OR (ch = CR) DO
IF ch = CR THEN INC(S.line) END ;
Read(S, ch)
END ;
IF ("A" <= ch) & (ch <= "Z") OR ("a" <= ch) & (ch <= "z") THEN (*name*)
REPEAT S.s[i] := ch; INC(i); Read(S, ch)
UNTIL ((ch < "0") & (ch # ".") OR ("9" < ch) & (ch < "A") OR ("Z" < ch) & (ch < "a") OR ("z" < ch)) OR (i = 31);
S.s[i] := 0X; S.len := i; S.class := Name
ELSIF ch = 22X THEN (*string*)
Read(S, ch);
WHILE (ch # 22X) & (ch >= " ") & (i # 31) DO S.s[i] := ch; INC(i); Read(S, ch) END;
S.s[i] := 0X; S.len := i+1; Read(S, ch); S.class := String
ELSE hex := FALSE;
IF ch = "-" THEN neg := TRUE; Read(S, ch) ELSE neg := FALSE END ;
IF ("0" <= ch) & (ch <= "9") THEN (*number*)
n := ORD(ch) - 30H; h := n; Read(S, ch);
WHILE ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") DO
IF ch <= "9" THEN d := ORD(ch) - 30H ELSE d := ORD(ch) - 37H; hex := TRUE END ;
n := 10*n + d; h := 10H*h + d; Read(S, ch)
END ;
IF ch = "H" THEN (*hex integer*) Read(S, ch); S.i := h; S.class := Int (*neg?*)
ELSIF ch = "." THEN (*real number*)
Read(S, ch); x := 0.0; e := 0; j := 0;
WHILE ("0" <= ch) & (ch <= "9") DO (*fraction*)
h := 10*n + (ORD(ch) - 30H);
IF h < maxM THEN n := h; INC(j) END ;
Read(S, ch)
END ;
IF ch = "E" THEN (*scale factor*)
s := 0; Read(S, ch);
IF ch = "-" THEN negE := TRUE; Read(S, ch)
ELSE negE := FALSE;
IF ch = "+" THEN Read(S, ch) END
END ;
WHILE ("0" <= ch) & (ch <= "9") DO
s := s*10 + ORD(ch) - 30H; Read(S, ch)
END ;
IF negE THEN DEC(e, s) ELSE INC(e, s) END ;
END ;
(*x := FLT(n);*)
x := n; (* voc adaptation by noch *)
DEC(e, j);
IF e < 0 THEN
IF e >= -maxExp THEN x := x / Ten(-e) ELSE x := 0.0 END
ELSIF e > 0 THEN
IF e <= maxExp THEN x := Ten(e) * x ELSE x := 0.0 END
END ;
IF neg THEN S.x := -x ELSE S.x := x END ;
IF hex THEN S.class := 0 ELSE S.class := Real END
ELSE (*decimal integer*)
IF neg THEN S.i := -n ELSE S.i := n END;
IF hex THEN S.class := Inval ELSE S.class := Int END
END
ELSE (*spectal character*) S.class := Char;
IF neg THEN S.c := "-" ELSE S.c := ch; Read(S, ch) END
END
END ;
S.nextCh := ch
END Scan;
(* --------------- Access: Writers (NW) ------------------ *)
PROCEDURE OpenWriter* (VAR W: Writer);
BEGIN NEW(W.buf);
OpenBuf(W.buf); W.fnt := Fonts.Default; W.col := 15; W.voff := 0;
Files.Set(W.rider, Files.New(""), 0)
END OpenWriter;
PROCEDURE SetFont* (VAR W: Writer; fnt: Fonts.Font);
BEGIN W.fnt := fnt
END SetFont;
PROCEDURE SetColor* (VAR W: Writer; col: INTEGER);
BEGIN W.col := col
END SetColor;
PROCEDURE SetOffset* (VAR W: Writer; voff: INTEGER);
BEGIN W.voff := voff
END SetOffset;
PROCEDURE Write* (VAR W: Writer; ch: CHAR);
VAR p: Piece;
BEGIN
IF (W.buf.last.fnt # W.fnt) OR (W.buf.last.col # W.col) OR (W.buf.last.voff # W.voff) THEN
NEW(p); p.f := Files.Base(W.rider); p.off := Files.Pos(W.rider); p.len := 0;
p.fnt := W.fnt; p.col := W.col; p.voff:= W.voff;
p.next := NIL; W.buf.last.next := p;
p.prev := W.buf.last; W.buf.last := p
END;
Files.Write(W.rider, ch);
INC(W.buf.last.len); INC(W.buf.len)
END Write;
PROCEDURE WriteLn* (VAR W: Writer);
BEGIN Write(W, CR)
END WriteLn;
PROCEDURE WriteString* (VAR W: Writer; s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE s[i] >= " " DO Write(W, s[i]); INC(i) END
END WriteString;
PROCEDURE WriteInt* (VAR W: Writer; x, n: LONGINT);
VAR i: INTEGER; x0: LONGINT;
a: ARRAY 10 OF CHAR;
BEGIN
(*IF ROR(x, 31) = 1 THEN WriteString(W, " -2147483648")
ELSE*) i := 0; (* voc adaptation by noch *)
IF x < 0 THEN DEC(n); x0 := -x ELSE x0 := x END;
REPEAT
a[i] := CHR(x0 MOD 10 + 30H); x0 := x0 DIV 10; INC(i)
UNTIL x0 = 0;
WHILE n > i DO Write(W, " "); DEC(n) END;
IF x < 0 THEN Write(W, "-") END;
REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
(*END*)
END WriteInt;
PROCEDURE WriteHex* (VAR W: Writer; x: LONGINT);
VAR i: INTEGER; y: LONGINT;
a: ARRAY 10 OF CHAR;
BEGIN i := 0; Write(W, " ");
REPEAT y := x MOD 10H;
IF y < 10 THEN a[i] := CHR(y + 30H) ELSE a[i] := CHR(y + 37H) END;
x := x DIV 10H; INC(i)
UNTIL i = 8;
REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
END WriteHex;
(* commented out because it's not necessary to compile OR compiler; -- noch
PROCEDURE WriteReal* (VAR W: Writer; x: REAL; n: INTEGER);
VAR e, i, m: INTEGER; x0: REAL; neg: BOOLEAN;
d: ARRAY 16 OF CHAR;
BEGIN
IF x = 0.0 THEN
WriteString(W, " 0.0"); i := 5;
WHILE i < n DO Write(W, " "); INC(i) END
ELSE
IF x < 0.0 THEN x := -x; neg := TRUE ELSE neg := FALSE END ;
x0 := x; UNPK(x0, e);
IF e = 255 THEN WriteString(W, " NaN")
ELSE
REPEAT Write(W, " "); DEC(n) UNTIL n <= 14;
IF neg THEN Write(W, "-") ELSE Write(W, " ") END ;
e := e * 77 DIV 256 - 6;
IF e >= 0 THEN x := x / Ten(e) ELSE x := x * Ten(-e) END ;
IF x >= 10.0E6 THEN x := 0.1*x; INC(e) END ;
m := FLOOR(x + 0.5); i := 0;
IF x >= 10.0E6 THEN x := 0.1*x; INC(e) END ;
REPEAT d[i] := CHR(m MOD 10 + 30H); m := m DIV 10; INC(i) UNTIL m = 0;
DEC(i); Write(W, d[i]); Write(W, ".");
IF i < n-6 THEN n := 0 ELSE n := 13-n END ;
WHILE i > n DO DEC(i); Write(W, d[i]) END ;
Write(W, "E"); INC(e, 6);
IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END ;
Write(W, CHR(e DIV 10 + 30H)); Write(W, CHR(e MOD 10 + 30H))
END
END
END WriteReal;
*)
PROCEDURE WriteRealFix* (VAR W: Writer; x: REAL; n, k: INTEGER);
VAR i, m: INTEGER; neg: BOOLEAN;
d: ARRAY 12 OF CHAR;
BEGIN
IF x = 0.0 THEN WriteString(W, " 0")
ELSE
IF x < 0.0 THEN x := -x; neg := TRUE ELSE neg := FALSE END ;
IF k > 7 THEN k := 7 END ;
x := Ten(k) * x; m := FLOOR(x + 0.5);
i := 0;
REPEAT d[i] := CHR(m MOD 10 + 30H); m := m DIV 10; INC(i) UNTIL m = 0;
REPEAT Write(W, " "); DEC(n) UNTIL n <= i+3;
IF neg THEN Write(W, "-"); DEC(n) ELSE Write(W, " ") END ;
WHILE i > k DO DEC(i); Write(W, d[i]) END ;
Write(W, ".");
WHILE k > i DO DEC(k); Write(W, "0") END ;
WHILE i > 0 DO DEC(i); Write(W, d[i]) END
END
END WriteRealFix;
PROCEDURE WritePair(VAR W: Writer; ch: CHAR; x: LONGINT);
BEGIN Write(W, ch);
Write(W, CHR(x DIV 10 + 30H)); Write(W, CHR(x MOD 10 + 30H))
END WritePair;
PROCEDURE WriteClock* (VAR W: Writer; d: LONGINT);
BEGIN
WritePair(W, " ", d DIV 20000H MOD 20H); (*day*)
WritePair(W, ".", d DIV 400000H MOD 10H); (*month*)
WritePair(W, ".", d DIV 4000000H MOD 40H); (*year*)
WritePair(W, " ", d DIV 1000H MOD 20H); (*hour*)
WritePair(W, ":", d DIV 40H MOD 40H); (*min*)
WritePair(W, ":", d MOD 40H) (*sec*)
END WriteClock;
BEGIN TrailerFile := Files.New("")
END CompatTexts.

146
src/voc07R/Fonts.Mod Normal file
View file

@ -0,0 +1,146 @@
MODULE Fonts; (*JG 18.11.90; PDR 8.6.12; NW 25.3.2013*)
IMPORT SYSTEM, Files := CompatFiles;
TYPE INTEGER = LONGINT; (* voc adaptation by noch *)
BYTE = CHAR;
CONST FontFileId = 0DBH;
TYPE Font* = POINTER TO FontDesc;
FontDesc* = RECORD
name*: ARRAY 32 OF CHAR;
height*, minX*, maxX*, minY*, maxY*: INTEGER;
next*: Font;
T: ARRAY 128 OF INTEGER;
raster: ARRAY 2360 OF BYTE
END ;
LargeFontDesc = RECORD (FontDesc) ext: ARRAY 2560 OF BYTE END ;
LargeFont = POINTER TO LargeFontDesc;
(* raster sizes: Syntax8 1367, Syntax10 1628, Syntax12 1688, Syntax14 1843, Syntax14b 1983,
Syntax16 2271, Syntax20 3034, Syntac24 4274, Syntax24b 4302 *)
VAR Default*, root*: Font;
PROCEDURE GetPat*(fnt: Font; ch: CHAR; VAR dx, x, y, w, h, patadr: INTEGER);
VAR pa: INTEGER; dxb, xb, yb, wb, hb: BYTE;
BEGIN pa := fnt.T[ORD(ch) MOD 80H]; patadr := pa;
SYSTEM.GET(pa-3, dxb); SYSTEM.GET(pa-2, xb); SYSTEM.GET(pa-1, yb); SYSTEM.GET(pa, wb); SYSTEM.GET(pa+1, hb);
(*dx := dxb;*)
dx := ORD(dxb); (* voc adaptation by noch *)
(*x := xb;*)
x := ORD(xb); (* voc adaptation by noch *)
(*y := yb;*)
y := ORD(yb); (* voc adaptation by noch *)
(*w := wb;*)
w := ORD(wb); (* voc adaptation by noch *)
(*h := hb;*)
h := ORD(hb); (* voc adaptation by noch *)
(*IF yb < 128 THEN y := yb ELSE y := yb - 256 END*)
IF ORD(yb) < 128 THEN y := ORD(yb) ELSE y := ORD(yb) - 256 END (* voc adaptation by noch *)
END GetPat;
PROCEDURE This*(name: ARRAY OF CHAR): Font;
TYPE RunRec = RECORD beg, end: BYTE END ;
BoxRec = RECORD dx, x, y, w, h: BYTE END ;
VAR F: Font; LF: LargeFont;
f: Files.File; R: Files.Rider;
NofRuns, NofBoxes: BYTE;
NofBytes: INTEGER;
height, minX, maxX, minY, maxY: BYTE;
i, j, k, m, n: INTEGER;
a, a0: INTEGER;
b, beg, end: BYTE;
run: ARRAY 16 OF RunRec;
box: ARRAY 512 OF BoxRec;
PROCEDURE RdInt16(VAR R: Files.Rider; VAR b0: BYTE);
VAR b1: BYTE;
BEGIN Files.ReadByte(R, b0); Files.ReadByte(R, b1)
END RdInt16;
BEGIN F := root;
WHILE (F # NIL) & (name # F.name) DO F := F.next END;
IF F = NIL THEN
f := Files.Old(name);
IF f # NIL THEN
Files.Set(R, f, 0); Files.ReadByte(R, b);
(*IF b = FontFileId THEN*)
IF ORD(b) = FontFileId THEN (* voc adaptation by noch *)
Files.ReadByte(R, b); (*abstraction*)
Files.ReadByte(R, b); (*family*)
Files.ReadByte(R, b); (*variant*)
NEW(F);
(*F.name := name;*)
COPY(name, F.name); (* voc adaptation by noch *)
RdInt16(R, height); RdInt16(R, minX); RdInt16(R, maxX); RdInt16(R, minY); RdInt16(R, maxY); RdInt16(R, NofRuns);
(*NofBoxes := 0;*) (* voc adaptation by noch *)
NofBoxes := 0X;
k := 0;
(*WHILE k # NofRuns DO*)
WHILE k # ORD(NofRuns) DO (* voc adaptation by noch *)
RdInt16(R, beg);
run[k].beg := beg; RdInt16(R, end);
run[k].end := end;
(*NofBoxes := NofBoxes + end - beg;*)
NofBoxes := CHR(ORD(NofBoxes) + ORD(end) - ORD(beg)); (* voc adaptation by noch *)
INC(k)
END;
NofBytes := 5; j := 0;
(*WHILE j # NofBoxes DO*)
WHILE j # ORD(NofBoxes) DO (* voc adaptation by noch *)
RdInt16(R, box[j].dx); RdInt16(R, box[j].x); RdInt16(R, box[j].y);
RdInt16(R, box[j].w); RdInt16(R, box[j].h);
(*NofBytes := NofBytes + 5 + (box[j].w + 7) DIV 8 * box[j].h;*)
NofBytes := (NofBytes + 5 + (ORD(box[j].w) + 7) DIV 8 * ORD(box[j].h)); (* voc adaptation by noch *)
INC(j)
END;
IF NofBytes < 2300 THEN NEW(F) ELSE NEW(LF); F := LF END ;
(*F.name := name;*)
COPY(name, F.name); (* voc adaptation by noch *)
(*F.height := height; F.minX := minX; F.maxX := maxX; F.maxY := maxY;*)
F.height := ORD(height); F.minX := ORD(minX); F.maxX := ORD(maxX); F.maxY := ORD(maxY); (* voc adaptation by noch *)
(*IF minY >= 80H THEN F.minY := minY - 100H ELSE F.minY := minY END ;*)
IF ORD(minY) >= 80H THEN F.minY := ORD(minY) - 100H ELSE F.minY := ORD(minY) END ; (* voc adaptation by noch *)
a0 := SYSTEM.ADR(F.raster);
SYSTEM.PUT(a0, 0X); SYSTEM.PUT(a0+1, 0X); SYSTEM.PUT(a0+2, 0X); SYSTEM.PUT(a0+3, 0X); SYSTEM.PUT(a0+4, 0X);
(*null pattern for characters not in a run*)
INC(a0, 2); a := a0+3; j := 0; k := 0; m := 0;
(*WHILE k < NofRuns DO*)
WHILE k < ORD(NofRuns) DO
(*WHILE (m < run[k].beg) & (m < 128) DO F.T[m] := a0; INC(m) END;*)
WHILE (m < ORD(run[k].beg)) & (m < 128) DO F.T[m] := a0; INC(m) END; (* voc adaptation by noch *)
(*WHILE (m < run[k].end) & (m < 128) DO*) (* voc adaptation by noch *)
WHILE (m < ORD(run[k].end)) & (m < 128) DO
F.T[m] := a+3;
SYSTEM.PUT(a, box[j].dx); SYSTEM.PUT(a+1, box[j].x); SYSTEM.PUT(a+2, box[j].y);
SYSTEM.PUT(a+3, box[j].w); SYSTEM.PUT(a+4, box[j].h); INC(a, 5);
(*n := (box[j].w + 7) DIV 8 * box[j].h;*)
n := (ORD(box[j].w) + 7) DIV 8 * ORD(box[j].h); (* voc adaptation by noch *)
WHILE n # 0 DO DEC(n); Files.ReadByte(R, b); SYSTEM.PUT(a, b); INC(a) END ;
INC(j); INC(m)
END;
INC(k)
END;
WHILE m < 128 DO F.T[m] := a0; INC(m) END ;
F.next := root; root := F
ELSE (*bad file id*) F := Default
END
ELSE (*font file not available*) F := Default
END
END;
RETURN F
END This;
PROCEDURE Free*; (*remove all but first two from font list*)
VAR f: Font;
BEGIN f := root.next;
IF f # NIL THEN f := f.next END ;
f.next := NIL
END Free;
BEGIN root := NIL; Default := This("Oberon10.Scn.Fnt")
END Fonts.

90
src/voc07R/ORB.Mod
View file

@ -1,6 +1,6 @@
MODULE ORB; (*NW 7.10.2013 in Oberon-07*)
IMPORT Files, ORS, S := SYSTEM;
TYPE BYTE = S.BYTE;
MODULE ORB; (*NW 25.6.2014 in Oberon-07*)
IMPORT Files := CompatFiles (* voc adaptation by noch *)
, ORS;
(*Definition of data types Object and Type, which together form the data structure
called "symbol table". Contains procedures for creation of Objects, and for search:
NewObj, this, thisimport, thisfield (and OpenScope, CloseScope).
@ -8,6 +8,9 @@ MODULE ORB; (*NW 7.10.2013 in Oberon-07*)
Import and Export. This module contains the list of standard identifiers, with which
the symbol table (universe), and that of the pseudo-module SYSTEM are initialized. *)
TYPE INTEGER = LONGINT; (* voc adaptation by noch *)
BYTE = CHAR;
CONST versionkey* = 1; maxTypTab = 64;
(* class values*) Head* = 0;
Const* = 1; Var* = 2; Par* = 3; Fld* = 4; Typ* = 5;
@ -146,11 +149,9 @@ MODULE ORB; (*NW 7.10.2013 in Oberon-07*)
PROCEDURE Read(VAR R: Files.Rider; VAR x: INTEGER);
VAR b: BYTE;
BEGIN
(*Files.ReadByte(R, b);*)
Files.ReadBytes(R, b, 1);
BEGIN Files.ReadByte(R, b);
(*IF b < 80H THEN x := b ELSE x := b - 100H END*)
IF S.VAL(SHORTINT, b) < 128 THEN x := S.VAL(SHORTINT, b) ELSE x := S.VAL(SHORTINT, b) - 100H END
IF b < 80X THEN x := ORD(b) ELSE x := ORD(b) - 100H END (* voc adaptation by noch *)
END Read;
PROCEDURE InType(VAR R: Files.Rider; thismod: Object; VAR T: Type);
@ -170,8 +171,7 @@ MODULE ORB; (*NW 7.10.2013 in Oberon-07*)
InType(R, thismod, t.base);
IF t.base.form = NoTyp THEN t.base := NIL; obj := NIL ELSE obj := t.base.dsc END ;
Files.ReadNum(R, t.len); (*TD adr/exno*)
(*Files.ReadNum(R, t.nofpar);*) (*ext level*)
Files.ReadInt(R, t.nofpar); (*ext level*)
Files.ReadNum(R, t.nofpar); (*ext level*)
Files.ReadNum(R, t.size);
Read(R, class);
WHILE class # 0 DO (*fields*)
@ -191,15 +191,14 @@ MODULE ORB; (*NW 7.10.2013 in Oberon-07*)
END ;
Files.ReadString(R, modname);
IF modname[0] # 0X THEN (*re-import*)
(*Files.ReadInt(R, key); Files.ReadString(R, name);*)
Files.ReadNum(R, key); Files.ReadString(R, name);
Files.ReadInt(R, key); Files.ReadString(R, name);
mod := ThisModule(modname, modname, FALSE, key);
obj := mod.dsc; (*search type*)
WHILE (obj # NIL) & (obj.name # name) DO obj := obj.next END ;
IF obj # NIL THEN T := obj.type (*type object found in object list of mod*)
ELSE (*insert new type object in object list of mod*)
NEW(obj); obj.name := name; obj.class := Typ; obj.next := mod.dsc; mod.dsc := obj; obj.type := t;
t.mno := mod.lev; T := t
t.mno := mod.lev; t.typobj := obj; T := t
END ;
typtab[ref] := T
END
@ -218,10 +217,7 @@ MODULE ORB; (*NW 7.10.2013 in Oberon-07*)
thismod.lev := 0; thismod.dsc := system; thismod.rdo := TRUE
ELSE MakeFileName(fname, modid1, ".smb"); F := Files.Old(fname);
IF F # NIL THEN
Files.Set(R, F, 0);
(*Files.ReadInt(R, key); Files.ReadInt(R, key);*)
Files.ReadNum(R, key); Files.ReadNum(R, key);
Files.ReadString(R, modname);
Files.Set(R, F, 0); Files.ReadInt(R, key); Files.ReadInt(R, key); Files.ReadString(R, modname);
thismod := ThisModule(modid, modid1, TRUE, key); thismod.rdo := TRUE;
Read(R, class); (*version key*)
IF class # versionkey THEN ORS.Mark("wrong version") END ;
@ -234,12 +230,7 @@ MODULE ORB; (*NW 7.10.2013 in Oberon-07*)
WHILE k # 0 DO typtab[k].base := t; Read(R, k) END
ELSE
IF class = Const THEN
IF obj.type.form = Real THEN
(*Files.ReadInt(R, obj.val) *)
Files.ReadNum(R, obj.val)
ELSE
Files.ReadNum(R, obj.val)
END
IF obj.type.form = Real THEN Files.ReadInt(R, obj.val) ELSE Files.ReadNum(R, obj.val) END
ELSIF class = Var THEN Files.ReadNum(R, obj.val); obj.rdo := TRUE
END
END ;
@ -254,8 +245,8 @@ MODULE ORB; (*NW 7.10.2013 in Oberon-07*)
PROCEDURE Write(VAR R: Files.Rider; x: INTEGER);
BEGIN
(*Files.WriteByte(R, x)*) (* -128 <= x < 128 *)
Files.WriteByte(R, SHORT(x)) (* -128 <= x < 128 *)
(*Files.WriteByte(R, x)*)
Files.WriteByte(R, SHORT(SHORT(x))) (* voc adaptation by noch *)
END Write;
PROCEDURE OutType(VAR R: Files.Rider; t: Type);
@ -288,11 +279,7 @@ MODULE ORB; (*NW 7.10.2013 in Oberon-07*)
ELSE obj := t.typobj;
IF obj # NIL THEN Write(R, Ref); t.ref := Ref; INC(Ref) ELSE (*anonymous*) Write(R, 0) END ;
Write(R, t.form);
IF t.form = Pointer THEN
IF t.base.ref > 0 THEN Write(R, -t.base.ref)
ELSIF (t.base.typobj = NIL) OR ~t.base.typobj.expo THEN (*base not exported*) Write(R, -1)
ELSE OutType(R, t.base)
END
IF t.form = Pointer THEN OutType(R, t.base)
ELSIF t.form = Array THEN OutType(R, t.base); Files.WriteNum(R, t.len); Files.WriteNum(R, t.size)
ELSIF t.form = Record THEN
IF t.base # NIL THEN OutType(R, t.base) ELSE OutType(R, noType) END ;
@ -302,20 +289,17 @@ MODULE ORB; (*NW 7.10.2013 in Oberon-07*)
WHILE fld # NIL DO (*fields*)
IF fld.expo THEN
Write(R, Fld); Files.WriteString(R, fld.name); OutType(R, fld.type); Files.WriteNum(R, fld.val)
ELSE FindHiddenPointers(R, fld.type, fld.val)
ELSE FindHiddenPointers(R, fld.type, fld.val) (*offset*)
END ;
fld := fld.next
END ;
Write(R, 0)
Write(R, 0)
ELSIF t.form = Proc THEN OutType(R, t.base); OutPar(R, t.dsc, t.nofpar); Write(R, 0)
END ;
IF (t.mno > 0) & (obj # NIL) THEN (*re-export, output name*)
mod := topScope.next;
WHILE (mod # NIL) & (mod.lev # t.mno) DO mod := mod.next END ;
IF mod # NIL THEN Files.WriteString(R, mod.name);
(*Files.WriteInt(R, mod.val); *)
Files.WriteNum(R, mod.val);
Files.WriteString(R, obj.name)
IF mod # NIL THEN Files.WriteString(R, mod.name); Files.WriteInt(R, mod.val); Files.WriteString(R, obj.name)
ELSE ORS.Mark("re-export not found"); Write(R, 0)
END
ELSE Write(R, 0)
@ -349,9 +333,7 @@ MODULE ORB; (*NW 7.10.2013 in Oberon-07*)
Write(R, 0)
ELSIF obj.class = Const THEN
IF obj.type.form = Proc THEN Files.WriteNum(R, obj.exno)
ELSIF obj.type.form = Real THEN
(*Files.WriteInt(R, obj.val)*)
Files.WriteNum(R, obj.val)
ELSIF obj.type.form = Real THEN Files.WriteInt(R, obj.val)
ELSE Files.WriteNum(R, obj.val)
END
ELSIF obj.class = Var THEN
@ -365,26 +347,13 @@ MODULE ORB; (*NW 7.10.2013 in Oberon-07*)
END ;
REPEAT Write(R, 0) UNTIL Files.Length(F) MOD 4 = 0;
FOR Ref := Record+1 TO maxTypTab-1 DO typtab[Ref] := NIL END ;
Files.Set(R, F, 0); sum := 0; (* compute key (checksum) *)
WHILE ~R.eof DO
(*Files.ReadInt(R, x); *)
Files.ReadNum (R, x);
sum := sum + x
END ;
Files.Set(R, F, 0); sum := 0; Files.ReadInt(R, x); (* compute key (checksum) *)
WHILE ~R.eof DO sum := sum + x; Files.ReadInt(R, x) END ;
F1 := Files.Old(filename); (*sum is new key*)
IF F1 # NIL THEN
Files.Set(R1, F1, 4);
(*Files.ReadInt(R1, oldkey) *)
Files.ReadNum(R1, oldkey)
ELSE
oldkey := sum+1
END ;
IF F1 # NIL THEN Files.Set(R1, F1, 4); Files.ReadInt(R1, oldkey) ELSE oldkey := sum+1 END ;
IF sum # oldkey THEN
IF newSF THEN
key := sum; Files.Set(R, F, 4);
(*Files.WriteInt(R, sum); *)
Files.WriteNum(R, sum);
Files.Register(F) (*insert checksum*)
IF newSF OR (F1 = NIL) THEN
key := sum; newSF := TRUE; Files.Set(R, F, 4); Files.WriteInt(R, sum); Files.Register(F) (*insert checksum*)
ELSE ORS.Mark("new symbol file inhibited")
END
ELSE newSF := FALSE; key := sum
@ -406,8 +375,11 @@ MODULE ORB; (*NW 7.10.2013 in Oberon-07*)
BEGIN
NEW(obj);
(*obj.name := name; *)
COPY(name, obj.name);
obj.class := cl; obj.type := type; obj.val := n; obj.dsc := NIL;
COPY(name, obj.name); (* voc adaptation by noch *)
obj.class := cl;
obj.type := type;
obj.val := n;
obj.dsc := NIL;
IF cl = Typ THEN type.typobj := obj END ;
obj.next := system; system := obj
END enter;
@ -425,7 +397,7 @@ BEGIN
(*initialize universe with data types and in-line procedures;
LONGINT is synonym to INTEGER, LONGREAL to REAL.
LED, ADC, SBC; LDPSR, LDREG, REG, COND, MSK are not in language definition*)
LED, ADC, SBC; LDPSR, LDREG, REG, COND are not in language definition*)
system := NIL; (*n = procno*10 + nofpar*)
enter("UML", SFunc, intType, 132); (*functions*)
enter("SBC", SFunc, intType, 122);

206
src/voc07R/ORC.Mod
View file

@ -1,206 +0,0 @@
MODULE ORC; (*Connection to RISC; NW 11.11.2013*)
IMPORT SYSTEM, Files, Texts, Oberon, V24;
CONST portno = 1; (*RS-232*)
BlkLen = 255; pno = 1;
REQ = 20X; REC = 21X; SND = 22X; CLS = 23X; ACK = 10X;
Tout = 1000;
VAR res: LONGINT;
W: Texts.Writer;
PROCEDURE Flush*;
VAR ch: CHAR;
BEGIN
WHILE V24.Available(portno) > 0 DO V24.Receive(portno, ch, res); Texts.Write(W, ch) END ;
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
END Flush;
PROCEDURE Open*;
VAR ch: CHAR;
BEGIN V24.Start(pno, 19200, 8, V24.ParNo, V24.Stop1, res);
WHILE V24.Available(pno) > 0 DO V24.Receive(pno, ch, res) END ;
IF res > 0 THEN Texts.WriteString(W, "open V24, error ="); Texts.WriteInt(W, res, 4)
ELSE Texts.WriteString(W, "connection open")
END ;
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
END Open;
PROCEDURE TestReq*;
VAR ch: CHAR;
BEGIN V24.Send(pno, REQ, res); Rec(ch); Texts.WriteInt(W, ORD(ch), 4);
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
END TestReq;
PROCEDURE SendInt(x: LONGINT);
VAR i: INTEGER;
BEGIN i := 4;
WHILE i > 0 DO
DEC(i); V24.Send(portno, CHR(x), res); x := x DIV 100H
END
END SendInt;
PROCEDURE Load*; (*linked boot file F.bin*)
VAR i, m, n, w: LONGINT;
F: Files.File; R: Files.Rider;
S: Texts.Scanner;
BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
IF S.class = Texts.Name THEN (*input file name*)
Texts.WriteString(W, S.s); F := Files.Old(S.s);
IF F # NIL THEN
Files.Set(R, F, 0); Files.ReadLInt(R, n); Files.ReadLInt(R, m); n := n DIV 4;
Texts.WriteInt(W, n, 6); Texts.WriteString(W, " loading "); Texts.Append(Oberon.Log, W.buf);
i := 0; SendInt(n*4); SendInt(m);
WHILE i < n DO
IF i + 1024 < n THEN m := i + 1024 ELSE m := n END ;
WHILE i < m DO Files.ReadLInt(R, w); SendInt(w); INC(i) END ;
Texts.Write(W, "."); Texts.Append(Oberon.Log, W.buf)
END ;
SendInt(0); Texts.WriteString(W, "done")
ELSE Texts.WriteString(W, " not found")
END ;
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
END
END Load;
(* ------------ send and receive files ------------ *)
PROCEDURE Rec(VAR ch: CHAR); (*receive with timeout*)
VAR time: LONGINT;
BEGIN time := Oberon.Time() + 3000;
LOOP
IF V24.Available(pno) > 0 THEN V24.Receive(pno, ch, res); EXIT END ;
IF Oberon.Time() >= time THEN ch := 0X; EXIT END
END
END Rec;
PROCEDURE SendName(VAR s: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR;
BEGIN i := 0; ch := s[0];
WHILE ch > 0X DO V24.Send(pno, ch, res); INC(i); ch := s[i] END ;
V24.Send(pno, 0X, res)
END SendName;
PROCEDURE Send*;
VAR ch, code: CHAR;
n, n0, L: LONGINT;
F: Files.File; R: Files.Rider;
S: Texts.Scanner;
BEGIN V24.Send(pno, REQ, res); Rec(code);
IF code = ACK THEN
Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
WHILE S.class = Texts.Name DO
Texts.WriteString(W, S.s); F := Files.Old(S.s);
IF F # NIL THEN
V24.Send(pno, REC, res); SendName(S.s); Rec(code);
IF code = ACK THEN
Texts.WriteString(W, " sending ");
L := Files.Length(F); Files.Set(R, F, 0);
REPEAT (*send paket*)
IF L > BlkLen THEN n := BlkLen ELSE n := L END ;
n0 := n; V24.Send(pno, CHR(n), res); DEC(L, n);
WHILE n > 0 DO Files.Read(R, ch); V24.Send(pno, ch, res); DEC(n) END ;
Rec(code);
IF code = ACK THEN Texts.Write(W, ".") ELSE Texts.Write(W, "*"); n := 0 END ;
Texts.Append(Oberon.Log, W.buf)
UNTIL n0 < BlkLen;
Rec(code)
ELSE Texts.WriteString(W, " no response"); Texts.WriteInt(W, ORD(code), 4)
END
ELSE Texts.WriteString(W, " not found")
END ;
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Texts.Scan(S)
END
ELSE Texts.WriteString(W, " connection not open");
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
END
END Send;
PROCEDURE Receive*;
VAR ch, code: CHAR;
n, L, LL: LONGINT;
F: Files.File; R: Files.Rider;
orgname: ARRAY 32 OF CHAR;
S: Texts.Scanner;
BEGIN V24.Send(pno, REQ, res); Rec(code);
IF code = ACK THEN
Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
WHILE S.class = Texts.Name DO
Texts.WriteString(W, S.s); COPY(S.s, orgname);
F := Files.New(S.s); Files.Set(R, F, 0); LL := 0;
V24.Send(pno, SND, res); SendName(S.s); Rec(code);
IF code = ACK THEN
Texts.WriteString(W, " receiving ");
REPEAT Rec(ch); L := ORD(ch); n := L;
WHILE n > 0 DO V24.Receive(pno, ch, res); Files.Write(R, ch); DEC(n) END ;
V24.Send(pno, ACK, res); LL := LL + L; Texts.Write(W, "."); Texts.Append(Oberon.Log, W.buf)
UNTIL L < BlkLen;
Files.Register(F); Texts.WriteInt(W, LL, 6)
ELSE Texts.WriteString(W, " no response"); Texts.WriteInt(W, ORD(code), 4)
END ;
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); Texts.Scan(S)
END
ELSE Texts.WriteString(W, " connection not open");
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
END
END Receive;
PROCEDURE Close*;
BEGIN V24.Send(pno, CLS, res);
Texts.WriteString(W, "Server closed"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
END Close;
(* ------------ Oberon-0 commands ------------ *)
PROCEDURE RecByte(VAR ch: CHAR);
VAR T: LONGINT; ch0: CHAR;
BEGIN T := Oberon.Time() + Tout;
REPEAT UNTIL (V24.Available(portno) > 0) OR (Oberon.Time() >= T);
IF V24.Available(portno) > 0 THEN V24.Receive(portno, ch, res) ELSE ch := 0X END ;
END RecByte;
PROCEDURE RecInt(VAR x: LONGINT);
VAR i, k, T: LONGINT; ch: CHAR;
BEGIN i := 4; k := 0;
REPEAT
DEC(i); V24.Receive(portno, ch, res);
k := SYSTEM.ROT(ORD(ch)+k, -8)
UNTIL i = 0;
x := k
END RecInt;
PROCEDURE SR*; (*send, then receive sequence of items*)
VAR S: Texts.Scanner; i, k: LONGINT; ch, xch: CHAR;
BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
WHILE (S.class # Texts.Char) & (S.c # "~") DO
IF S.class = Texts.Int THEN Texts.WriteInt(W, S.i, 6); SendInt(S.i)
ELSIF S.class = Texts.Real THEN
Texts.WriteReal(W, S.x, 12); SendInt(SYSTEM.VAL(LONGINT, S.x))
ELSIF S.class IN {Texts.Name, Texts.String} THEN
Texts.Write(W, " "); Texts.WriteString(W, S.s); i := 0;
REPEAT ch := S.s[i]; V24.Send(portno, ch, res); INC(i) UNTIL ch = 0X
ELSIF S.class = Texts.Char THEN Texts.Write(W, S.c)
ELSE Texts.WriteString(W, "bad value")
END ;
Texts.Scan(S)
END ;
Texts.Write(W, "|"); (*Texts.Append(Oberon.Log, W.buf);*)
(*receive input*)
REPEAT RecByte(xch);
IF xch = 0X THEN Texts.WriteString(W, " timeout"); Flush
ELSIF xch = 1X THEN RecInt(k); Texts.WriteInt(W, k, 6)
ELSIF xch = 2X THEN RecInt(k); Texts.WriteHex(W, k)
ELSIF xch = 3X THEN RecInt(k); Texts.WriteReal(W, SYSTEM.VAL(REAL, k), 15)
ELSIF xch = 4X THEN Texts.Write(W, " "); V24.Receive(portno, ch, res);
WHILE ch > 0X DO Texts.Write(W, ch); V24.Receive(portno, ch, res) END
ELSIF xch = 5X THEN V24.Receive(portno, ch, res); Texts.Write(W, ch)
ELSIF xch = 6X THEN Texts.WriteLn(W)
ELSIF xch = 7X THEN Texts.Write(W, "~"); xch := 0X
ELSIF xch = 8X THEN RecByte(ch); Texts.WriteInt(W, ORD(ch), 4); Texts.Append(Oberon.Log, W.buf)
ELSE xch := 0X
END
UNTIL xch = 0X;
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
END SR;
BEGIN Texts.OpenWriter(W);
END ORC.

310
src/voc07R/ORG.Mod
View file

@ -1,16 +1,20 @@
MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
IMPORT SYSTEM, Files, ORS, ORB;
MODULE ORG; (* NW 24.6.2014 code generator in Oberon-07 for RISC*)
IMPORT SYSTEM, Files := CompatFiles, ORS, ORB;
(*Code generator for Oberon compiler for RISC processor.
Procedural interface to Parser OSAP; result in array "code".
Procedure Close writes code-files*)
(* voc adaptation by noch *)
TYPE INTEGER = LONGINT;
BYTE = CHAR;
CONST WordSize* = 4;
StkOrg0 = -64; VarOrg0 = 0; (*for RISC-0 only*)
MT = 12; SB = 13; SP = 14; LNK = 15; (*dedicated registers*)
maxCode = 8000; maxStrx = 2400; maxTD = 120; C24 = 1000000H;
Reg = 10; RegI = 11; Cond = 12; (*internal item modes*)
(*frequently used opcodes*) U = 2000H;
(*frequently used opcodes*) U = 2000H; V = 1000H;
Mov = 0; Lsl = 1; Asr = 2; Ror= 3; And = 4; Ann = 5; Ior = 6; Xor = 7;
Add = 8; Sub = 9; Cmp = 9; Mul = 10; Div = 11;
Fad = 12; Fsb = 13; Fml = 14; Fdv = 15;
@ -28,7 +32,7 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
(* Item forms and meaning of fields:
mode r a b
--------------------------------
Const - value (proc adr) (immediate value)
Const - value (proc adr) (immediate value)
Var base off - (direct adr)
Par - off0 off1 (indirect adr)
Reg regno
@ -40,8 +44,9 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
entry: LONGINT; (*main entry point*)
RH: LONGINT; (*available registers R[0] ... R[H-1]*)
curSB: LONGINT; (*current static base in SB*)
frame: LONGINT; (*frame offset changed in SaveRegs and RestoreRegs*)
fixorgP, fixorgD, fixorgT: LONGINT; (*origins of lists of locations to be fixed up by loader*)
check, inhibitCalls: BOOLEAN; (*emit run-time checks*)
check: BOOLEAN; (*emit run-time checks*)
version: INTEGER; (* 0 = RISC-0, 1 = RISC-5 *)
relmap: ARRAY 6 OF INTEGER; (*condition codes for relations*)
@ -49,6 +54,15 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
data: ARRAY maxTD OF LONGINT; (*type descriptors*)
str: ARRAY maxStrx OF CHAR;
(* voc adaptation by noch *)
PROCEDURE LSL (x, n : INTEGER): INTEGER;
BEGIN
RETURN ASH(x, n);
END LSL;
(*instruction assemblers according to formats*)
PROCEDURE Put0(op, a, b, c: LONGINT);
@ -58,7 +72,7 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
PROCEDURE Put1(op, a, b, im: LONGINT);
BEGIN (*emit format-1 instruction, -10000H <= im < 10000H*)
IF im < 0 THEN INC(op, 1000H) END ; (*set v-bit*)
IF im < 0 THEN INC(op, V) END ;
code[pc] := (((a+40H) * 10H + b) * 10H + op) * 10000H + (im MOD 10000H); INC(pc)
END Put1;
@ -83,36 +97,21 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
PROCEDURE incR;
BEGIN
IF RH < MT THEN INC(RH) ELSE ORS.Mark("register stack overflow") END
IF RH < MT-1 THEN INC(RH) ELSE ORS.Mark("register stack overflow") END
END incR;
PROCEDURE CheckRegs*;
BEGIN
IF RH # 0 THEN ORS.Mark("Reg Stack"); RH := 0 END ;
IF pc >= maxCode - 40 THEN ORS.Mark("Program too long"); END
IF pc >= maxCode - 40 THEN ORS.Mark("Program too long") END
END CheckRegs;
PROCEDURE SaveRegs(r: LONGINT); (* R[0 .. r-1] to be saved; R[r .. RH-1] to be moved down*)
VAR rs, rd: LONGINT; (*r > 0*)
BEGIN rs := r; rd := 0;
REPEAT DEC(rs); Put1(Sub, SP, SP, 4); Put2(Str, rs, SP, 0) UNTIL rs = 0;
rs := r; rd := 0;
WHILE rs < RH DO Put0(Mov, rd, 0, rs); INC(rs); INC(rd) END ;
RH := rd
END SaveRegs;
PROCEDURE RestoreRegs(r: LONGINT; VAR x: Item); (*R[0 .. r-1] to be restored*)
VAR rd: LONGINT; (*r > 0*)
BEGIN Put0(Mov, r, 0, 0); rd := 0;
REPEAT Put2(Ldr, rd, SP, 0); Put1(Add, SP, SP, 4); INC(rd) UNTIL rd = r
END RestoreRegs;
PROCEDURE SetCC(VAR x: Item; n: LONGINT);
BEGIN x.mode := Cond; x.a := 0; x.b := 0; x.r := n
END SetCC;
PROCEDURE Trap(cond, num: LONGINT);
BEGIN Put3(BLR, cond, ORS.Pos()*100H + num*10H + MT)
BEGIN num := ORS.Pos()*100H + num*10H + MT; Put3(BLR, cond, num)
END Trap;
(*handling of forward reference, fixups of branch addresses and constant tables*)
@ -174,13 +173,7 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
BEGIN
IF x.type.size = 1 THEN op := Ldr+1 ELSE op := Ldr END ;
IF x.mode # Reg THEN
IF x.mode = ORB.Var THEN
IF x.r > 0 THEN (*local*) Put2(op, RH, SP, x.a)
ELSE GetSB(x.r); Put2(op, RH, SB, x.a)
END ;
x.r := RH; incR
ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a); Put2(op, RH, RH, x.b); x.r := RH; incR
ELSIF x.mode = ORB.Const THEN
IF x.mode = ORB.Const THEN
IF x.type.form = ORB.Proc THEN
IF x.r > 0 THEN ORS.Mark("not allowed")
ELSIF x.r = 0 THEN Put3(BL, 7, 0); Put1a(Sub, RH, LNK, pc*4 - x.a)
@ -191,6 +184,12 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
IF x.a MOD 10000H # 0 THEN Put1(Ior, RH, RH, x.a MOD 10000H) END
END ;
x.r := RH; incR
ELSIF x.mode = ORB.Var THEN
IF x.r > 0 THEN (*local*) Put2(op, RH, SP, x.a + frame)
ELSE GetSB(x.r); Put2(op, RH, SB, x.a)
END ;
x.r := RH; incR
ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, RH, RH, x.b); x.r := RH; incR
ELSIF x.mode = RegI THEN Put2(op, x.r, x.r, x.a)
ELSIF x.mode = Cond THEN
Put3(BC, negated(x.r), 2);
@ -204,16 +203,16 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
PROCEDURE loadAdr(VAR x: Item);
BEGIN
IF x.mode = ORB.Var THEN
IF x.r > 0 THEN (*local*) Put1a(Add, RH, SP, x.a)
IF x.r > 0 THEN (*local*) Put1a(Add, RH, SP, x.a + frame)
ELSE GetSB(x.r); Put1a(Add, RH, SB, x.a)
END ;
x.r := RH; incR
ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a);
ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame);
IF x.b # 0 THEN Put1a(Add, RH, RH, x.b) END ;
x.r := RH; incR
ELSIF x.mode = RegI THEN
IF x.a # 0 THEN Put1a(Add, x.r, x.r, x.a) END
ELSE ORS.Mark("address error")
ELSE ORS.Mark("address error")
END ;
x.mode := Reg
END loadAdr;
@ -295,15 +294,15 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
IF check THEN (*check array bounds*)
IF lim >= 0 THEN Put1a(Cmp, RH, y.r, lim)
ELSE (*open array*)
IF x.mode IN {ORB.Var, ORB.Par} THEN Put2(Ldr, RH, SP, x.a+4); Put0(Cmp, RH, y.r, RH)
IF x.mode IN {ORB.Var, ORB.Par} THEN Put2(Ldr, RH, SP, x.a+4+frame); Put0(Cmp, RH, y.r, RH)
ELSE ORS.Mark("error in Index")
END
END ;
Trap(10, 1)
Trap(10, 1) (*BCC*)
END ;
IF s = 4 THEN Put1(Lsl, y.r, y.r, 2) ELSIF s > 1 THEN Put1(Mul, y.r, y.r, s) END ;
IF s = 4 THEN Put1(Lsl, y.r, y.r, 2) ELSIF s > 1 THEN Put1a(Mul, y.r, y.r, s) END ;
IF x.mode = ORB.Var THEN
IF x.r > 0 THEN Put0(Add, y.r, SP, y.r)
IF x.r > 0 THEN Put0(Add, y.r, SP, y.r); INC(x.a, frame)
ELSE GetSB(x.r);
IF x.r = 0 THEN Put0(Add, y.r, SB, y.r)
ELSE Put1a(Add, RH, SB, x.a); Put0(Add, y.r, RH, y.r); x.a := 0
@ -311,7 +310,7 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
END ;
x.r := y.r; x.mode := RegI
ELSIF x.mode = ORB.Par THEN
Put2(Ldr, RH, SP, x.a);
Put2(Ldr, RH, SP, x.a + frame);
Put0(Add, y.r, RH, y.r); x.mode := RegI; x.r := y.r; x.a := x.b
ELSIF x.mode = RegI THEN Put0(Add, x.r, x.r, y.r); DEC(RH)
END
@ -321,10 +320,10 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
PROCEDURE DeRef*(VAR x: Item);
BEGIN
IF x.mode = ORB.Var THEN
IF x.r > 0 THEN (*local*) Put2(Ldr, RH, SP, x.a) ELSE GetSB(x.r); Put2(Ldr, RH, SB, x.a) END ;
IF x.r > 0 THEN (*local*) Put2(Ldr, RH, SP, x.a + frame) ELSE GetSB(x.r); Put2(Ldr, RH, SB, x.a) END ;
NilCheck; x.r := RH; incR
ELSIF x.mode = ORB.Par THEN
Put2(Ldr, RH, SP, x.a); Put2(Ldr, RH, RH, x.b); NilCheck; x.r := RH; incR
Put2(Ldr, RH, SP, x.a + frame); Put2(Ldr, RH, RH, x.b); NilCheck; x.r := RH; incR
ELSIF x.mode = RegI THEN Put2(Ldr, x.r, x.r, x.a); NilCheck
ELSIF x.mode # Reg THEN ORS.Mark("bad mode in DeRef")
END ;
@ -358,7 +357,7 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
IF s <= 24 THEN s := 32 ELSIF s <= 56 THEN s := 64 ELSIF s <= 120 THEN s := 128
ELSE s := (s+263) DIV 256 * 256
END ;
data[dcw] := s; INC(dcw);
T.len := dc; data[dcw] := s; INC(dcw);
k := T.nofpar; (*extension level!*)
IF k > 3 THEN ORS.Mark("ext level too large")
ELSE Q(T, dcw);
@ -369,13 +368,17 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
END BuildTD;
PROCEDURE TypeTest*(VAR x: Item; T: ORB.Type; varpar, isguard: BOOLEAN);
VAR pc0: LONGINT;
BEGIN (*fetch tag into RH*)
IF varpar THEN Put2(Ldr, RH, SP, x.a+4)
ELSE load(x); NilCheck; Put2(Ldr, RH, x.r, -8)
IF varpar THEN Put2(Ldr, RH, SP, x.a+4+frame)
ELSE load(x);
pc0 := pc; Put3(BC, EQ, 0); (*NIL belongs to every pointer type*)
Put2(Ldr, RH, x.r, -8)
END ;
Put2(Ldr, RH, RH, T.nofpar*4); incR;
loadTypTagAdr(T); (*tag of T*)
Put0(Cmp, RH, RH-1, RH-2); DEC(RH, 2);
Put0(Cmp, RH-1, RH-1, RH-2); DEC(RH, 2);
IF ~varpar THEN fix(pc0, pc - pc0 - 1) END ;
IF isguard THEN
IF check THEN Trap(NE, 2) END
ELSE SetCC(x, EQ);
@ -514,32 +517,20 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
PROCEDURE Singleton*(VAR x: Item); (* x := {x} *)
BEGIN
IF x.mode = ORB.Const THEN
(*x.a := LSL(1, x.a)*) (* o7 -> o2 *)
x.a := ASH(1, x.a)
ELSE
load(x); Put1(Mov, RH, 0, 1); Put0(Lsl, x.r, RH, x.r)
x.a := LSL(1, x.a)
ELSE load(x); Put1(Mov, RH, 0, 1); Put0(Lsl, x.r, RH, x.r)
END
END Singleton;
PROCEDURE Set*(VAR x, y: Item); (* x := {x .. y} *)
BEGIN
IF (x.mode = ORB.Const) & ( y.mode = ORB.Const) THEN
IF x.a <= y.a THEN
(*x.a := LSL(2, y.a) - LSL(1, x.a)*) (* o7 -> o2 *)
x.a := ASH(2, y.a) - ASH(1, x.a)
ELSE
x.a := 0
END
IF x.a <= y.a THEN x.a := LSL(2, y.a) - LSL(1, x.a) ELSE x.a := 0 END
ELSE
IF (x.mode = ORB.Const) & (x.a < 10H) THEN
(*x.a := LSL(-1, x.a)*) (* o7 -> o2 *)
x.a := ASH(-1, x.a)
IF (x.mode = ORB.Const) & (x.a < 16) THEN x.a := LSL(-1, x.a)
ELSE load(x); Put1(Mov, RH, 0, -1); Put0(Lsl, x.r, RH, x.r)
END ;
IF (y.mode = ORB.Const) & (y.a < 10H) THEN
(*Put1(Mov, RH, 0, LSL(-2, y.a)); *) (* o7 -> o2 *)
Put1(Mov, RH, 0, ASH(-2, y.a));
y.mode := Reg; y.r := RH; INC(RH)
IF (y.mode = ORB.Const) & (y.a < 16) THEN Put1(Mov, RH, 0, LSL(-2, y.a)); y.mode := Reg; y.r := RH; incR
ELSE load(y); Put1(Mov, RH, 0, -2); Put0(Lsl, y.r, RH, y.r)
END ;
IF x.mode = ORB.Const THEN
@ -641,36 +632,36 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
BEGIN load(y);
IF x.type.size = 1 THEN op := Str+1 ELSE op := Str END ;
IF x.mode = ORB.Var THEN
IF x.r > 0 THEN (*local*) Put2(op, y.r, SP, x.a)
IF x.r > 0 THEN (*local*) Put2(op, y.r, SP, x.a + frame)
ELSE GetSB(x.r); Put2(op, y.r, SB, x.a)
END
ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a); Put2(op, y.r, RH, x.b);
ELSIF x.mode = ORB.Par THEN Put2(Ldr, RH, SP, x.a + frame); Put2(op, y.r, RH, x.b);
ELSIF x.mode = RegI THEN Put2(op, y.r, x.r, x.a); DEC(RH);
ELSE ORS.Mark("bad mode in Store")
END ;
DEC(RH)
END Store;
PROCEDURE StoreStruct*(VAR x, y: Item); (* x := y *)
PROCEDURE StoreStruct*(VAR x, y: Item); (* x := y, frame = 0 *)
VAR s, pc0: LONGINT;
BEGIN loadAdr(x); loadAdr(y);
IF (x.type.form = ORB.Array) & (x.type.len > 0) THEN
IF y.type.len >= 0 THEN
IF x.type.len >= y.type.len THEN Put1(Mov, RH, 0, (y.type.size+3) DIV 4)
IF x.type.len >= y.type.len THEN Put1a(Mov, RH, 0, (y.type.size+3) DIV 4)
ELSE ORS.Mark("source array too long")
END
ELSE (*y is open array*)
Put2(Ldr, RH, SP, y.a+4); s := y.type.base.size; (*element size*)
pc0 := pc; Put3(BC, EQ, 0);
IF s = 1 THEN Put1(Add, RH, RH, 3); Put1(Asr, RH, RH, 2)
ELSIF s # 4 THEN Put1(Mul, RH, RH, s DIV 4)
ELSIF s # 4 THEN Put1a(Mul, RH, RH, s DIV 4)
END ;
IF check THEN
Put1(Mov, RH+1, 0, (x.type.size+3) DIV 4); Put0(Cmp, RH+1, RH, RH+1); Trap(GT, 3)
Put1a(Mov, RH+1, 0, (x.type.size+3) DIV 4); Put0(Cmp, RH+1, RH, RH+1); Trap(GT, 3)
END ;
fix(pc0, pc + 5 - pc0)
END
ELSIF x.type.form = ORB.Record THEN Put1(Mov, RH, 0, x.type.size DIV 4)
ELSIF x.type.form = ORB.Record THEN Put1a(Mov, RH, 0, x.type.size DIV 4)
ELSE ORS.Mark("inadmissible assignment")
END ;
Put2(Ldr, RH+1, y.r, 0); Put1(Add, y.r, y.r, 4);
@ -698,10 +689,10 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
VAR xmd: INTEGER;
BEGIN xmd := x.mode; loadAdr(x);
IF (ftype.form = ORB.Array) & (ftype.len < 0) THEN (*open array*)
IF x.type.len >= 0 THEN Put1(Mov, RH, 0, x.type.len) ELSE Put2(Ldr, RH, SP, x.a+4) END ;
IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE Put2(Ldr, RH, SP, x.a+4+frame) END ;
incR
ELSIF ftype.form = ORB.Record THEN
IF xmd = ORB.Par THEN Put2(Ldr, RH, SP, x.a+4); incR ELSE loadTypTagAdr(x.type) END
IF xmd = ORB.Par THEN Put2(Ldr, RH, SP, x.a+4+frame); incR ELSE loadTypTagAdr(x.type) END
END
END VarParam;
@ -711,7 +702,7 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
PROCEDURE OpenArrayParam*(VAR x: Item);
BEGIN loadAdr(x);
IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE Put2(Ldr, RH, SP, x.a+4) END ;
IF x.type.len >= 0 THEN Put1a(Mov, RH, 0, x.type.len) ELSE Put2(Ldr, RH, SP, x.a+4+frame) END ;
incR
END OpenArrayParam;
@ -772,38 +763,47 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
BEGIN FixLink(x.a)
END Fixup;
PROCEDURE SaveRegs(r: LONGINT); (* R[0 .. r-1]*)
VAR r0: LONGINT;
BEGIN (*r > 0*) r0 := 0;
Put1(Sub, SP, SP, r*4); INC(frame, 4*r);
REPEAT Put2(Str, r0, SP, (r-r0-1)*4); INC(r0) UNTIL r0 = r
END SaveRegs;
PROCEDURE RestoreRegs(r: LONGINT); (*R[0 .. r-1]*)
VAR r0: LONGINT;
BEGIN (*r > 0*) r0 := r;
REPEAT DEC(r0); Put2(Ldr, r0, SP, (r-r0-1)*4) UNTIL r0 = 0;
Put1(Add, SP, SP, r*4); DEC(frame, 4*r)
END RestoreRegs;
PROCEDURE PrepCall*(VAR x: Item; VAR r: LONGINT);
BEGIN
IF x.type.form = ORB.Proc THEN
IF x.mode # ORB.Const THEN
load(x); code[pc-1] := code[pc-1] + 0B000000H; x.r := 11; DEC(RH); inhibitCalls := TRUE;
IF check THEN Trap(EQ, 5) END
END
ELSE ORS.Mark("not a procedure")
END ;
r := RH
BEGIN (*x.type.form = ORB.Proc*)
IF x.mode > ORB.Par THEN load(x) END ;
r := RH;
IF RH > 0 THEN SaveRegs(RH); RH := 0 END
END PrepCall;
PROCEDURE Call*(VAR x: Item; r: LONGINT);
BEGIN
IF inhibitCalls & (x.r # 11) THEN ORS.Mark("inadmissible call") ELSE inhibitCalls := FALSE END ;
IF r > 0 THEN SaveRegs(r) END ;
IF x.type.form = ORB.Proc THEN
IF x.mode = ORB.Const THEN
IF x.r >= 0 THEN Put3(BL, 7, (x.a DIV 4)-pc-1)
ELSE (*imported*)
IF pc - fixorgP < 1000H THEN
Put3(BL, 7, ((-x.r) * 100H + x.a) * 1000H + pc-fixorgP); fixorgP := pc-1
ELSE ORS.Mark("fixup impossible")
END
BEGIN (*x.type.form = ORB.Proc*)
IF x.mode = ORB.Const THEN
IF x.r >= 0 THEN Put3(BL, 7, (x.a DIV 4)-pc-1)
ELSE (*imported*)
IF pc - fixorgP < 1000H THEN
Put3(BL, 7, ((-x.r) * 100H + x.a) * 1000H + pc-fixorgP); fixorgP := pc-1
ELSE ORS.Mark("fixup impossible")
END
ELSE Put3(BLR, 7, x.r)
END
ELSE ORS.Mark("not a procedure")
END ;
IF x.type.base.form = ORB.NoTyp THEN RH := 0
ELSE
IF r > 0 THEN RestoreRegs(r, x) END ;
IF x.mode <= ORB.Par THEN load(x); DEC(RH)
ELSE Put2(Ldr, RH, SP, 0); Put1(Add, SP, SP, 4); DEC(r); DEC(frame, 4)
END ;
IF check THEN Trap(EQ, 5) END ;
Put3(BLR, 7, RH)
END ;
IF x.type.base.form = ORB.NoTyp THEN (*procedure*) RH := 0
ELSE (*function*)
IF r > 0 THEN Put0(Mov, r, 0, 0); RestoreRegs(r) END ;
x.mode := Reg; x.r := r; RH := r+1
END ;
invalSB
@ -811,14 +811,14 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
PROCEDURE Enter*(parblksize, locblksize: LONGINT; int: BOOLEAN);
VAR a, r: LONGINT;
BEGIN invalSB;
BEGIN invalSB; frame := 0;
IF ~int THEN (*procedure prolog*)
a := 4; r := 0;
Put1(Sub, SP, SP, locblksize); Put2(Str, LNK, SP, 0);
WHILE a < parblksize DO Put2(Str, r, SP, a); INC(r); INC(a, 4) END
ELSE (*interrupt procedure*)
Put1(Sub, SP, SP, 8); Put2(Str, 0, SP, 0); Put2(Str, 1, SP, 4)
(*R0 and R1 saved, but NOT LNK*)
Put1(Sub, SP, SP, 12); Put2(Str, 0, SP, 0); Put2(Str, 1, SP, 4); Put2(Str, SB, SP, 8)
(*R0, R1, SB saved os stack*)
END
END Enter;
@ -827,8 +827,8 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
IF form # ORB.NoTyp THEN load(x) END ;
IF ~int THEN (*procedure epilog*)
Put2(Ldr, LNK, SP, 0); Put1(Add, SP, SP, size); Put3(BR, 7, LNK)
ELSE (*interrupt*)
Put2(Ldr, 1, SP, 4); Put2(Ldr, 0, SP, 0); Put1(Add, SP, SP, 8); Put3(BR, 7, 10H)
ELSE (*interrupt return, restore SB, R1, R0*)
Put2(Ldr, SB, SP, 8); Put2(Ldr, 1, SP, 4); Put2(Ldr, 0, SP, 0); Put1(Add, SP, SP, 12); Put3(BR, 7, 10H)
END ;
RH := 0
END Return;
@ -837,35 +837,26 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
PROCEDURE Increment*(upordown: LONGINT; VAR x, y: Item);
VAR op, zr, v: LONGINT;
BEGIN
BEGIN (*frame = 0*)
IF upordown = 0 THEN op := Add ELSE op := Sub END ;
IF x.type = ORB.byteType THEN v := 1 ELSE v := 0 END ;
IF y.type.form = ORB.NoTyp THEN y.mode := ORB.Const; y.a := 1 END ;
IF (x.mode = ORB.Var) & (x.r > 0) THEN
zr := RH; Put2(Ldr+v, zr, SP, x.a); incR;
IF y.mode = ORB.Const THEN Put1(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ;
IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ;
Put2(Str+v, zr, SP, x.a); DEC(RH)
ELSE loadAdr(x); zr := RH; Put2(Ldr+v, RH, x.r, 0); incR;
IF y.mode = ORB.Const THEN Put1(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ;
IF y.mode = ORB.Const THEN Put1a(op, zr, zr, y.a) ELSE load(y); Put0(op, zr, zr, y.r); DEC(RH) END ;
Put2(Str+v, zr, x.r, 0); DEC(RH, 2)
END
END Increment;
PROCEDURE Include*(inorex: LONGINT; VAR x, y: Item);
VAR zr: LONGINT;
VAR op, zr: LONGINT;
BEGIN loadAdr(x); zr := RH; Put2(Ldr, RH, x.r, 0); incR;
IF inorex = 0 THEN (*include*)
IF y.mode = ORB.Const THEN
(*Put1(Ior, zr, zr, LSL(1, y.a))*) (* o7 -> o2 *)
Put1(Ior, zr, zr, ASH(1, y.a))
ELSE load(y); Put1(Mov, RH, 0, 1); Put0(Lsl, y.r, RH, y.r); Put0(Ior, zr, zr, y.r); DEC(RH)
END
ELSE (*exclude*)
IF y.mode = ORB.Const THEN
(*Put1(And, zr, zr, -LSL(1, y.a)-1)*) (* o7 -> o2 *)
Put1(And, zr, zr, - ASH(1, y.a)-1)
ELSE load(y); Put1(Mov, RH, 0, 1); Put0(Lsl, y.r, RH, y.r); Put1(Xor, y.r, y.r, -1); Put0(And, zr, zr, y.r); DEC(RH)
END
IF inorex = 0 THEN op := Ior ELSE op := Ann END ;
IF y.mode = ORB.Const THEN Put1a(op, zr, zr, LSL(1, y.a))
ELSE load(y); Put1(Mov, RH, 0, 1); Put0(Lsl, y.r, RH, y.r); Put0(op, zr, zr, y.r); DEC(RH)
END ;
Put2(Str, zr, x.r, 0); DEC(RH, 2)
END Include;
@ -950,7 +941,7 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
END Odd;
PROCEDURE Floor*(VAR x: Item);
BEGIN load(x); Put1(Mov+U, RH, 0, 4B00H); Put0(Fad+1000H, x.r, x.r, RH)
BEGIN load(x); Put1(Mov+U, RH, 0, 4B00H); Put0(Fad+V, x.r, x.r, RH)
END Floor;
PROCEDURE Float*(VAR x: Item);
@ -965,7 +956,7 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
PROCEDURE Len*(VAR x: Item);
BEGIN
IF x.type.len >= 0 THEN x.mode := ORB.Const; x.a := x.type.len
ELSE (*open array*) Put2(Ldr, RH, SP, x.a + 4); x.mode := Reg; x.r := RH; incR
ELSE (*open array*) Put2(Ldr, RH, SP, x.a + 4 + frame); x.mode := Reg; x.r := RH; incR
END
END Len;
@ -1005,7 +996,7 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
PROCEDURE H*(VAR x: Item);
BEGIN (*x.mode = Const*)
Put0(Mov + U + (x.a MOD 2 * 1000H), RH, 0, 0); x.mode := Reg; x.r := RH; incR
Put0(Mov + U + x.a MOD 2 * V, RH, 0, 0); x.mode := Reg; x.r := RH; incR
END H;
PROCEDURE Adr*(VAR x: Item);
@ -1022,8 +1013,7 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
END Condition;
PROCEDURE Open*(v: INTEGER);
BEGIN pc := 0; tdx := 0; strx := 0; RH := 0; fixorgP := 0; fixorgD := 0; fixorgT := 0;
check := v # 0; version := v; inhibitCalls := FALSE;
BEGIN pc := 0; tdx := 0; strx := 0; RH := 0; fixorgP := 0; fixorgD := 0; fixorgT := 0; check := v # 0; version := v;
IF v = 0 THEN pc := 8 END
END Open;
@ -1033,7 +1023,7 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
PROCEDURE Header*;
BEGIN entry := pc*4;
IF version = 0 THEN code[0] := 0E7000000H-1 + pc; Put1(Mov, SB, 0, 16); Put1(Mov, SP, 0, StkOrg0) (*RISC-0*)
IF version = 0 THEN code[0] := 0E7000000H-1 + pc; Put1a(Mov, SB, 0, VarOrg0); Put1a(Mov, SP, 0, StkOrg0) (*RISC-0*)
ELSE Put1(Sub, SP, SP, 4); Put2(Str, LNK, SP, 0); invalSB
END
END Header;
@ -1054,9 +1044,7 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
PROCEDURE FindPtrs(VAR R: Files.Rider; typ: ORB.Type; adr: LONGINT);
VAR fld: ORB.Object; i, s: LONGINT;
BEGIN
IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN
(*Files.WriteInt(R, adr)*) (* o7 -> o2 *)
Files.WriteNum(R, adr)
IF (typ.form = ORB.Pointer) OR (typ.form = ORB.NilTyp) THEN Files.WriteInt(R, adr)
ELSIF typ.form = ORB.Record THEN
fld := typ.dsc;
WHILE fld # NIL DO FindPtrs(R, fld.type, fld.val + adr); fld := fld.next END
@ -1089,70 +1077,43 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
size := varsize + strx + comsize + (pc + nofimps + nofent + nofptrs + 1)*4; (*varsize includes type descriptors*)
ORB.MakeFileName(name, modid, ".rsc"); (*write code file*)
F := Files.New(name); Files.Set(R, F, 0); Files.WriteString(R, modid);
(*Files.WriteInt(R, key); *) (* o7 -> o2 *)
Files.WriteNum(R, key);
(*Files.WriteByte(R, version);*)
Files.WriteByte(R, SHORT(version));
(*Files.WriteInt(R, size);*)
Files.WriteNum(R, size);
F := Files.New(name); Files.Set(R, F, 0); Files.WriteString(R, modid); Files.WriteInt(R, key);
(*Files.WriteByte(R, version);*) (* who writes like that? -- noch *)
Files.WriteByte(R, SHORT(SHORT(version))); (* voc adaptation by noch *)
Files.WriteInt(R, size);
obj := ORB.topScope.next;
WHILE (obj # NIL) & (obj.class = ORB.Mod) DO (*imports*)
IF obj.dsc # ORB.system THEN
Files.WriteString(R, obj(ORB.Module).orgname);
(*Files.WriteInt(R, obj.val) *)
Files.WriteNum(R, obj.val)
END ;
IF obj.dsc # ORB.system THEN Files.WriteString(R, obj(ORB.Module).orgname); Files.WriteInt(R, obj.val) END ;
obj := obj.next
END ;
Files.Write(R, 0X);
(*Files.WriteInt(R, tdx*4);*)
Files.WriteNum(R, tdx*4);
Files.WriteInt(R, tdx*4);
i := 0;
WHILE i < tdx DO
(*Files.WriteInt(R, data[i]); *)
Files.WriteNum(R, data[i]);
INC(i)
END ; (*type descriptors*)
(*Files.WriteInt(R, varsize - tdx*4);*) (*data*)
Files.WriteNum(R, varsize - tdx*4); (*data*)
(*Files.WriteInt(R, strx);*)
Files.WriteNum(R, strx);
WHILE i < tdx DO Files.WriteInt(R, data[i]); INC(i) END ; (*type descriptors*)
Files.WriteInt(R, varsize - tdx*4); (*data*)
Files.WriteInt(R, strx);
FOR i := 0 TO strx-1 DO Files.Write(R, str[i]) END ; (*strings*)
(*Files.WriteInt(R, pc);*) (*code len*)
Files.WriteNum(R, pc); (*code len*)
FOR i := 0 TO pc-1 DO
(*Files.WriteInt(R, code[i]) *)
Files.WriteNum(R, code[i])
END ; (*program*)
Files.WriteInt(R, pc); (*code len*)
FOR i := 0 TO pc-1 DO Files.WriteInt(R, code[i]) END ; (*program*)
obj := ORB.topScope.next;
WHILE obj # NIL DO (*commands*)
IF (obj.exno # 0) & (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) &
(obj.type.nofpar = 0) & (obj.type.base = ORB.noType) THEN
Files.WriteString(R, obj.name);
(*Files.WriteInt(R, obj.val)*)
Files.WriteNum(R, obj.val)
Files.WriteString(R, obj.name); Files.WriteInt(R, obj.val)
END ;
obj := obj.next
END ;
Files.Write(R, 0X);
(*Files.WriteInt(R, nofent);*)
Files.WriteNum(R, nofent);
(*Files.WriteInt(R, entry);*)
Files.WriteNum(R, entry);
Files.WriteInt(R, nofent); Files.WriteInt(R, entry);
obj := ORB.topScope.next;
WHILE obj # NIL DO (*entries*)
IF obj.exno # 0 THEN
IF (obj.class = ORB.Const) & (obj.type.form = ORB.Proc) OR (obj.class = ORB.Var) THEN
(*Files.WriteInt(R, obj.val)*)
Files.WriteNum(R, obj.val)
Files.WriteInt(R, obj.val)
ELSIF obj.class = ORB.Typ THEN
IF obj.type.form = ORB.Record THEN
(*Files.WriteInt(R, obj.type.len MOD 10000H)*)
Files.WriteNum(R, obj.type.len MOD 10000H)
IF obj.type.form = ORB.Record THEN Files.WriteInt(R, obj.type.len MOD 10000H)
ELSIF (obj.type.form = ORB.Pointer) & ((obj.type.base.typobj = NIL) OR (obj.type.base.typobj.exno = 0)) THEN
(*Files.WriteInt(R, obj.type.base.len MOD 10000H)*)
Files.WriteNum(R, obj.type.base.len MOD 10000H)
Files.WriteInt(R, obj.type.base.len MOD 10000H)
END
END
END ;
@ -1164,14 +1125,7 @@ MODULE ORG; (* NW 10.10.2013 code generator in Oberon-07 for RISC*)
obj := obj.next
END ;
Files.WriteInt(R, -1);
(*Files.WriteInt(R, fixorgP);*)
Files.WriteNum(R, fixorgP);
(*Files.WriteInt(R, fixorgD);*)
Files.WriteNum(R, fixorgD);
(*Files.WriteInt(R, fixorgT);*)
Files.WriteNum(R, fixorgT);
(*Files.WriteInt(R, entry);*)
Files.WriteNum(R, entry);
Files.WriteInt(R, fixorgP); Files.WriteInt(R, fixorgD); Files.WriteInt(R, fixorgT); Files.WriteInt(R, entry);
Files.Write(R, "O"); Files.Register(F)
END Close;

182
src/voc07R/ORP.Mod
View file

@ -1,11 +1,13 @@
MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07*)
IMPORT Args, Out := Console, Texts, (*Oberon,*) ORS, ORB, ORG;
(*Author: Niklaus Wirth, 2011.
MODULE ORP; (*N. Wirth 1.7.97 / 7.6.2014 Oberon compiler for RISC in Oberon-07*)
IMPORT Texts := CompatTexts, Oberon, ORS, ORB, ORG;
(*Author: Niklaus Wirth, 2014.
Parser of Oberon-RISC compiler. Uses Scanner ORS to obtain symbols (tokens),
ORB for definition of data structures and for handling import and export, and
ORG to produce binary code. ORP performs type checking and data allocation.
Parser is target-independent, except for part of the handling of allocations.*)
TYPE INTEGER = LONGINT; (* voc adaptation by noch *)
TYPE PtrBase = POINTER TO PtrBaseDesc;
PtrBaseDesc = RECORD (*list of names of pointer base types*)
name: ORS.Ident; type: ORB.Type; next: PtrBase
@ -21,7 +23,7 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
modid: ORS.Ident;
pbsList: PtrBase; (*list of names of pointer base types*)
dummy: ORB.Object;
(*W: Texts.Writer;*)
W: Texts.Writer;
PROCEDURE Check(s: INTEGER; msg: ARRAY OF CHAR);
BEGIN
@ -166,8 +168,10 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
IF (t0.base = t1.base) & (t0.nofpar = t1.nofpar) THEN
p0 := t0.dsc; p1 := t1.dsc;
WHILE p0 # NIL DO
(*IF (p0.class = p1.class) & CompTypes(p0.type, p1.type, TRUE) & (ORD(p0.rdo) = ORD(p1.rdo)) THEN*)
IF (p0.class = p1.class) & CompTypes(p0.type, p1.type, TRUE) & (p0.rdo = p1.rdo) THEN
IF (p0.class = p1.class) & CompTypes(p0.type, p1.type, TRUE) &
(*(ORD(p0.rdo) = ORD(p1.rdo))*)
(p0.rdo = p1.rdo) (* voc adaptation by noch *)
THEN
IF p0.type.form >= ORB.Array THEN com := CompTypes(p0.type, p1.type, (p0.class = ORB.Par)) END ;
p0 := p0.next; p1 := p1.next
ELSE p0 := NIL; com := FALSE
@ -207,7 +211,7 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
ELSIF (x.type.form = ORB.Array) & (par.type.form = ORB.Array) &
(x.type.base.form = par.type.base.form) & (par.type.len < 0) THEN
ORG.OpenArrayParam(x);
ELSIF (x.type.form = ORB.String) & (par.class = ORB.Par) & (par.type.form = ORB.Array) &
ELSIF (x.type.form = ORB.String) & varpar & par.rdo & (par.type.form = ORB.Array) &
(par.type.base.form = ORB.Char) & (par.type.len < 0) THEN ORG.StringParam(x)
ELSIF (par.type.form = ORB.Array) & (par.type.base.form = ORB.Int) & (par.type.size = x.type.size) THEN
ORG.VarParam(x, par.type)
@ -314,11 +318,11 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
IF obj.class = ORB.SFunc THEN StandFunc(x, obj.val, obj.type)
ELSE ORG.MakeItem(x, obj, level); selector(x);
IF sym = ORS.lparen THEN
ORS.Get(sym); ORG.PrepCall(x, rx); ParamList(x);
ORS.Get(sym);
IF (x.type.form = ORB.Proc) & (x.type.base.form # ORB.NoTyp) THEN
ORG.Call(x, rx); x.type := x.type.base
ELSE ORS.Mark("not a function")
END ;
ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx); x.type := x.type.base
ELSE ORS.Mark("not a function"); ParamList(x)
END
END
END
ELSIF sym = ORS.int THEN ORG.MakeConstItem(x, ORB.intType, ORS.ival); ORS.Get(sym)
@ -472,6 +476,12 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
END
END TypeCase;
PROCEDURE SkipCase;
BEGIN
WHILE sym # ORS.colon DO ORS.Get(sym) END ;
ORS.Get(sym); StatSequence
END SkipCase;
BEGIN (* StatSequence *)
REPEAT (*sync*) obj := NIL;
IF ~((sym = ORS.ident) OR (sym >= ORS.if) & (sym <= ORS.for) OR (sym >= ORS.semicolon)) THEN
@ -496,9 +506,10 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
END
ELSIF sym = ORS.eql THEN ORS.Mark("should be :="); ORS.Get(sym); expression(y)
ELSIF sym = ORS.lparen THEN (*procedure call*)
ORS.Get(sym); ORG.PrepCall(x, rx); ParamList(x);
IF (x.type.form = ORB.Proc) & (x.type.base.form = ORB.NoTyp) THEN ORG.Call(x, rx)
ELSE ORS.Mark("not a procedure")
ORS.Get(sym);
IF (x.type.form = ORB.Proc) & (x.type.base.form = ORB.NoTyp) THEN
ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx)
ELSE ORS.Mark("not a procedure"); ParamList(x)
END
ELSIF x.type.form = ORB.Proc THEN (*procedure call without parameters*)
IF x.type.nofpar > 0 THEN ORS.Mark("missing parameters") END ;
@ -554,14 +565,16 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
ORS.Get(sym);
IF sym = ORS.ident THEN
qualident(obj); orgtype := obj.type;
IF ~((orgtype.form = ORB.Pointer) OR (orgtype.form = ORB.Record) & (obj.class = ORB.Par)) THEN
ORS.Mark("bad case var")
END ;
Check(ORS.of, "OF expected"); TypeCase(obj, x); L0 := 0;
WHILE sym = ORS.bar DO
ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); obj.type := orgtype; TypeCase(obj, x)
END ;
ORG.Fixup(x); ORG.FixLink(L0); obj.type := orgtype
IF (orgtype.form = ORB.Pointer) OR (orgtype.form = ORB.Record) & (obj.class = ORB.Par) THEN
Check(ORS.of, "OF expected"); TypeCase(obj, x); L0 := 0;
WHILE sym = ORS.bar DO
ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); obj.type := orgtype; TypeCase(obj, x)
END ;
ORG.Fixup(x); ORG.FixLink(L0); obj.type := orgtype
ELSE ORS.Mark("numeric case not implemented");
Check(ORS.of, "OF expected"); SkipCase;
WHILE sym = ORS.bar DO SkipCase END
END
ELSE ORS.Mark("ident expected")
END ;
Check(ORS.end, "no END")
@ -605,7 +618,7 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
ELSIF sym = ORS.comma THEN ORS.Get(sym); ArrayType(typ.base)
ELSE ORS.Mark("missing OF"); typ.base := ORB.intType
END ;
IF len >= 0 THEN typ.size := len * typ.base.size ELSE typ.size := 2*ORG.WordSize (*array desc*) END ;
IF len >= 0 THEN typ.size := (len * typ.base.size + 3) DIV 4 * 4 ELSE typ.size := 2*ORG.WordSize (*array desc*) END ;
typ.form := ORB.Array; typ.len := len; type := typ
END ArrayType;
@ -613,10 +626,10 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
VAR obj, obj0, new, bot, base: ORB.Object;
typ, tp: ORB.Type;
offset, off, n: LONGINT;
BEGIN NEW(typ); typ.form := ORB.NoTyp; typ.base := NIL; typ.mno := level; typ.nofpar := 0;
offset := 0; bot := NIL;
BEGIN NEW(typ); typ.form := ORB.NoTyp; typ.base := NIL; typ.mno := -level; typ.nofpar := 0; offset := 0; bot := NIL;
IF sym = ORS.lparen THEN
ORS.Get(sym); (*record extension*)
IF level # 0 THEN ORS.Mark("extension of local types not implemented") END ;
IF sym = ORS.ident THEN
qualident(base);
IF base.class = ORB.Typ THEN
@ -651,7 +664,7 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
bot := obj;
IF sym = ORS.semicolon THEN ORS.Get(sym) ELSIF sym # ORS.end THEN ORS.Mark(" ; or END") END
END ;
typ.form := ORB.Record; typ.dsc := bot; typ.size := offset; type := typ
typ.form := ORB.Record; typ.dsc := bot; typ.size := (offset + 3) DIV 4 * 4; type := typ
END RecordType;
PROCEDURE FPSection(VAR adr: LONGINT; VAR nofpar: INTEGER);
@ -715,6 +728,11 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
END
END FormalType0;
PROCEDURE CheckRecLevel(lev: INTEGER);
BEGIN
IF lev # 0 THEN ORS.Mark("ptr base must be global") END
END CheckRecLevel;
PROCEDURE Type0(VAR type: ORB.Type);
VAR dmy: LONGINT; obj: ORB.Object; ptbase: PtrBase;
BEGIN type := ORB.intType; (*sync*)
@ -736,13 +754,16 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
IF sym = ORS.ident THEN
obj := ORB.thisObj(); ORS.Get(sym);
IF obj # NIL THEN
IF (obj.class = ORB.Typ) & (obj.type.form IN {ORB.Record, ORB.NoTyp}) THEN type.base := obj.type
IF (obj.class = ORB.Typ) & (obj.type.form IN {ORB.Record, ORB.NoTyp}) THEN
CheckRecLevel(obj.lev); type.base := obj.type
ELSE ORS.Mark("no valid base type")
END
END ;
NEW(ptbase); ORS.CopyId(ptbase.name); ptbase.type := type; ptbase.next := pbsList; pbsList := ptbase
ELSE CheckRecLevel(level); (*enter into list of forward references to be fixed in Declarations*)
NEW(ptbase); ORS.CopyId(ptbase.name); ptbase.type := type; ptbase.next := pbsList; pbsList := ptbase
END
ELSE Type(type.base);
IF type.base.form # ORB.Record THEN ORS.Mark("must point to record") END
IF type.base.form # ORB.Record THEN ORS.Mark("must point to record") END ;
CheckRecLevel(level)
END
ELSIF sym = ORS.procedure THEN
ORS.Get(sym); ORB.OpenScope;
@ -768,11 +789,7 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
expression(x);
IF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x) END ;
ORB.NewObj(obj, id, ORB.Const); obj.expo := expo;
IF x.mode = ORB.Const THEN
obj.val := x.a;
(*obj.lev := x.b;*)
obj.lev := SHORT(x.b);
obj.type := x.type
IF x.mode = ORB.Const THEN obj.val := x.a; obj.lev := x.b; obj.type := x.type
ELSE ORS.Mark("expression not constant"); obj.type := ORB.intType
END;
Check(ORS.semicolon, "; missing")
@ -789,12 +806,9 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
IF tp.form = ORB.Record THEN
ptbase := pbsList; (*check whether this is base of a pointer type; search and fixup*)
WHILE ptbase # NIL DO
IF obj.name = ptbase.name THEN
IF ptbase.type.base = ORB.intType THEN ptbase.type.base := obj.type ELSE ORS.Mark("recursive record?") END
END ;
IF obj.name = ptbase.name THEN ptbase.type.base := obj.type END ;
ptbase := ptbase.next
END ;
tp.len := dc;
IF level = 0 THEN ORG.BuildTD(tp, dc) END (*type descriptor; len used as its address*)
END ;
Check(ORS.semicolon, "; missing")
@ -835,7 +849,6 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
IF sym = ORS.times THEN ORS.Get(sym); int := TRUE END ;
IF sym = ORS.ident THEN
ORS.CopyId(procid); ORS.Get(sym);
(*Texts.WriteLn(W); Texts.WriteString(W, procid); Texts.WriteInt(W, ORG.Here(), 7);*)
ORB.NewObj(proc, ORS.id, ORB.Const); parblksize := 4;
NEW(type); type.form := ORB.Proc; type.size := ORG.WordSize; proc.type := type;
CheckExport(proc.expo);
@ -875,25 +888,15 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
VAR key: LONGINT;
obj: ORB.Object;
impid, impid1: ORS.Ident;
BEGIN
(*Texts.WriteString(W, " compiling "); *)
Out.String(" compiling ");
ORS.Get(sym);
BEGIN Texts.WriteString(W, " compiling "); ORS.Get(sym);
IF sym = ORS.module THEN
ORS.Get(sym);
IF sym = ORS.times THEN
version := 0;
(*Texts.Write(W, "*"); *)
Out.Char("*");
ORS.Get(sym)
ELSE
version := 1
END ;
IF sym = ORS.times THEN version := 0; Texts.Write(W, "*"); ORS.Get(sym) ELSE version := 1 END ;
ORB.Init; ORB.OpenScope;
IF sym = ORS.ident THEN
ORS.CopyId(modid); ORS.Get(sym);
(*Texts.WriteString(W, modid); Texts.Append(Oberon.Log, W.buf)*)
Out.String(modid); Out.Ln
Texts.WriteString(W, modid); Texts.Append(Oberon.Log, W.buf);
Oberon.DumpLog; (* voc adaptation; -- noch *)
ELSE ORS.Mark("identifier expected")
END ;
Check(ORS.semicolon, "no ;"); level := 0; dc := 0; exno := 1; key := 0;
@ -927,30 +930,22 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
ELSE ORS.Mark("identifier missing")
END ;
IF sym # ORS.period THEN ORS.Mark("period missing") END ;
IF ORS.errcnt = 0 THEN
IF (ORS.errcnt = 0) & (version # 0) THEN
ORB.Export(modid, newSF, key);
IF newSF THEN
(*Texts.WriteLn(W); Texts.WriteString(W, "new symbol file ") *)
Out.Ln; Out.String("new symbol file ")
END
IF newSF THEN Texts.WriteString(W, " new symbol file") END
END ;
IF ORS.errcnt = 0 THEN
ORG.Close(modid, key, exno);
(*Texts.WriteLn(W); Texts.WriteString(W, "compilation done ");*)
Out.Ln; Out.String("compilation done ");
(*Texts.WriteInt(W, ORG.pc, 6); Texts.WriteInt(W, dc, 6)*)
Out.Int(ORG.pc, 6); Out.Int(dc, 6)
ELSE
(*Texts.WriteLn(W); Texts.WriteString(W, "compilation FAILED")*)
Out.Ln; Out.String("compilation FAILED")
ORG.Close(modid, key, exno);
Texts.WriteInt(W, ORG.pc, 6); Texts.WriteInt(W, dc, 6); Texts.WriteHex(W, key)
ELSE Texts.WriteLn(W); Texts.WriteString(W, "compilation FAILED")
END ;
(*Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);*)
Out.Ln;
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
Oberon.DumpLog; (* voc adaptation; -- noch *)
ORB.CloseScope; pbsList := NIL
ELSE ORS.Mark("must start with MODULE")
END
END Module;
(*
PROCEDURE Option(VAR S: Texts.Scanner);
BEGIN newSF := FALSE;
IF S.nextCh = "/" THEN
@ -958,24 +953,12 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
IF (S.class = Texts.Name) & (S.s[0] = "s") THEN newSF := TRUE END
END
END Option;
*)
PROCEDURE Option(VAR s: ARRAY OF CHAR);
BEGIN
newSF := FALSE;
IF s[0] = "-" THEN
IF s[1] = "s" THEN newSF := TRUE END
END
END Option;
PROCEDURE Compile*;
VAR beg, end, time: LONGINT;
(*T: Texts.Text;
S: Texts.Scanner;*)
s, name : ARRAY 32 OF CHAR;
T : Texts.Text;
BEGIN
(*Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos);
Texts.Scan(S);
T: Texts.Text;
S: Texts.Scanner;
BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
IF S.class = Texts.Char THEN
IF S.c = "@" THEN
Option(S); Oberon.GetSelection(T, beg, end, time);
@ -995,35 +978,20 @@ MODULE ORP; (*N. Wirth 1.7.97 / 5.11.2013 Oberon compiler for RISC in Oberon-07
NEW(T); Texts.Open(T, S.s);
IF T.len > 0 THEN Option(S); ORS.Init(T, 0); Module
ELSE Texts.WriteString(W, S.s); Texts.WriteString(W, " not found");
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
Oberon.DumpLog; (* voc adaptation; -- noch *)
END ;
IF (T.len # 0) & (ORS.errcnt = 0) THEN Texts.Scan(S) ELSE S.class := 0 END
END
END ;
Oberon.Collect(0)
*)
IF Args.argc <= 1 THEN HALT(1) END;
Args.Get (1, s);
Option(s);
IF s[0] = "-" THEN
IF Args.argc < 3 THEN Out.String ("module name expected"); Out.Ln; HALT(1) END;
Args.Get(2, name);
ELSE
COPY(s, name);
END;
NEW(T);
Texts.Open(T, name);
IF T.len > 0 THEN
ORS.Init(T, 0); Module
ELSE
Out.String ("module not found"); Out.Ln
END;
END Compile;
BEGIN (*Texts.OpenWriter(W); Texts.WriteString(W, "OR Compiler 5.11.2013");*)
Out.String("OR Compiler 5.11.2013"); Out.Ln;
(*Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);*)
BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "OR Compiler 7.6.2014");
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
Oberon.DumpLog; (* voc adaptation; -- noch *)
NEW(dummy); dummy.class := ORB.Var; dummy.type := ORB.intType;
expression := expression0; Type := Type0; FormalType := FormalType0;
Compile;
Compile (* voc adaptation; -- noch *)
END ORP.

44
src/voc07R/ORS.Mod
View file

@ -1,5 +1,7 @@
MODULE ORS; (* NW 19.9.93 / 10.10.2013 Scanner in Oberon-07*)
IMPORT SYSTEM, Texts, Console, S := SYSTEM;
MODULE ORS; (* NW 19.9.93 / 1.4.2014 Scanner in Oberon-07*)
IMPORT SYSTEM, Texts := CompatTexts, Oberon;
TYPE INTEGER = LONGINT; (* voc adaptation by noch *)
(* Oberon Scanner does lexical analysis. Input is Oberon-Text, output is
sequence of symbols, i.e identifiers, numbers, strings, and special symbols.
@ -10,7 +12,7 @@ MODULE ORS; (* NW 19.9.93 / 10.10.2013 Scanner in Oberon-07*)
If Get delivers ident, then the identifier (a string) is in variable id, if int or char
in ival, if real in rval, and if string in str (and slen) *)
CONST IdLen* = 32; WS = 4; (*Word size*)
CONST IdLen* = 32;
NKW = 34; (*nof keywords*)
maxExp = 38; stringBufSize = 256;
@ -29,7 +31,6 @@ MODULE ORS; (* NW 19.9.93 / 10.10.2013 Scanner in Oberon-07*)
else* = 55; elsif* = 56; until* = 57; return* = 58;
array* = 60; record* = 61; pointer* = 62; const* = 63; type* = 64;
var* = 65; procedure* = 66; begin* = 67; import* = 68; module* = 69;
eof = 70;
TYPE Ident* = ARRAY IdLen OF CHAR;
@ -60,8 +61,9 @@ MODULE ORS; (* NW 19.9.93 / 10.10.2013 Scanner in Oberon-07*)
VAR p: LONGINT;
BEGIN p := Pos();
IF (p > errpos) & (errcnt < 25) THEN
Console.Ln; Console.String(" pos "); Console.Int(p, 1); Console.Char(" ");
Console.String(msg)
Texts.WriteLn(W); Texts.WriteString(W, " pos "); Texts.WriteInt(W, p, 1); Texts.Write(W, " ");
Texts.WriteString(W, msg); Texts.Append(Oberon.Log, W.buf);
Oberon.DumpLog;
END ;
INC(errcnt); errpos := p + 4
END Mark;
@ -124,7 +126,7 @@ MODULE ORS; (* NW 19.9.93 / 10.10.2013 Scanner in Oberon-07*)
END Ten;
PROCEDURE Number(VAR sym: INTEGER);
CONST max = 2147483647 (*2^31*); maxM = 16777216; (*2^24*)
CONST max = 2147483647 (*2^31 - 1*);
VAR i, k, e, n, s, h: LONGINT; x: REAL;
d: ARRAY 16 OF INTEGER;
negE: BOOLEAN;
@ -149,25 +151,24 @@ MODULE ORS; (* NW 19.9.93 / 10.10.2013 Scanner in Oberon-07*)
IF ch = "." THEN (*double dot*) ch := 7FX; (*decimal integer*)
REPEAT
IF d[i] < 10 THEN
h := k*10 + d[i];
IF h < max THEN k := h ELSE Mark("too large") END
IF k <= (max-d[i]) DIV 10 THEN k := k *10 + d[i] ELSE Mark("too large"); k := 0 END
ELSE Mark("bad integer")
END ;
INC(i)
UNTIL i = n;
sym := int; ival := k
ELSE (*real number*) x := 0.0; e := 0;
REPEAT (*integer part*) h := k*10 + d[i];
IF h < maxM THEN k := h ELSE Mark("too many digits") END ;
INC(i)
UNTIL i = n;
WHILE (ch >= "0") & (ch <= "9") DO (*fraction*)
h := k*10 + ORD(ch) - 30H;
IF h < maxM THEN k := h ELSE Mark("too many digits*") END ;
DEC(e); Texts.Read(R, ch)
REPEAT (*integer part*)
(*x := x * 10.0 + FLT(d[i]); *)
x := x * 10.0 + (d[i]); (* voc adaptation by noch *)
INC(i)
UNTIL i = n;
WHILE (ch >= "0") & (ch <= "9") DO (*fraction*)
(*x := x * 10.0 + FLT(ORD(ch) - 30H);*)
x := x * 10.0 + (ORD(ch) - 30H); (* voc adaptation by noch *)
DEC(e);
Texts.Read(R, ch)
END ;
(*x := FLT(k);*)
x := S.VAL(REAL, k);
IF (ch = "E") OR (ch = "D") THEN (*scale factor*)
Texts.Read(R, ch); s := 0;
IF ch = "-" THEN negE := TRUE; Texts.Read(R, ch)
@ -275,8 +276,9 @@ MODULE ORS; (* NW 19.9.93 / 10.10.2013 Scanner in Oberon-07*)
PROCEDURE EnterKW(sym: INTEGER; name: ARRAY OF CHAR);
BEGIN
(*keyTab[k].id := name; *)
COPY(name, keyTab[k].id);
keyTab[k].sym := sym; INC(k)
COPY(name, keyTab[k].id); (* voc adaptation by noch *)
keyTab[k].sym := sym;
INC(k)
END EnterKW;
BEGIN Texts.OpenWriter(W); k := 0; KWX[0] := 0; KWX[1] := 0;

103
src/voc07R/Oberon.Mod Normal file
View file

@ -0,0 +1,103 @@
MODULE Oberon;
IMPORT Args, Strings, Texts := CompatTexts, (*Files := CompatFiles,*) Out := Console;
VAR Log*: Texts.Text;
Par*: RECORD
text*: Texts.Text;
pos* : LONGINT;
END;
arguments : ARRAY 2048 OF CHAR;
PROCEDURE GetSelection* (VAR text: Texts.Text; VAR beg, end, time: LONGINT);
(*VAR M: SelectionMsg;*)
BEGIN
(*M.time := -1; Viewers.Broadcast(M); time := M.time;
IF time >= 0 THEN text := M.text; beg := M.beg; end := M.end END*)
END GetSelection;
PROCEDURE Collect*( count : LONGINT);
BEGIN
END Collect;
PROCEDURE ArgsToString(VAR opts : ARRAY OF CHAR);
VAR i : INTEGER;
opt : ARRAY 256 OF CHAR;
BEGIN
i := 1;
opt := ""; COPY ("", opts);
WHILE i < Args.argc DO
Args.Get(i, opt);
Strings.Append(opt, opts);(* Strings.Append (" ", opts);*)
INC(i)
END;
END ArgsToString;
PROCEDURE StringToText(VAR arguments : ARRAY OF CHAR; VAR T : Texts.Text);
VAR
W : Texts.Writer;
BEGIN
Texts.OpenWriter(W);
Texts.WriteString(W, arguments);
Texts.Append (T, W.buf);
END StringToText;
(*
PROCEDURE WriteTextToFile(VAR T : Texts.Text; filename : ARRAY OF CHAR);
VAR f : Files.File; r : Files.Rider;
BEGIN
f := Files.New(filename);
Files.Set(r, f, 0);
Texts.Store(r, T);
Files.Register(f);
END WriteTextToFile;
*)
PROCEDURE TextToString(VAR T : Texts.Text; VAR string : ARRAY OF CHAR);
VAR R : Texts.Reader;
ch : CHAR;
i : LONGINT;
BEGIN
COPY("", string);
Texts.OpenReader(R, T, 0);
i := 0;
WHILE Texts.Pos(R) < T.len DO
Texts.Read(R, ch);
string[i] := ch;
INC(i);
END;
(*string[i] := 0X;*)
END TextToString;
PROCEDURE DumpLog*;
VAR s : POINTER TO ARRAY OF CHAR;
BEGIN
NEW(s, Log.len + 1);
COPY("", s^);
TextToString(Log, s^);
Out.String(s^); Out.Ln;
NEW(Log);
Texts.Open(Log, "");
END DumpLog;
BEGIN
NEW(Log);
Texts.Open(Log, "");
NEW(Par.text);
Texts.Open(Par.text, "");
Par.pos := 0;
COPY("", arguments);
ArgsToString(arguments);
StringToText(arguments, Par.text);
(*WriteTextToFile(Par.text, "params.txt");*)
(*WriteTextToFile(Log, "log.txt");*)
(*DumpLog;*)
END Oberon.

4
src/voc07R/makefile
View file

@ -7,7 +7,9 @@ all:
#$(VOC0) -s ORS.Mod
#$(VOC0) -s ORB.Mod
#$(VOC0) -s ORG.Mod
$(VOC0) -s ORS.Mod ORB.Mod ORG.Mod ORP.Mod -M
$(VOC0) -s CompatFiles.Mod \
Fonts.Mod CompatTexts.Mod Oberon.Mod \
ORS.Mod ORB.Mod ORG.Mod ORP.Mod -M
test:
./ORP -s test.Mod

BIN
voc
View file

Binary file not shown.