From 7cf90615c850ea252852266cf47ebfa939830c19 Mon Sep 17 00:00:00 2001 From: Norayr Chilingarian Date: Sun, 14 Sep 2014 06:09:09 +0400 Subject: [PATCH] re re revised oberon compiler for RISC works -- noch Former-commit-id: c900218965173a69c5fe9afa5ba53430ae663a11 --- src/voc07R/CompatFiles.Mod | 677 +++++++++++++++++++++++++++++++++++++ src/voc07R/CompatTexts.Mod | 581 +++++++++++++++++++++++++++++++ src/voc07R/Fonts.Mod | 146 ++++++++ src/voc07R/ORB.Mod | 90 ++--- src/voc07R/ORC.Mod | 206 ----------- src/voc07R/ORG.Mod | 310 ++++++++--------- src/voc07R/ORP.Mod | 182 ++++------ src/voc07R/ORS.Mod | 44 +-- src/voc07R/Oberon.Mod | 103 ++++++ src/voc07R/makefile | 4 +- voc.REMOVED.git-id | 2 +- 11 files changed, 1772 insertions(+), 573 deletions(-) create mode 100644 src/voc07R/CompatFiles.Mod create mode 100644 src/voc07R/CompatTexts.Mod create mode 100644 src/voc07R/Fonts.Mod delete mode 100644 src/voc07R/ORC.Mod create mode 100644 src/voc07R/Oberon.Mod diff --git a/src/voc07R/CompatFiles.Mod b/src/voc07R/CompatFiles.Mod new file mode 100644 index 00000000..d7a9c06e --- /dev/null +++ b/src/voc07R/CompatFiles.Mod @@ -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. diff --git a/src/voc07R/CompatTexts.Mod b/src/voc07R/CompatTexts.Mod new file mode 100644 index 00000000..f94b3151 --- /dev/null +++ b/src/voc07R/CompatTexts.Mod @@ -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. diff --git a/src/voc07R/Fonts.Mod b/src/voc07R/Fonts.Mod new file mode 100644 index 00000000..1798cfb6 --- /dev/null +++ b/src/voc07R/Fonts.Mod @@ -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. diff --git a/src/voc07R/ORB.Mod b/src/voc07R/ORB.Mod index e155d1bc..61d23f4f 100644 --- a/src/voc07R/ORB.Mod +++ b/src/voc07R/ORB.Mod @@ -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); diff --git a/src/voc07R/ORC.Mod b/src/voc07R/ORC.Mod deleted file mode 100644 index 84bfb97a..00000000 --- a/src/voc07R/ORC.Mod +++ /dev/null @@ -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. diff --git a/src/voc07R/ORG.Mod b/src/voc07R/ORG.Mod index eed166b4..9495337c 100644 --- a/src/voc07R/ORG.Mod +++ b/src/voc07R/ORG.Mod @@ -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; diff --git a/src/voc07R/ORP.Mod b/src/voc07R/ORP.Mod index 16010fd6..7c59e50f 100644 --- a/src/voc07R/ORP.Mod +++ b/src/voc07R/ORP.Mod @@ -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. diff --git a/src/voc07R/ORS.Mod b/src/voc07R/ORS.Mod index fddb871f..c6909944 100644 --- a/src/voc07R/ORS.Mod +++ b/src/voc07R/ORS.Mod @@ -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; diff --git a/src/voc07R/Oberon.Mod b/src/voc07R/Oberon.Mod new file mode 100644 index 00000000..736d664c --- /dev/null +++ b/src/voc07R/Oberon.Mod @@ -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. diff --git a/src/voc07R/makefile b/src/voc07R/makefile index dffd2946..7f9f03bd 100644 --- a/src/voc07R/makefile +++ b/src/voc07R/makefile @@ -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 diff --git a/voc.REMOVED.git-id b/voc.REMOVED.git-id index 8614c434..99600c9f 100644 --- a/voc.REMOVED.git-id +++ b/voc.REMOVED.git-id @@ -1 +1 @@ -c2141d5ead9b48d2d3e1f3cb25fb884e3671608d \ No newline at end of file +83842f359842b851cdb948a605d2f45392e7573c \ No newline at end of file